swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

preview_thread -> pp_thread_preview; changed post's type

Browse source
This commit is contained in:
Swrup 2022-02-21 01:59:36 +01:00
parent fe94594592
commit f5b6840fb4
2 changed files with 45 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

30
src/babillard.ml
View file

@ -7,7 +7,7 @@ type thread_data =
; lat : float ; lat : float
} }
type reply = type post =
{ id : string { id : string
; parent_id : string ; parent_id : string
; date : int ; date : int
@ -19,9 +19,9 @@ type reply =
; citations : string list ; citations : string list
} }
type post = type t =
| Op of thread_data * reply | Op of thread_data * post
| Reply of reply | Post of post
module Q = struct module Q = struct
let create_post_user_table = let create_post_user_table =
@ -299,7 +299,7 @@ let upload_post ?image_content post =
let thread_data, reply = let thread_data, reply =
match post with match post with
| Op (thread_data, reply) -> (Some thread_data, reply) | Op (thread_data, reply) -> (Some thread_data, reply)
| Reply reply -> (None, reply) | Post reply -> (None, reply)
in in
let { id; parent_id; date; nick; comment; image_info; tags; citations; _ } = let { id; parent_id; date; nick; comment; image_info; tags; citations; _ } =
reply reply
@ -399,7 +399,7 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng nick =
let make_reply ~comment ?image ~tags ~parent_id nick = let make_reply ~comment ?image ~tags ~parent_id nick =
let* reply = build_reply ~comment ?image ~tags ~parent_id nick in let* reply = build_reply ~comment ?image ~tags ~parent_id nick in
let post = Reply reply in let post = Post reply in
match image with match image with
| None -> upload_post post | None -> upload_post post
| Some (_image_info, image_content) -> upload_post ~image_content post | Some (_image_info, image_content) -> upload_post ~image_content post
@ -414,6 +414,11 @@ let get_post_image_content id =
let^? content = Db.find_opt Q.get_post_image_content id in let^? content = Db.find_opt Q.get_post_image_content id in
Ok content Ok content
let thread_exists id = Result.is_ok (Db.find Q.get_is_thread id)
(* true if post is an op too *)
let post_exists id = Result.is_ok (Db.find Q.get_is_post id)
let get_post id = let get_post id =
let^ parent_id = Db.find Q.get_post_thread id in let^ parent_id = Db.find Q.get_post_thread id in
let^ nick = Db.find Q.get_post_nick id in let^ nick = Db.find Q.get_post_nick id in
@ -429,7 +434,14 @@ let get_post id =
in in
Ok reply Ok reply
let thread_exists id = Result.is_ok (Db.find Q.get_is_thread id) let get_thread_data id =
if thread_exists id then
let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in
let thread_data = { subject; lat; lng } in
Ok thread_data
else Error "not an op"
(* true if post is an op too *) let get_op id =
let post_exists id = Result.is_ok (Db.find Q.get_is_post id) let* thread_data = get_thread_data id in
let* reply = get_post id in
Ok (thread_data, reply)

36
src/pp_babillard.ml
View file

@ -109,12 +109,11 @@ let pp_post fmt ~hide_replies post =
in in
pp pp
let preview_thread thread_id = let pp_thread_preview op =
let* post_data = get_post thread_id in let thread_data, post = op in
let^? subject, _lat, _lng = Db.find_opt Q.get_thread_info thread_id in let post_view =
let post =
(Format.asprintf "%a" (fun fmt data -> pp_post fmt ~hide_replies:true data)) (Format.asprintf "%a" (fun fmt data -> pp_post fmt ~hide_replies:true data))
post_data post
in in
let thread_preview = let thread_preview =
Format.sprintf Format.sprintf
@ -126,14 +125,21 @@ let preview_thread thread_id =
%s %s
</div> </div>
|} |}
subject post thread_data.subject post_view
in in
Ok thread_preview thread_preview
let catalog_content () = let catalog_content () =
Format.printf "catalog_content@."; Format.printf "catalog_content@.";
let^ threads = Db.collect_list Q.get_threads () in let^ threads = Db.collect_list Q.get_threads () in
let res_previews = List.map preview_thread threads in let res_previews =
List.map
(fun id ->
let* op = get_op id in
Ok (pp_thread_preview op) )
threads
in
let res_opt = List.find_opt Result.is_error res_previews in let res_opt = List.find_opt Result.is_error res_previews in
if Option.is_some res_opt then Option.get res_opt if Option.is_some res_opt then Option.get res_opt
else else
@ -192,9 +198,15 @@ let view_thread thread_id =
Ok thread_view Ok thread_view
let get_markers () = let get_markers () =
let^ threads = Db.collect_list Q.get_threads () in let^ ids = Db.collect_list Q.get_threads () in
let res_previews = List.map preview_thread threads in let res_previews =
let res_infos = List.map (Db.find Q.get_thread_info) threads in List.map
(fun id ->
let* op = get_op id in
Ok (pp_thread_preview op) )
ids
in
let res_infos = List.map (Db.find Q.get_thread_info) ids in
let res_previews_opt = List.find_opt Result.is_error res_previews in 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 let res_info_opt = List.find_opt Result.is_error res_infos in
@ -208,7 +220,7 @@ let get_markers () =
let previews = List.map Result.get_ok res_previews in let previews = List.map Result.get_ok res_previews in
let infos = List.map Result.get_ok res_infos in let infos = List.map Result.get_ok res_infos in
let previews_infos = List.combine previews infos in let previews_infos = List.combine previews infos in
let previews_infos_ids = List.combine previews_infos threads in let previews_infos_ids = List.combine previews_infos ids in
let pp_marker fmt lat lng content thread_id = let pp_marker fmt lat lng content thread_id =
(* geojson use lng lat, and not lat lng*) (* geojson use lng lat, and not lat lng*)