From 0632a713c7e08f35901335e75afc83b240778253 Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 4 Apr 2022 21:38:09 +0200 Subject: [PATCH] open caqti_type; use Q module for discuss --- src/babillard.ml | 87 +++++++++++++++++++----------------------------- src/db.ml | 4 +-- src/discuss.ml | 73 ++++++++++++++++++++-------------------- src/image.ml | 44 ++++++++++-------------- src/user.ml | 69 +++++++++++++------------------------- 5 files changed, 115 insertions(+), 162 deletions(-) diff --git a/src/babillard.ml b/src/babillard.ml index 6988551..7b1d89a 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -42,154 +42,135 @@ type t = module Q = struct open Caqti_request.Infix + open Caqti_type let create_post_user_table = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.(tup4 string string float string) ->. Caqti_type.unit) + (tup4 string string float string ->. unit) "INSERT INTO report VALUES (?,?,?,?)" - let ignore_report = - (Caqti_type.string ->. Caqti_type.unit) "DELETE FROM report WHERE post_id=?" + let ignore_report = (string ->. unit) "DELETE FROM report WHERE post_id=?" let get_reports = - (Caqti_type.unit ->* Caqti_type.(tup4 string string float string)) - "SELECT * FROM report" + (unit ->* tup4 string string float string) "SELECT * FROM report" let upload_post_id = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO post_user VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO post_user VALUES (?,?)" let upload_thread_info = - (Caqti_type.(tup4 string string float float) ->. Caqti_type.unit) + (tup4 string string float float ->. unit) "INSERT INTO thread_info VALUES (?,?,?,?)" let upload_thread_post = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO thread_post VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO thread_post VALUES (?,?)" let upload_post_reply = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO post_replies VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO post_replies VALUES (?,?)" let upload_post_comment = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO post_comment VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO post_comment VALUES (?,?)" let upload_post_tag = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO post_tags VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO post_tags VALUES (?,?)" let upload_post_date = - (Caqti_type.(tup2 string float) ->. Caqti_type.unit) - "INSERT INTO post_date VALUES (?,?)" + (tup2 string float ->. unit) "INSERT INTO post_date VALUES (?,?)" let get_post_user_id = - (Caqti_type.string ->! Caqti_type.string) - "SELECT user_id FROM post_user WHERE post_id=?" + (string ->! string) "SELECT user_id FROM post_user WHERE post_id=?" let get_post_comment = - (Caqti_type.string ->! Caqti_type.string) - "SELECT comment FROM post_comment WHERE post_id=?" + (string ->! string) "SELECT comment FROM post_comment WHERE post_id=?" let get_post_tags = - (Caqti_type.string ->* Caqti_type.string) - "SELECT tag FROM post_tags WHERE post_id=?" + (string ->* string) "SELECT tag FROM post_tags WHERE post_id=?" let get_post_date = - (Caqti_type.string ->! Caqti_type.float) - "SELECT date FROM post_date WHERE post_id=?" + (string ->! float) "SELECT date FROM post_date WHERE post_id=?" let get_post_citations = - (Caqti_type.string ->* Caqti_type.string) - "SELECT post_id FROM post_citations WHERE post_id=?" + (string ->* string) "SELECT post_id FROM post_citations WHERE post_id=?" let get_post_replies = - (Caqti_type.string ->* Caqti_type.string) - "SELECT reply_id FROM post_replies WHERE post_id=?" + (string ->* string) "SELECT reply_id FROM post_replies WHERE post_id=?" let get_thread_posts = - (Caqti_type.string ->* Caqti_type.string) - "SELECT post_id FROM thread_post WHERE thread_id=?" + (string ->* string) "SELECT post_id FROM thread_post WHERE thread_id=?" let count_thread_posts = - (Caqti_type.string ->! Caqti_type.int) - "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?" + (string ->! int) "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?" let get_is_thread = - (Caqti_type.string ->! Caqti_type.string) + (string ->! string) "SELECT thread_id FROM thread_info WHERE thread_id=? LIMIT 1" let get_is_post = - (Caqti_type.string ->! Caqti_type.string) - "SELECT post_id FROM post_user WHERE post_id=? LIMIT 1" + (string ->! string) "SELECT post_id FROM post_user WHERE post_id=? LIMIT 1" let get_post_thread = - (Caqti_type.string ->! Caqti_type.string) + (string ->! string) "SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1" let get_thread_info = - (Caqti_type.string ->! Caqti_type.(tup3 string float float)) + (string ->! tup3 string float float) "SELECT subject,lat,lng FROM thread_info WHERE thread_id=?" - let get_threads = - (Caqti_type.unit ->* Caqti_type.string) "SELECT thread_id FROM thread_info" + let get_threads = (unit ->* string) "SELECT thread_id FROM thread_info" - let delete_post = - (Caqti_type.string ->. Caqti_type.unit) - "DELETE FROM post_user WHERE post_id=?" + let delete_post = (string ->. unit) "DELETE FROM post_user WHERE post_id=?" end let () = diff --git a/src/db.ml b/src/db.ml index 53cbdb7..a73df19 100644 --- a/src/db.ml +++ b/src/db.ml @@ -18,14 +18,14 @@ module Db = let () = let set_foreign_keys_on = - (Caqti_type.unit ->. Caqti_type.unit) "PRAGMA foreign_keys = ON" + Caqti_type.(unit ->. unit) "PRAGMA foreign_keys = ON" in if Result.is_error (Db.exec set_foreign_keys_on ()) then Dream.error (fun log -> log "can't set foreign_keys on") let () = let query = - (Caqti_type.unit ->. Caqti_type.unit) + Caqti_type.(unit ->. unit) "CREATE TABLE IF NOT EXISTS dream_session (id TEXT PRIMARY KEY, label \ TEXT NOT NULL, expires_at REAL NOT NULL, payload TEXT NOT NULL)" in diff --git a/src/discuss.ml b/src/discuss.ml index 23dcfe0..21cf414 100644 --- a/src/discuss.ml +++ b/src/discuss.ml @@ -1,5 +1,4 @@ open Db -open Caqti_request.Infix (** Creating the table of all messages. @@ -11,44 +10,51 @@ open Caqti_request.Infix - some text (msg) TODO: add date ? *) -let () = + +module Q = struct + open Caqti_request.Infix + open Caqti_type + let create_msg_table = - (Caqti_type.unit ->. Caqti_type.unit) + (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)" - in - match Db.exec create_msg_table () with + + let find_comrades = + (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=?)" + + let insert_msg = + (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") (** let's find who the user is talking to so we can know if they're dangerous *) -let find_comrades = - let find_comrades = - (Caqti_type.(tup2 string string) ->* Caqti_type.(tup2 string string)) - "SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?" +let find_comrades user_id = + let open Syntax in + let^ comrades = Db.collect_list 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 - fun user_id -> - let open Syntax in - let^ comrades = 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) + Ok (List.sort_uniq String.compare comrades) (** find all messages between two товарищи *) -let find_messages = - let find_messages = - ( 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 Syntax in - let^ comrades = Db.collect_list find_messages ((k1, k2), (k2, k1)) in - Ok comrades +let find_messages k1 k2 = + let open Syntax in + let^ comrades = Db.collect_list Q.find_messages ((k1, k2), (k2, k1)) in + Ok comrades (** display the list of discussions *) let render request = @@ -133,15 +139,10 @@ let render_one request = 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_type.(tup3 string string string) ->. Caqti_type.unit) - "INSERT INTO msg VALUES (NULL, ?, ?, ?)" - in - fun from_id to_id msg -> - let open Syntax in - let^ () = Db.exec insert_msg (from_id, to_id, msg) in - Ok () +let insert_msg from_id to_id msg = + let open Syntax in + let^ () = Db.exec Q.insert_msg (from_id, to_id, msg) in + Ok () (** handle posts *) let post request = diff --git a/src/image.ml b/src/image.ml index 802cd1a..9dd9d8b 100644 --- a/src/image.ml +++ b/src/image.ml @@ -10,81 +10,73 @@ type t = module Q = struct open Caqti_request.Infix + open Caqti_type let create_info_table = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.(tup3 string string string) ->. Caqti_type.unit) - "INSERT INTO image_info VALUES (?,?,?)" + (tup3 string string string ->. unit) "INSERT INTO image_info VALUES (?,?,?)" let upload_content = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO image_content VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO image_content VALUES (?,?)" let upload_thumbnail = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO image_thumbnail VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO image_thumbnail VALUES (?,?)" let get_post_content = - (Caqti_type.string ->? Caqti_type.string) - "SELECT content FROM image_content WHERE post_id=?" + (string ->? string) "SELECT content FROM image_content WHERE post_id=?" let get_post_thumbnail = - (Caqti_type.string ->? Caqti_type.string) - "SELECT content FROM image_thumbnail WHERE post_id=?" + (string ->? string) "SELECT content FROM image_thumbnail WHERE post_id=?" let get_post_info = - (Caqti_type.string ->? Caqti_type.(tup2 string string)) + (string ->? tup2 string string) "SELECT image_name,image_alt FROM image_info WHERE post_id=?" (*avatars*) let create_user_content_table = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO user_image_content VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO user_image_content VALUES (?,?)" let upload_user_thumbnail = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) + (tup2 string string ->. unit) "INSERT INTO user_image_thumbnail VALUES (?,?)" let get_user_content = - (Caqti_type.string ->? Caqti_type.string) - "SELECT content FROM user_image_content WHERE user_id=?" + (string ->? string) "SELECT content FROM user_image_content WHERE user_id=?" let get_user_thumbnail = - (Caqti_type.string ->? Caqti_type.string) + (string ->? string) "SELECT content FROM user_image_thumbnail WHERE user_id=?" let delete_user_content = - (Caqti_type.string ->. Caqti_type.unit) - "DELETE FROM user_image_content WHERE user_id=?" + (string ->. unit) "DELETE FROM user_image_content WHERE user_id=?" let delete_user_thumbnail = - (Caqti_type.string ->. Caqti_type.unit) - "DELETE FROM user_image_thumbnail WHERE user_id=?" + (string ->. unit) "DELETE FROM user_image_thumbnail WHERE user_id=?" end let () = diff --git a/src/user.ml b/src/user.ml index 678e91f..5cf56c8 100644 --- a/src/user.ml +++ b/src/user.ml @@ -12,101 +12,80 @@ type t = module Q = struct open Caqti_request.Infix + open Caqti_type let create_user_table = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.unit ->. Caqti_type.unit) + (unit ->. unit) "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)" let create_metadata_table = - (Caqti_type.unit ->. Caqti_type.unit) + (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 = - (Caqti_type.string ->! Caqti_type.string) - "SELECT metadata FROM user_metadata WHERE user_id=?" + (string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?" let upload_metadata = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO user_metadata VALUES (?, ?)" + (tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)" let delete_metadata = - (Caqti_type.string ->. Caqti_type.unit) - "DELETE FROM user_metadata WHERE user_id=?" + (string ->. unit) "DELETE FROM user_metadata WHERE user_id=?" let get_user_id_from_nick = - (Caqti_type.string ->! Caqti_type.string) - "SELECT user_id FROM user WHERE nick=?" + (string ->! string) "SELECT user_id FROM user WHERE nick=?" let get_user_id_from_email = - (Caqti_type.string ->! Caqti_type.string) - "SELECT user_id FROM user WHERE email=?" + (string ->! string) "SELECT user_id FROM user WHERE email=?" let get_password = - (Caqti_type.string ->! Caqti_type.string) - "SELECT password FROM user WHERE user_id=?" + (string ->! string) "SELECT password FROM user WHERE user_id=?" let is_already_user = - (Caqti_type.(tup2 string string) ->! Caqti_type.int) + (tup2 string string ->! int) "SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)" let upload_user = - ( Caqti_type.(tup4 string string string Caqti_type.(tup2 string string)) - ->. Caqti_type.unit ) + (tup4 string string string (tup2 string string) ->. unit) "INSERT INTO user VALUES (?, ?, ?, ?, ?)" - let list_nicks = - (Caqti_type.unit ->* Caqti_type.string) "SELECT nick FROM user" + let list_nicks = (unit ->* string) "SELECT nick FROM user" let get_user = (* there is no "tup6" *) - ( Caqti_type.string - ->! Caqti_type.(tup4 string string string Caqti_type.(tup2 string string)) - ) + (string ->! tup4 string string string (tup2 string string)) "SELECT * FROM user WHERE user_id=?" let update_bio = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "UPDATE user SET bio=? WHERE user_id=?" + (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?" let update_nick = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "UPDATE user SET nick=? WHERE user_id=?" + (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?" let update_email = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "UPDATE user SET email=? WHERE user_id=?" + (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?" let update_password = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "UPDATE user SET password=? WHERE user_id=?" + (tup2 string string ->. unit) "UPDATE user SET password=? WHERE user_id=?" - let get_nick = - (Caqti_type.string ->! Caqti_type.string) - "SELECT nick FROM user WHERE user_id=?" + let get_nick = (string ->! string) "SELECT nick FROM user WHERE user_id=?" - let get_bio = - (Caqti_type.string ->! Caqti_type.string) - "SELECT bio FROM user WHERE user_id=?" + let get_bio = (string ->! string) "SELECT bio FROM user WHERE user_id=?" - let get_email = - (Caqti_type.string ->! Caqti_type.string) - "SELECT email FROM user WHERE user_id=?" + let get_email = (string ->! string) "SELECT email FROM user WHERE user_id=?" - let delete_user = - (Caqti_type.string ->. Caqti_type.unit) "DELETE FROM user WHERE user_id=?" + let delete_user = (string ->. unit) "DELETE FROM user WHERE user_id=?" let upload_banished = - (Caqti_type.(tup2 string string) ->. Caqti_type.unit) - "INSERT INTO banished VALUES (?,?)" + (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)" let get_banished = - (Caqti_type.(tup2 string string) ->! Caqti_type.(tup2 string string)) + (tup2 string string ->! tup2 string string) "SELECT * FROM banished WHERE nick=? OR email=?" end