clean babillard, remove option for multiple boards

src/babillard.ml

@@ -1,23 +1,8 @@
 open Db
 include Bindings
 
-exception Invalid_post of string
-
-type board = Babillard
-
-let int_of_board = function
-  | Babillard -> 1
-
-let pp_board fmt = function
-  | Babillard -> Format.fprintf fmt "babillard"
-
-let board_of_int = function
-  | 1 -> Babillard
-  | _ -> raise (Invalid_argument "board_of_int")
-
 type thread_data =
-  { board : board
+  { subject : string
-  ; subject : string
   ; lng : float
   ; lat : float
   }
@@ -51,12 +36,6 @@ module Q = struct
        FOREIGN KEY(post_id) REFERENCES post_user(post_id),\n\
       \       FOREIGN KEY(parent_id) REFERENCES post_user(post_id));"
 
-  let create_thread_board_table =
-    Caqti_request.exec Caqti_type.unit
-      "CREATE TABLE IF NOT EXISTS thread_board (thread_id TEXT, board INT, \
-       FOREIGN KEY(thread_id) REFERENCES post_user(post_id));"
-
-  (* TODO useless? *)
   let create_thread_table =
     Caqti_request.exec Caqti_type.unit
       "CREATE TABLE IF NOT EXISTS threads (thread_id TEXT, post_id TEXT,\n\
@@ -151,11 +130,6 @@ module Q = struct
       Caqti_type.(tup2 string string)
       "INSERT INTO threads VALUES (?,?);"
 
-  let upload_thread_board =
-    Caqti_request.exec
-      Caqti_type.(tup2 string int)
-      "INSERT INTO thread_board VALUES (?,?);"
-
   let upload_post_parent =
     Caqti_request.exec
       Caqti_type.(tup2 string string)
@@ -202,14 +176,9 @@ module Q = struct
     Caqti_request.find Caqti_type.string Caqti_type.int
       "SELECT COUNT(post_id) FROM threads WHERE thread_id=?;"
 
-  (* TODO return bool *)
   let is_thread =
-    Caqti_request.find_opt Caqti_type.string Caqti_type.string
+    Caqti_request.find Caqti_type.string Caqti_type.bool
-      "SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1;"
+      "IF EXISTS (SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1);"
-
-  let get_thread_board =
-    Caqti_request.find Caqti_type.string Caqti_type.int
-      "SELECT board FROM thread_board WHERE thread_id=? LIMIT 1;"
 
   let get_post_subject =
     Caqti_request.find_opt Caqti_type.string Caqti_type.string
@@ -220,9 +189,9 @@ module Q = struct
       Caqti_type.(tup2 float float)
       "SELECT lat, lng FROM post_gps WHERE post_id=?;"
 
-  let list_threads =
+  let get_threads =
-    Caqti_request.collect Caqti_type.int Caqti_type.string
+    Caqti_request.collect Caqti_type.unit Caqti_type.string
-      "SELECT thread_id FROM thread_board WHERE board=?;"
+      "SELECT thread_id FROM threads;"
 end
 
 let () =
@@ -230,7 +199,6 @@ let () =
     [ Q.create_post_user_table
     ; Q.create_post_parent_table
     ; Q.create_thread_table
-    ; Q.create_thread_board_table
     ; Q.create_post_replies_table
     ; Q.create_post_citations_table
     ; Q.create_post_date_table
@@ -269,21 +237,26 @@ let parse_image image =
       else
         Ok (Some image) )
 
-(* TODO: Is this safe? *)
+(*TODO switch to markdown !*)
-(*TODO fix bad link if post in other thread*)
+(* insert html into the comment, and keep tracks of citations :
+       -wraps lines starting with ">" with a <span class="quote">
+       -make raw posts uuid into links
+   (*TODO fix bad link if post is in other thread*)
+       -keeps tracks of every post cited in this comment
+      - add <br> at each line *)
 let parse_comment comment =
   let handle_word w =
     let trim_w = String.trim w in
     (* '>' is '&gt;' after html_escape *)
