add profile metadata

src/babillard.ml

@@ -24,14 +24,6 @@ type t =
   | Op of thread_data * post
   | Post of post
 
-let unwrap_list f ids =
-  let l = List.map f ids in
-  let res = List.find_opt Result.is_error l in
-  match res with
-  | None -> Ok (List.map Result.get_ok l)
-  | Some (Ok _) -> assert false
-  | Some (Error _e as error) -> error
-
 module Q = struct
   let create_post_user_table =
     Caqti_request.exec Caqti_type.unit

src/bindings.ml

@@ -12,3 +12,11 @@ let ( let^ ) o f =
   | Ok x -> f x
 
 let ( let* ) o f = Result.fold ~ok:f ~error:Result.error o
+
+let unwrap_list f ids =
+  let l = List.map f ids in
+  let res = List.find_opt Result.is_error l in
+  match res with
+  | None -> Ok (List.map Result.get_ok l)
+  | Some (Ok _) -> assert false
+  | Some (Error _e as error) -> error

src/login.eml.html

@@ -9,8 +9,8 @@ let f request =
 <%s! Dream.form_tag ~action:url request %>
   <div class="mb-3">
     <label for="nick" class="form-label">Nick</label>
-    <input name="nick" type="text" class="form-control" id="nick" aria-describedby="nickHelp">
+    <input name="nick" type="text" class="form-control" id="nick" aria-describedby="nick-help">
-    <div id="nickHelp" class="form-text">Who are u ?</div>
+    <div id="nick-help" class="form-text">What is you nickname?</div>
   </div>
   <div class="mb-3">
     <label for="password" class="form-label">Password</label>

src/permap.ml

@@ -268,6 +268,14 @@ let profile_post request =
           ~headers:[ ("Location", "/profile") ]
           "Your display nick was updated!"
       | Error e -> render_unsafe e request )
+    | `Ok [ ("content", content); ("count", count); ("label", label) ] -> (
+      let count = int_of_string count in
+      match User.update_metadata count label content nick with
+      | Ok () ->
+        Dream.respond ~status:`See_Other
+          ~headers:[ ("Location", "/profile") ]
+          "Your display nick was updated!"
+      | Error e -> render_unsafe e request )
     | `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
     | `Wrong_session _ | `Expired _ | `Wrong_content_type -> (
       match%lwt Dream.multipart request with

src/user.ml

@@ -8,6 +8,7 @@ type t =
   ; email : string
   ; bio : string
   ; avatar : string
+  ; metadata : (int * string * string) list
   }
 
 module Q = struct
@@ -16,6 +17,31 @@ module Q = struct
       "CREATE TABLE IF NOT EXISTS user (nick TEXT, display_nick TEXT, password \
        TEXT, email TEXT, bio TEXT, avatar BLOB, PRIMARY KEY(nick));"
 
+  let create_banished_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT);"
+
+  let create_metadata_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS metadata (nick TEXT, count INT, label TEXT, \
+       content TEXT, FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \
+       CASCADE);"
+
+  let get_metadata =
+    Caqti_request.collect Caqti_type.string
+      Caqti_type.(tup3 int string string)
+      "SELECT count, label, content FROM metadata WHERE nick=?;"
+
+  let upload_metadata =
+    Caqti_request.exec
+      Caqti_type.(tup4 string int string string)
+      "INSERT INTO metadata VALUES (?, ?, ?, ?);"
+
+  let delete_metadata =
+    Caqti_request.exec
+      Caqti_type.(tup2 string int)
+      "DELETE FROM metadata WHERE nick=? AND count=?;"
+
   let get_password =
     Caqti_request.find_opt Caqti_type.string Caqti_type.string
       "SELECT password FROM user WHERE nick=?;"
@@ -84,10 +110,6 @@ module Q = struct
       Caqti_type.(tup2 string string)
       "UPDATE user SET avatar=? WHERE nick=?;"
 
-  let create_banished_table =
-    Caqti_request.exec Caqti_type.unit
-      "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT);"
-
   let delete_user =
     Caqti_request.exec Caqti_type.string "DELETE FROM user WHERE nick=?;"
 
@@ -103,7 +125,9 @@ module Q = struct
 end
 
 let () =
-  let tables = [| Q.create_user_table; Q.create_banished_table |] in
+  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)
@@ -111,11 +135,17 @@ let () =
 
 let exist nick = Result.is_ok (Db.find Q.get_user nick)
 
+let get_metadata nick =
+  let^ metadata = Db.collect_list Q.get_metadata nick in
+  let metadata = List.sort (fun (a, _, _) (b, _, _) -> compare a b) metadata in
+  Ok metadata
+
 let get_user nick =
   let^? nick, display_nick, password, (email, bio, avatar) =
     Db.find_opt Q.get_user nick
   in
-  Ok { nick; display_nick; password; email; bio; avatar }
+  let* metadata = get_metadata nick in
+  Ok { nick; display_nick; password; email; bio; avatar; metadata }
 
 let is_banished nick = Result.is_ok (Db.find Q.get_banished nick)
 
@@ -164,26 +194,6 @@ let list () =
        )
        users )
 
-let public_profile nick =
-  let* user = get_user nick in
-  let user_info =
-    Format.sprintf
-      {|
-    <h1>%s</h1>
-    <br />
-    <div class="row">
-      <div class="col-md-6">
-        <blockquote>%s</blockquote>
-      </div>
-      <div class="col-md-6">
-        <img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">
-      </div>
-    </div>
-|}
-      user.nick user.bio user.nick
-  in
-  Ok user_info
-
 let profile request =
   match Dream.session "nick" request with
   | None -> "not logged in"
