implements discussions

src/discuss.ml

@@ -0,0 +1,169 @@
+(** Creating the table of all messages.
+
+    Each message is made of :
+
+    - an id (msg_id)
+    - the id of the sender (from_id)
+    - the id of the receiver (to_id)
+    - some text (msg)
+
+    TODO: add date ? *)
+let () =
+  let create_msg_table =
+    Caqti_request.exec Caqti_type.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);"
+  in
+  match Db.Db.exec create_msg_table () with
+  | Ok () -> ()
+  | Error _e -> Dream.error (fun log -> log "can't create msg table")
+
+(** let's find who the user is talking to so we can know if they're dangerous *)
+let find_comrades =
+  let find_comrades =
+    Caqti_request.collect
+      Caqti_type.(tup2 string string)
+      Caqti_type.(tup2 string string)
+      "SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?"
+  in
+  fun user_id ->
+    let open Bindings in
+    let^ comrades = Db.Db.collect_list 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 =
+  let find_messages =
+    Caqti_request.collect
+      Caqti_type.(tup2 (tup2 string string) (tup2 string string))
+      Caqti_type.(tup2 string string)
+      "SELECT from_id, msg FROM msg WHERE (from_id=? AND to_id=?) OR \
+       (from_id=? AND to_id=?)"
+  in
+  fun k1 k2 ->
+    let open Bindings in
+    let^ comrades = Db.Db.collect_list find_messages ((k1, k2), (k2, k1)) in
+    Ok comrades
+
+(** display the list of discussions *)
+let render request =
+  match Dream.session "user_id" request with
+  | None ->
+    let redirect_url =
+      Format.sprintf "/login=?redirect=%s" (Dream.to_percent_encoded "/discuss")
+    in
+    Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
+  | Some user_id -> (
+    match find_comrades user_id with
+    | Error e -> Template_utils.render_unsafe e request
+    | Ok comrades -> (
+      let comrades =
+        Bindings.unwrap_list
+          (fun id ->
+            match User.get_nick id with
+            | Error _e as e -> e
+            | Ok nick -> Ok (id, nick) )
+          comrades
+      in
+      match comrades with
+      | Error e -> Template_utils.render_unsafe e request
+      | Ok comrades ->
+        let pp_one_discuss fmt (id, nick) =
+          Format.fprintf fmt {|<li><a href="/discuss/%s">%s</a></li>|} id nick
+        in
+        let output =
+          Format.asprintf "<ul>%a</ul>"
+            (Format.pp_print_list
+               ~pp_sep:(fun fmt () -> Format.fprintf fmt "<br />")
+               pp_one_discuss )
+            comrades
+        in
+        Template_utils.render_unsafe output request ) )
+
+let pp_discussion (request, user_id, comrade_id) =
+  let path = Format.sprintf "/discuss/%s" comrade_id in
+  match find_messages user_id comrade_id with
+  | Error e -> Template_utils.render_unsafe e request
+  | Ok msg -> (
+    match User.get_nick user_id with
+    | Error e -> Template_utils.render_unsafe e request
+    | Ok user_nick -> (
+      match User.get_nick comrade_id with
+      | Error e -> Template_utils.render_unsafe e request
+      | Ok comrade_nick ->
+        let pp_one_msg fmt (from_id, msg) =
+          Format.fprintf fmt "<li>%s | %s</li>"
+            (if from_id = user_id then user_nick else comrade_nick)
+            msg
+        in
+        let pp_all_msg fmt msg =
+          Format.fprintf fmt "<ul>%a</ul>"
+            (Format.pp_print_list
+               ~pp_sep:(fun fmt () -> Format.fprintf fmt "<br />")
+               pp_one_msg )
+            msg
+        in
+        Template_utils.render_unsafe
+          (Format.asprintf
+             {|%a<br />
+          %s
+          <input value="" name="msg" type="text" />
+          <button type="submit" class="btn btn-primary">Send</button>
+        </form>|}
+             pp_all_msg msg
+             (Dream.form_tag ~action:path request) )
+          request ) )
+
+(** display one discussion *)
+let render_one request =
+  let comrade_id = Dream.param request "comrade_id" in
+
+  let path = Format.sprintf "/discuss/%s" comrade_id in
+
+  match Dream.session "user_id" request with
+  | None ->
+    let redirect_url =
+      Format.sprintf "/login=?redirect=%s" (Dream.to_percent_encoded path)
+    in
+    Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
+  | Some user_id -> pp_discussion (request, user_id, comrade_id)
+
+let insert_msg =
+  let insert_msg =
+    Caqti_request.exec
+      Caqti_type.(tup3 string string string)
+      "INSERT INTO msg VALUES (NULL, ?, ?, ?);"
+  in
+  fun from_id to_id msg ->
+    let open Bindings in
+    let^ () = Db.Db.exec insert_msg (from_id, to_id, msg) in
+    Ok ()
+
+(** handle posts *)
+let post request =
+  let comrade_id = Dream.param request "comrade_id" in
+
+  let path = Format.sprintf "/discuss/%s" comrade_id in
+
+  match Dream.session "user_id" request with
+  | None ->
+    let redirect_url =
+      Format.sprintf "/login=?redirect=%s" (Dream.to_percent_encoded path)
+    in
+    Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
+  | Some user_id -> (
+    match%lwt Dream.form request with
+    | `Ok [ ("msg", msg) ] -> begin
+      match insert_msg user_id comrade_id msg with
+      | Ok () -> pp_discussion (request, user_id, comrade_id)
+      | Error e -> Template_utils.render_unsafe e request
+    end
+    | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
+    | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
+    | `Wrong_session _ | `Wrong_content_type ->
+      Dream.empty `Bad_Request )

