diff --git a/src/babillard.ml b/src/babillard.ml index e489e19..9d347b5 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -176,9 +176,9 @@ module Q = struct Caqti_request.find Caqti_type.string Caqti_type.int "SELECT COUNT(post_id) FROM threads WHERE thread_id=?;" - let is_thread = - Caqti_request.find Caqti_type.string Caqti_type.bool - "IF EXISTS (SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1);" + let get_thread = + Caqti_request.find Caqti_type.string Caqti_type.string + "SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1;" let get_post_subject = Caqti_request.find_opt Caqti_type.string Caqti_type.string @@ -213,7 +213,7 @@ let () = List.exists Result.is_error (List.map (fun query -> Db.exec query ()) tables) then - Dream.warning (fun log -> log "can't create table") + Dream.error (fun log -> log "can't create table") let parse_image image = match image with diff --git a/src/js/js_map.ml b/src/js/js_map.ml index ce6ed97..b07d9a5 100644 --- a/src/js/js_map.ml +++ b/src/js/js_map.ml @@ -91,8 +91,7 @@ module Leaflet = struct let () = log "add on (move/zoom)end event@."; ignore @@ Jv.call map "on" [| Jv.of_string "moveend"; Jv.repr on_moveend |]; - ignore @@ Jv.call map "on" [| Jv.of_string "zoomend"; Jv.repr on_zoomend |]; - () + ignore @@ Jv.call map "on" [| Jv.of_string "zoomend"; Jv.repr on_zoomend |] end module Geolocalize = struct @@ -106,14 +105,12 @@ module Geolocalize = struct let latlng = Jv.call Leaflet.leaflet "latLng" [| Jv.of_float lat; Jv.of_float lng |] in - ignore @@ Jv.call Leaflet.map "setView" [| latlng; Jv.of_int 13 |]; - () + ignore @@ Jv.call Leaflet.map "setView" [| latlng; Jv.of_int 13 |] let geolocalize () = log "geolocalize@."; let l = Brr_io.Geolocation.of_navigator Brr.G.navigator in - ignore @@ Fut.await (Brr_io.Geolocation.get l) update_location; - () + ignore @@ Fut.await (Brr_io.Geolocation.get l) update_location let () = Jv.set Jv.global "geolocalize" (Jv.repr geolocalize) end @@ -141,8 +138,7 @@ module Marker = struct @@ Jv.call layer "on" [| Jv.of_string "click" ; Jv.repr (marker_on_click thread_preview thread_id) - |]; - () + |] let handle_geojson geojson = log "handle_geojson@."; @@ -162,14 +158,12 @@ module Marker = struct let markers_handle_response response = log "markers_handle_response@."; let geo_json_list_futur = Jv.call response "json" [||] in - ignore @@ Jv.call geo_json_list_futur "then" [| Jv.repr handle_geojson |]; - () + ignore @@ Jv.call geo_json_list_futur "then" [| Jv.repr handle_geojson |] let () = log "fetch thread geojson@."; let window = Jv.get Jv.global "window" in let link = Jv.of_string "/babillard/markers" in let fetchfutur = Jv.call window "fetch" [| link |] in - ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |]; - () + ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |] end diff --git a/src/js/js_newthread.ml b/src/js/js_newthread.ml index 87510d1..bf48327 100644 --- a/src/js/js_newthread.ml +++ b/src/js/js_newthread.ml @@ -27,8 +27,7 @@ let on_click e = let newthread_div = Jv.get Jv.global "newthread" in ignore @@ Jv.call newthread_div "setAttribute" - [| Jv.of_string "style"; Jv.of_string "visibility:hidden" |]; - () + [| Jv.of_string "style"; Jv.of_string "visibility:hidden" |] (*add on_click callback to map*) let () = diff --git a/src/js/js_post_form.ml b/src/js/js_post_form.ml index 96651cf..f9f0c99 100644 --- a/src/js/js_post_form.ml +++ b/src/js/js_post_form.ml @@ -4,37 +4,34 @@ let log = Format.printf (* insert id into reply form *) let insert_quote post_id = log "quote@."; - match Jv.(find global "replyComment") with - | None -> Jv.undefined - | Some comment_textarea -> - let content = Jv.get comment_textarea "value" in - let new_content = - Jv.call content "concat" - [| Jv.of_string "\n>>"; post_id; Jv.of_string " " |] - in - ignore @@ Jv.set comment_textarea "value" new_content; - Jv.undefined + Option.iter + (fun comment_textarea -> + let content = Jv.get comment_textarea "value" in + let new_content = + Jv.call content "concat" + [| Jv.of_string "\n>>"; post_id; Jv.of_string " " |] + in + ignore @@ Jv.set comment_textarea "value" new_content ) + Jv.(find global "replyComment"); + Jv.undefined let () = Jv.set Jv.global "insert_quote" (Jv.repr insert_quote) (* make image description field visible when a file is selected*) let make_visible el _event = let el_style = Jv.get el "style" in - ignore @@ Jv.set el_style "display" (Jv.of_string "block"); - () + ignore @@ Jv.set el_style "display" (Jv.of_string "block") let () = log "change image description visibility@."; - let file_input = Jv.find Jv.global "file" in - match file_input with - | None -> () (*not post form on the page, not logged in*) - | Some file_input -> - let alt_input = Jv.get Jv.global "alt" in - let alt_label = Jv.get Jv.global "altLabel" in - ignore - @@ Jv.call file_input "addEventListener" - [| Jv.of_string "change"; Jv.repr (make_visible alt_input) |]; - ignore - @@ Jv.call file_input "addEventListener" - [| Jv.of_string "change"; Jv.repr (make_visible alt_label) |]; - () + Option.iter + (fun file_input -> + let alt_input = Jv.get Jv.global "alt" in + let alt_label = Jv.get Jv.global "altLabel" in + ignore + @@ Jv.call file_input "addEventListener" + [| Jv.of_string "change"; Jv.repr (make_visible alt_input) |]; + ignore + @@ Jv.call file_input "addEventListener" + [| Jv.of_string "change"; Jv.repr (make_visible alt_label) |] ) + Jv.(find global "file") diff --git a/src/js/js_pretty_post.ml b/src/js/js_pretty_post.ml index 45114b3..9a5b211 100644 --- a/src/js/js_pretty_post.ml +++ b/src/js/js_pretty_post.ml @@ -1,5 +1,18 @@ let log = Format.printf +type image_size = + | Big + | Small + +let of_string = function + | "postImage" -> Some Small + | "postImageBig" -> Some Big + | _ -> None + +let to_string = function + | Small -> "postImage" + | Big -> "postImageBig" + (*change postImage class to make it bigger/smaller on click*) let image_click post_image event = log "image_click@."; @@ -7,17 +20,19 @@ let image_click post_image event = Jv.to_string @@ Jv.call post_image "getAttribute" [| Jv.of_string "class" |] in let new_class = - match current_class with - | "postImage" -> "postImageBig" - | "postImageBig" -> "postImage" - | _ -> failwith "invalid image class name" + match of_string current_class with + | Some image_size -> + to_string + ( match image_size with + | Big -> Small + | Small -> Big ) + | None -> failwith "invalid image class name" in ignore @@ Jv.call post_image "setAttribute" [| Jv.of_string "class"; Jv.of_string new_class |]; (*prevent opening image in new tab*) - ignore @@ Jv.call event "preventDefault" [||]; - () + ignore @@ Jv.call event "preventDefault" [||] let render_time date_span = log "render time@."; @@ -39,8 +54,7 @@ let render_time date_span = let date_string = Format.sprintf "%02d-%02d-%02d %02d:%02d" year month day hour min in - ignore @@ Jv.set date_span "innerHTML" (Jv.of_string date_string); - () + ignore @@ Jv.set date_span "innerHTML" (Jv.of_string date_string) let make_pretty _ = log "make pretty@."; @@ -71,5 +85,4 @@ let () = let window = Jv.get Jv.global "window" in ignore @@ Jv.call window "addEventListener" - [| Jv.of_string "load"; Jv.repr make_pretty |]; - () + [| Jv.of_string "load"; Jv.repr make_pretty |] diff --git a/src/permap.ml b/src/permap.ml index 454f444..6c916f3 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -63,17 +63,11 @@ let login_post request = | _ -> assert false let user request = - render_unsafe - ( match User.list () with - | Ok s -> s - | Error _ -> "" ) - request + render_unsafe (Result.fold ~ok:Fun.id ~error:Fun.id (User.list ())) request let user_profile request = render_unsafe - ( match User.public_profile request with - | Ok s -> s - | Error e -> e ) + (Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile request)) request let logout request = diff --git a/src/pp_babillard.ml b/src/pp_babillard.ml index c1702f5..b47d73a 100644 --- a/src/pp_babillard.ml +++ b/src/pp_babillard.ml @@ -8,103 +8,101 @@ let view_post ?is_thread_preview post_id = 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 + let^ tags = Db.collect_list Q.get_post_tags post_id in + let^ replies = Db.collect_list Q.get_post_replies post_id in - let image_view = + let image_view fmt () = 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 + Format.fprintf fmt {|
- + %s
|} post_id post_id image_alt image_alt - | None -> "" + | None -> Format.fprintf fmt "" in let pp_print_reply fmt reply = Format.fprintf fmt {|>>%s|} reply reply in - let pp_print_replies replies = - Format.asprintf {|
%a
|} + let pp_print_replies fmt replies = + Format.fprintf fmt {|
%a
|} (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_reply) replies in - let replies_view = + let replies_view fmt () = match is_thread_preview with - | None -> pp_print_replies replies + | None -> pp_print_replies fmt replies | Some () -> ( let res_nb = Db.find Q.count_thread_posts post_id in match res_nb with - | Error _ -> "" + | Error _ -> Format.fprintf fmt "" | Ok ((1 | 2) as nb) -> - Format.sprintf {|
%d reply
|} (nb - 1) + Format.fprintf fmt {|
%d reply
|} (nb - 1) | Ok nb -> - Format.sprintf {|
%d replies
|} (nb - 1) ) + Format.fprintf fmt {|
%d replies
|} (nb - 1) ) in - let post_links_view = + let post_links_view fmt () = match is_thread_preview with | None -> - Format.sprintf + Format.fprintf fmt {| # - %s + %s - %s + %a |} - post_id post_id post_id replies_view - | Some () -> Format.sprintf {| - %s - |} replies_view + post_id post_id post_id replies_view () + | Some () -> Format.fprintf fmt {| + %a + |} replies_view () in - let post_info_view = - Format.sprintf + let post_info_view fmt () = + Format.fprintf fmt {|
%s - %s + %a
|} - nick date post_links_view + nick date post_links_view () in let pp_print_tag fmt tag = Format.fprintf fmt {|%s|} tag in - let pp_print_tags tags = - Format.asprintf {|
%a
|} + let pp_print_tags fmt tags = + Format.fprintf fmt {|
%a
|} (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_tag) tags in let tags = List.sort String.compare tags in - let tags_view = pp_print_tags tags in + let tags_view fmt () = pp_print_tags fmt tags in let post_view = - Format.sprintf + Format.asprintf {|
- %s - %s + %a + %a
%s
- %s + %a
|} - post_id post_info_view image_view comment tags_view + post_id post_info_view () image_view () comment tags_view () in Ok post_view @@ -126,46 +124,40 @@ let preview_thread thread_id = Ok thread_preview let view_thread thread_id = - let^ is_thread = Db.find Q.is_thread thread_id in - if not is_thread then - Error "This thread doesn't exists" - else - let^? subject = Db.find_opt Q.get_post_subject 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 + let^ _is_thread = Db.find Q.get_thread thread_id in + let^? subject = Db.find_opt Q.get_post_subject 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 + 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 - 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 posts = - List.map Result.get_ok (List.filter Result.is_ok view_posts) - in - let posts = - Format.asprintf "%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n") - Format.pp_print_string ) - posts - in - let thread_view = - Format.sprintf - {| + 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 posts = + List.map Result.get_ok (List.filter Result.is_ok view_posts) + in + let posts = + Format.asprintf "%a" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n") + Format.pp_print_string ) + posts + in + let thread_view = + Format.sprintf + {|
%s @@ -175,12 +167,12 @@ let view_thread thread_id =
|} - subject posts - in - Ok thread_view ) + subject posts + in + Ok thread_view ) let get_markers () = - let^ thread_id_list = Db.fold Q.get_threads List.cons () [] in + let^ thread_id_list = Db.collect_list Q.get_threads () in let markers_res = List.map (fun thread_id -> diff --git a/src/user.ml b/src/user.ml index cb4f496..791b78d 100644 --- a/src/user.ml +++ b/src/user.ml @@ -69,7 +69,7 @@ let () = List.exists Result.is_error (List.map (fun query -> Db.exec query ()) tables) then - Dream.warning (fun log -> log "can't create table") + Dream.error (fun log -> log "can't create table") let login ~nick ~password request = let^? good_password = Db.find_opt Q.get_password nick in @@ -109,14 +109,14 @@ let register ~email ~nick ~password = Error "Something is wrong" else let^? nb = Db.find_opt Q.is_already_user (nick, email) in - match nb with - | 0 -> + if nb = 0 then let^ () = Db.exec Q.inser_new_user (nick, password, email, ("", "")) in Ok () - | _ -> Error "nick or email already exists" + else + Error "nick or email already exists" let list () = - let^ users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in + let^ users = Db.collect_list Q.list_nicks () in Ok (Format.asprintf "" (Format.pp_print_list (fun fmt -> function