-    match String.starts_with ~prefix:{|&gt;&gt;|} trim_w with
+    if String.starts_with ~prefix:{|&gt;&gt;|} trim_w then
-    | false -> (w, None)
-    | true -> (
       let sub_w = String.sub trim_w 8 (String.length trim_w - 8) in
       match Uuidm.of_string sub_w with
       | None -> (w, None)
       | Some _ ->
         let new_w = Format.sprintf {|<a href="#%s">%s</a>|} sub_w w in
-        (new_w, Some sub_w) )
+        (new_w, Some sub_w)
+    else
+      (w, None)
   in
   let handle_line l =
     let trim_w = String.trim l in
@@ -344,46 +317,36 @@ let upload_post post =
     | Op (thread_data, reply) -> (Some thread_data, reply)
     | Reply reply -> (None, reply)
   in
-  let post_id, parent_id, date, nick, comment, image, tags, citations =
+  let { id; parent_id; date; nick; comment; image; tags; citations; _ } =
-    match reply with
+    reply
-    | { id
-      ; parent_id
-      ; date
-      ; nick
-      ; comment
-      ; image
-      ; tags
-      ; replies = _replies
-      ; citations
-      } ->
-      (id, parent_id, date, nick, comment, image, tags, citations)
   in
 
-  let^ _res_post_id = Db.exec Q.upload_post_id (post_id, nick) in
+  let^ () = Db.exec Q.upload_post_id (id, nick) in
-  let^ _res_comment = Db.exec Q.upload_post_comment (post_id, comment) in
+  let^ () = Db.exec Q.upload_post_comment (id, comment) in
-  let^ _res_date = Db.exec Q.upload_post_date (post_id, date) in
+  let^ () = Db.exec Q.upload_post_date (id, date) in
-  let^ _res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in
+  let^ () = Db.exec Q.upload_to_thread (parent_id, id) in
-  let^ _res_image =
+  let^ () =
     match image with
     | None -> Ok ()
     | Some (image_name, image_content, alt) ->
-      Db.exec Q.upload_post_image (post_id, image_name, image_content, alt)
+      Db.exec Q.upload_post_image (id, image_name, image_content, alt)
   in
-  let^ _res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in
+  (* what is parent and why do i need it again? TODO TODO *)
-  let^ _res_tags =
+  let^ () = Db.exec Q.upload_post_parent (id, parent_id) in
+  let^ () =
     match
       List.find_opt Result.is_error
-        (List.map (fun tag -> Db.exec Q.upload_post_tag (post_id, tag)) tags)
+        (List.map (fun tag -> Db.exec Q.upload_post_tag (id, tag)) tags)
     with
     | Some (Error e) -> Error e
     | Some _ -> assert false
     | None -> Ok ()
   in
-  let^ _res_citations =
+  let^ () =
     match
       List.find_opt Result.is_error
         (List.map
-           (fun cited_id -> Db.exec Q.upload_post_reply (cited_id, post_id))
+           (fun cited_id -> Db.exec Q.upload_post_reply (cited_id, id))
            citations )
     with
     | Some (Error e) -> Error e
@@ -391,27 +354,18 @@ let upload_post post =
     | None -> Ok ()
   in
   match thread_data with
-  | None -> Ok post_id
+  | None -> Ok id
-  | Some thread_data -> (
+  | Some { subject; lng; lat } ->
-    match thread_data with
+    let^ () = Db.exec Q.upload_post_gps (id, lat, lng) in
-    | { board; subject; lng; lat } ->
+    let^ () = Db.exec Q.upload_post_subject (id, subject) in
-      let^ _res_board =
+    Ok id
-        Db.exec Q.upload_thread_board (post_id, int_of_board board)
-      in
-      let^ _res_gps = Db.exec Q.upload_post_gps (post_id, lat, lng) in
-      let^ _res_subject = Db.exec Q.upload_post_subject (post_id, subject) in
-      Ok post_id )
 
 let build_reply ~comment ?image ~tags ?parent_id nick =
   let comment = Dream.html_escape comment in
   let tags = Dream.html_escape tags in
   let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
   (* parent_id is None if this reply is supposed to be a new thread *)
