From a54f614e059abaff34a3dc2f2e554b86079b11f1 Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 21 Feb 2022 00:19:35 +0100 Subject: [PATCH] change db: merge subject+latlng in thread_info; add catalog; fix get_markers hidding errors --- src/babillard.ml | 86 +++++++++++++-------------------- src/catalog_page.eml.html | 8 +++ src/content/assets/js/dune | 9 ++++ src/dune | 8 +++ src/js/dune | 8 +++ src/js/js_catalog.ml | 1 + src/permap.ml | 7 +++ src/pp_babillard.ml | 99 +++++++++++++++++++++++--------------- src/template.eml.html | 3 ++ 9 files changed, 138 insertions(+), 91 deletions(-) create mode 100644 src/catalog_page.eml.html create mode 100644 src/js/js_catalog.ml diff --git a/src/babillard.ml b/src/babillard.ml index 1a0b61f..3d5fcd0 100644 --- a/src/babillard.ml +++ b/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\ - \ FOREIGN KEY(thread_id) REFERENCES post_user(post_id),\n\ - \ FOREIGN KEY(post_id) REFERENCES post_user(post_id));" + "CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject TEXT, \ + lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \ + 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) - "INSERT INTO post_gps VALUES (?,?,?);" + Caqti_type.(tup4 string string float float) + "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 = - Caqti_request.find_opt Caqti_type.string Caqti_type.string - "SELECT subject FROM post_subject WHERE post_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_thread_info = + Caqti_request.find Caqti_type.string + Caqti_type.(tup3 string float float) + "SELECT subject,lat,lng FROM thread_info WHERE thread_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_post_subject (id, subject) in + let^ () = Db.exec Q.upload_thread_info (id, subject, lat, lng) in Ok id let build_reply ~comment ?image ~tags ?parent_id nick = diff --git a/src/catalog_page.eml.html b/src/catalog_page.eml.html new file mode 100644 index 0000000..8f0f95a --- /dev/null +++ b/src/catalog_page.eml.html @@ -0,0 +1,8 @@ +let f content = + + +

Catalog:

+
+
+ <%s! content %> +
diff --git a/src/content/assets/js/dune b/src/content/assets/js/dune index 4b7944d..3c3cc21 100644 --- a/src/content/assets/js/dune +++ b/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 diff --git a/src/dune b/src/dune index 509bc85..917bc41 100644 --- a/src/dune +++ b/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)) diff --git a/src/js/dune b/src/js/dune index d23bebe..487a43e 100644 --- a/src/js/dune +++ b/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) diff --git a/src/js/js_catalog.ml b/src/js/js_catalog.ml new file mode 100644 index 0000000..0b673cf --- /dev/null +++ b/src/js/js_catalog.ml @@ -0,0 +1 @@ +include Js_pretty_post diff --git a/src/permap.ml b/src/permap.ml index caee470..aabc085 100644 --- a/src/permap.ml +++ b/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 diff --git a/src/pp_babillard.ml b/src/pp_babillard.ml index 9b0f377..b3d74fe 100644 --- a/src/pp_babillard.ml +++ b/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 markers_res = - List.map - (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^ threads = Db.collect_list Q.get_threads () in + let res_previews = List.map preview_thread threads in + let res_infos = List.map (Db.find Q.get_thread_info) 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) ] - ) - ] + let res_previews_opt = List.find_opt Result.is_error res_previews in + let res_info_opt = List.find_opt Result.is_error res_infos in + if Option.is_some res_previews_opt then Option.get res_previews_opt + else if Option.is_some res_info_opt then + Error + (Result.fold + ~ok:(assert false) + ~error:Caqti_error.show (Option.get res_info_opt) ) + else + let previews = List.map Result.get_ok res_previews in + let infos = List.map Result.get_ok res_infos in + let previews_infos = List.combine previews infos in + 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 = - Format.asprintf "[%a]" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ",") - pp_marker ) - markers - in - Ok markers + + let markers = + Format.asprintf "[%a]" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",") + (fun fmt ((preview, (_sub, lat, lng)), id) -> + pp_marker fmt lat lng preview id ) ) + previews_infos_ids + in + Ok markers diff --git a/src/template.eml.html b/src/template.eml.html index 7e8660b..296f898 100644 --- a/src/template.eml.html +++ b/src/template.eml.html @@ -21,6 +21,9 @@ let render_unsafe ~title ~content request =
  • Babillard
    • +
  • + Catalog +
  • Discover users