open Syntax (** 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 ? *) module Q = struct open Caqti_request.Infix open Caqti_type let create_msg_table = 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 = 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 = 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 = Db.exec @@ (tup3 string string string ->. unit) "INSERT INTO msg VALUES (NULL, ?, ?, ?)" end let () = 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 = 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 = Q.find_messages ((k1, k2), (k2, k1)) (** display the list of discussions *) let render = let pp_one_discuss fmt (id, nick) = Format.fprintf fmt {|
  • %s
  • |} id nick in fun request -> Utils.logged_in_or_redirect request (fun user_id -> Utils.render_result request @@ let* comrades = find_comrades user_id in let* comrades = Syntax.unwrap_list (fun id -> match User.get_nick id with | Error _e as e -> e | Ok nick -> Ok (id, nick) ) comrades in Ok (Format.asprintf "" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "
    ") pp_one_discuss ) comrades ) ) let pp_discussion (request, user_id, comrade_id) = let path = Format.sprintf "/discuss/%s" comrade_id in Utils.render_result request @@ let* msg = find_messages user_id comrade_id in let* user_nick = User.get_nick user_id in let* comrade_nick = User.get_nick comrade_id in let pp_one_msg fmt (from_id, msg) = Format.fprintf fmt "
  • %s | %s
  • " (if from_id = user_id then user_nick else comrade_nick) (Dream.html_escape msg) in let pp_all_msg fmt msg = Format.fprintf fmt "" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "
    ") pp_one_msg ) msg in Ok (Format.asprintf {|%a
    %s |} pp_all_msg msg (Dream.form_tag ~action:path request) ) (** display one discussion *) let renderone request = Utils.logged_in_or_redirect request (fun user_id -> let comrade_id = Dream.param request "comrade_id" in pp_discussion (request, user_id, comrade_id) ) let insert_msg from_id to_id msg = Q.insert_msg (from_id, to_id, msg) (** handle posts *) let post request = Utils.logged_in_or_redirect request (fun user_id -> match%lwt Dream.form request with | `Ok [ ("msg", msg) ] -> begin let comrade_id = Dream.param request "comrade_id" in match insert_msg user_id comrade_id msg with | Ok () -> pp_discussion (request, user_id, comrade_id) | Error e -> Utils.render e request end | form -> Utils.handle_invalid_form form )