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 {|
|} 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 "
%a
"
(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 "
%a
"
(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 )