src/dune

@@ -9,12 +9,14 @@
   content
   db
   delete_page
+  discuss
   login
   permap
   pp_babillard
   register
   report_page
   template
+  template_utils
   thread_page
   user
   user_account

src/permap.ml

@@ -1,26 +1,4 @@
-include Bindings
+open Template_utils
-
-let get_title content =
-  let open Soup in
-  try
-    let soup = content |> parse in
-    soup $ "h1" |> R.leaf_text
-  with Failure _e -> "Permap"
-
-let render ?title content request =
-  let title =
-    match title with None -> get_title content | Some title -> title
-  in
-  Dream.html
-  @@ Template.render_unsafe ~title:(Dream.html_escape title)
-       ~content:(Dream.html_escape content)
-       request
-
-let render_unsafe ?title content request =
-  let title =
-    match title with None -> get_title content | Some title -> title
-  in
-  Dream.html @@ Template.render_unsafe ~title ~content request
 
 let not_logged_in redirect request =
   let content =
@@ -484,6 +462,9 @@ let routes =
   ; get_ "/catalog" catalog
   ; get_ "/delete/:post_id" delete_get
   ; post "/delete/:post_id" delete_post
+  ; get_ "/discuss" Discuss.render
+  ; get_ "/discuss/:comrade_id" Discuss.render_one
+  ; post "/discuss/:comrade_id" Discuss.post
   ; get_ "/img/:post_id" (get_post_image ~thumbnail:false)
   ; get_ "/img/s/:post_id" (get_post_image ~thumbnail:true)
   ; get_ "/login" login_get

src/template.eml.html

@@ -27,6 +27,11 @@ let render_unsafe ~title ~content request =
                           <li class="nav-item">
                               <a class="nav-link" href="/user">Discover users</a>
                           </li>
+% begin if Option.is_some @@ Dream.session "nick" request then
+                          <li class="nav-item">
+                              <a class="nav-link" href="/discuss">Discuss</a>
+                          </li>
+% end;
                       </ul>
                       <ul class="navbar-nav ms-auto mb-2 mb-md-0">
 % begin match Dream.session "nick" request with

src/template_utils.ml

@@ -0,0 +1,21 @@
+let get_title content =
+  let open Soup in
+  try
+    let soup = content |> parse in
+    soup $ "h1" |> R.leaf_text
+  with Failure _e -> "Permap"
+
+let render ?title content request =
+  let title =
+    match title with None -> get_title content | Some title -> title
+  in
+  Dream.html
+  @@ Template.render_unsafe ~title:(Dream.html_escape title)
+       ~content:(Dream.html_escape content)
+       request
+
+let render_unsafe ?title content request =
+  let title =
+    match title with None -> get_title content | Some title -> title
+  in
+  Dream.html @@ Template.render_unsafe ~title ~content request

src/user.ml

@@ -387,11 +387,12 @@ let public_profile user_id =
       <div class="col-md-6">
         <img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">
       </div>
+      <a href="/discuss/%s">Speak to me !</a>
       <div class="col-md-6">
         %a
       </div>
     </div>
 |}
-      user.nick user.bio user.nick pp_metadata_table user.metadata
+      user.nick user.bio user.nick user_id pp_metadata_table user.metadata
   in
   Ok user_info