From 758973d02b74f2bfdebbb8bd57e033aba49b7dc8 Mon Sep 17 00:00:00 2001 From: Swrup Date: Sat, 29 Jan 2022 09:34:57 +0100 Subject: [PATCH] split printing functions --- src/babillard.ml | 173 ------------------------------------------- src/dune | 1 + src/permap.ml | 6 +- src/pp_babillard.ml | 175 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 179 insertions(+), 176 deletions(-) create mode 100644 src/pp_babillard.ml diff --git a/src/babillard.ml b/src/babillard.ml index bf12343..2da4019 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -353,139 +353,6 @@ let parse_comment comment = let cited_posts = List.sort_uniq String.compare cited_posts in (comment, cited_posts) -let view_post ?is_thread_preview post_id = - let* nick = Db.find Q.get_post_nick post_id in - let* comment = Db.find Q.get_post_comment post_id in - let* date = Db.find Q.get_post_date post_id in - let* image_info = Db.find_opt Q.get_post_image_info post_id in - - let* _tags = Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id [] in - let* replies = - Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) post_id [] - in - - (* TODO special stuff for OP - let* _subject = Db.find_opt Q.get_post_subject post_id in - let* _latlng = Db.find_opt Q.get_post_gps post_id in - *) - let image_view = - match image_info with - | Some (_image_name, image_alt) -> - (*TODO thumbnails *) - (*TODO image info like file name and size on top of image*) - Format.sprintf - {| -
- - %s - -
-|} - post_id post_id image_alt image_alt - | None -> "" - in - - let pp_print_reply fmt reply = - Format.fprintf fmt {|>>%s|} reply - reply - in - let pp_print_replies = - Format.asprintf {|
%a
|} - (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_reply) - in - - let replies_view = - match is_thread_preview with - | None -> pp_print_replies replies - | Some () -> ( - let res_nb = Db.find Q.count_thread_posts post_id in - match res_nb with - | Error _ -> "" - | Ok ((1 | 2) as nb) -> - Format.sprintf {|
%d reply
|} (nb - 1) - | Ok nb -> - Format.sprintf {|
%d replies
|} (nb - 1) ) - in - - let post_links_view = - match is_thread_preview with - | None -> - Format.sprintf - {| - - No. - %s - - %s - |} - post_id post_id post_id replies_view - | Some () -> Format.sprintf {| - %s - |} replies_view - in - - let post_info_view = - Format.sprintf - {| -
- %s - - %s -
|} - nick date post_links_view - in - let post_view = - Format.sprintf - {| -
-
- %s - %s -
%s
-
-
-|} - post_id post_info_view image_view comment - in - Ok post_view - -let preview_thread thread_id = view_post ~is_thread_preview:() thread_id - -let view_thread thread_id = - let** _ = Db.find_opt Q.is_thread thread_id in - let* thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in - (*order by date *) - let dates = - List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts - in - match List.find_opt Result.is_error dates with - | Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | 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 - - let posts, _ = List.split sorted_posts_dates in - let view_posts = List.map view_post posts in - match List.find_opt Result.is_error view_posts with - | Some (Error e) -> Error e - | Some (Ok _) -> assert false - | None -> - let view_posts = - List.map Result.get_ok (List.filter Result.is_ok view_posts) - in - let view_posts = - Format.asprintf "%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n") - Format.pp_print_string ) - view_posts - in - Ok view_posts ) - let upload_post post = let thread_data, reply = match post with @@ -616,46 +483,6 @@ let make_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick = let+ op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in upload_post op -let get_markers board = - let* thread_id_list = - Db.fold Q.list_threads List.cons (int_of_board board) [] - 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 pp_marker fmt (lat, lng, content, thread_id) = - Format.fprintf fmt - {|{ - "type": "Feature", - "geometry": { - "type": "Point", - "coordinates": [%s,%s] - }, - "properties": { - "content": "%s", - "thread_id": "%s" - }}|} - (* geojson use lng lat, and not lat lng*) - (Float.to_string lng) - (Float.to_string lat) (String.escaped content) thread_id - in - let markers = - Format.asprintf "[%a]" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ",") - pp_marker ) - markers - in - Ok markers - let get_post_image_content post_id = let** content = Db.find_opt Q.get_post_image_content post_id in Ok content diff --git a/src/dune b/src/dune index 4e3f6da..1b2fd2a 100644 --- a/src/dune +++ b/src/dune @@ -4,6 +4,7 @@ newthread_page thread_page babillard + pp_babillard babillard_page db app diff --git a/src/permap.ml b/src/permap.ml index 88c02d7..e4cbd81 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -149,7 +149,7 @@ let post_image request = | Error _ -> Dream.empty `Not_Found let markers ~board request = - let markers = Babillard.get_markers board in + let markers = Pp_babillard.get_markers board in match markers with | Ok markers -> Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers @@ -216,7 +216,7 @@ let newthread_post ~board request = let thread_get request = let thread_id = Dream.param "thread_id" request in - let thread_view = Babillard.view_thread thread_id in + let thread_view = Pp_babillard.view_thread thread_id in match thread_view with | Error e -> render_unsafe e request | Ok thread_view -> @@ -225,7 +225,7 @@ let thread_get request = (* get thread view but not wrapped in template, so we can display it on /babillard*) let thread_view request = let thread_id = Dream.param "thread_id" request in - let thread_view = Babillard.view_thread thread_id in + let thread_view = Pp_babillard.view_thread thread_id in match thread_view with | Error e -> render_unsafe e request | Ok thread_view -> Dream.html (Thread_page.f thread_view thread_id request) diff --git a/src/pp_babillard.ml b/src/pp_babillard.ml new file mode 100644 index 0000000..5e94294 --- /dev/null +++ b/src/pp_babillard.ml @@ -0,0 +1,175 @@ +include Babillard +open Db + +let view_post ?is_thread_preview post_id = + let* nick = Db.find Q.get_post_nick post_id in + let* comment = Db.find Q.get_post_comment post_id in + let* date = Db.find Q.get_post_date post_id in + let* image_info = Db.find_opt Q.get_post_image_info post_id in + + let* _tags = Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id [] in + let* replies = + Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) post_id [] + in + + (* TODO special stuff for OP + let* _subject = Db.find_opt Q.get_post_subject post_id in + let* _latlng = Db.find_opt Q.get_post_gps post_id in + *) + let image_view = + match image_info with + | Some (_image_name, image_alt) -> + (*TODO thumbnails *) + (*TODO image info like file name and size on top of image*) + Format.sprintf + {| +
+ + %s + +
+|} + post_id post_id image_alt image_alt + | None -> "" + in + + let pp_print_reply fmt reply = + Format.fprintf fmt {|>>%s|} reply + reply + in + let pp_print_replies = + Format.asprintf {|
%a
|} + (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_reply) + in + + let replies_view = + match is_thread_preview with + | None -> pp_print_replies replies + | Some () -> ( + let res_nb = Db.find Q.count_thread_posts post_id in + match res_nb with + | Error _ -> "" + | Ok ((1 | 2) as nb) -> + Format.sprintf {|
%d reply
|} (nb - 1) + | Ok nb -> + Format.sprintf {|
%d replies
|} (nb - 1) ) + in + + let post_links_view = + match is_thread_preview with + | None -> + Format.sprintf + {| + + No. + %s + + %s + |} + post_id post_id post_id replies_view + | Some () -> Format.sprintf {| + %s + |} replies_view + in + + let post_info_view = + Format.sprintf + {| +
+ %s + + %s +
|} + nick date post_links_view + in + let post_view = + Format.sprintf + {| +
+
+ %s + %s +
%s
+
+
+|} + post_id post_info_view image_view comment + in + Ok post_view + +let preview_thread thread_id = view_post ~is_thread_preview:() thread_id + +let view_thread thread_id = + let** _ = Db.find_opt Q.is_thread thread_id in + let* thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in + (*order by date *) + let dates = + List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts + in + match List.find_opt Result.is_error dates with + | Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | 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 + + let posts, _ = List.split sorted_posts_dates in + let view_posts = List.map view_post posts in + match List.find_opt Result.is_error view_posts with + | Some (Error e) -> Error e + | Some (Ok _) -> assert false + | None -> + let view_posts = + List.map Result.get_ok (List.filter Result.is_ok view_posts) + in + let view_posts = + Format.asprintf "%a" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n") + Format.pp_print_string ) + view_posts + in + Ok view_posts ) + +let get_markers board = + let* thread_id_list = + Db.fold Q.list_threads List.cons (int_of_board board) [] + 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 pp_marker fmt (lat, lng, content, thread_id) = + Format.fprintf fmt + {|{ + "type": "Feature", + "geometry": { + "type": "Point", + "coordinates": [%s,%s] + }, + "properties": { + "content": "%s", + "thread_id": "%s" + }}|} + (* geojson use lng lat, and not lat lng*) + (Float.to_string lng) + (Float.to_string lat) (String.escaped content) thread_id + in + let markers = + Format.asprintf "[%a]" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",") + pp_marker ) + markers + in + Ok markers