big fix

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 =
+  let get_thread =
-    Caqti_request.find Caqti_type.string Caqti_type.bool
+    Caqti_request.find Caqti_type.string Caqti_type.string
-      "IF EXISTS (SELECT thread_id FROM threads WHERE thread_id=? LIMIT 1);"
+      "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

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

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 () =

src/js/js_post_form.ml

@@ -4,15 +4,15 @@ let log = Format.printf
 (* insert id into reply form *)
 let insert_quote post_id =
   log "quote@.";
-  match Jv.(find global "replyComment") with
+  Option.iter
-  | None -> Jv.undefined
+    (fun comment_textarea ->
-  | 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;
+      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)
@@ -20,15 +20,12 @@ 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
+  Option.iter
-  match file_input with
+    (fun file_input ->
-  | 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
@@ -36,5 +33,5 @@ let () =
            [| 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.of_string "change"; Jv.repr (make_visible alt_label) |] )
-    ()
+    Jv.(find global "file")

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
+    match of_string current_class with
-    | "postImage" -> "postImageBig"
+    | Some image_size ->
-    | "postImageBig" -> "postImage"
+      to_string
-    | _ -> failwith "invalid image class name"
+        ( 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 |]
-  ()

src/permap.ml

@@ -63,17 +63,11 @@ let login_post request =
   | _ -> assert false
 
 let user request =
-  render_unsafe
+  render_unsafe (Result.fold ~ok:Fun.id ~error:Fun.id (User.list ())) request
-    ( match User.list () with
-    | Ok s -> s
-    | Error _ -> "" )
-    request
 
 let user_profile request =
   render_unsafe
-    ( match User.public_profile request with
+    (Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile request))
-    | Ok s -> s
-    | Error e -> e )
     request
 
 let logout request =

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^ tags = Db.collect_list Q.get_post_tags post_id in
-  let^ replies =
+  let^ replies = Db.collect_list Q.get_post_replies post_id in
-    Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) 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
         {|
     <div class="postImageContainer">
-        <a href="/post_pic/%s" target="_blank">
+        <a href="/post_pic/%s">
         <img class="postImage" src="/post_pic/%s" alt="%s" title="%s" loading="lazy">
         </a>
     </div> 
 |}
         post_id post_id image_alt image_alt
-    | None -> ""
+    | None -> Format.fprintf fmt ""
   in
 
   let pp_print_reply fmt reply =
     Format.fprintf fmt {|<a class="replyLink" href="#%s">&gt;&gt;%s</a>|} reply
       reply
   in
-  let pp_print_replies replies =
+  let pp_print_replies fmt replies =
-    Format.asprintf {|<div class="replies">%a</div>|}
+    Format.fprintf fmt {|<div class="replies">%a</div>|}
       (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 {|<div class="replies">%d reply</div>|} (nb - 1)
+        Format.fprintf fmt {|<div class="replies">%d reply</div>|} (nb - 1)
       | Ok nb ->
-        Format.sprintf {|<div class="replies">%d replies</div>|} (nb - 1) )
+        Format.fprintf fmt {|<div class="replies">%d replies</div>|} (nb - 1) )
   in
 
-  let post_links_view =
+  let post_links_view fmt () =
     match is_thread_preview with
     | None ->
-      Format.sprintf
+      Format.fprintf fmt
         {|
         <span class=postNo>
             <a href="#%s" title="Link to this post">#</a>
-            <a href="javascript:insert_quote('%s')" "class=quoteLink title="Reply to this post">%s</a>
+            <a href="javascript:insert_quote('%s')" class="quoteLink" title="Reply to this post">%s</a>
         </span>
-        %s
+        %a
         |}
-        post_id post_id post_id replies_view
+        post_id post_id post_id replies_view ()
-    | Some () -> Format.sprintf {|
+    | Some () -> Format.fprintf fmt {|
-        %s
+        %a
-        |} replies_view
+        |} replies_view ()
   in
 
-  let post_info_view =
+  let post_info_view fmt () =
-    Format.sprintf
+    Format.fprintf fmt
       {|
     <div class="postInfo">
         <span class="nick">%s</span>
         <span class="date" data-time="%d"></span>
-        %s
+        %a
     </div>|}
-      nick date post_links_view
+      nick date post_links_view ()
   in
 
   let pp_print_tag fmt tag =
     Format.fprintf fmt {|<span class="tag">%s</span>|} tag
   in
-  let pp_print_tags tags =
+  let pp_print_tags fmt tags =
-    Format.asprintf {|<div class="tags">%a</div>|}
+    Format.fprintf fmt {|<div class="tags">%a</div>|}
       (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
       {|
 <div class="container">
         <div class="post" id="%s">
-            %s
+            %a
-            %s
+            %a
             <blockquote class="postComment">%s</blockquote> 
-            %s
+            %a
         </div> 
 </div> 
 |}
-      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,19 +124,13 @@ let preview_thread thread_id =
   Ok thread_preview
 
 let view_thread thread_id =
-  let^ is_thread = Db.find Q.is_thread thread_id in
+  let^ _is_thread = Db.find Q.get_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
+  let^ thread_posts = Db.collect_list Q.get_thread_posts thread_id in
   (*order by date *)
-    let dates =
+  let dates = List.map (Db.find Q.get_post_date) thread_posts in
-      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) ->
+  | Some (Error e) -> Error (Format.sprintf "db error: %s" (Caqti_error.show 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
@@ -180,7 +172,7 @@ let view_thread thread_id =
       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 ->

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
+    if nb = 0 then
-    | 0 ->
       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 "<ul>%a</ul>"
        (Format.pp_print_list (fun fmt -> function