-  let parent_id =
+  let parent_id = Option.value parent_id ~default:id in
-    match parent_id with
-    | Some parent_id -> parent_id
-    | None -> id
-  in
   if Option.is_none (Uuidm.of_string parent_id) then
     Error "invalid thread id"
   else if String.length comment > 10000 then
@@ -441,7 +395,7 @@ let build_reply ~comment ?image ~tags ?parent_id nick =
         in
         Ok reply
 
-let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
+let build_op ~comment ?image ~tags ~subject ~lat ~lng nick =
   let subject = Dream.html_escape subject in
   (* TODO latlng validation? *)
   let is_valid_latlng = true in
@@ -450,7 +404,7 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
   else if String.length subject > 600 then
     Error "Invalid subject"
   else
-    let thread_data = { board; subject; lng; lat } in
+    let thread_data = { subject; lng; lat } in
     let* reply =
       match image with
       | Some image -> build_reply ~comment ~image ~tags nick
@@ -464,8 +418,8 @@ let make_reply ~comment ?image ~tags ~parent_id nick =
   let post = Reply reply in
   upload_post post
 
-let make_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
+let make_op ~comment ?image ~tags ~subject ~lat ~lng nick =
-  let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in
+  let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng nick in
   upload_post op
 
 let get_post_image_content post_id =

src/babillard_page.eml.html

@@ -1,17 +1,13 @@
-let f ~board request =
+let f request =
-%let board = Format.asprintf "%a" Babillard.pp_board board in
 <script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
-<div id="board" data-board=<%s board %> >
 <%s  Format.sprintf "Babillard is love" %>
-</div>
 <div class="row mb-3">
       <div class="col-md-6">
 % begin match Dream.session "nick" request with
 % | None ->
 
 % | Some _nick ->
-%let url = Format.sprintf "/%s/new_thread" board in
+<a href="/babillard/new_thread" >[New Thread]</a>
-<a href=<%s url %>>[New Thread]</a>
 % end;
 <div id="map"></div>
 <button onclick="geolocalize()">Geolocalize me</button>

src/bindings.ml

@@ -13,5 +13,5 @@ let ( let^ ) o f =
 
 let ( let* ) o f =
   match o with
-  | Error e -> Error (Format.sprintf "%s" e)
+  | Error e -> Error e
   | Ok x -> f x

src/content/assets/css/style.css

@@ -32,7 +32,7 @@ blockquote.blockquote {
   margin: 5px 5px 5px 5px;
   border: 2px solid #FFB300;
   padding: 2px;
-  display:table;
+  display: table;
 }
 
 .postInfo {
@@ -74,7 +74,7 @@ blockquote.blockquote {
   margin: 5px 5px 5px 5px;
   border: 2px solid #FFB300;
   padding: 2px;
-  display:table;
+  display: table;
   width: 500px;
 }
 

src/js/js_map.ml

@@ -119,11 +119,6 @@ module Geolocalize = struct
 end
 
 module Marker = struct
-  let board =
-    let board_div = Jv.get Jv.global "board" in
-    Jv.to_string
-      (Jv.call board_div "getAttribute" [| Jv.of_string "data-board" |])
-
   (*todo do this in js_babillard*)
   let marker_on_click thread_preview thread_id _e =
     log "marker_on_click@.";
@@ -131,7 +126,7 @@ module Marker = struct
     let thread_preview_div = Jv.get Jv.global "thread_preview_div" in
     ignore @@ Jv.set thread_preview_div "innerHTML" thread_preview;
     let thread_link = Jv.get Jv.global "thread_link" in
-    let link = Format.sprintf "/%s/%s" board thread_id in
+    let link = Format.sprintf "/babillard/%s" thread_id in
     ignore @@ Jv.set thread_link "href" (Jv.of_string link);
     ignore @@ Jv.set thread_link "innerText" (Jv.of_string "[View Thread]");
     let _ = Js_pretty_post.make_pretty () in
@@ -173,7 +168,7 @@ module Marker = struct
   let () =
     log "fetch thread geojson@.";
     let window = Jv.get Jv.global "window" in
-    let link = Jv.of_string (Format.sprintf "/%s/markers" board) in
+    let link = Jv.of_string "/babillard/markers" in
     let fetchfutur = Jv.call window "fetch" [| link |] in
     ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |];
     ()

