move let bindings magic to bindings.ml

src/babillard.ml

@@ -1,4 +1,5 @@
 open Db
+include Bindings
 
 exception Invalid_post of string
 
@@ -37,22 +38,6 @@ type post =
   | Op of thread_data * reply
   | Reply of reply
 
-let ( let** ) o f =
-  match o with
-  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
-  | Ok None -> Error "db error"
-  | Ok (Some x) -> f x
-
-let ( let* ) o f =
-  match o with
-  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
-  | Ok x -> f x
-
-let ( let+ ) o f =
-  match o with
-  | Error e -> Error (Format.sprintf "%s" e)
-  | Ok x -> f x
-
 module Q = struct
   let create_post_user_table =
     Caqti_request.exec Caqti_type.unit
@@ -374,18 +359,18 @@ let upload_post post =
       (id, parent_id, date, nick, comment, image, tags, citations)
   in
 
-  let* _res_post_id = Db.exec Q.upload_post_id (post_id, nick) in
+  let^ _res_post_id = Db.exec Q.upload_post_id (post_id, nick) in
-  let* _res_comment = Db.exec Q.upload_post_comment (post_id, comment) in
+  let^ _res_comment = Db.exec Q.upload_post_comment (post_id, comment) in
-  let* _res_date = Db.exec Q.upload_post_date (post_id, date) in
+  let^ _res_date = Db.exec Q.upload_post_date (post_id, date) in
-  let* _res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in
+  let^ _res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in
-  let* _res_image =
+  let^ _res_image =
     match image with
     | None -> Ok ()
     | Some (image_name, image_content, alt) ->
       Db.exec Q.upload_post_image (post_id, image_name, image_content, alt)
   in
-  let* _res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in
+  let^ _res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in
-  let* _res_tags =
+  let^ _res_tags =
     match
       List.find_opt Result.is_error
         (List.map (fun tag -> Db.exec Q.upload_post_tag (post_id, tag)) tags)
@@ -394,7 +379,7 @@ let upload_post post =
     | Some _ -> assert false
     | None -> Ok ()
   in