@@ -254,3 +264,107 @@ let update_password password nick =
     let^ () = Db.exec Q.update_password (password, nick) in
     Ok ()
   else Error "invalid password"
+
+let update_metadata count label content nick =
+  let label = Dream.html_escape label in
+  let content = Dream.html_escape content in
+  if String.length label > 200 || String.length content > 400 then
+    Error "label or content is too long"
+  else
+    (* rewrite all user's metadata *)
+    let* metadata = get_metadata nick in
+    let^ _unit_list =
+      unwrap_list
+        (fun (count, _l, _c) -> Db.exec Q.delete_metadata (nick, count))
+        metadata
+    in
+    let l = List.filter (fun (i, _, _) -> i <> count) metadata in
+    let l =
+      if not (label = "" && content = "") then (count, label, content) :: l
+      else l
+    in
+    let l = List.sort (fun (a, _, _) (b, _, _) -> compare a b) l in
+    let l = List.mapi (fun i (_, label, content) -> (i, label, content)) l in
+    let^ _unit_list =
+      unwrap_list
+        (fun (i, label, content) ->
+          Db.exec Q.upload_metadata (nick, i, label, content) )
+        l
+    in
+    Ok ()
+
+let pp_metadata fmt metadata =
+  let _count, label, content = metadata in
+  Format.fprintf fmt
+    {|
+<div class="row">
+    <div class="col metadata-label">%s</div>
+    <div class="col metadata-content">%s</div>
+</div>
+    |}
+    label content
+
+let pp_metadata_form fmt ?is_last metadata request =
+  let count, label, content = metadata in
+  let form_tag = Dream.form_tag ~action:"/profile" request in
+  let button_text = if Option.is_some is_last then "Add" else "Save" in
+  Format.fprintf fmt
+    {|
+<div class="row">
+    %s
+        <input name="label" class="metadata-label" value="%s"/>
+        <input name="content" class="metadata-content" value="%s"/>
+    <button name="count" value="%d" type="submit" class="btn btn-primary">%s</button>
+    </form>
+</div>
+    |}
+    form_tag label content count button_text
+
+let pp_metadata_table fmt metadata =
+  Format.fprintf fmt
+    {|
+<div class="metadata-table">
+    %a
+</div>
+|}
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_metadata)
+    metadata
+
+let pp_metadata_table_form fmt metadata request =
+  let length = List.length metadata in
+  let new_metadata_field fmt () =
+    pp_metadata_form fmt ~is_last:() (length, "", "") request
+  in
+  Format.fprintf fmt
+    {|
+<div class="metadata-form-table">
+    %a
+    %a
+</div>
+|}
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun fmt metadata ->
+         pp_metadata_form fmt metadata request ) )
+    metadata new_metadata_field ()
+
+let public_profile nick =
+  let* user = get_user nick in
+  let user_info =
+    Format.asprintf
+      {|
+    <h1>%s</h1>
+    <br />
+    <div class="row">
+      <div class="col-md-6">
+        <blockquote>%s</blockquote>
+      </div>
+      <div class="col-md-6">
+        <img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">
+      </div>
+      <div class="col-md-6">
+        %a
+      </div>
+    </div>
+|}
+      user.display_nick user.bio user.nick pp_metadata_table user.metadata
+  in
+  Ok user_info

src/user_profile.eml.html

@@ -1,7 +1,8 @@
 let f (user: User.t) request =
-  <h1><%s  Format.sprintf "Hello %s !" user.nick %></h1>
+% let metadata_table = Format.asprintf "%a" (fun fmt metadata -> User.pp_metadata_table_form fmt metadata request) user.metadata in
+  <h1>Edit your profile</h1>
   <p>Check your <a href="/user/<%s user.nick %>">public profile rendering</a>.</p>
-  <h2>Edit profile</h2>
+  <h2>Display nickname</h2>
   <%s! Dream.form_tag ~action:"/profile" request %>
     <div class="mb-3">
       <label for="display-nick" class="form-label">Change display name</label>
@@ -11,15 +12,22 @@ let f (user: User.t) request =
   </form>
   <br />
   <br />
+  <h2>Profile metadata</h2>
+  <p>Add items displayed as a table on your profile.</p>
+<%s! metadata_table %>
+  <br />
+  <br />
+  <h2>Bio</h2>
   <%s! Dream.form_tag ~action:"/profile" request %>
     <div class="mb-3">
-      <label for="bio" class="form-label">Bio</label>
+      <label for="bio" class="form-label">Change your bio</label>
-      <textarea name="bio" type="text" class="form-control" id="bio" aria-describedby="bioHelp"><%s! user.bio %></textarea>
+      <textarea name="bio" type="text" class="form-control" id="bio" aria-describedby="bio-help"><%s! user.bio %></textarea>
-      <div id="bioHelp" class="form-text">Who are you?</div>
+      <div id="bio-help" class="form-text">Who are you?</div>
     </div>
     <button type="submit" class="btn btn-primary">Save</button>
   </form>
   <br />
+  <h2>Avatar</h2>
   <img src="/user/<%s user.nick %>/avatar" class="img-thumbnail" alt="Your avatar picture" />
   <br />
   <br />