src/newthread_page.eml.html

@@ -1,13 +1,10 @@
-let f ~board request =
+let f request =
-%let board = Format.asprintf "%a" Babillard.pp_board board in
-%let url = Format.sprintf "/%s/new_thread" board in
 % begin match Dream.session "nick" request with
 % | None ->
 Login to make a new thread.
 % | Some _nick ->
 <script type="text/javascript" src="/assets/js/js_newthread.js" defer="defer"></script>
 <div id="newthread">Click the map to make a new thread:</div>
-<div id="board" data-board=<%s board %> ></div>
 <div class="row mb-3">
     <div class="col-md-6">
         <div id="map"></div>
@@ -16,7 +13,7 @@ Login to make a new thread.
 
     <div class="col-md-6" id="newthread-form">
     <div class="postForm">
-<%s! Dream.form_tag ~action:url ~enctype:`Multipart_form_data request %>
+<%s! Dream.form_tag ~action:"/babillard/new_thread" ~enctype:`Multipart_form_data request %>
         <input type="hidden" id="lat_input" name="lat_input">
         <input type="hidden" id="lng_input" name="lng_input">
 

src/permap.ml

@@ -148,20 +148,18 @@ let post_image request =
   | Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image
   | Error _ -> Dream.empty `Not_Found
 
-let markers ~board request =
+let markers request =
-  let markers = Pp_babillard.get_markers board in
+  let markers = Pp_babillard.get_markers () in
   match markers with
   | Ok markers ->
     Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers
   | Error e -> render_unsafe e request
 
-let babillard_get ~board request =
+let babillard_get request = render_unsafe (Babillard_page.f request) request
-  render_unsafe (Babillard_page.f ~board request) request
 
-let newthread_get ~board request =
+let newthread_get request = render_unsafe (Newthread_page.f request) request
-  render_unsafe (Newthread_page.f ~board request) request
 
-let newthread_post ~board request =
+let newthread_post request =
   match Dream.session "nick" request with
   | None -> render_unsafe "Not logged in" request
   | Some nick -> (
@@ -181,19 +179,15 @@ let newthread_post ~board request =
       | Some lat, Some lng -> (
         let res =
           match file with
-          | [] ->
+          | [] -> Babillard.make_op ~comment ~lat ~lng ~subject ~tags nick
-            Babillard.make_op ~comment ~lat ~lng ~subject ~tags ~board nick
           | _ :: _ :: _ -> Error "More than one image"
           | [ (image_name, image_content) ] ->
             let image = (image_name, image_content, alt) in
-            Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags ~board
+            Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags nick
-              nick
         in
         match res with
         | Ok thread_id ->
-          let adress =
+          let adress = Format.asprintf "/babillard/%s" thread_id in
-            Format.asprintf "/%a/%s" Babillard.pp_board board thread_id
-          in
           Dream.respond ~status:`See_Other
             ~headers:[ ("Location", adress) ]
             "Your thread was posted!"
@@ -282,11 +276,11 @@ let () =
        ; Dream.get "/profile" profile_get
        ; Dream.post "/profile" profile_post
        ; Dream.get "/thread_view/:thread_id" thread_view
