add emojid

src/app.ml

@@ -90,3 +90,5 @@ let admins = get_dirs "admin"
 let categories = List.sort_uniq compare (get_dirs "category")
 
 let random_state = Random.State.make_self_init ()
+
+let () = Random.set_state random_state

src/babillard.ml

@@ -26,6 +26,7 @@ type thread_data =
 
 type post =
   { id : string
+  ; emojid : string
   ; parent_id : string
   ; date : float
   ; user_id : string
@@ -294,8 +295,10 @@ let build_reply ~comment ~image_info ~tag_list ?parent_id user_id =
     let date = Unix.time () in
     let comment, citations = parse_comment comment in
     let* nick = User.get_nick user_id in
+    let* emojid = Emojid.make_emojid id in
     let reply =
       { id
+      ; emojid
       ; parent_id
       ; date
       ; user_id
@@ -353,6 +356,7 @@ let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
 let post_exist id = Result.is_ok (Q.get_is_post id)
 
 let get_post id =
+  let* emojid = Emojid.Q.get_emojid 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
@@ -365,6 +369,7 @@ let get_post id =
   let* citations = Q.get_post_citations id in
   let reply =
     { id
+    ; emojid
     ; parent_id
     ; date
     ; user_id

src/dune

@@ -10,6 +10,7 @@
   delete_page
   discuss
   image
+  emojid
   login
   permap
   pp_babillard
@@ -33,6 +34,7 @@
   directories
   dream
   emile
+  emoji
   fpath
   lambdasoup
   omd

src/emojid.ml

@@ -0,0 +1,71 @@
+open Syntax
+open Caqti_request.Infix
+open Caqti_type
+
+module Q = struct
+  let upload_emojid =
+    Db.exec
+    @@ (tup2 string string ->. unit) "INSERT INTO uuid_emojid VALUES (?,?)"
+
+  let get_emojid =
+    Db.find @@ (string ->! string) "SELECT emojid FROM uuid_emojid WHERE uuid=?"
+
+  let is_free =
+    Db.find
+    @@ (string ->! int)
+         "SELECT EXISTS(SELECT 1 FROM uuid_emojid WHERE emojid=?)"
+end
+
+let () =
+  let tables =
+    [| (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS uuid_emojid (uuid TEXT, emojid TEXT)"
+    |]
+  in
+  if
+    Array.exists Result.is_error
+      (Array.map (fun query -> Db.exec query ()) tables)
+  then Dream.error (fun log -> log "can't create emojid's tables")
+
+let max_emojid_lenght = 16
+
+let emojis =
+  Array.append Emoji.category_animals_and_nature Emoji.category_food_and_drink
+
+let is_free emojid =
+  let* is_free = Q.is_free emojid in
+  Ok (is_free = 0)
+
+let upload_emojid uuid emojid =
+  let* is_free = is_free emojid in
+  if is_free then
+    let* () = Q.upload_emojid (uuid, emojid) in
+    Ok ()
+  else Error "Invalid emojid: already taken"
+
+let make_emojid uuid =
+  (* pick a list of emojis *)
+  let random_emojis =
+    Array.init max_emojid_lenght (fun _i ->
+        let n = Random.int (Array.length emojis) in
+        Array.get emojis n )
+  in
+  (* pick the smallest emojid possible *)
+  let* emojid, is_emojid =
+    Array.fold_left
+      (fun acc emoji ->
+        match acc with
+        | Error e -> Error e
+        | Ok (s, is_emojid) ->
+          if is_emojid then Ok (s, is_emojid)
+          else
+            let s = s ^ emoji in
+            let* is_emojid = is_free s in
+            Ok (s, is_emojid) )
+      (Ok ("", false))
+      random_emojis
+  in
+  if is_emojid then
+    let* () = upload_emojid uuid emojid in
+    Ok emojid
+  else Error "couldn't find a free emojid"

src/js/js_post_form.ml

@@ -1,16 +1,17 @@
 let log = Format.printf
 
 (* called by clicking post_id *)
-(* insert id into reply form *)
-let insert_quote post_id _event =
+(* insert emojid into reply form *)
+let insert_quote emojid _event =
   log "quote@\n";
   Option.iter
     (fun textarea ->
       let content = Jv.to_string @@ Jv.get textarea "value" in
       let new_content =
         if String.ends_with ~suffix:"\n" content || String.length content = 0
-        then Format.sprintf "%s>>%s " content post_id
-        else Format.sprintf "%s@\n>>%s " content post_id
+        then (* don't skip a line *)
+          Format.sprintf "%s[%s] " content emojid
+        else Format.sprintf "%s@\n[%s] " content emojid
       in
       ignore @@ Jv.set textarea "value" (Jv.of_string new_content) )
     Jv.(find global "reply-comment")
@@ -24,13 +25,13 @@ let () =
   in
   log "quote_links leng %d@\n" (List.length quote_links);
   let add_click quote_link =
-    let post_id =
+    let emojid =
       Jv.to_string
-      @@ Jv.call quote_link "getAttribute" [| Jv.of_string "data-id" |]
+      @@ Jv.call quote_link "getAttribute" [| Jv.of_string "data-emojid" |]
     in
     ignore
     @@ Jv.call quote_link "addEventListener"
-         [| Jv.of_string "click"; Jv.repr (insert_quote post_id) |]
+         [| Jv.of_string "click"; Jv.repr (insert_quote emojid) |]
   in
   List.iter add_click quote_links
 

src/pp_babillard.ml

@@ -8,6 +8,7 @@ let pp_post fmt t =
     | Post post -> (None, post)
   in
   let { id
+      ; emojid
       ; parent_id = _parent_id
       ; date
       ; user_id
@@ -68,11 +69,11 @@ let pp_post fmt t =
       Format.fprintf fmt
         {|
         <span class=postNo>
-            <button data-id="%s" class="quote-link" title="Reply to this post">%s</button>
+            <button data-id="%s" data-emojid="%s" class="quote-link" title="Reply to this post">%s</button>
         </span>
         %a
         |}
-        id id replies_view ()
+        id emojid emojid replies_view ()
   in
 
   let post_info_view fmt () =