diff --git a/src/babillard.ml b/src/babillard.ml index 8a17784..47b81d7 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -1,5 +1,6 @@ -open Db open Syntax +open Caqti_request.Infix +open Caqti_type type moderation_action = | Ignore @@ -40,150 +41,50 @@ type t = | Op of thread_data * 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 tables = - [| Q.create_post_user_table - ; Q.create_thread_info_table - ; Q.create_thread_post_table - ; Q.create_post_replies_table - ; Q.create_post_citations_table - ; Q.create_post_date_table - ; Q.create_post_comment_table - ; Q.create_post_tags_table - ; Q.create_report_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 *) + (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 *) + (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 if @@ -191,6 +92,101 @@ let () = (Array.map (fun query -> Db.exec query ()) 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 !*) (* insert html into the comment, and keep tracks of citations : -wraps lines starting with ">" with a @@ -252,28 +248,28 @@ let upload_post ~image post = 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^ () = Db.exec Q.upload_post_comment (id, comment) in - let^ () = Db.exec Q.upload_post_date (id, date) in - let^ () = Db.exec Q.upload_thread_post (parent_id, id) in + let* () = Q.upload_post_id (id, user_id) in + let* () = Q.upload_post_comment (id, comment) in + let* () = Q.upload_post_date (id, date) in + let* () = Q.upload_thread_post (parent_id, id) in let* () = match image with None -> Ok () | Some image -> Image.upload image id in - let^ _unit_list = - unwrap_list (fun tag -> Db.exec Q.upload_post_tag (id, tag)) tags - in - let^ _unit_list = - unwrap_list - (fun cited_id -> Db.exec Q.upload_post_reply (cited_id, id)) - citations - in - let^ () = - match thread_data with - | None -> Ok () - | Some { subject; lng; lat } -> - Db.exec Q.upload_thread_info (id, subject, lat, lng) - in - Ok id + match unwrap_list (fun tag -> Q.upload_post_tag (id, tag)) tags with + | Error _e as e -> e + | Ok _ -> ( + match + unwrap_list (fun cited_id -> Q.upload_post_reply (cited_id, id)) citations + with + | Error _e as e -> e + | Ok _ -> + let* () = + match thread_data with + | None -> Ok () + | Some { subject; lng; lat } -> + Q.upload_thread_info (id, subject, lat, lng) + in + Ok id ) let build_reply ~comment ~image_info ~tag_list ?parent_id user_id = 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 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 *) -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^ parent_id = Db.find Q.get_post_thread id in - let^ user_id = Db.find Q.get_post_user_id 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 - let^ comment = Db.find Q.get_post_comment id in - let^ date = Db.find Q.get_post_date id in + let* comment = Q.get_post_comment id in + let* date = Q.get_post_date id in let* image_info = Image.get_info id in - let^ tags = Db.collect_list Q.get_post_tags id in - let^ replies = Db.collect_list Q.get_post_replies id in - let^ citations = Db.collect_list Q.get_post_citations id in + let* tags = Q.get_post_tags id in + let* replies = Q.get_post_replies id in + let* citations = Q.get_post_citations id in let reply = { id ; parent_id @@ -385,10 +379,8 @@ let get_post id = Ok reply let get_thread_data id = - if thread_exist id then - let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in - Ok { subject; lat; lng } - else Error "not an op" + let* subject, lat, lng = Q.get_thread_info id in + Ok { subject; lat; lng } let get_op id = 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* post = get_post id in - if post.user_id = user_id || User.is_admin user_id then - let^ () = Db.exec Q.delete_post id in - Ok () + if post.user_id = user_id || User.is_admin user_id then Q.delete_post id else Error "You can only delete your posts" let report ~user_id ~reason id = @@ -412,15 +402,10 @@ let report ~user_id ~reason id = else let reason = Dream.html_escape reason in let date = Unix.time () in - let^ () = Db.exec Q.upload_report (user_id, reason, date, id) in - Ok () - -let ignore_report id = - let^ () = Db.exec Q.ignore_report id in - Ok () + Q.upload_report (user_id, reason, date, id) let get_reports () = - let^ reports = Db.collect_list Q.get_reports () in + let* reports = Q.get_reports () in let* posts = unwrap_list (fun (_reporter_id, _reason, _date, id) -> get_post id) reports in diff --git a/src/db.ml b/src/db.ml index a73df19..eb865c8 100644 --- a/src/db.ml +++ b/src/db.ml @@ -34,3 +34,15 @@ let () = | Error _e -> Format.eprintf "db error@\n"; 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 diff --git a/src/db.mli b/src/db.mli new file mode 100644 index 0000000..d9ed38b --- /dev/null +++ b/src/db.mli @@ -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 diff --git a/src/discuss.ml b/src/discuss.ml index fff5b5d..d5ec97f 100644 --- a/src/discuss.ml +++ b/src/discuss.ml @@ -1,4 +1,3 @@ -open Db open Syntax (** Creating the table of all messages. @@ -17,43 +16,45 @@ module Q = struct open Caqti_type let create_msg_table = - (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)" + 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 = - (tup2 string string ->* tup2 string string) - "SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?" + 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 = - (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=?)" + 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 = - (tup3 string string string ->. unit) - "INSERT INTO msg VALUES (NULL, ?, ?, ?)" + Db.exec + @@ (tup3 string string string ->. unit) + "INSERT INTO msg VALUES (NULL, ?, ?, ?)" end let () = - match Db.exec Q.create_msg_table () with - | Ok () -> () - | Error _e -> Dream.error (fun log -> log "can't create msg table") + 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 = Db.collect_list Q.find_comrades (user_id, user_id) in + 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 = - let^ comrades = Db.collect_list Q.find_messages ((k1, k2), (k2, k1)) in - Ok comrades +let find_messages k1 k2 = Q.find_messages ((k1, k2), (k2, k1)) (** display the list of discussions *) let render = @@ -113,9 +114,7 @@ let renderone request = let comrade_id = Dream.param request "comrade_id" in pp_discussion (request, user_id, comrade_id) ) -let insert_msg from_id to_id msg = - let^ () = Db.exec Q.insert_msg (from_id, to_id, msg) in - Ok () +let insert_msg from_id to_id msg = Q.insert_msg (from_id, to_id, msg) (** handle posts *) let post request = diff --git a/src/image.ml b/src/image.ml index 81cbf25..b6df556 100644 --- a/src/image.ml +++ b/src/image.ml @@ -1,5 +1,6 @@ -open Db open Syntax +open Caqti_request.Infix +open Caqti_type type t = { name : string @@ -8,84 +9,28 @@ type t = ; 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 tables = - [| Q.create_info_table - ; Q.create_content_table - ; Q.create_thumbnail_table - ; Q.create_user_content_table - ; Q.create_user_thumbnail_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)" + ; (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 if @@ -93,38 +38,68 @@ let () = (Array.map (fun query -> Db.exec query ()) 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^ () = Db.exec Q.upload_info (id, image.name, image.alt) in - let^ () = Db.exec Q.upload_content (id, image.content) in - let^ () = Db.exec Q.upload_thumbnail (id, image.thumbnail) in - 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_info (id, image.name, image.alt) in + let* () = upload_content (id, image.content) in + upload_thumbnail (id, image.thumbnail) let upload_avatar image id = - let^ () = Db.exec Q.delete_user_content id in - let^ () = Db.exec Q.delete_user_thumbnail id in - let^ () = Db.exec Q.upload_user_content (id, image.content) in - let^ () = Db.exec Q.upload_user_thumbnail (id, image.thumbnail) in - 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* () = delete_user_content id in + let* () = delete_user_thumbnail id in + let* () = upload_user_content (id, image.content) in + upload_user_thumbnail (id, image.thumbnail) let make_thumbnail content = let open Bos in diff --git a/src/permap.ml b/src/permap.ml index 9051edd..dd16617 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -148,12 +148,9 @@ let user request = let user_profile request = 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" - | Ok user_id -> - render - (Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile user_id)) - request + | Ok user_id -> render_result request @@ User.public_profile user_id let logout request = let _ = Dream.invalidate_session request in @@ -260,7 +257,7 @@ let get_post_image ~thumbnail request = let get_avatar_image request = 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" | Ok user_id -> ( let avatar = Image.get_user_content user_id in @@ -331,24 +328,19 @@ let babillard_post request = let thread_feed_get request = let thread_id = Dream.param request "thread_id" in - if Babillard.thread_exist thread_id then - match Pp_babillard.feed thread_id with - | Error e -> render e request - | Ok feed -> - Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed - else Dream.respond ~status:`Not_Found "Thread not found" + match Pp_babillard.feed thread_id with + | Error e -> render e request + | Ok feed -> + Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed let thread_get request = 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 res = - match thread_view with - | Error e -> e - | Ok thread_view -> Thread_page.f thread_view thread_id request - in - render res request - else Dream.respond ~status:`Not_Found "Thread not found" + let thread_view = Pp_babillard.view_thread thread_id in + render + ( match thread_view with + | Error e -> e + | Ok thread_view -> Thread_page.f thread_view thread_id request ) + request (*form to reply to a thread *) let reply_post request = diff --git a/src/pp_babillard.ml b/src/pp_babillard.ml index c61a6da..3940c5d 100644 --- a/src/pp_babillard.ml +++ b/src/pp_babillard.ml @@ -1,6 +1,5 @@ open Syntax open Babillard -open Db let pp_post fmt t = let thread_data_opt, post = @@ -50,7 +49,7 @@ let pp_post fmt t = let replies_view fmt () = if Option.is_some thread_data_opt then (* 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 | Error _ -> Format.fprintf fmt "" | Ok ((1 | 2) as nb) -> @@ -164,7 +163,7 @@ let pp_thread_preview fmt op = thread_preview let catalog_content () = - let^ ids = Db.collect_list Q.get_threads () in + let* ids = Q.get_threads () in let* ops = get_ops ids in Ok (Format.asprintf "%a" @@ -244,7 +243,7 @@ let pp_thread fmt op posts = let view_thread thread_id = 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 s = (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 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 markers = Format.asprintf "[%a]" @@ -329,7 +328,7 @@ let pp_feed_entry fmt post = let feed thread_id = 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 = List.sort (fun a b -> compare b.date a.date) posts in let* last_update = diff --git a/src/syntax.ml b/src/syntax.ml index aca03fc..62a0617 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -1,15 +1,5 @@ (* let bindings for early return when encountering an error *) (* 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 diff --git a/src/user.ml b/src/user.ml index 5cf56c8..976ab53 100644 --- a/src/user.ml +++ b/src/user.ml @@ -1,5 +1,6 @@ -open Db open Syntax +open Caqti_request.Infix +open Caqti_type type t = { user_id : string @@ -10,125 +11,123 @@ type t = ; 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 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 if Array.exists Result.is_error (Array.map (fun query -> Db.exec query ()) 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^ metadata = Db.find Q.get_metadata nick in - let metadata : (string * string) list = Marshal.from_string metadata 0 in - Ok metadata + let get_password = + Db.find @@ (string ->! string) "SELECT password FROM user WHERE user_id=?" -let get_user_id_from_nick nick = - let^ user_id = Db.find Q.get_user_id_from_nick nick in - Ok 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 + Ok metadata let get_user user_id = - let^? user_id, nick, password, (email, bio) = - Db.find_opt Q.get_user user_id - in + let* user_id, nick, password, (email, bio) = Q.get_user user_id in let* metadata = get_metadata user_id in Ok { user_id; nick; password; email; bio; metadata } -let is_banished login = Result.is_ok (Db.find Q.get_banished (login, login)) - -let get_nick user_id = - let^ nick = Db.find Q.get_nick user_id in - Ok nick +let is_banished login = Result.is_ok (Q.get_banished (login, login)) let login ~login ~password request = 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 let _unit_lwt = Dream.invalidate_session 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" in - let^ id_from_nick = Db.find_opt Q.get_user_id_from_nick login in - let^ id_from_email = Db.find_opt Q.get_user_id_from_email login in - let user_id_list = List.filter_map Fun.id [ id_from_nick; id_from_email ] in - match user_id_list with - | [] -> Error "Invalid login" - | [ id ] -> try_password id - | [ id_1; id_2 ] -> ( - match try_password id_1 with - | Ok () -> Ok () - | Error _e -> try_password id_2 ) - | _to_many_ids -> assert false + let id_from_nick = get_id_from_nick login in + let id_from_email = Q.get_user_id_from_email login in + let user_id_list = + List.filter_map Result.to_option [ id_from_nick; id_from_email ] + in + try + List.iter + (fun id -> if Result.is_ok @@ try_password id then raise Exit) + user_id_list; + Error "invalid login" + with Exit -> Ok () let valid_nick nick = String.length nick < 64 @@ -169,16 +168,15 @@ let register ~email ~nick ~password = if not valid then Error "Something is wrong" 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 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^ () = Db.exec Q.upload_metadata (user_id, Marshal.to_string [] []) in - Ok () + let* () = Q.upload_user (user_id, nick, password, (email, "")) in + Q.upload_metadata (user_id, Marshal.to_string [] []) else Error "nick or email already exists" let list () = - let^ users = Db.collect_list Q.list_nicks () in + let* users = Q.list_nicks () in Ok (Format.asprintf "" (Format.pp_print_list (fun fmt -> function @@ -194,18 +192,7 @@ let profile request = let update_bio bio user_id = let bio = Dream.html_escape bio in let valid = String.length bio < 10000 in - if not valid then Error "Not biologic" - 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 + if not valid then Error "Not biologic" else Q.update_bio (bio, user_id) let upload_avatar files user_id = match files with @@ -223,37 +210,28 @@ let is_admin user_id = let banish user_id = let* nick = get_nick user_id in - let* email = get_email user_id in - let^ () = Db.exec Q.delete_user user_id in - let^ () = Db.exec Q.upload_banished (nick, email) in - Ok () + let* email = Q.get_email user_id in + let* () = Q.delete_user user_id in + Q.upload_banished (nick, email) -let delete_user user_id = - let^ () = Db.exec Q.delete_user user_id in - Ok () +let delete_user user_id = Q.delete_user user_id let update_nick nick user_id = if valid_nick nick then - if not (exist_nick nick) then - let^ () = Db.exec Q.update_nick (nick, user_id) in - Ok () + if not (exist_nick nick) then Q.update_nick (nick, user_id) else Error "nick already taken" else Error "invalid nick" let update_email email user_id = if valid_email email then - if not (exist_email email) then - let^ () = Db.exec Q.update_email (email, user_id) in - Ok () + if not (exist_email email) then Q.update_email (email, user_id) else Error "email already taken" else Error "invalid email" let update_password password user_id = if valid_password password then - let password = Bcrypt.hash password in - let password = Bcrypt.string_of_hash password in - let^ () = Db.exec Q.update_password (password, user_id) in - Ok () + let password = Bcrypt.hash password |> Bcrypt.string_of_hash in + Q.update_password (password, user_id) else Error "invalid password" 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" else let s = Marshal.to_string metadata [] in - let^ () = Db.exec Q.delete_metadata user_id in - let^ () = Db.exec Q.upload_metadata (user_id, s) in - Ok () + let* () = Q.delete_metadata user_id in + Q.upload_metadata (user_id, s) let pp_metadata fmt (label, content) = Format.fprintf fmt