refactor

src/babillard.ml

@@ -1,5 +1,6 @@
-open Db
 open Syntax
+open Caqti_request.Infix
+open Caqti_type
 
 type moderation_action =
   | Ignore
@@ -40,156 +41,151 @@ type t =
   | Op of thread_data * post
   | Post of post
 
-module Q = struct
-  open Caqti_request.Infix
-  open Caqti_type
-
-  let create_post_user_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, user_id TEXT, \
-       PRIMARY KEY(post_id), FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
-       DELETE CASCADE)"
-
-  (* one row for each thread, with thread's data *)
-  let create_thread_info_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject TEXT, \
-       lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \
-       post_user(post_id) ON DELETE CASCADE)"
-
-  (* map thread and reply to the thread *)
-  let create_thread_post_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS thread_post (thread_id TEXT, post_id TEXT, \
-       FOREIGN KEY(thread_id) REFERENCES post_user(post_id) ON DELETE CASCADE, \
-       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let create_post_replies_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id TEXT, \
-       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE, \
-       FOREIGN KEY(reply_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let create_post_citations_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id TEXT, \
-       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE, \
-       FOREIGN KEY(cited_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let create_post_date_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date FLOAT, FOREIGN \
-       KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let create_post_comment_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
-       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let create_post_tags_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, FOREIGN \
-       KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let create_report_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS report (user_id TEXT, reason TEXT, date \
-       FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) \
-       ON DELETE CASCADE, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
-       DELETE CASCADE)"
+let () =
+  let tables =
+    [| (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, user_id TEXT, \
+          PRIMARY KEY(post_id), FOREIGN KEY(user_id) REFERENCES user(user_id) \
+          ON DELETE CASCADE)"
+     ; (* one row for each thread, with thread's data *)
+       (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject \
+          TEXT, lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \
+          post_user(post_id) ON DELETE CASCADE)"
+     ; (* map thread and reply to the thread *)
+       (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS thread_post (thread_id TEXT, post_id \
+          TEXT, FOREIGN KEY(thread_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \
+          DELETE CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id \
+          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE, FOREIGN KEY(reply_id) REFERENCES post_user(post_id) ON \
+          DELETE CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id \
+          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE, FOREIGN KEY(cited_id) REFERENCES post_user(post_id) ON \
+          DELETE CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date FLOAT, \
+          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
+          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, \
+          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS report (user_id TEXT, reason TEXT, date \
+          FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES \
+          post_user(post_id) ON DELETE CASCADE, FOREIGN KEY(user_id) \
+          REFERENCES user(user_id) ON DELETE CASCADE)"
+    |]
+  in
+  if
+    Array.exists Result.is_error
+      (Array.map (fun query -> Db.exec query ()) tables)
+  then Dream.error (fun log -> log "can't create babillard's tables")
 
+module Q = struct
   let upload_report =
-    (tup4 string string float string ->. unit)
-      "INSERT INTO report VALUES (?,?,?,?)"
-
-  let ignore_report = (string ->. unit) "DELETE FROM report WHERE post_id=?"
+    Db.exec
+    @@ (tup4 string string float string ->. unit)
+         "INSERT INTO report VALUES (?,?,?,?)"
 
   let get_reports =
-    (unit ->* tup4 string string float string) "SELECT * FROM report"
+    Db.collect_list
+    @@ (unit ->* tup4 string string float string) "SELECT * FROM report"
 
   let upload_post_id =
-    (tup2 string string ->. unit) "INSERT INTO post_user VALUES (?,?)"
+    Db.exec
+    @@ (tup2 string string ->. unit) "INSERT INTO post_user VALUES (?,?)"
 
   let upload_thread_info =
-    (tup4 string string float float ->. unit)
-      "INSERT INTO thread_info VALUES (?,?,?,?)"
+    Db.exec
+    @@ (tup4 string string float float ->. unit)
+         "INSERT INTO thread_info VALUES (?,?,?,?)"
 
   let upload_thread_post =
-    (tup2 string string ->. unit) "INSERT INTO thread_post VALUES (?,?)"
+    Db.exec
+    @@ (tup2 string string ->. unit) "INSERT INTO thread_post VALUES (?,?)"
 
   let upload_post_reply =
-    (tup2 string string ->. unit) "INSERT INTO post_replies VALUES (?,?)"
+    Db.exec
+    @@ (tup2 string string ->. unit) "INSERT INTO post_replies VALUES (?,?)"
 
   let upload_post_comment =
-    (tup2 string string ->. unit) "INSERT INTO post_comment VALUES (?,?)"
+    Db.exec
+    @@ (tup2 string string ->. unit) "INSERT INTO post_comment VALUES (?,?)"
 
   let upload_post_tag =
-    (tup2 string string ->. unit) "INSERT INTO post_tags VALUES (?,?)"
+    Db.exec
+    @@ (tup2 string string ->. unit) "INSERT INTO post_tags VALUES (?,?)"
 
   let upload_post_date =
-    (tup2 string float ->. unit) "INSERT INTO post_date VALUES (?,?)"
+    Db.exec @@ (tup2 string float ->. unit) "INSERT INTO post_date VALUES (?,?)"
 
   let get_post_user_id =
-    (string ->! string) "SELECT user_id FROM post_user WHERE post_id=?"
+    Db.find
+    @@ (string ->! string) "SELECT user_id FROM post_user WHERE post_id=?"
 
   let get_post_comment =
-    (string ->! string) "SELECT comment FROM post_comment WHERE post_id=?"
+    Db.find
+    @@ (string ->! string) "SELECT comment FROM post_comment WHERE post_id=?"
 
   let get_post_tags =
-    (string ->* string) "SELECT tag FROM post_tags WHERE post_id=?"
+    Db.collect_list
+    @@ (string ->* string) "SELECT tag FROM post_tags WHERE post_id=?"
 
   let get_post_date =
-    (string ->! float) "SELECT date FROM post_date WHERE post_id=?"
+    Db.find @@ (string ->! float) "SELECT date FROM post_date WHERE post_id=?"
 
   let get_post_citations =
-    (string ->* string) "SELECT post_id FROM post_citations WHERE post_id=?"
+    Db.collect_list
+    @@ (string ->* string) "SELECT post_id FROM post_citations WHERE post_id=?"
 
   let get_post_replies =
-    (string ->* string) "SELECT reply_id FROM post_replies WHERE post_id=?"
+    Db.collect_list
+    @@ (string ->* string) "SELECT reply_id FROM post_replies WHERE post_id=?"
 
   let get_thread_posts =
-    (string ->* string) "SELECT post_id FROM thread_post WHERE thread_id=?"
+    Db.collect_list
+    @@ (string ->* string) "SELECT post_id FROM thread_post WHERE thread_id=?"
 
   let count_thread_posts =
-    (string ->! int) "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?"
-
-  let get_is_thread =
-    (string ->! string)
-      "SELECT thread_id FROM thread_info WHERE thread_id=? LIMIT 1"
+    Db.find
+    @@ (string ->! int)
+         "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?"
 
   let get_is_post =
-    (string ->! string) "SELECT post_id FROM post_user WHERE post_id=? LIMIT 1"
+    Db.find
+    @@ (string ->! string)
+         "SELECT post_id FROM post_user WHERE post_id=? LIMIT 1"
 
   let get_post_thread =
-    (string ->! string)
-      "SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1"
+    Db.find
+    @@ (string ->! string)
+         "SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1"
 
   let get_thread_info =
-    (string ->! tup3 string float float)
-      "SELECT subject,lat,lng FROM thread_info WHERE thread_id=?"
+    Db.find
+    @@ (string ->! tup3 string float float)
+         "SELECT subject,lat,lng FROM thread_info WHERE thread_id=?"
 
-  let get_threads = (unit ->* string) "SELECT thread_id FROM thread_info"
+  let get_threads =
+    Db.collect_list @@ (unit ->* string) "SELECT thread_id FROM thread_info"
 
-  let delete_post = (string ->. unit) "DELETE FROM post_user WHERE post_id=?"
+  let delete_post =
+    Db.exec @@ (string ->. unit) "DELETE FROM post_user WHERE post_id=?"
 end
 
-let () =
-  let tables =
-    [| Q.create_post_user_table
-     ; Q.create_thread_info_table
-     ; Q.create_thread_post_table
-     ; Q.create_post_replies_table
-     ; Q.create_post_citations_table
-     ; Q.create_post_date_table
-     ; Q.create_post_comment_table
-     ; Q.create_post_tags_table
-     ; Q.create_report_table
-    |]
-  in
-  if
-    Array.exists Result.is_error
-      (Array.map (fun query -> Db.exec query ()) tables)
-  then Dream.error (fun log -> log "can't create babillard's tables")
+let ignore_report =
+  Db.exec @@ (string ->. unit) "DELETE FROM report WHERE post_id=?"
 
 (*TODO switch to markdown !*)
 (* insert html into the comment, and keep tracks of citations :
@@ -252,28 +248,28 @@ let upload_post ~image post =
   in
   let { id; parent_id; date; user_id; comment; tags; citations; _ } = reply in
 
-  let^ () = Db.exec Q.upload_post_id (id, user_id) in
-  let^ () = Db.exec Q.upload_post_comment (id, comment) in
-  let^ () = Db.exec Q.upload_post_date (id, date) in
-  let^ () = Db.exec Q.upload_thread_post (parent_id, id) in
+  let* () = Q.upload_post_id (id, user_id) in
+  let* () = Q.upload_post_comment (id, comment) in
+  let* () = Q.upload_post_date (id, date) in
+  let* () = Q.upload_thread_post (parent_id, id) in
   let* () =
     match image with None -> Ok () | Some image -> Image.upload image id
   in
-  let^ _unit_list =
-    unwrap_list (fun tag -> Db.exec Q.upload_post_tag (id, tag)) tags
-  in
-  let^ _unit_list =
-    unwrap_list
-      (fun cited_id -> Db.exec Q.upload_post_reply (cited_id, id))
-      citations
-  in
-  let^ () =
-    match thread_data with
-    | None -> Ok ()
-    | Some { subject; lng; lat } ->
-      Db.exec Q.upload_thread_info (id, subject, lat, lng)
-  in
-  Ok id
+  match unwrap_list (fun tag -> Q.upload_post_tag (id, tag)) tags with
+  | Error _e as e -> e
+  | Ok _ -> (
+    match
+      unwrap_list (fun cited_id -> Q.upload_post_reply (cited_id, id)) citations
+    with
+    | Error _e as e -> e
+    | Ok _ ->
+      let* () =
+        match thread_data with
+        | None -> Ok ()
+        | Some { subject; lng; lat } ->
+          Q.upload_thread_info (id, subject, lat, lng)
+      in
+      Ok id )
 
 let build_reply ~comment ~image_info ~tag_list ?parent_id user_id =
   let comment = Dream.html_escape comment in
@@ -353,22 +349,20 @@ let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
   in
   upload_post ~image post
 
-let thread_exist id = Result.is_ok (Db.find Q.get_is_thread id)
-
 (* true if post is an op too *)
-let post_exist id = Result.is_ok (Db.find Q.get_is_post id)
+let post_exist id = Result.is_ok (Q.get_is_post id)
 
 let get_post id =
-  let^ parent_id = Db.find Q.get_post_thread id in
-  let^ user_id = Db.find Q.get_post_user_id id in
+  let* parent_id = Q.get_post_thread id in
+  let* user_id = Q.get_post_user_id id in
   let* nick = User.get_nick user_id in
-  let^ comment = Db.find Q.get_post_comment id in
-  let^ date = Db.find Q.get_post_date id in
+  let* comment = Q.get_post_comment id in
+  let* date = Q.get_post_date id in
   let* image_info = Image.get_info id in
 
-  let^ tags = Db.collect_list Q.get_post_tags id in
-  let^ replies = Db.collect_list Q.get_post_replies id in
-  let^ citations = Db.collect_list Q.get_post_citations id in
+  let* tags = Q.get_post_tags id in
+  let* replies = Q.get_post_replies id in
+  let* citations = Q.get_post_citations id in
   let reply =
     { id
     ; parent_id
@@ -385,10 +379,8 @@ let get_post id =
   Ok reply
 
 let get_thread_data id =
-  if thread_exist id then
-    let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in
-    Ok { subject; lat; lng }
-  else Error "not an op"
+  let* subject, lat, lng = Q.get_thread_info id in
+  Ok { subject; lat; lng }
 
 let get_op id =
   let* thread_data = get_thread_data id in
@@ -401,9 +393,7 @@ let get_ops ids = unwrap_list get_op ids
 
 let try_delete_post ~user_id id =
   let* post = get_post id in
-  if post.user_id = user_id || User.is_admin user_id then
-    let^ () = Db.exec Q.delete_post id in
-    Ok ()
+  if post.user_id = user_id || User.is_admin user_id then Q.delete_post id
   else Error "You can only delete your posts"
 
 let report ~user_id ~reason id =
@@ -412,15 +402,10 @@ let report ~user_id ~reason id =
   else
     let reason = Dream.html_escape reason in
     let date = Unix.time () in
-    let^ () = Db.exec Q.upload_report (user_id, reason, date, id) in
-    Ok ()
-
-let ignore_report id =
-  let^ () = Db.exec Q.ignore_report id in
-  Ok ()
+    Q.upload_report (user_id, reason, date, id)
 
 let get_reports () =
-  let^ reports = Db.collect_list Q.get_reports () in
+  let* reports = Q.get_reports () in
   let* posts =
     unwrap_list (fun (_reporter_id, _reason, _date, id) -> get_post id) reports
   in

src/db.ml

@@ -34,3 +34,15 @@ let () =
   | Error _e ->
     Format.eprintf "db error@\n";
     exit 1
+
+let unwrap_err = function
+  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+  | Ok _ as ok -> ok
+
+let exec q v = Db.exec q v |> unwrap_err
+
+let find q v = Db.find q v |> unwrap_err
+
+let find_opt q v = Db.find_opt q v |> unwrap_err
+
+let collect_list q v = Db.collect_list q v |> unwrap_err

src/db.mli

@@ -0,0 +1,13 @@
+val exec : ('a, unit, [< `Zero ]) Caqti_request.t -> 'a -> (unit, string) result
+
+val find : ('a, 'b, [< `One ]) Caqti_request.t -> 'a -> ('b, string) result
+
+val find_opt :
+     ('a, 'b, [< `One | `Zero ]) Caqti_request.t
+  -> 'a
+  -> ('b option, string) result
+
+val collect_list :
+     ('a, 'b, [ `Many | `One | `Zero ]) Caqti_request.t
+  -> 'a
+  -> ('b list, string) result

src/discuss.ml

@@ -1,4 +1,3 @@
-open Db
 open Syntax
 
 (** Creating the table of all messages.
@@ -17,43 +16,45 @@ module Q = struct
   open Caqti_type
 
   let create_msg_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS msg ( msg_id TEXT, from_id TEXT, to_id TEXT, \
-       msg TEXT, PRIMARY KEY(msg_id), FOREIGN KEY(from_id) REFERENCES \
-       user(user_id) ON DELETE CASCADE, FOREIGN KEY(to_id) REFERENCES \
-       user(user_id) ON DELETE CASCADE)"
+    Db.exec
+    @@ (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS msg ( msg_id TEXT, from_id TEXT, to_id \
+          TEXT, msg TEXT, PRIMARY KEY(msg_id), FOREIGN KEY(from_id) REFERENCES \
+          user(user_id) ON DELETE CASCADE, FOREIGN KEY(to_id) REFERENCES \
+          user(user_id) ON DELETE CASCADE)"
 
   let find_comrades =
-    (tup2 string string ->* tup2 string string)
-      "SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?"
+    Db.collect_list
+    @@ (tup2 string string ->* tup2 string string)
+         "SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?"
 
   let find_messages =
-    (tup2 (tup2 string string) (tup2 string string) ->* tup2 string string)
-      "SELECT from_id, msg FROM msg WHERE (from_id=? AND to_id=?) OR \
-       (from_id=? AND to_id=?)"
+    Db.collect_list
+    @@ (tup2 (tup2 string string) (tup2 string string) ->* tup2 string string)
+         "SELECT from_id, msg FROM msg WHERE (from_id=? AND to_id=?) OR \
+          (from_id=? AND to_id=?)"
 
   let insert_msg =
-    (tup3 string string string ->. unit)
-      "INSERT INTO msg VALUES (NULL, ?, ?, ?)"
+    Db.exec
+    @@ (tup3 string string string ->. unit)
+         "INSERT INTO msg VALUES (NULL, ?, ?, ?)"
 end
 
 let () =
-  match Db.exec Q.create_msg_table () with
-  | Ok () -> ()
-  | Error _e -> Dream.error (fun log -> log "can't create msg table")
+  Result.iter_error
+    (fun _e -> Dream.error (fun log -> log "can't create table"))
+    (Q.create_msg_table ())
 
 (** let's find who the user is talking to so we can know if they're dangerous *)
 let find_comrades user_id =
-  let^ comrades = Db.collect_list Q.find_comrades (user_id, user_id) in
+  let* comrades = Q.find_comrades (user_id, user_id) in
   let comrades =
     List.map (fun (l, r) -> if l = user_id then r else l) comrades
   in
   Ok (List.sort_uniq String.compare comrades)
 
 (** find all messages between two товарищи *)
-let find_messages k1 k2 =
-  let^ comrades = Db.collect_list Q.find_messages ((k1, k2), (k2, k1)) in
-  Ok comrades
+let find_messages k1 k2 = Q.find_messages ((k1, k2), (k2, k1))
 
 (** display the list of discussions *)
 let render =
@@ -113,9 +114,7 @@ let renderone request =
       let comrade_id = Dream.param request "comrade_id" in
       pp_discussion (request, user_id, comrade_id) )
 
-let insert_msg from_id to_id msg =
-  let^ () = Db.exec Q.insert_msg (from_id, to_id, msg) in
-  Ok ()
+let insert_msg from_id to_id msg = Q.insert_msg (from_id, to_id, msg)
 
 (** handle posts *)
 let post request =

src/image.ml

@@ -1,5 +1,6 @@
-open Db
 open Syntax
+open Caqti_request.Infix
+open Caqti_type
 
 type t =
   { name : string
@@ -8,123 +9,97 @@ type t =
   ; thumbnail : string
   }
 
-module Q = struct
-  open Caqti_request.Infix
-  open Caqti_type
-
-  let create_info_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS image_info (post_id TEXT, image_name TEXT, \
-       image_alt TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \
-       DELETE CASCADE)"
-
-  let create_content_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS image_content (post_id TEXT, content TEXT, \
-       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let create_thumbnail_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS image_thumbnail (post_id TEXT, content TEXT, \
-       FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
-
-  let upload_info =
-    (tup3 string string string ->. unit) "INSERT INTO image_info VALUES (?,?,?)"
-
-  let upload_content =
-    (tup2 string string ->. unit) "INSERT INTO image_content VALUES (?,?)"
+let () =
+  let tables =
+    [| (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS image_info (post_id TEXT, image_name \
+          TEXT, image_alt TEXT, FOREIGN KEY(post_id) REFERENCES \
+          post_user(post_id) ON DELETE CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS image_content (post_id TEXT, content \
+          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS image_thumbnail (post_id TEXT, content \
+          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
+          CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS user_image_content (user_id TEXT, content \
+          TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE \
+          CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS user_image_thumbnail (user_id TEXT, \
+          content TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
+          DELETE CASCADE)"
+    |]
+  in
+  if
+    Array.exists Result.is_error
+      (Array.map (fun query -> Db.exec query ()) tables)
+  then Dream.error (fun log -> log "can't create images tables")
 
-  let upload_thumbnail =
-    (tup2 string string ->. unit) "INSERT INTO image_thumbnail VALUES (?,?)"
+let upload_info =
+  Db.exec
+  @@ (tup3 string string string ->. unit)
+       "INSERT INTO image_info VALUES (?,?,?)"
 
-  let get_post_content =
-    (string ->? string) "SELECT content FROM image_content WHERE post_id=?"
+let upload_content =
+  Db.exec
+  @@ (tup2 string string ->. unit) "INSERT INTO image_content VALUES (?,?)"
 
-  let get_post_thumbnail =
-    (string ->? string) "SELECT content FROM image_thumbnail WHERE post_id=?"
+let upload_thumbnail =
+  Db.exec
+  @@ (tup2 string string ->. unit) "INSERT INTO image_thumbnail VALUES (?,?)"
 
-  let get_post_info =
-    (string ->? tup2 string string)
-      "SELECT image_name,image_alt FROM image_info WHERE post_id=?"
+let get_content =
+  Db.find_opt
+  @@ (string ->? string) "SELECT content FROM image_content WHERE post_id=?"
 
-  (*avatars*)
-  let create_user_content_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS user_image_content (user_id TEXT, content \
-       TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
+let get_thumbnail =
+  Db.find_opt
+  @@ (string ->? string) "SELECT content FROM image_thumbnail WHERE post_id=?"
 
-  let create_user_thumbnail_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS user_image_thumbnail (user_id TEXT, content \
-       TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
+let get_info =
+  Db.find_opt
+  @@ (string ->? tup2 string string)
+       "SELECT image_name,image_alt FROM image_info WHERE post_id=?"
 
-  let upload_user_content =
-    (tup2 string string ->. unit) "INSERT INTO user_image_content VALUES (?,?)"
+let upload_user_content =
+  Db.exec
+  @@ (tup2 string string ->. unit) "INSERT INTO user_image_content VALUES (?,?)"
 
-  let upload_user_thumbnail =
-    (tup2 string string ->. unit)
-      "INSERT INTO user_image_thumbnail VALUES (?,?)"
+let upload_user_thumbnail =
+  Db.exec
+  @@ (tup2 string string ->. unit)
+       "INSERT INTO user_image_thumbnail VALUES (?,?)"
 
-  let get_user_content =
-    (string ->? string) "SELECT content FROM user_image_content WHERE user_id=?"
+let get_user_content =
+  Db.find_opt
+  @@ (string ->? string)
+       "SELECT content FROM user_image_content WHERE user_id=?"
 
-  let get_user_thumbnail =
-    (string ->? string)
-      "SELECT content FROM user_image_thumbnail WHERE user_id=?"
+let get_user_thumbnail =
+  Db.find_opt
+  @@ (string ->? string)
+       "SELECT content FROM user_image_thumbnail WHERE user_id=?"
 
-  let delete_user_content =
-    (string ->. unit) "DELETE FROM user_image_content WHERE user_id=?"
+let delete_user_content =
+  Db.exec @@ (string ->. unit) "DELETE FROM user_image_content WHERE user_id=?"
 
-  let delete_user_thumbnail =
-    (string ->. unit) "DELETE FROM user_image_thumbnail WHERE user_id=?"
-end
-
-let () =
-  let tables =
-    [| Q.create_info_table
-     ; Q.create_content_table
-     ; Q.create_thumbnail_table
-     ; Q.create_user_content_table
-     ; Q.create_user_thumbnail_table
-    |]
-  in
-  if
-    Array.exists Result.is_error
-      (Array.map (fun query -> Db.exec query ()) tables)
-  then Dream.error (fun log -> log "can't create images tables")
+let delete_user_thumbnail =
+  Db.exec
+  @@ (string ->. unit) "DELETE FROM user_image_thumbnail WHERE user_id=?"
 
 let upload image id =
-  let^ () = Db.exec Q.upload_info (id, image.name, image.alt) in
-  let^ () = Db.exec Q.upload_content (id, image.content) in
-  let^ () = Db.exec Q.upload_thumbnail (id, image.thumbnail) in
-  Ok ()
-
-let get_content id =
-  let^ content = Db.find_opt Q.get_post_content id in
-  Ok content
-
-let get_thumbnail id =
-  let^ thumbnail = Db.find_opt Q.get_post_thumbnail id in
-  Ok thumbnail
-
-let get_info id =
-  let^ info = Db.find_opt Q.get_post_info id in
-  Ok info
+  let* () = upload_info (id, image.name, image.alt) in
+  let* () = upload_content (id, image.content) in
+  upload_thumbnail (id, image.thumbnail)
 
 let upload_avatar image id =
-  let^ () = Db.exec Q.delete_user_content id in
-  let^ () = Db.exec Q.delete_user_thumbnail id in
-  let^ () = Db.exec Q.upload_user_content (id, image.content) in
-  let^ () = Db.exec Q.upload_user_thumbnail (id, image.thumbnail) in
-  Ok ()
-
-let get_user_content id =
-  let^ content = Db.find_opt Q.get_user_content id in
-  Ok content
-
-let get_user_thumbnail id =
-  let^ thumbnail = Db.find_opt Q.get_user_thumbnail id in
-  Ok thumbnail
+  let* () = delete_user_content id in
+  let* () = delete_user_thumbnail id in
+  let* () = upload_user_content (id, image.content) in
+  upload_user_thumbnail (id, image.thumbnail)
 
 let make_thumbnail content =
   let open Bos in

src/permap.ml

@@ -148,12 +148,9 @@ let user request =
 
 let user_profile request =
   let nick = Dream.param request "user" in
-  match User.get_user_id_from_nick nick with
+  match User.get_id_from_nick nick with
   | Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
-  | Ok user_id ->
-    render
-      (Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile user_id))
-      request
+  | Ok user_id -> render_result request @@ User.public_profile user_id
 
 let logout request =
   let _ = Dream.invalidate_session request in
@@ -260,7 +257,7 @@ let get_post_image ~thumbnail request =
 
 let get_avatar_image request =
   let nick = Dream.param request "user" in
-  match User.get_user_id_from_nick nick with
+  match User.get_id_from_nick nick with
   | Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
   | Ok user_id -> (
     let avatar = Image.get_user_content user_id in
@@ -331,24 +328,19 @@ let babillard_post request =
 
 let thread_feed_get request =
   let thread_id = Dream.param request "thread_id" in
-  if Babillard.thread_exist thread_id then
-    match Pp_babillard.feed thread_id with
-    | Error e -> render e request
-    | Ok feed ->
-      Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed
-  else Dream.respond ~status:`Not_Found "Thread not found"
+  match Pp_babillard.feed thread_id with
+  | Error e -> render e request
+  | Ok feed ->
+    Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed
 
 let thread_get request =
   let thread_id = Dream.param request "thread_id" in
-  if Babillard.thread_exist thread_id then
-    let thread_view = Pp_babillard.view_thread thread_id in
-    let res =
-      match thread_view with
-      | Error e -> e
-      | Ok thread_view -> Thread_page.f thread_view thread_id request
-    in
-    render res request
-  else Dream.respond ~status:`Not_Found "Thread not found"
+  let thread_view = Pp_babillard.view_thread thread_id in
+  render
+    ( match thread_view with
+    | Error e -> e
+    | Ok thread_view -> Thread_page.f thread_view thread_id request )
+    request
 
 (*form to reply to a thread *)
 let reply_post request =

src/pp_babillard.ml

@@ -1,6 +1,5 @@
 open Syntax
 open Babillard
-open Db
 
 let pp_post fmt t =
   let thread_data_opt, post =
@@ -50,7 +49,7 @@ let pp_post fmt t =
   let replies_view fmt () =
     if Option.is_some thread_data_opt then
       (* TODO put thread_posts count in thread_info ? *)
-      let res_nb = Db.find Q.count_thread_posts id in
+      let res_nb = Q.count_thread_posts id in
       match res_nb with
       | Error _ -> Format.fprintf fmt ""
       | Ok ((1 | 2) as nb) ->
@@ -164,7 +163,7 @@ let pp_thread_preview fmt op =
   thread_preview
 
 let catalog_content () =
-  let^ ids = Db.collect_list Q.get_threads () in
+  let* ids = Q.get_threads () in
   let* ops = get_ops ids in
   Ok
     (Format.asprintf "%a"
@@ -244,7 +243,7 @@ let pp_thread fmt op posts =
 
 let view_thread thread_id =
   let* op = get_op thread_id in
-  let^ ids = Db.collect_list Q.get_thread_posts thread_id in
+  let* ids = Q.get_thread_posts thread_id in
   let* posts = get_posts ids in
   let s =
     (Format.asprintf "%a" (fun fmt (op, posts) -> pp_thread fmt op posts))
@@ -273,7 +272,7 @@ let pp_marker fmt op =
   Yojson.pretty_print fmt json
 
 let get_markers () =
-  let^ ids = Db.collect_list Q.get_threads () in
+  let* ids = Q.get_threads () in
   let* ops = get_ops ids in
   let markers =
     Format.asprintf "[%a]"
@@ -329,7 +328,7 @@ let pp_feed_entry fmt post =
 
 let feed thread_id =
   let* thread_data, op_post = get_op thread_id in
-  let^ ids = Db.collect_list Q.get_thread_posts thread_id in
+  let* ids = Q.get_thread_posts thread_id in
   let* posts = get_posts ids in
   let posts = List.sort (fun a b -> compare b.date a.date) posts in
   let* last_update =

src/syntax.ml

@@ -1,15 +1,5 @@
 (* 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 = Result.fold ~ok:f ~error:Result.error o
 

src/user.ml

@@ -1,5 +1,6 @@
-open Db
 open Syntax
+open Caqti_request.Infix
+open Caqti_type
 
 type t =
   { user_id : string
@@ -10,125 +11,123 @@ type t =
   ; metadata : (string * string) list
   }
 
-module Q = struct
-  open Caqti_request.Infix
-  open Caqti_type
-
-  let create_user_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
-       TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
-
-  let create_banished_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
-
-  let create_metadata_table =
-    (unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS user_metadata (user_id TEXT, metadata TEXT, \
-       FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
-
-  let get_metadata =
-    (string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?"
+let () =
+  let tables =
+    [| (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
+          TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS user_metadata (user_id TEXT, metadata \
+          TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE \
+          CASCADE)"
+    |]
+  in
+  if
+    Array.exists Result.is_error
+      (Array.map (fun query -> Db.exec query ()) tables)
+  then Dream.error (fun log -> log "can't create user tables")
 
+module Q = struct
   let upload_metadata =
-    (tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
+    Db.exec
+    @@ (tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
 
   let delete_metadata =
-    (string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
-
-  let get_user_id_from_nick =
-    (string ->! string) "SELECT user_id FROM user WHERE nick=?"
+    Db.exec @@ (string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
 
   let get_user_id_from_email =
-    (string ->! string) "SELECT user_id FROM user WHERE email=?"
+    Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE email=?"
 
   let get_password =
-    (string ->! string) "SELECT password FROM user WHERE user_id=?"
+    Db.find @@ (string ->! string) "SELECT password FROM user WHERE user_id=?"
 
   let is_already_user =
-    (tup2 string string ->! int)
-      "SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
+    Db.find
+    @@ (tup2 string string ->! int)
+         "SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
 
   let upload_user =
-    (tup4 string string string (tup2 string string) ->. unit)
-      "INSERT INTO user VALUES (?, ?, ?, ?, ?)"
+    Db.exec
+    @@ (tup4 string string string (tup2 string string) ->. unit)
+         "INSERT INTO user VALUES (?, ?, ?, ?, ?)"
 
-  let list_nicks = (unit ->* string) "SELECT nick FROM user"
+  let list_nicks = Db.collect_list @@ (unit ->* string) "SELECT nick FROM user"
 
   let get_user =
-    (* there is no "tup6" *)
+    Db.find
+    @@ (* there is no "tup6" *)
     (string ->! tup4 string string string (tup2 string string))
       "SELECT * FROM user WHERE user_id=?"
 
   let update_bio =
-    (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
+    Db.exec
+    @@ (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
 
   let update_nick =
-    (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
+    Db.exec
+    @@ (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
 
   let update_email =
-    (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
+    Db.exec
+    @@ (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
 
   let update_password =
-    (tup2 string string ->. unit) "UPDATE user SET password=? WHERE user_id=?"
-
-  let get_nick = (string ->! string) "SELECT nick FROM user WHERE user_id=?"
+    Db.exec
+    @@ (tup2 string string ->. unit)
+         "UPDATE user SET password=? WHERE user_id=?"
 
-  let get_bio = (string ->! string) "SELECT bio FROM user WHERE user_id=?"
+  let get_bio =
+    Db.find @@ (string ->! string) "SELECT bio FROM user WHERE user_id=?"
 
-  let get_email = (string ->! string) "SELECT email FROM user WHERE user_id=?"
+  let get_email =
+    Db.find @@ (string ->! string) "SELECT email FROM user WHERE user_id=?"
 
-  let delete_user = (string ->. unit) "DELETE FROM user WHERE user_id=?"
+  let delete_user =
+    Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?"
 
   let upload_banished =
-    (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
+    Db.exec @@ (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
 
   let get_banished =
-    (tup2 string string ->! tup2 string string)
-      "SELECT * FROM banished WHERE nick=? OR email=?"
+    Db.find
+    @@ (tup2 string string ->! tup2 string string)
+         "SELECT * FROM banished WHERE nick=? OR email=?"
 end
 
-let () =
-  let tables =
-    [| Q.create_user_table; Q.create_banished_table; Q.create_metadata_table |]
-  in
-  if
-    Array.exists Result.is_error
-      (Array.map (fun query -> Db.exec query ()) tables)
-  then Dream.error (fun log -> log "can't create user tables")
+let get_nick =
+  Db.find @@ (string ->! string) "SELECT nick FROM user WHERE user_id=?"
 
-let exist id = Result.is_ok (Db.find Q.get_user id)
+let get_id_from_nick =
+  Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE nick=?"
 
-let exist_nick nick = Result.is_ok (Db.find Q.get_user_id_from_nick nick)
+let exist id = Result.is_ok (Q.get_user id)
 
-let exist_email email = Result.is_ok (Db.find Q.get_user_id_from_email email)
+let exist_nick nick = Result.is_ok (get_id_from_nick nick)
 
-let get_metadata nick =
-  let^ metadata = Db.find Q.get_metadata nick in
-  let metadata : (string * string) list = Marshal.from_string metadata 0 in
-  Ok metadata
+let exist_email email = Result.is_ok (Q.get_user_id_from_email email)
 
-let get_user_id_from_nick nick =
-  let^ user_id = Db.find Q.get_user_id_from_nick nick in
-  Ok user_id
+let get_metadata =
+  let query =
+    Db.find
+    @@ (string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?"
+  in
+  fun nick ->
+    let* metadata = query nick in
+    let metadata : (string * string) list = Marshal.from_string metadata 0 in
+    Ok metadata
 
 let get_user user_id =
-  let^? user_id, nick, password, (email, bio) =
-    Db.find_opt Q.get_user user_id
-  in
+  let* user_id, nick, password, (email, bio) = Q.get_user user_id in
   let* metadata = get_metadata user_id in
   Ok { user_id; nick; password; email; bio; metadata }
 
-let is_banished login = Result.is_ok (Db.find Q.get_banished (login, login))
-
-let get_nick user_id =
-  let^ nick = Db.find Q.get_nick user_id in
-  Ok nick
+let is_banished login = Result.is_ok (Q.get_banished (login, login))
 
 let login ~login ~password request =
   let try_password user_id =
-    let^ good_password = Db.find Q.get_password user_id in
+    let* good_password = Q.get_password user_id in
     if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
       let _unit_lwt = Dream.invalidate_session request in
       let _unit_lwt = Dream.put_session "user_id" user_id request in
@@ -139,17 +138,17 @@ let login ~login ~password request =
     else Error "wrong password"
   in
 
-  let^ id_from_nick = Db.find_opt Q.get_user_id_from_nick login in
-  let^ id_from_email = Db.find_opt Q.get_user_id_from_email login in
-  let user_id_list = List.filter_map Fun.id [ id_from_nick; id_from_email ] in
-  match user_id_list with
-  | [] -> Error "Invalid login"
-  | [ id ] -> try_password id
-  | [ id_1; id_2 ] -> (
-    match try_password id_1 with
-    | Ok () -> Ok ()
-    | Error _e -> try_password id_2 )
-  | _to_many_ids -> assert false
+  let id_from_nick = get_id_from_nick login in
+  let id_from_email = Q.get_user_id_from_email login in
+  let user_id_list =
+    List.filter_map Result.to_option [ id_from_nick; id_from_email ]
+  in
+  try
+    List.iter
+      (fun id -> if Result.is_ok @@ try_password id then raise Exit)
+      user_id_list;
+    Error "invalid login"
+  with Exit -> Ok ()
 
 let valid_nick nick =
   String.length nick < 64
@@ -169,16 +168,15 @@ let register ~email ~nick ~password =
 
   if not valid then Error "Something is wrong"
   else
-    let^ nb = Db.find Q.is_already_user (nick, email) in
+    let* nb = Q.is_already_user (nick, email) in
     if nb = 0 then
       let user_id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in
-      let^ () = Db.exec Q.upload_user (user_id, nick, password, (email, "")) in
-      let^ () = Db.exec Q.upload_metadata (user_id, Marshal.to_string [] []) in
-      Ok ()
+      let* () = Q.upload_user (user_id, nick, password, (email, "")) in
+      Q.upload_metadata (user_id, Marshal.to_string [] [])
     else Error "nick or email already exists"
 
 let list () =
-  let^ users = Db.collect_list Q.list_nicks () in
+  let* users = Q.list_nicks () in
   Ok
     (Format.asprintf "<ul>%a</ul>"
        (Format.pp_print_list (fun fmt -> function
@@ -194,18 +192,7 @@ let profile request =
 let update_bio bio user_id =
   let bio = Dream.html_escape bio in
   let valid = String.length bio < 10000 in
-  if not valid then Error "Not biologic"
-  else
-    let^ () = Db.exec Q.update_bio (bio, user_id) in
-    Ok ()
-
-let get_bio user_id =
-  let^ bio = Db.find Q.get_bio user_id in
-  Ok bio
-
-let get_email user_id =
-  let^ email = Db.find Q.get_email user_id in
-  Ok email
+  if not valid then Error "Not biologic" else Q.update_bio (bio, user_id)
 
 let upload_avatar files user_id =
   match files with
@@ -223,37 +210,28 @@ let is_admin user_id =
 
 let banish user_id =
   let* nick = get_nick user_id in
-  let* email = get_email user_id in
-  let^ () = Db.exec Q.delete_user user_id in
-  let^ () = Db.exec Q.upload_banished (nick, email) in
-  Ok ()
+  let* email = Q.get_email user_id in
+  let* () = Q.delete_user user_id in
+  Q.upload_banished (nick, email)
 
-let delete_user user_id =
-  let^ () = Db.exec Q.delete_user user_id in
-  Ok ()
+let delete_user user_id = Q.delete_user user_id
 
 let update_nick nick user_id =
   if valid_nick nick then
-    if not (exist_nick nick) then
-      let^ () = Db.exec Q.update_nick (nick, user_id) in
-      Ok ()
+    if not (exist_nick nick) then Q.update_nick (nick, user_id)
     else Error "nick already taken"
   else Error "invalid nick"
 
 let update_email email user_id =
   if valid_email email then
-    if not (exist_email email) then
-      let^ () = Db.exec Q.update_email (email, user_id) in
-      Ok ()
+    if not (exist_email email) then Q.update_email (email, user_id)
     else Error "email already taken"
   else Error "invalid email"
 
 let update_password password user_id =
   if valid_password password then
-    let password = Bcrypt.hash password in
-    let password = Bcrypt.string_of_hash password in
-    let^ () = Db.exec Q.update_password (password, user_id) in
-    Ok ()
+    let password = Bcrypt.hash password |> Bcrypt.string_of_hash in
+    Q.update_password (password, user_id)
   else Error "invalid password"
 
 let update_metadata count label content user_id =
@@ -278,9 +256,8 @@ let update_metadata count label content user_id =
       if List.length metadata >= 42 then Error "to many metadata"
       else
         let s = Marshal.to_string metadata [] in
-        let^ () = Db.exec Q.delete_metadata user_id in
-        let^ () = Db.exec Q.upload_metadata (user_id, s) in
-        Ok ()
+        let* () = Q.delete_metadata user_id in
+        Q.upload_metadata (user_id, s)
 
 let pp_metadata fmt (label, content) =
   Format.fprintf fmt