diff --git a/src/babillard.ml b/src/babillard.ml index a303709..95e5790 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -10,14 +10,14 @@ let int_of_board = function | Plants -> 0 | Babillard -> 1 -let string_of_board = function - | Plants -> "plants" - | Babillard -> "babillard" +let pp_board fmt = function + | Plants -> Format.fprintf fmt "plants" + | Babillard -> Format.fprintf fmt "babillard" let board_of_int = function | 0 -> Plants | 1 -> Babillard - | _ -> assert false + | _ -> raise (Invalid_argument "board_of_int") type op = { id : string @@ -269,6 +269,9 @@ let () = (* TODO: Is this safe? *) (*TODO fix bad link if post in other thread*) let parse_comment comment = + let comment = String.trim comment in + let comment = Dream.html_escape comment in + let handle_word w = let trim_w = String.trim w in (* '>' is '>' after html_escape *) @@ -303,12 +306,16 @@ let parse_comment comment = ([], []) words in let words = List.rev words in - let line = String.concat (String.make 1 ' ') words in + let line = + Format.asprintf "%a" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt " ") + Format.pp_print_string ) + words + in (line, cited_posts) in - let comment = String.trim comment in - let comment = Dream.html_escape comment in let lines = String.split_on_char '\n' comment in let lines, cited_posts = List.fold_left @@ -319,7 +326,13 @@ let parse_comment comment = in let lines = List.rev lines in (*insert
*) - let comment = String.concat "\n
" lines in + let comment = + Format.asprintf "%a" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n
") + Format.pp_print_string ) + lines + in (* remove duplicate cited_id *) let cited_posts = List.sort_uniq (fun _ _ -> 1) cited_posts in (comment, cited_posts) @@ -354,16 +367,16 @@ let view_post post_id = image_name post_id post_id | None -> "" in - let replies_view = - {| |} + + let pp_print_reply fmt reply = + Format.fprintf fmt {|>>%s|} reply reply in + let pp_print_replies = + Format.asprintf {| |} + (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_reply) + in + + let replies_view = pp_print_replies replies in (* TODO how to display date, I should probably render everything on the client*) let post_info_view = Format.sprintf @@ -396,11 +409,8 @@ let view_post post_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 (fun post_id acc -> post_id :: acc) thread_id [] - in + let* thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in (*order by date *) - (*TODO do this more clean *) let dates = List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts in @@ -408,13 +418,7 @@ let view_thread thread_id = | Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) | Some (Ok _) -> assert false | None -> - let dates = - List.map - (function - | Ok date -> date - | Error _ -> assert false ) - dates - in + 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 @@ -423,13 +427,16 @@ let view_thread thread_id = let posts, _ = List.split sorted_posts_dates in let view_posts = List.map view_post posts in let view_posts = - List.map - (function - | Ok view -> view - | Error _ -> assert false ) - (List.filter Result.is_ok view_posts) + List.map Result.get_ok (List.filter Result.is_ok view_posts) in - Ok (String.concat "\n\r" view_posts) + 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 post_id, parent_id, date, nick, comment, image, tags, citations, op_data = @@ -597,44 +604,24 @@ let make_op ~comment ~image ~tags ~subject ~lat ~lng ~board nick = in upload_post op -(* TODO make this return geojson directly *) -let marker_list board = +let get_markers board = let* thread_id_list = - Db.fold Q.list_threads - (fun thread_id acc -> thread_id :: acc) - (int_of_board board) [] + Db.fold Q.list_threads List.cons (int_of_board board) [] in let markers_res = List.map (fun thread_id -> - match Db.find_opt Q.get_post_gps thread_id with - | Ok (Some (lat, lng)) -> - let content = - match view_post thread_id with - | Ok s -> s - | Error e -> e - in - Ok (lat, lng, content, thread_id) - | Ok None -> Error "latlng not found" - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - ) + let** lat, lng = Db.find_opt Q.get_post_gps thread_id in + match view_post thread_id with + | Ok content -> Ok (lat, lng, content, thread_id) + | Error e -> Error e ) thread_id_list in - let markers = - List.map - (function - | Ok res -> res - | Error _ -> assert false ) - (List.filter Result.is_ok markers_res) - in - Ok markers + let markers = List.map Result.get_ok (List.filter Result.is_ok markers_res) in -let marker_to_geojson marker = - match marker with - | lat, lng, content, thread_id -> - Format.sprintf - {| -{ + let pp_marker fmt (lat, lng, content, thread_id) = + Format.fprintf fmt + {|{ "type": "Feature", "geometry": { "type": "Point", @@ -643,12 +630,19 @@ let marker_to_geojson marker = "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 post_id = let** content = Db.find_opt Q.get_post_image_content post_id in diff --git a/src/js_babillard.ml b/src/js_babillard.ml index f3dcaa5..0a59e15 100644 --- a/src/js_babillard.ml +++ b/src/js_babillard.ml @@ -79,7 +79,7 @@ module Marker = struct Jv.to_string (Jv.call board_div "getAttribute" [| Jv.of_string "boardvalue" |]) in - let link = "/" ^ board ^ "/" ^ thread_id in + let link = Format.sprintf "/%s/%s" board thread_id in ignore @@ Jv.set thread_link "href" (Jv.of_string link); ignore @@ Jv.set thread_link "innerText" (Jv.of_string "[View Thread]"); () @@ -118,9 +118,8 @@ module Marker = struct (Jv.call board_div "getAttribute" [| Jv.of_string "boardvalue" |]) in let window = Jv.get Jv.global "window" in - let fetchfutur = - Jv.call window "fetch" [| Jv.of_string ("/" ^ board ^ "/markers") |] - in + let link = Jv.of_string (Format.sprintf "/%s/markers" board) in + let fetchfutur = Jv.call window "fetch" [| link |] in ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |]; () end diff --git a/src/newthread_page.eml.html b/src/newthread_page.eml.html index 64d6a62..a0cdff2 100644 --- a/src/newthread_page.eml.html +++ b/src/newthread_page.eml.html @@ -1,6 +1,7 @@ let f ~board request = - <%s! Dream.form_tag ~action:(Format.sprintf "/%s/new_thread" (Babillard.string_of_board board)) ~enctype:`Multipart_form_data request %> +%let url = Format.asprintf "/%a/new_thread" Babillard.pp_board board in + <%s! Dream.form_tag ~action:url ~enctype:`Multipart_form_data request %> diff --git a/src/permap.ml b/src/permap.ml index 97e0e0b..100557e 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -141,16 +141,10 @@ let post_image request = let plants_get request = render_unsafe (Plants_page.f request) request let markers ~board request = - (*TODO should be in babillard*) - let marker_list = Babillard.marker_list board in - match marker_list with - | Ok marker_list -> - let json = - {| [ |} - ^ String.concat "," (List.map Babillard.marker_to_geojson marker_list) - ^ "]" - in - Dream.respond ~headers:[ ("Content-Type", "application/json") ] json + let markers = Babillard.get_markers board in + match markers with + | Ok markers -> + Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers | Error e -> render_unsafe e request let babillard_get request = render_unsafe (Babillard_page.f request) request @@ -193,9 +187,7 @@ let newthread_post ~board request = with | Ok thread_id -> let adress = - Format.sprintf "/%s/%s" - (Babillard.string_of_board board) - thread_id + Format.asprintf "/%a/%s" Babillard.pp_board board thread_id in Dream.respond ~status:`See_Other ~headers:[ ("Location", adress) ] "Your thread was posted on the babillard!"