change db: merge subject+latlng in thread_info; add catalog; fix get_markers hidding errors

src/babillard.ml

@@ -29,11 +29,19 @@ module Q = struct
       "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, nick TEXT, PRIMARY \
        KEY(post_id), FOREIGN KEY(nick) REFERENCES user(nick));"
 
-  let create_thread_table =
+  (* one row for each thread, with thread's data *)
+  let create_thread_info_table =
     Caqti_request.exec Caqti_type.unit
-      "CREATE TABLE IF NOT EXISTS threads (thread_id TEXT, post_id TEXT,\n\
+      "CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject TEXT, \
-      \         FOREIGN KEY(thread_id) REFERENCES post_user(post_id),\n\
+       lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \
-      \         FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
+       post_user(post_id));"
+
+  (* map thread and reply to the thread *)
+  let create_thread_post_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS thread_post (thread_id TEXT, post_id TEXT,\n\
+      \               FOREIGN KEY(thread_id) REFERENCES post_user(post_id),\n\
+      \               FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
 
   let create_post_replies_table =
     Caqti_request.exec Caqti_type.unit
@@ -67,16 +75,6 @@ module Q = struct
       "CREATE TABLE IF NOT EXISTS image_content (post_id TEXT,image_content \
        TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
 
-  let create_post_gps_table =
-    Caqti_request.exec Caqti_type.unit
-      "CREATE TABLE IF NOT EXISTS post_gps (post_id TEXT, lat FLOAT, lng FLOAT ,\n\
-      \       FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
-
-  let create_post_subject_table =
-    Caqti_request.exec Caqti_type.unit
-      "CREATE TABLE IF NOT EXISTS post_subject (post_id TEXT, subject TEXT, \
-       FOREIGN KEY(post_id) REFERENCES post_user(post_id));"
-
   let create_post_tags_table =
     Caqti_request.exec Caqti_type.unit
       "CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, FOREIGN \
@@ -87,10 +85,15 @@ module Q = struct
       Caqti_type.(tup2 string string)
       "INSERT INTO post_user VALUES (?,?);"
 
-  let upload_post_gps =
+  let upload_thread_info =
     Caqti_request.exec
-      Caqti_type.(tup3 string float float)
+      Caqti_type.(tup4 string string float float)
-      "INSERT INTO post_gps VALUES (?,?,?);"
+      "INSERT INTO thread_info VALUES (?,?,?,?);"
+
+  let upload_thread_post =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO thread_post VALUES (?,?);"
 
   let upload_image_info =
     Caqti_request.exec
@@ -112,11 +115,6 @@ module Q = struct
       Caqti_type.(tup2 string string)
       "INSERT INTO post_comment VALUES (?,?);"
 
-  let upload_post_subject =
-    Caqti_request.exec
-      Caqti_type.(tup2 string string)
-      "INSERT INTO post_subject VALUES (?,?);"
-
   let upload_post_tag =
     Caqti_request.exec
       Caqti_type.(tup2 string string)
@@ -127,16 +125,6 @@ module Q = struct
       Caqti_type.(tup2 string int)
       "INSERT INTO post_date VALUES (?,?);"
 
-  let upload_to_thread =
-    Caqti_request.exec
-      Caqti_type.(tup2 string string)
-      "INSERT INTO threads VALUES (?,?);"
-
-  let upload_post_parent =
-    Caqti_request.exec
-      Caqti_type.(tup2 string string)
-      "INSERT INTO post_parent VALUES (?,?);"
-
   let get_post_nick =
     Caqti_request.find Caqti_type.string Caqti_type.string
       "SELECT nick FROM post_user WHERE post_id=?;"
@@ -172,15 +160,15 @@ module Q = struct
 
   let get_thread_posts =
     Caqti_request.collect Caqti_type.string Caqti_type.string
-      "SELECT post_id FROM threads WHERE thread_id=?;"
+      "SELECT post_id FROM thread_post WHERE thread_id=?;"
 
   let count_thread_posts =
     Caqti_request.find Caqti_type.string Caqti_type.int
-      "SELECT COUNT(post_id) FROM threads WHERE thread_id=?;"
+      "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?;"
 
   let get_is_thread =
     Caqti_request.find Caqti_type.string Caqti_type.string
-      "SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1;"
+      "SELECT thread_id FROM thread_info WHERE thread_id=? LIMIT 1;"
 
   let get_is_post =
     Caqti_request.find Caqti_type.string Caqti_type.string
@@ -188,34 +176,29 @@ module Q = struct
 
   let get_post_thread =
     Caqti_request.find Caqti_type.string Caqti_type.string
-      "SELECT thread_id FROM threads WHERE post_id=? LIMIT 1;"
+      "SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1;"
 
-  let get_post_subject =
+  let get_thread_info =
-    Caqti_request.find_opt Caqti_type.string Caqti_type.string
+    Caqti_request.find Caqti_type.string
-      "SELECT subject FROM post_subject WHERE post_id=?;"
+      Caqti_type.(tup3 string float float)
-
+      "SELECT subject,lat,lng FROM thread_info WHERE thread_id=?;"
-  let get_post_gps =
-    Caqti_request.find_opt Caqti_type.string
-      Caqti_type.(tup2 float float)
-      "SELECT lat, lng FROM post_gps WHERE post_id=?;"
 
   let get_threads =
     Caqti_request.collect Caqti_type.unit Caqti_type.string
-      "SELECT thread_id FROM threads;"
+      "SELECT thread_id FROM thread_info;"
 end
 
 let () =
   let tables =
     [ Q.create_post_user_table
-    ; Q.create_thread_table
+    ; Q.create_thread_info_table
+    ; Q.create_thread_post_table
     ; Q.create_post_replies_table
     ; Q.create_post_citations_table
     ; Q.create_post_date_table
     ; Q.create_post_comment_table
     ; Q.create_image_info_table
     ; Q.create_image_content_table
-    ; Q.create_post_gps_table
-    ; Q.create_post_subject_table
     ; Q.create_post_tags_table
     ]
   in
@@ -325,7 +308,7 @@ let upload_post ?image_content post =
   let^ () = Db.exec Q.upload_post_id (id, nick) in
   let^ () = Db.exec Q.upload_post_comment (id, comment) in
   let^ () = Db.exec Q.upload_post_date (id, date) in
-  let^ () = Db.exec Q.upload_to_thread (parent_id, id) in
+  let^ () = Db.exec Q.upload_thread_post (parent_id, id) in
   let _res_image_info, _res_image_content =
     match image_info with
     | None -> (Ok (), Ok ())
@@ -336,8 +319,6 @@ let upload_post ?image_content post =
         ( Db.exec Q.upload_image_info (id, name, alt)
         , Db.exec Q.upload_image_content (id, content) ) )
   in