-  let* _res_citations =
+  let^ _res_citations =
     match
       List.find_opt Result.is_error
         (List.map
@@ -410,11 +395,11 @@ let upload_post post =
   | Some thread_data -> (
     match thread_data with
     | { board; subject; lng; lat } ->
-      let* _res_board =
+      let^ _res_board =
         Db.exec Q.upload_thread_board (post_id, int_of_board board)
       in
-      let* _res_gps = Db.exec Q.upload_post_gps (post_id, lat, lng) in
+      let^ _res_gps = Db.exec Q.upload_post_gps (post_id, lat, lng) in
-      let* _res_subject = Db.exec Q.upload_post_subject (post_id, subject) in
+      let^ _res_subject = Db.exec Q.upload_post_subject (post_id, subject) in
       Ok post_id )
 
 let build_reply ~comment ?image ~tags ?parent_id nick =
@@ -466,7 +451,7 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
     Error "Invalid subject"
   else
     let thread_data = { board; subject; lng; lat } in
-    let+ reply =
+    let* reply =
       match image with
       | Some image -> build_reply ~comment ~image ~tags nick
       | None -> build_reply ~comment ~tags nick
@@ -475,14 +460,14 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
     Ok op
 
 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
   upload_post post
 
 let make_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick =
-  let+ op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in
+  let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in
   upload_post op
 
 let get_post_image_content post_id =
-  let** content = Db.find_opt Q.get_post_image_content post_id in
+  let^? content = Db.find_opt Q.get_post_image_content post_id in
   Ok content

src/bindings.ml

@@ -0,0 +1,17 @@
+(* let bindings for early return when encountering an error *)
+(* see https://ocaml.org/releases/4.13/htmlman/bindingops.html *)
+let ( let^? ) o f =
+  match o with
+  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+  | Ok None -> Error "db error"
+  | Ok (Some x) -> f x
+
+let ( let^ ) o f =
+  match o with
+  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+  | Ok x -> f x
+
+let ( let* ) o f =
+  match o with
+  | Error e -> Error (Format.sprintf "%s" e)
+  | Ok x -> f x

src/dune

@@ -1,6 +1,7 @@
 (executable
  (public_name permap)
  (modules
+  bindings
   newthread_page
   thread_page
   babillard

src/pp_babillard.ml

@@ -1,14 +1,15 @@
+include Bindings
 include Babillard
 open Db
 
 let view_post ?is_thread_preview post_id =
-  let* nick = Db.find Q.get_post_nick post_id in
+  let^ nick = Db.find Q.get_post_nick post_id in
-  let* comment = Db.find Q.get_post_comment 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^ 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^ 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.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id [] in
-  let* replies =
+  let^ replies =
     Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) post_id []
   in
 
@@ -108,8 +109,8 @@ let view_post ?is_thread_preview post_id =
   Ok post_view
 
 let preview_thread thread_id =
-  let+ post = view_post ~is_thread_preview:() thread_id in
+  let* post = view_post ~is_thread_preview:() thread_id in
-  let** subject = Db.find_opt Q.get_post_subject thread_id in
+  let^? subject = Db.find_opt Q.get_post_subject thread_id in
   let thread_preview =
     Format.sprintf
       {|
@@ -125,9 +126,9 @@ let preview_thread thread_id =
   Ok thread_preview
 
 let view_thread thread_id =
-  let** _ = Db.find_opt Q.is_thread thread_id in
+  let^? _ = Db.find_opt Q.is_thread thread_id in
-  let** subject = Db.find_opt Q.get_post_subject thread_id in
+  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.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
@@ -175,13 +176,13 @@ let view_thread thread_id =
       Ok thread_view )
 
 let get_markers board =
-  let* thread_id_list =
+  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
+        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 )

src/user.ml

@@ -1,3 +1,4 @@
+include Bindings
 open Db
 
 type t =
@@ -8,19 +9,6 @@ type t =
   ; avatar : string
   }
 
-(* ('a option, string) result *)
-let ( let** ) o f =
-  match o with
-  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
-  | Ok None -> Error "db error"
-  | Ok (Some x) -> f x
-
-(* ('a, string) result *)
-let ( let* ) o f =
-  match o with
-  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
-  | Ok x -> f x
-
 module Q = struct
   let create_user_table =
     Caqti_request.exec Caqti_type.unit
@@ -84,7 +72,7 @@ let () =
     Dream.warning (fun log -> log "can't create table")
 
 let login ~nick ~password request =
-  let** good_password = Db.find_opt Q.get_password nick in
+  let^? good_password = Db.find_opt Q.get_password nick in
   if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
     let _ =
       let%lwt () = Dream.invalidate_session request in
@@ -120,15 +108,15 @@ let register ~email ~nick ~password =
   if not valid then
     Error "Something is wrong"
   else
-    let** nb = Db.find_opt Q.is_already_user (nick, email) in
+    let^? nb = Db.find_opt Q.is_already_user (nick, email) in
     match nb with
     | 0 ->
-      let* () = Db.exec Q.inser_new_user (nick, password, email, ("", "")) in
+      let^ () = Db.exec Q.inser_new_user (nick, password, email, ("", "")) in
       Ok ()
     | _ -> Error "nick or email already exists"
 
 let list () =
-  let* users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in
+  let^ users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in
   Ok
     (Format.asprintf "<ul>%a</ul>"
        (Format.pp_print_list (fun fmt -> function
@@ -138,7 +126,7 @@ let list () =
 
 let public_profile request =
   let nick = Dream.param "user" request in
-  let** nick, password, email, (bio, _) = Db.find_opt Q.get_user nick in
+  let^? nick, password, email, (bio, _) = Db.find_opt Q.get_user nick in
   let user_info =
     Format.sprintf
       {|nick = `%s`; password = `%s`; email = `%s`; bio = '%s';
@@ -158,15 +146,15 @@ let update_bio bio nick =
   if not valid then
     Error "Not biologic"
   else
-    let* () = Db.exec Q.update_bio (bio, nick) in
+    let^ () = Db.exec Q.update_bio (bio, nick) in
     Ok ()
 
 let get_bio nick =
-  let** bio = Db.find_opt Q.get_bio nick in
+  let^? bio = Db.find_opt Q.get_bio nick in
   Ok bio
 
 let get_avatar nick =
-  let** avatar = Db.find_opt Q.get_avatar nick in
+  let^? avatar = Db.find_opt Q.get_avatar nick in
   if String.length avatar = 0 then
     Ok None
   else
@@ -179,6 +167,6 @@ let upload_avatar files nick =
     if not (is_valid_image content) then
       Error "Invalid image"
     else
-      let* () = Db.exec Q.upload_avatar (content, nick) in
+      let^ () = Db.exec Q.upload_avatar (content, nick) in
       Ok ()
   | _files -> Error "More than one file provided"