swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

refactor

Browse source
This commit is contained in:
zapashcanon 2022-04-08 00:43:00 +02:00
parent 190d086206
commit ce7bb9d386
No known key found for this signature in database
GPG key ID: 8981C3C62D1D28F1
9 changed files with 442 additions and 500 deletions
Download patch file Download diff file Expand all files Collapse all files

347
src/babillard.ml
View file

@ -1,5 +1,6 @@
open Db
open Syntax open Syntax
open Caqti_request.Infix
open Caqti_type
type moderation_action = type moderation_action =
| Ignore | Ignore
@ -40,150 +41,50 @@ type t =
| Op of thread_data * post | Op of thread_data * post
| Post of post | Post of post
module Q = struct
open Caqti_request.Infix
open Caqti_type
let create_post_user_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, user_id TEXT, \
PRIMARY KEY(post_id), FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
DELETE CASCADE)"
(* one row for each thread, with thread's data *)
let create_thread_info_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject TEXT, \
lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \
post_user(post_id) ON DELETE CASCADE)"
(* map thread and reply to the thread *)
let create_thread_post_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS thread_post (thread_id TEXT, post_id TEXT, \
FOREIGN KEY(thread_id) REFERENCES post_user(post_id) ON DELETE CASCADE, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let create_post_replies_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id TEXT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE, \
FOREIGN KEY(reply_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let create_post_citations_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id TEXT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE, \
FOREIGN KEY(cited_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let create_post_date_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date FLOAT, FOREIGN \
KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let create_post_comment_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let create_post_tags_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, FOREIGN \
KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let create_report_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS report (user_id TEXT, reason TEXT, date \
FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) \
ON DELETE CASCADE, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
DELETE CASCADE)"
let upload_report =
(tup4 string string float string ->. unit)
"INSERT INTO report VALUES (?,?,?,?)"
let ignore_report = (string ->. unit) "DELETE FROM report WHERE post_id=?"
let get_reports =
(unit ->* tup4 string string float string) "SELECT * FROM report"
let upload_post_id =
(tup2 string string ->. unit) "INSERT INTO post_user VALUES (?,?)"
let upload_thread_info =
(tup4 string string float float ->. unit)
"INSERT INTO thread_info VALUES (?,?,?,?)"
let upload_thread_post =
(tup2 string string ->. unit) "INSERT INTO thread_post VALUES (?,?)"
let upload_post_reply =
(tup2 string string ->. unit) "INSERT INTO post_replies VALUES (?,?)"
let upload_post_comment =
(tup2 string string ->. unit) "INSERT INTO post_comment VALUES (?,?)"
let upload_post_tag =
(tup2 string string ->. unit) "INSERT INTO post_tags VALUES (?,?)"
let upload_post_date =
(tup2 string float ->. unit) "INSERT INTO post_date VALUES (?,?)"
let get_post_user_id =
(string ->! string) "SELECT user_id FROM post_user WHERE post_id=?"
let get_post_comment =
(string ->! string) "SELECT comment FROM post_comment WHERE post_id=?"
let get_post_tags =
(string ->* string) "SELECT tag FROM post_tags WHERE post_id=?"
let get_post_date =
(string ->! float) "SELECT date FROM post_date WHERE post_id=?"
let get_post_citations =
(string ->* string) "SELECT post_id FROM post_citations WHERE post_id=?"
let get_post_replies =
(string ->* string) "SELECT reply_id FROM post_replies WHERE post_id=?"
let get_thread_posts =
(string ->* string) "SELECT post_id FROM thread_post WHERE thread_id=?"
let count_thread_posts =
(string ->! int) "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?"
let get_is_thread =
(string ->! string)
"SELECT thread_id FROM thread_info WHERE thread_id=? LIMIT 1"
let get_is_post =
(string ->! string) "SELECT post_id FROM post_user WHERE post_id=? LIMIT 1"
let get_post_thread =
(string ->! string)
"SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1"
let get_thread_info =
(string ->! tup3 string float float)
"SELECT subject,lat,lng FROM thread_info WHERE thread_id=?"
let get_threads = (unit ->* string) "SELECT thread_id FROM thread_info"
let delete_post = (string ->. unit) "DELETE FROM post_user WHERE post_id=?"
end
let () = let () =
let tables = let tables =
[| Q.create_post_user_table [| (unit ->. unit)
; Q.create_thread_info_table "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, user_id TEXT, \
; Q.create_thread_post_table PRIMARY KEY(post_id), FOREIGN KEY(user_id) REFERENCES user(user_id) \
; Q.create_post_replies_table ON DELETE CASCADE)"
; Q.create_post_citations_table ; (* one row for each thread, with thread's data *)
; Q.create_post_date_table (unit ->. unit)
; Q.create_post_comment_table "CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject \
; Q.create_post_tags_table TEXT, lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \
; Q.create_report_table post_user(post_id) ON DELETE CASCADE)"
; (* map thread and reply to the thread *)
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS thread_post (thread_id TEXT, post_id \
TEXT, FOREIGN KEY(thread_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \
DELETE CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id \
TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE, FOREIGN KEY(reply_id) REFERENCES post_user(post_id) ON \
DELETE CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id \
TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE, FOREIGN KEY(cited_id) REFERENCES post_user(post_id) ON \
DELETE CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date FLOAT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS report (user_id TEXT, reason TEXT, date \
FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES \
post_user(post_id) ON DELETE CASCADE, FOREIGN KEY(user_id) \
REFERENCES user(user_id) ON DELETE CASCADE)"
|] |]
in in
if if
@ -191,6 +92,101 @@ let () =
(Array.map (fun query -> Db.exec query ()) tables) (Array.map (fun query -> Db.exec query ()) tables)
then Dream.error (fun log -> log "can't create babillard's tables") then Dream.error (fun log -> log "can't create babillard's tables")
module Q = struct
let upload_report =
Db.exec
@@ (tup4 string string float string ->. unit)
"INSERT INTO report VALUES (?,?,?,?)"
let get_reports =
Db.collect_list
@@ (unit ->* tup4 string string float string) "SELECT * FROM report"
let upload_post_id =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO post_user VALUES (?,?)"
let upload_thread_info =
Db.exec
@@ (tup4 string string float float ->. unit)
"INSERT INTO thread_info VALUES (?,?,?,?)"
let upload_thread_post =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO thread_post VALUES (?,?)"
let upload_post_reply =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO post_replies VALUES (?,?)"
let upload_post_comment =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO post_comment VALUES (?,?)"
let upload_post_tag =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO post_tags VALUES (?,?)"
let upload_post_date =
Db.exec @@ (tup2 string float ->. unit) "INSERT INTO post_date VALUES (?,?)"
let get_post_user_id =
Db.find
@@ (string ->! string) "SELECT user_id FROM post_user WHERE post_id=?"
let get_post_comment =
Db.find
@@ (string ->! string) "SELECT comment FROM post_comment WHERE post_id=?"
let get_post_tags =
Db.collect_list
@@ (string ->* string) "SELECT tag FROM post_tags WHERE post_id=?"
let get_post_date =
Db.find @@ (string ->! float) "SELECT date FROM post_date WHERE post_id=?"
let get_post_citations =
Db.collect_list
@@ (string ->* string) "SELECT post_id FROM post_citations WHERE post_id=?"
let get_post_replies =
Db.collect_list
@@ (string ->* string) "SELECT reply_id FROM post_replies WHERE post_id=?"
let get_thread_posts =
Db.collect_list
@@ (string ->* string) "SELECT post_id FROM thread_post WHERE thread_id=?"
let count_thread_posts =
Db.find
@@ (string ->! int)
"SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?"
let get_is_post =
Db.find
@@ (string ->! string)
"SELECT post_id FROM post_user WHERE post_id=? LIMIT 1"
let get_post_thread =
Db.find
@@ (string ->! string)
"SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1"
let get_thread_info =
Db.find
@@ (string ->! tup3 string float float)
"SELECT subject,lat,lng FROM thread_info WHERE thread_id=?"
let get_threads =
Db.collect_list @@ (unit ->* string) "SELECT thread_id FROM thread_info"
let delete_post =
Db.exec @@ (string ->. unit) "DELETE FROM post_user WHERE post_id=?"
end
let ignore_report =
Db.exec @@ (string ->. unit) "DELETE FROM report WHERE post_id=?"
(*TODO switch to markdown !*) (*TODO switch to markdown !*)
(* insert html into the comment, and keep tracks of citations : (* insert html into the comment, and keep tracks of citations :
-wraps lines starting with ">" with a <span class="quote"> -wraps lines starting with ">" with a <span class="quote">
@ -252,28 +248,28 @@ let upload_post ~image post =
in in
let { id; parent_id; date; user_id; comment; tags; citations; _ } = reply in let { id; parent_id; date; user_id; comment; tags; citations; _ } = reply in
let^ () = Db.exec Q.upload_post_id (id, user_id) in let* () = Q.upload_post_id (id, user_id) in
let^ () = Db.exec Q.upload_post_comment (id, comment) in let* () = Q.upload_post_comment (id, comment) in
let^ () = Db.exec Q.upload_post_date (id, date) in let* () = Q.upload_post_date (id, date) in
let^ () = Db.exec Q.upload_thread_post (parent_id, id) in let* () = Q.upload_thread_post (parent_id, id) in
let* () = let* () =
match image with None -> Ok () | Some image -> Image.upload image id match image with None -> Ok () | Some image -> Image.upload image id
in in
let^ _unit_list = match unwrap_list (fun tag -> Q.upload_post_tag (id, tag)) tags with
unwrap_list (fun tag -> Db.exec Q.upload_post_tag (id, tag)) tags | Error _e as e -> e
in | Ok _ -> (
let^ _unit_list = match
unwrap_list unwrap_list (fun cited_id -> Q.upload_post_reply (cited_id, id)) citations
(fun cited_id -> Db.exec Q.upload_post_reply (cited_id, id)) with
citations | Error _e as e -> e
in | Ok _ ->
let^ () = let* () =
match thread_data with match thread_data with
| None -> Ok () | None -> Ok ()
| Some { subject; lng; lat } -> | Some { subject; lng; lat } ->
Db.exec Q.upload_thread_info (id, subject, lat, lng) Q.upload_thread_info (id, subject, lat, lng)
in in
Ok id Ok id )
let build_reply ~comment ~image_info ~tag_list ?parent_id user_id = let build_reply ~comment ~image_info ~tag_list ?parent_id user_id =
let comment = Dream.html_escape comment in let comment = Dream.html_escape comment in
@ -353,22 +349,20 @@ let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
in in
upload_post ~image post upload_post ~image post
let thread_exist id = Result.is_ok (Db.find Q.get_is_thread id)
(* true if post is an op too *) (* true if post is an op too *)
let post_exist id = Result.is_ok (Db.find Q.get_is_post id) let post_exist id = Result.is_ok (Q.get_is_post id)
let get_post id = let get_post id =
let^ parent_id = Db.find Q.get_post_thread id in let* parent_id = Q.get_post_thread id in
let^ user_id = Db.find Q.get_post_user_id id in let* user_id = Q.get_post_user_id id in
let* nick = User.get_nick user_id in let* nick = User.get_nick user_id in
let^ comment = Db.find Q.get_post_comment id in let* comment = Q.get_post_comment id in
let^ date = Db.find Q.get_post_date id in let* date = Q.get_post_date id in
let* image_info = Image.get_info id in let* image_info = Image.get_info id in
let^ tags = Db.collect_list Q.get_post_tags id in let* tags = Q.get_post_tags id in
let^ replies = Db.collect_list Q.get_post_replies id in let* replies = Q.get_post_replies id in
let^ citations = Db.collect_list Q.get_post_citations id in let* citations = Q.get_post_citations id in
let reply = let reply =
{ id { id
; parent_id ; parent_id
@ -385,10 +379,8 @@ let get_post id =
Ok reply Ok reply
let get_thread_data id = let get_thread_data id =
if thread_exist id then let* subject, lat, lng = Q.get_thread_info id in
let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in
Ok { subject; lat; lng } Ok { subject; lat; lng }
else Error "not an op"
let get_op id = let get_op id =
let* thread_data = get_thread_data id in let* thread_data = get_thread_data id in
@ -401,9 +393,7 @@ let get_ops ids = unwrap_list get_op ids
let try_delete_post ~user_id id = let try_delete_post ~user_id id =
let* post = get_post id in let* post = get_post id in
if post.user_id = user_id || User.is_admin user_id then if post.user_id = user_id || User.is_admin user_id then Q.delete_post id
let^ () = Db.exec Q.delete_post id in
Ok ()
else Error "You can only delete your posts" else Error "You can only delete your posts"
let report ~user_id ~reason id = let report ~user_id ~reason id =
@ -412,15 +402,10 @@ let report ~user_id ~reason id =
else else
let reason = Dream.html_escape reason in let reason = Dream.html_escape reason in
let date = Unix.time () in let date = Unix.time () in
let^ () = Db.exec Q.upload_report (user_id, reason, date, id) in Q.upload_report (user_id, reason, date, id)
Ok ()
let ignore_report id =
let^ () = Db.exec Q.ignore_report id in
Ok ()
let get_reports () = let get_reports () =
let^ reports = Db.collect_list Q.get_reports () in let* reports = Q.get_reports () in
let* posts = let* posts =
unwrap_list (fun (_reporter_id, _reason, _date, id) -> get_post id) reports unwrap_list (fun (_reporter_id, _reason, _date, id) -> get_post id) reports
in in

12
src/db.ml
View file

@ -34,3 +34,15 @@ let () =
| Error _e -> | Error _e ->
Format.eprintf "db error@\n"; Format.eprintf "db error@\n";
exit 1 exit 1
let unwrap_err = function
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok _ as ok -> ok
let exec q v = Db.exec q v |> unwrap_err
let find q v = Db.find q v |> unwrap_err
let find_opt q v = Db.find_opt q v |> unwrap_err
let collect_list q v = Db.collect_list q v |> unwrap_err

13
src/db.mli Normal file
View file

@ -0,0 +1,13 @@
val exec : ('a, unit, [< `Zero ]) Caqti_request.t -> 'a -> (unit, string) result
val find : ('a, 'b, [< `One ]) Caqti_request.t -> 'a -> ('b, string) result
val find_opt :
('a, 'b, [< `One | `Zero ]) Caqti_request.t
-> 'a
-> ('b option, string) result
val collect_list :
('a, 'b, [ `Many | `One | `Zero ]) Caqti_request.t
-> 'a
-> ('b list, string) result

33
src/discuss.ml
View file

@ -1,4 +1,3 @@
open Db
open Syntax open Syntax
(** Creating the table of all messages. (** Creating the table of all messages.
@ -17,43 +16,45 @@ module Q = struct
open Caqti_type open Caqti_type
let create_msg_table = let create_msg_table =
(unit ->. unit) Db.exec
"CREATE TABLE IF NOT EXISTS msg ( msg_id TEXT, from_id TEXT, to_id TEXT, \ @@ (unit ->. unit)
msg TEXT, PRIMARY KEY(msg_id), FOREIGN KEY(from_id) REFERENCES \ "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, FOREIGN KEY(to_id) REFERENCES \
user(user_id) ON DELETE CASCADE)" user(user_id) ON DELETE CASCADE)"
let find_comrades = let find_comrades =
(tup2 string string ->* tup2 string string) Db.collect_list
@@ (tup2 string string ->* tup2 string string)
"SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?" "SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?"
let find_messages = let find_messages =
(tup2 (tup2 string string) (tup2 string string) ->* tup2 string string) 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 \ "SELECT from_id, msg FROM msg WHERE (from_id=? AND to_id=?) OR \
(from_id=? AND to_id=?)" (from_id=? AND to_id=?)"
let insert_msg = let insert_msg =
(tup3 string string string ->. unit) Db.exec
@@ (tup3 string string string ->. unit)
"INSERT INTO msg VALUES (NULL, ?, ?, ?)" "INSERT INTO msg VALUES (NULL, ?, ?, ?)"
end end
let () = let () =
match Db.exec Q.create_msg_table () with Result.iter_error
| Ok () -> () (fun _e -> Dream.error (fun log -> log "can't create table"))
| Error _e -> Dream.error (fun log -> log "can't create msg table") (Q.create_msg_table ())
(** let's find who the user is talking to so we can know if they're dangerous *) (** let's find who the user is talking to so we can know if they're dangerous *)
let find_comrades user_id = let find_comrades user_id =
let^ comrades = Db.collect_list Q.find_comrades (user_id, user_id) in let* comrades = Q.find_comrades (user_id, user_id) in
let comrades = let comrades =
List.map (fun (l, r) -> if l = user_id then r else l) comrades List.map (fun (l, r) -> if l = user_id then r else l) comrades
in in
Ok (List.sort_uniq String.compare comrades) Ok (List.sort_uniq String.compare comrades)
(** find all messages between two товарищи *) (** find all messages between two товарищи *)
let find_messages k1 k2 = let find_messages k1 k2 = Q.find_messages ((k1, k2), (k2, k1))
let^ comrades = Db.collect_list Q.find_messages ((k1, k2), (k2, k1)) in
Ok comrades
(** display the list of discussions *) (** display the list of discussions *)
let render = let render =
@ -113,9 +114,7 @@ let renderone request =
let comrade_id = Dream.param request "comrade_id" in let comrade_id = Dream.param request "comrade_id" in
pp_discussion (request, user_id, comrade_id) ) pp_discussion (request, user_id, comrade_id) )
let insert_msg from_id to_id msg = let insert_msg from_id to_id msg = Q.insert_msg (from_id, to_id, msg)
let^ () = Db.exec Q.insert_msg (from_id, to_id, msg) in
Ok ()
(** handle posts *) (** handle posts *)
let post request = let post request =

187
src/image.ml
View file

@ -1,5 +1,6 @@
open Db
open Syntax open Syntax
open Caqti_request.Infix
open Caqti_type
type t = type t =
{ name : string { name : string
@ -8,84 +9,28 @@ type t =
; thumbnail : string ; thumbnail : string
} }
module Q = struct
open Caqti_request.Infix
open Caqti_type
let create_info_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS image_info (post_id TEXT, image_name TEXT, \
image_alt TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \
DELETE CASCADE)"
let create_content_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS image_content (post_id TEXT, content TEXT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let create_thumbnail_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS image_thumbnail (post_id TEXT, content TEXT, \
FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE CASCADE)"
let upload_info =
(tup3 string string string ->. unit) "INSERT INTO image_info VALUES (?,?,?)"
let upload_content =
(tup2 string string ->. unit) "INSERT INTO image_content VALUES (?,?)"
let upload_thumbnail =
(tup2 string string ->. unit) "INSERT INTO image_thumbnail VALUES (?,?)"
let get_post_content =
(string ->? string) "SELECT content FROM image_content WHERE post_id=?"
let get_post_thumbnail =
(string ->? string) "SELECT content FROM image_thumbnail WHERE post_id=?"
let get_post_info =
(string ->? tup2 string string)
"SELECT image_name,image_alt FROM image_info WHERE post_id=?"
(*avatars*)
let create_user_content_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS user_image_content (user_id TEXT, content \
TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
let create_user_thumbnail_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS user_image_thumbnail (user_id TEXT, content \
TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
let upload_user_content =
(tup2 string string ->. unit) "INSERT INTO user_image_content VALUES (?,?)"
let upload_user_thumbnail =
(tup2 string string ->. unit)
"INSERT INTO user_image_thumbnail VALUES (?,?)"
let get_user_content =
(string ->? string) "SELECT content FROM user_image_content WHERE user_id=?"
let get_user_thumbnail =
(string ->? string)
"SELECT content FROM user_image_thumbnail WHERE user_id=?"
let delete_user_content =
(string ->. unit) "DELETE FROM user_image_content WHERE user_id=?"
let delete_user_thumbnail =
(string ->. unit) "DELETE FROM user_image_thumbnail WHERE user_id=?"
end
let () = let () =
let tables = let tables =
[| Q.create_info_table [| (unit ->. unit)
; Q.create_content_table "CREATE TABLE IF NOT EXISTS image_info (post_id TEXT, image_name \
; Q.create_thumbnail_table TEXT, image_alt TEXT, FOREIGN KEY(post_id) REFERENCES \
; Q.create_user_content_table post_user(post_id) ON DELETE CASCADE)"
; Q.create_user_thumbnail_table ; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS image_content (post_id TEXT, content \
TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS image_thumbnail (post_id TEXT, content \
TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS user_image_content (user_id TEXT, content \
TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE \
CASCADE)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS user_image_thumbnail (user_id TEXT, \
content TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
DELETE CASCADE)"
|] |]
in in
if if
@ -93,38 +38,68 @@ let () =
(Array.map (fun query -> Db.exec query ()) tables) (Array.map (fun query -> Db.exec query ()) tables)
then Dream.error (fun log -> log "can't create images tables") then Dream.error (fun log -> log "can't create images tables")
let upload_info =
Db.exec
@@ (tup3 string string string ->. unit)
"INSERT INTO image_info VALUES (?,?,?)"
let upload_content =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO image_content VALUES (?,?)"
let upload_thumbnail =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO image_thumbnail VALUES (?,?)"
let get_content =
Db.find_opt
@@ (string ->? string) "SELECT content FROM image_content WHERE post_id=?"
let get_thumbnail =
Db.find_opt
@@ (string ->? string) "SELECT content FROM image_thumbnail WHERE post_id=?"
let get_info =
Db.find_opt
@@ (string ->? tup2 string string)
"SELECT image_name,image_alt FROM image_info WHERE post_id=?"
let upload_user_content =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO user_image_content VALUES (?,?)"
let upload_user_thumbnail =
Db.exec
@@ (tup2 string string ->. unit)
"INSERT INTO user_image_thumbnail VALUES (?,?)"
let get_user_content =
Db.find_opt
@@ (string ->? string)
"SELECT content FROM user_image_content WHERE user_id=?"
let get_user_thumbnail =
Db.find_opt
@@ (string ->? string)
"SELECT content FROM user_image_thumbnail WHERE user_id=?"
let delete_user_content =
Db.exec @@ (string ->. unit) "DELETE FROM user_image_content WHERE user_id=?"
let delete_user_thumbnail =
Db.exec
@@ (string ->. unit) "DELETE FROM user_image_thumbnail WHERE user_id=?"
let upload image id = let upload image id =
let^ () = Db.exec Q.upload_info (id, image.name, image.alt) in let* () = upload_info (id, image.name, image.alt) in
let^ () = Db.exec Q.upload_content (id, image.content) in let* () = upload_content (id, image.content) in
let^ () = Db.exec Q.upload_thumbnail (id, image.thumbnail) in upload_thumbnail (id, image.thumbnail)
Ok ()
let get_content id =
let^ content = Db.find_opt Q.get_post_content id in
Ok content
let get_thumbnail id =
let^ thumbnail = Db.find_opt Q.get_post_thumbnail id in
Ok thumbnail
let get_info id =
let^ info = Db.find_opt Q.get_post_info id in
Ok info
let upload_avatar image id = let upload_avatar image id =
let^ () = Db.exec Q.delete_user_content id in let* () = delete_user_content id in
let^ () = Db.exec Q.delete_user_thumbnail id in let* () = delete_user_thumbnail id in
let^ () = Db.exec Q.upload_user_content (id, image.content) in let* () = upload_user_content (id, image.content) in
let^ () = Db.exec Q.upload_user_thumbnail (id, image.thumbnail) in upload_user_thumbnail (id, image.thumbnail)
Ok ()
let get_user_content id =
let^ content = Db.find_opt Q.get_user_content id in
Ok content
let get_user_thumbnail id =
let^ thumbnail = Db.find_opt Q.get_user_thumbnail id in
Ok thumbnail
let make_thumbnail content = let make_thumbnail content =
let open Bos in let open Bos in

22
src/permap.ml
View file

@ -148,12 +148,9 @@ let user request =
let user_profile request = let user_profile request =
let nick = Dream.param request "user" in let nick = Dream.param request "user" in
match User.get_user_id_from_nick nick with match User.get_id_from_nick nick with
| Error _e -> Dream.respond ~status:`Not_Found "User does not exists" | Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
| Ok user_id -> | Ok user_id -> render_result request @@ User.public_profile user_id
render
(Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile user_id))
request
let logout request = let logout request =
let _ = Dream.invalidate_session request in let _ = Dream.invalidate_session request in
@ -260,7 +257,7 @@ let get_post_image ~thumbnail request =
let get_avatar_image request = let get_avatar_image request =
let nick = Dream.param request "user" in let nick = Dream.param request "user" in
match User.get_user_id_from_nick nick with match User.get_id_from_nick nick with
| Error _e -> Dream.respond ~status:`Not_Found "User does not exists" | Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
| Ok user_id -> ( | Ok user_id -> (
let avatar = Image.get_user_content user_id in let avatar = Image.get_user_content user_id in
@ -331,24 +328,19 @@ let babillard_post request =
let thread_feed_get request = let thread_feed_get request =
let thread_id = Dream.param request "thread_id" in let thread_id = Dream.param request "thread_id" in
if Babillard.thread_exist thread_id then
match Pp_babillard.feed thread_id with match Pp_babillard.feed thread_id with
| Error e -> render e request | Error e -> render e request
| Ok feed -> | Ok feed ->
Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed
else Dream.respond ~status:`Not_Found "Thread not found"
let thread_get request = let thread_get request =
let thread_id = Dream.param request "thread_id" in let thread_id = Dream.param request "thread_id" in
if Babillard.thread_exist thread_id then
let thread_view = Pp_babillard.view_thread thread_id in let thread_view = Pp_babillard.view_thread thread_id in
let res = render
match thread_view with ( match thread_view with
| Error e -> e | Error e -> e
| Ok thread_view -> Thread_page.f thread_view thread_id request | Ok thread_view -> Thread_page.f thread_view thread_id request )
in request
render res request
else Dream.respond ~status:`Not_Found "Thread not found"
(*form to reply to a thread *) (*form to reply to a thread *)
let reply_post request = let reply_post request =

11
src/pp_babillard.ml
View file

@ -1,6 +1,5 @@
open Syntax open Syntax
open Babillard open Babillard
open Db
let pp_post fmt t = let pp_post fmt t =
let thread_data_opt, post = let thread_data_opt, post =
@ -50,7 +49,7 @@ let pp_post fmt t =
let replies_view fmt () = let replies_view fmt () =
if Option.is_some thread_data_opt then if Option.is_some thread_data_opt then
(* TODO put thread_posts count in thread_info ? *) (* TODO put thread_posts count in thread_info ? *)
let res_nb = Db.find Q.count_thread_posts id in let res_nb = Q.count_thread_posts id in
match res_nb with match res_nb with
| Error _ -> Format.fprintf fmt "" | Error _ -> Format.fprintf fmt ""
| Ok ((1 | 2) as nb) -> | Ok ((1 | 2) as nb) ->
@ -164,7 +163,7 @@ let pp_thread_preview fmt op =
thread_preview thread_preview
let catalog_content () = let catalog_content () =
let^ ids = Db.collect_list Q.get_threads () in let* ids = Q.get_threads () in
let* ops = get_ops ids in let* ops = get_ops ids in
Ok Ok
(Format.asprintf "%a" (Format.asprintf "%a"
@ -244,7 +243,7 @@ let pp_thread fmt op posts =
let view_thread thread_id = let view_thread thread_id =
let* op = get_op thread_id in let* op = get_op thread_id in
let^ ids = Db.collect_list Q.get_thread_posts thread_id in let* ids = Q.get_thread_posts thread_id in
let* posts = get_posts ids in let* posts = get_posts ids in
let s = let s =
(Format.asprintf "%a" (fun fmt (op, posts) -> pp_thread fmt op posts)) (Format.asprintf "%a" (fun fmt (op, posts) -> pp_thread fmt op posts))
@ -273,7 +272,7 @@ let pp_marker fmt op =
Yojson.pretty_print fmt json Yojson.pretty_print fmt json
let get_markers () = let get_markers () =
let^ ids = Db.collect_list Q.get_threads () in let* ids = Q.get_threads () in
let* ops = get_ops ids in let* ops = get_ops ids in
let markers = let markers =
Format.asprintf "[%a]" Format.asprintf "[%a]"
@ -329,7 +328,7 @@ let pp_feed_entry fmt post =
let feed thread_id = let feed thread_id =
let* thread_data, op_post = get_op thread_id in let* thread_data, op_post = get_op thread_id in
let^ ids = Db.collect_list Q.get_thread_posts thread_id in let* ids = Q.get_thread_posts thread_id in
let* posts = get_posts ids in let* posts = get_posts ids in
let posts = List.sort (fun a b -> compare b.date a.date) posts in let posts = List.sort (fun a b -> compare b.date a.date) posts in
let* last_update = let* last_update =

10
src/syntax.ml
View file

@ -1,15 +1,5 @@
(* let bindings for early return when encountering an error *) (* let bindings for early return when encountering an error *)
(* see https://ocaml.org/releases/4.13/htmlman/bindingops.html *) (* see https://ocaml.org/releases/4.13/htmlman/bindingops.html *)
let ( let^? ) o f =
match o with
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok None -> Error "db error"
| Ok (Some x) -> f x
let ( let^ ) o f =
match o with
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok x -> f x
let ( let* ) o f = Result.fold ~ok:f ~error:Result.error o let ( let* ) o f = Result.fold ~ok:f ~error:Result.error o

271
src/user.ml
View file

@ -1,5 +1,6 @@
open Db
open Syntax open Syntax
open Caqti_request.Infix
open Caqti_type
type t = type t =
{ user_id : string { user_id : string
@ -10,125 +11,123 @@ type t =
; metadata : (string * string) list ; metadata : (string * string) list
} }
module Q = struct
open Caqti_request.Infix
open Caqti_type
let create_user_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
let create_banished_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
let create_metadata_table =
(unit ->. unit)
"CREATE TABLE IF NOT EXISTS user_metadata (user_id TEXT, metadata TEXT, \
FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
let get_metadata =
(string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?"
let upload_metadata =
(tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
let delete_metadata =
(string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
let get_user_id_from_nick =
(string ->! string) "SELECT user_id FROM user WHERE nick=?"
let get_user_id_from_email =
(string ->! string) "SELECT user_id FROM user WHERE email=?"
let get_password =
(string ->! string) "SELECT password FROM user WHERE user_id=?"
let is_already_user =
(tup2 string string ->! int)
"SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
let upload_user =
(tup4 string string string (tup2 string string) ->. unit)
"INSERT INTO user VALUES (?, ?, ?, ?, ?)"
let list_nicks = (unit ->* string) "SELECT nick FROM user"
let get_user =
(* there is no "tup6" *)
(string ->! tup4 string string string (tup2 string string))
"SELECT * FROM user WHERE user_id=?"
let update_bio =
(tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
let update_nick =
(tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
let update_email =
(tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
let update_password =
(tup2 string string ->. unit) "UPDATE user SET password=? WHERE user_id=?"
let get_nick = (string ->! string) "SELECT nick FROM user WHERE user_id=?"
let get_bio = (string ->! string) "SELECT bio FROM user WHERE user_id=?"
let get_email = (string ->! string) "SELECT email FROM user WHERE user_id=?"
let delete_user = (string ->. unit) "DELETE FROM user WHERE user_id=?"
let upload_banished =
(tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
let get_banished =
(tup2 string string ->! tup2 string string)
"SELECT * FROM banished WHERE nick=? OR email=?"
end
let () = let () =
let tables = let tables =
[| Q.create_user_table; Q.create_banished_table; Q.create_metadata_table |] [| (unit ->. unit)
"CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
; (unit ->. unit)
"CREATE TABLE IF NOT EXISTS user_metadata (user_id TEXT, metadata \
TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE \
CASCADE)"
|]
in in
if if
Array.exists Result.is_error Array.exists Result.is_error
(Array.map (fun query -> Db.exec query ()) tables) (Array.map (fun query -> Db.exec query ()) tables)
then Dream.error (fun log -> log "can't create user tables") then Dream.error (fun log -> log "can't create user tables")
let exist id = Result.is_ok (Db.find Q.get_user id) module Q = struct
let upload_metadata =
Db.exec
@@ (tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
let exist_nick nick = Result.is_ok (Db.find Q.get_user_id_from_nick nick) let delete_metadata =
Db.exec @@ (string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
let exist_email email = Result.is_ok (Db.find Q.get_user_id_from_email email) let get_user_id_from_email =
Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE email=?"
let get_metadata nick = let get_password =
let^ metadata = Db.find Q.get_metadata nick in Db.find @@ (string ->! string) "SELECT password FROM user WHERE user_id=?"
let is_already_user =
Db.find
@@ (tup2 string string ->! int)
"SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
let upload_user =
Db.exec
@@ (tup4 string string string (tup2 string string) ->. unit)
"INSERT INTO user VALUES (?, ?, ?, ?, ?)"
let list_nicks = Db.collect_list @@ (unit ->* string) "SELECT nick FROM user"
let get_user =
Db.find
@@ (* there is no "tup6" *)
(string ->! tup4 string string string (tup2 string string))
"SELECT * FROM user WHERE user_id=?"
let update_bio =
Db.exec
@@ (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
let update_nick =
Db.exec
@@ (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
let update_email =
Db.exec
@@ (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
let update_password =
Db.exec
@@ (tup2 string string ->. unit)
"UPDATE user SET password=? WHERE user_id=?"
let get_bio =
Db.find @@ (string ->! string) "SELECT bio FROM user WHERE user_id=?"
let get_email =
Db.find @@ (string ->! string) "SELECT email FROM user WHERE user_id=?"
let delete_user =
Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?"
let upload_banished =
Db.exec @@ (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
let get_banished =
Db.find
@@ (tup2 string string ->! tup2 string string)
"SELECT * FROM banished WHERE nick=? OR email=?"
end
let get_nick =
Db.find @@ (string ->! string) "SELECT nick FROM user WHERE user_id=?"
let get_id_from_nick =
Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE nick=?"
let exist id = Result.is_ok (Q.get_user id)
let exist_nick nick = Result.is_ok (get_id_from_nick nick)
let exist_email email = Result.is_ok (Q.get_user_id_from_email email)
let get_metadata =
let query =
Db.find
@@ (string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?"
in
fun nick ->
let* metadata = query nick in
let metadata : (string * string) list = Marshal.from_string metadata 0 in let metadata : (string * string) list = Marshal.from_string metadata 0 in
Ok metadata Ok metadata
let get_user_id_from_nick nick =
let^ user_id = Db.find Q.get_user_id_from_nick nick in
Ok user_id
let get_user user_id = let get_user user_id =
let^? user_id, nick, password, (email, bio) = let* user_id, nick, password, (email, bio) = Q.get_user user_id in
Db.find_opt Q.get_user user_id
in
let* metadata = get_metadata user_id in let* metadata = get_metadata user_id in
Ok { user_id; nick; password; email; bio; metadata } Ok { user_id; nick; password; email; bio; metadata }
let is_banished login = Result.is_ok (Db.find Q.get_banished (login, login)) let is_banished login = Result.is_ok (Q.get_banished (login, login))
let get_nick user_id =
let^ nick = Db.find Q.get_nick user_id in
Ok nick
let login ~login ~password request = let login ~login ~password request =
let try_password user_id = let try_password user_id =
let^ good_password = Db.find Q.get_password user_id in let* good_password = Q.get_password user_id in
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
let _unit_lwt = Dream.invalidate_session request in let _unit_lwt = Dream.invalidate_session request in
let _unit_lwt = Dream.put_session "user_id" user_id request in let _unit_lwt = Dream.put_session "user_id" user_id request in
@ -139,17 +138,17 @@ let login ~login ~password request =
else Error "wrong password" else Error "wrong password"
in in
let^ id_from_nick = Db.find_opt Q.get_user_id_from_nick login in let id_from_nick = get_id_from_nick login in
let^ id_from_email = Db.find_opt Q.get_user_id_from_email login in let id_from_email = Q.get_user_id_from_email login in
let user_id_list = List.filter_map Fun.id [ id_from_nick; id_from_email ] in let user_id_list =
match user_id_list with List.filter_map Result.to_option [ id_from_nick; id_from_email ]
| [] -> Error "Invalid login" in
| [ id ] -> try_password id try
| [ id_1; id_2 ] -> ( List.iter
match try_password id_1 with (fun id -> if Result.is_ok @@ try_password id then raise Exit)
| Ok () -> Ok () user_id_list;
| Error _e -> try_password id_2 ) Error "invalid login"
| _to_many_ids -> assert false with Exit -> Ok ()
let valid_nick nick = let valid_nick nick =
String.length nick < 64 String.length nick < 64
@ -169,16 +168,15 @@ let register ~email ~nick ~password =
if not valid then Error "Something is wrong" if not valid then Error "Something is wrong"
else else
let^ nb = Db.find Q.is_already_user (nick, email) in let* nb = Q.is_already_user (nick, email) in
if nb = 0 then if nb = 0 then
let user_id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in let user_id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in
let^ () = Db.exec Q.upload_user (user_id, nick, password, (email, "")) in let* () = Q.upload_user (user_id, nick, password, (email, "")) in
let^ () = Db.exec Q.upload_metadata (user_id, Marshal.to_string [] []) in Q.upload_metadata (user_id, Marshal.to_string [] [])
Ok ()
else Error "nick or email already exists" else Error "nick or email already exists"
let list () = let list () =
let^ users = Db.collect_list Q.list_nicks () in let* users = Q.list_nicks () in
Ok Ok
(Format.asprintf "<ul>%a</ul>" (Format.asprintf "<ul>%a</ul>"
(Format.pp_print_list (fun fmt -> function (Format.pp_print_list (fun fmt -> function
@ -194,18 +192,7 @@ let profile request =
let update_bio bio user_id = let update_bio bio user_id =
let bio = Dream.html_escape bio in let bio = Dream.html_escape bio in
let valid = String.length bio < 10000 in let valid = String.length bio < 10000 in
if not valid then Error "Not biologic" if not valid then Error "Not biologic" else Q.update_bio (bio, user_id)
else
let^ () = Db.exec Q.update_bio (bio, user_id) in
Ok ()
let get_bio user_id =
let^ bio = Db.find Q.get_bio user_id in
Ok bio
let get_email user_id =
let^ email = Db.find Q.get_email user_id in
Ok email
let upload_avatar files user_id = let upload_avatar files user_id =
match files with match files with
@ -223,37 +210,28 @@ let is_admin user_id =
let banish user_id = let banish user_id =
let* nick = get_nick user_id in let* nick = get_nick user_id in
let* email = get_email user_id in let* email = Q.get_email user_id in
let^ () = Db.exec Q.delete_user user_id in let* () = Q.delete_user user_id in
let^ () = Db.exec Q.upload_banished (nick, email) in Q.upload_banished (nick, email)
Ok ()
let delete_user user_id = let delete_user user_id = Q.delete_user user_id
let^ () = Db.exec Q.delete_user user_id in
Ok ()
let update_nick nick user_id = let update_nick nick user_id =
if valid_nick nick then if valid_nick nick then
if not (exist_nick nick) then if not (exist_nick nick) then Q.update_nick (nick, user_id)
let^ () = Db.exec Q.update_nick (nick, user_id) in
Ok ()
else Error "nick already taken" else Error "nick already taken"
else Error "invalid nick" else Error "invalid nick"
let update_email email user_id = let update_email email user_id =
if valid_email email then if valid_email email then
if not (exist_email email) then if not (exist_email email) then Q.update_email (email, user_id)
let^ () = Db.exec Q.update_email (email, user_id) in
Ok ()
else Error "email already taken" else Error "email already taken"
else Error "invalid email" else Error "invalid email"
let update_password password user_id = let update_password password user_id =
if valid_password password then if valid_password password then
let password = Bcrypt.hash password in let password = Bcrypt.hash password |> Bcrypt.string_of_hash in
let password = Bcrypt.string_of_hash password in Q.update_password (password, user_id)
let^ () = Db.exec Q.update_password (password, user_id) in
Ok ()
else Error "invalid password" else Error "invalid password"
let update_metadata count label content user_id = let update_metadata count label content user_id =
@ -278,9 +256,8 @@ let update_metadata count label content user_id =
if List.length metadata >= 42 then Error "to many metadata" if List.length metadata >= 42 then Error "to many metadata"
else else
let s = Marshal.to_string metadata [] in let s = Marshal.to_string metadata [] in
let^ () = Db.exec Q.delete_metadata user_id in let* () = Q.delete_metadata user_id in
let^ () = Db.exec Q.upload_metadata (user_id, s) in Q.upload_metadata (user_id, s)
Ok ()
let pp_metadata fmt (label, content) = let pp_metadata fmt (label, content) =
Format.fprintf fmt Format.fprintf fmt