-  (* what is parent and why do i need it again? TODO TODO *)
-  let^ () = Db.exec Q.upload_post_parent (id, parent_id) in
   let^ () =
     match
       List.find_opt Result.is_error
@@ -361,8 +342,7 @@ let upload_post ?image_content post =
   match thread_data with
   | None -> Ok id
   | Some { subject; lng; lat } ->
-    let^ () = Db.exec Q.upload_post_gps (id, lat, lng) in
+    let^ () = Db.exec Q.upload_thread_info (id, subject, lat, lng) in
-    let^ () = Db.exec Q.upload_post_subject (id, subject) in
     Ok id
 
 let build_reply ~comment ?image ~tags ?parent_id nick =

src/catalog_page.eml.html

@@ -0,0 +1,8 @@
+let f content =
+
+<script type="text/javascript" src="/assets/js/js_catalog.js" defer="defer"></script>
+  <h1>Catalog:</h1>
+  <br />
+  <div class="row mb-3">
+      <%s! content %>
+  </div>

src/content/assets/js/dune

@@ -1,3 +1,12 @@
+(rule
+ (target js_catalog.js)
+ (deps
+  (file ../../../js/js_catalog.bc.js))
+ (action
+  (with-stdout-to
+   %{target}
+   (cat ../../../js/js_catalog.bc.js))))
+
 (rule
  (target js_babillard.js)
  (deps

src/dune

@@ -4,6 +4,7 @@
   app
   babillard
   babillard_page
+  catalog_page
   bindings
   content
   db
@@ -35,6 +36,12 @@
  (preprocess
   (pps lwt_ppx)))
 
+(rule
+ (targets catalog_page.ml)
+ (deps catalog_page.eml.html)
+ (action
+  (run dream_eml %{deps} --workspace %{workspace_root})))
+
 (rule
  (targets template.ml)
  (deps template.eml.html)
@@ -81,6 +88,7 @@
  (target content.ml)
  (deps
   (source_tree content)
+  (file content/assets/js/js_catalog.js)
   (file content/assets/js/js_babillard.js)
   (file content/assets/js/js_newthread.js)
   (file content/assets/js/js_thread.js))

src/js/dune

@@ -21,6 +21,14 @@
  (preprocess
   (pps js_of_ocaml-ppx)))
 
+(executable
+ (name js_catalog)
+ (modules js_catalog)
+ (libraries js_of_ocaml brr js_pretty_post)
+ (modes js)
+ (preprocess
+  (pps js_of_ocaml-ppx)))
+
 (executable
  (name js_babillard)
  (modules js_babillard)

src/js/js_catalog.ml

@@ -0,0 +1 @@
+include Js_pretty_post

src/permap.ml

@@ -64,6 +64,12 @@ let login_post request =
   | `Wrong_session _ | `Expired _ | `Wrong_content_type ->
     Dream.empty `Bad_Request
 
+let catalog request =
+  let catalog_content =
+    Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.catalog_content ())
+  in
+  render_unsafe (Catalog_page.f catalog_content) request
+
 let user request =
   render_unsafe (Result.fold ~ok:Fun.id ~error:Fun.id (User.list ())) request
 
@@ -266,6 +272,7 @@ let routes =
   ; get_ "/user/:user/avatar" avatar_image
   ; get_ "/thread/:thread_id" thread_get
   ; post "/thread/:thread_id" reply_post
+  ; get_ "/catalog" catalog
   ]
   @
   if App.open_registration then

