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

357
src/babillard.ml
View file

@ -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 <span class="quote">
@ -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

12
src/db.ml
View file

@ -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

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

45
src/discuss.ml
View file

@ -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 =

187
src/image.ml
View file

@ -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

34
src/permap.ml
View file

@ -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 =

11
src/pp_babillard.ml
View file

@ -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 =

10
src/syntax.ml
View file

@ -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

273
src/user.ml
View file

@ -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 "<ul>%a</ul>"
(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