-       ; Dream.get "/babillard/markers" (markers ~board:Babillard)
+       ; Dream.get "/babillard/markers" markers
        ; Dream.get "/post_pic/:post_id" post_image
-       ; Dream.get "/babillard" (babillard_get ~board:Babillard)
+       ; Dream.get "/babillard" babillard_get
-       ; Dream.get "/babillard/new_thread" (newthread_get ~board:Babillard)
+       ; Dream.get "/babillard/new_thread" newthread_get
-       ; Dream.post "/babillard/new_thread" (newthread_post ~board:Babillard)
+       ; Dream.post "/babillard/new_thread" newthread_post
        ; Dream.get "/babillard/:thread_id" thread_get
        ; Dream.post "/reply/:thread_id" reply_post
        ; Dream.get "/post_pic/:post_id" post_image

src/pp_babillard.ml

@@ -126,42 +126,46 @@ let preview_thread thread_id =
   Ok thread_preview
 
 let view_thread thread_id =
-  let^? _ = Db.find_opt Q.is_thread thread_id in
+  let^ is_thread = Db.find Q.is_thread thread_id in
-  let^? subject = Db.find_opt Q.get_post_subject thread_id in
+  if not is_thread then
-  let^ thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in
+    Error "This thread doesn't exists"
-  (*order by date *)
+  else
-  let dates =
+    let^? subject = Db.find_opt Q.get_post_subject thread_id in
-    List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts
+    let^ thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in
-  in
+    (*order by date *)
-  match List.find_opt Result.is_error dates with
+    let dates =
-  | Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+      List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts
-  | Some (Ok _) -> assert false
-  | None -> (
-    let dates = List.map Result.get_ok dates in
-    let posts_dates = List.combine thread_posts dates in
-    let sorted_posts_dates =
-      List.sort (fun (_, a) (_, b) -> compare a b) posts_dates
     in
-
+    match List.find_opt Result.is_error dates with
-    let posts, _ = List.split sorted_posts_dates in
+    | Some (Error e) ->
-    let view_posts = List.map view_post posts in
+      Error (Format.sprintf "db error: %s" (Caqti_error.show e))
-    match List.find_opt Result.is_error view_posts with
-    | Some (Error e) -> Error e
     | Some (Ok _) -> assert false
-    | None ->
+    | None -> (
-      let posts =
+      let dates = List.map Result.get_ok dates in
-        List.map Result.get_ok (List.filter Result.is_ok view_posts)
+      let posts_dates = List.combine thread_posts dates in
+      let sorted_posts_dates =
+        List.sort (fun (_, a) (_, b) -> compare a b) posts_dates
       in
-      let posts =
+
-        Format.asprintf "%a"
+      let posts, _ = List.split sorted_posts_dates in
-          (Format.pp_print_list
+      let view_posts = List.map view_post posts in
-             ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
+      match List.find_opt Result.is_error view_posts with
-             Format.pp_print_string )
+      | Some (Error e) -> Error e
-          posts
+      | Some (Ok _) -> assert false
-      in
+      | None ->
-      let thread_view =
+        let posts =
-        Format.sprintf
+          List.map Result.get_ok (List.filter Result.is_ok view_posts)
-          {|
+        in
+        let posts =
+          Format.asprintf "%a"
+            (Format.pp_print_list
+               ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
+               Format.pp_print_string )
+            posts
+        in
+        let thread_view =
+          Format.sprintf
+            {|
 <div class="thread">
     <div class="threadSubject">
         %s
@@ -171,14 +175,12 @@ let view_thread thread_id =
     </div>
 </div>
 |}
-          subject posts
+            subject posts
-      in
+        in
-      Ok thread_view )
+        Ok thread_view )
 
-let get_markers board =
+let get_markers () =
-  let^ thread_id_list =
+  let^ thread_id_list = Db.fold Q.get_threads List.cons () [] in
-    Db.fold Q.list_threads List.cons (int_of_board board) []
-  in
   let markers_res =
     List.map
       (fun thread_id ->