src/pp_babillard.ml

@@ -113,7 +113,7 @@ let view_post ?is_thread_preview id =
 
 let preview_thread thread_id =
   let* post = view_post ~is_thread_preview:() thread_id in
-  let^? subject = Db.find_opt Q.get_post_subject thread_id in
+  let^? subject, _lat, _lng = Db.find_opt Q.get_thread_info thread_id in
   let thread_preview =
     Format.sprintf
       {|
@@ -128,9 +128,23 @@ let preview_thread thread_id =
   in
   Ok thread_preview
 
+let catalog_content () =
+  Format.printf "catalog_content@.";
+  let^ threads = Db.collect_list Q.get_threads () in
+  let res_previews = List.map preview_thread threads in
+  let res_opt = List.find_opt Result.is_error res_previews in
+  if Option.is_some res_opt then Option.get res_opt
+  else
+    let previews = List.map Result.get_ok res_previews in
+    Ok
+      (Format.asprintf "%a"
+         (Format.pp_print_list ~pp_sep:Format.pp_print_space
+            Format.pp_print_string )
+         previews )
+
 let view_thread thread_id =
   let^ _is_thread = Db.find Q.get_is_thread thread_id in
-  let^? subject = Db.find_opt Q.get_post_subject thread_id in
+  let^? subject, _lat, _lng = Db.find_opt Q.get_thread_info thread_id in
   let^ thread_posts = Db.collect_list Q.get_thread_posts thread_id in
   (*order by date *)
   let dates = List.map (Db.find Q.get_post_date) thread_posts in
@@ -177,41 +191,50 @@ let view_thread thread_id =
       Ok thread_view )
 
 let get_markers () =
-  let^ thread_id_list = Db.collect_list Q.get_threads () in
+  let^ threads = Db.collect_list Q.get_threads () in
-  let markers_res =
+  let res_previews = List.map preview_thread threads in
-    List.map
+  let res_infos = List.map (Db.find Q.get_thread_info) threads in
-      (fun thread_id ->
-        let^? lat, lng = Db.find_opt Q.get_post_gps thread_id in
-        match preview_thread thread_id with
-        | Ok content -> Ok (lat, lng, content, thread_id)
-        | Error e -> Error e )
-      thread_id_list
-  in
-  let markers = List.map Result.get_ok (List.filter Result.is_ok markers_res) in
 
-  let pp_marker fmt (lat, lng, content, thread_id) =
+  let res_previews_opt = List.find_opt Result.is_error res_previews in
-    (* geojson use lng lat, and not lat lng*)
+  let res_info_opt = List.find_opt Result.is_error res_infos in
-    let json =
+  if Option.is_some res_previews_opt then Option.get res_previews_opt
-      `Assoc
+  else if Option.is_some res_info_opt then
-        [ ("type", `String "Feature")
+    Error
-        ; ( "geometry"
+      (Result.fold
-          , `Assoc
+         ~ok:(assert false)
-              [ ("type", `String "Point")
+         ~error:Caqti_error.show (Option.get res_info_opt) )
-              ; ("coordinates", `List [ `Float lng; `Float lat ])
+  else
-              ] )
+    let previews = List.map Result.get_ok res_previews in
-        ; ( "properties"
+    let infos = List.map Result.get_ok res_infos in
-          , `Assoc
+    let previews_infos = List.combine previews infos in
-              [ ("content", `String content); ("thread_id", `String thread_id) ]
+    let previews_infos_ids = List.combine previews_infos threads in
-          )
+
-        ]
+    let pp_marker fmt lat lng content thread_id =
+      (* geojson use lng lat, and not lat lng*)
+      let json =
+        `Assoc
+          [ ("type", `String "Feature")
+          ; ( "geometry"
+            , `Assoc
+                [ ("type", `String "Point")
+                ; ("coordinates", `List [ `Float lng; `Float lat ])
+                ] )
+          ; ( "properties"
+            , `Assoc
+                [ ("content", `String content)
+                ; ("thread_id", `String thread_id)
+                ] )
+          ]
+      in
+      Yojson.pretty_print fmt json
     in
-    Yojson.pretty_print fmt json
+
-  in
+    let markers =
-  let markers =
+      Format.asprintf "[%a]"
-    Format.asprintf "[%a]"
+        (Format.pp_print_list
-      (Format.pp_print_list
+           ~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
-         ~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
+           (fun fmt ((preview, (_sub, lat, lng)), id) ->
-         pp_marker )
+             pp_marker fmt lat lng preview id ) )
-      markers
+        previews_infos_ids
-  in
+    in
-  Ok markers
+    Ok markers

src/template.eml.html

@@ -21,6 +21,9 @@ let render_unsafe ~title ~content request =
                           <li class="nav-item">
                               <a class="nav-link" href="/">Babillard</a>
                           </li>
+                          <li class="nav-item">
+                              <a class="nav-link" href="/catalog">Catalog</a>
+                          </li>
                           <li class="nav-item">
                               <a class="nav-link" href="/user">Discover users</a>
                           </li>