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

add user_id

Browse source
This commit is contained in:
Swrup 2022-03-08 21:20:01 +01:00
parent c2d4d03555
commit 53617f1077
6 changed files with 206 additions and 169 deletions
Download patch file Download diff file Expand all files Collapse all files

67
src/babillard.ml
View file

@ -11,8 +11,8 @@ type post =
{ id : string
; parent_id : string
; date : float
; user_id : string
; nick : string
; display_nick : string
; comment : string
; image_info : (string * string) option
; tags : string list
@ -27,9 +27,9 @@ type t =
module Q = struct
let create_post_user_table =
Caqti_request.exec Caqti_type.unit
"CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, nick TEXT, PRIMARY \
KEY(post_id), FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \
CASCADE);"
"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 =
@ -86,10 +86,10 @@ module Q = struct
let create_report_table =
Caqti_request.exec Caqti_type.unit
"CREATE TABLE IF NOT EXISTS report (nick TEXT, reason TEXT, date \
"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(nick) REFERENCES user(nick) ON DELETE \
CASCADE);"
ON DELETE CASCADE, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
DELETE CASCADE);"
let upload_report =
Caqti_request.exec
@ -149,9 +149,9 @@ module Q = struct
Caqti_type.(tup2 string float)
"INSERT INTO post_date VALUES (?,?);"
let get_post_nick =
let get_post_user_id =
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT nick FROM post_user WHERE post_id=?;"
"SELECT user_id FROM post_user WHERE post_id=?;"
let get_post_comment =
Caqti_request.find Caqti_type.string Caqti_type.string
@ -310,11 +310,12 @@ let upload_post ?image_content post =
| Op (thread_data, reply) -> (Some thread_data, reply)
| Post reply -> (None, reply)
in
let { id; parent_id; date; nick; comment; image_info; tags; citations; _ } =
let { id; parent_id; date; user_id; comment; image_info; tags; citations; _ }
=
reply
in
let^ () = Db.exec Q.upload_post_id (id, nick) 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
@ -342,7 +343,7 @@ let upload_post ?image_content post =
let^ () = Db.exec Q.upload_thread_info (id, subject, lat, lng) in
Ok id
let build_reply ~comment ?image ~tags ?parent_id nick =
let build_reply ~comment ?image ~tags ?parent_id user_id =
let comment = Dream.html_escape comment in
let tags = Dream.html_escape tags in
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
@ -370,13 +371,13 @@ let build_reply ~comment ?image ~tags ?parent_id nick =
in
let date = Unix.time () in
let comment, citations = parse_comment comment in
let* display_nick = User.get_display_nick nick in
let* nick = User.get_nick user_id in
let reply =
{ id
; parent_id
; date
; user_id
; nick
; display_nick
; comment
; image_info
; tags = tag_list
@ -386,7 +387,7 @@ let build_reply ~comment ?image ~tags ?parent_id nick =
in
Ok reply
let build_op ~comment ?image ~tags ~subject ~lat ~lng nick =
let build_op ~comment ?image ~tags ~subject ~lat ~lng user_id =
let subject = Dream.html_escape subject in
(* TODO latlng validation? *)
let is_valid_latlng = true in
@ -396,21 +397,21 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng nick =
let thread_data = { subject; lng; lat } in
let* reply =
match image with
| Some image -> build_reply ~comment ~image ~tags nick
| None -> build_reply ~comment ~tags nick
| Some image -> build_reply ~comment ~image ~tags user_id
| None -> build_reply ~comment ~tags user_id
in
let op = Op (thread_data, reply) in
Ok op
let make_reply ~comment ?image ~tags ~parent_id nick =
let* reply = build_reply ~comment ?image ~tags ~parent_id nick in
let make_reply ~comment ?image ~tags ~parent_id user_id =
let* reply = build_reply ~comment ?image ~tags ~parent_id user_id in
let post = Post reply in
match image with
| None -> upload_post post
| Some (_image_info, image_content) -> upload_post ~image_content post
let make_op ~comment ?image ~tags ~subject ~lat ~lng nick =
let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng nick in
let make_op ~comment ?image ~tags ~subject ~lat ~lng user_id =
let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng user_id in
match image with
| None -> upload_post op
| Some (_image_info, image_content) -> upload_post ~image_content op
@ -426,8 +427,8 @@ let post_exist id = Result.is_ok (Db.find Q.get_is_post id)
let get_post id =
let^ parent_id = Db.find Q.get_post_thread id in
let^ nick = Db.find Q.get_post_nick id in
let* display_nick = User.get_display_nick nick in
let^ user_id = Db.find 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^ image_info = Db.find_opt Q.get_post_image_info id in
@ -439,8 +440,8 @@ let get_post id =
{ id
; parent_id
; date
; user_id
; nick
; display_nick
; comment
; image_info
; tags
@ -466,20 +467,20 @@ let get_posts ids = unwrap_list get_post ids
let get_ops ids = unwrap_list get_op ids
let try_delete_post ~nick id =
let try_delete_post ~user_id id =
let* post = get_post id in
if post.nick = nick || User.is_admin nick then
if post.user_id = user_id || User.is_admin user_id then
let^ () = Db.exec Q.delete_post id in
Ok ()
else Error "You can only delete your posts"
let report ~nick ~reason id =
let report ~user_id ~reason id =
if not (post_exist id) then Error "This post exists not"
else if String.length reason > 2000 then Error "Your reason is too long.."
else
let reason = Dream.html_escape reason in
let date = Unix.time () in
let^ () = Db.exec Q.upload_report (nick, reason, date, id) in
let^ () = Db.exec Q.upload_report (user_id, reason, date, id) in
Ok ()
let ignore_report id =
@ -489,6 +490,14 @@ let ignore_report id =
let get_reports () =
let^ reports = Db.collect_list Q.get_reports () in
let* posts =
unwrap_list (fun (_nick, _reason, _date, id) -> get_post id) reports
unwrap_list (fun (_reporter_id, _reason, _date, id) -> get_post id) reports
in
(* add reporter_nick to reports so we can display it *)
let* reports =
unwrap_list
(fun (reporter_id, reason, date, id) ->
let* reporter_nick = User.get_nick reporter_id in
Ok (reporter_id, reporter_nick, reason, date, id) )
reports
in
Ok (posts, reports)

6
src/login.eml.html
View file

@ -8,9 +8,9 @@ let f request =
% in
<%s! Dream.form_tag ~action:url request %>
<div class="mb-3">
<label for="nick" class="form-label">Nick</label>
<input name="nick" type="text" class="form-control" id="nick" aria-describedby="nick-help">
<div id="nick-help" class="form-text">What is you nickname?</div>
<label for="login" class="form-label">Nick</label>
<input name="login" type="text" class="form-control" id="login" aria-describedby="login-help">
<div id="login-help" class="form-text">What is you nickname or email?</div>
</div>
<div class="mb-3">
<label for="password" class="form-label">Password</label>

102
src/permap.ml
View file

@ -56,8 +56,8 @@ let login_get request = render_unsafe (Login.f request) request
let login_post request =
match%lwt Dream.form request with
| `Ok [ ("nick", nick); ("password", password) ] -> (
match User.login ~nick ~password request with
| `Ok [ ("login", login); ("password", password) ] -> (
match User.login ~login ~password request with
| Error e -> render_unsafe e request
| Ok () ->
let url =
@ -73,14 +73,14 @@ let login_post request =
Dream.empty `Bad_Request
let admin_get request =
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None ->
let redirect_url =
Format.sprintf "/login?redirect=%s" (Dream.to_percent_encoded "/admin")
in
Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
| Some nick ->
if not (User.is_admin nick) then Dream.respond ~status:`Forbidden ""
| Some user_id ->
if not (User.is_admin user_id) then Dream.respond ~status:`Forbidden ""
else
let res =
match Babillard.get_reports () with
@ -91,10 +91,10 @@ let admin_get request =
render_unsafe res request
let admin_post request =
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in "/admin" request
| Some nick -> (
if not (User.is_admin nick) then Dream.respond ~status:`Forbidden ""
| Some user_id -> (
if not (User.is_admin user_id) then Dream.respond ~status:`Forbidden ""
else
match%lwt Dream.form request with
| `Ok [ ("action", action); ("post_id", id) ] -> (
@ -102,10 +102,10 @@ let admin_post request =
match Babillard.get_post id with
| Error _e as e -> e
| Ok post -> (
let evil_nick = post.nick in
let evil_user_id = post.user_id in
match action with
| "delete" -> Babillard.try_delete_post ~nick id
| "banish" -> User.banish evil_nick
| "delete" -> Babillard.try_delete_post ~user_id:evil_user_id id
| "banish" -> User.banish evil_user_id
| "ignore" -> Babillard.ignore_report id
| a -> Error (Format.sprintf "invalid action: `%s`" a) )
in
@ -134,13 +134,13 @@ let delete_get request =
let delete_post request =
let post_id = Dream.param request "post_id" in
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in (Format.sprintf "/delete/%s" post_id) request
| Some nick -> (
| Some user_id -> (
(* match on Dream.form needed for hidden csrf field *)
match%lwt Dream.form request with
| `Ok [] -> (
match Babillard.try_delete_post ~nick post_id with
match Babillard.try_delete_post ~user_id post_id with
| Error e -> render_unsafe e request
| Ok () ->
Dream.respond ~status:`See_Other
@ -159,13 +159,13 @@ let report_get request =
let report_post request =
let post_id = Dream.param request "post_id" in
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in (Format.sprintf "/report/%s" post_id) request
| Some nick -> (
| Some user_id -> (
match%lwt Dream.form request with
| `Ok [ ("reason", reason) ] ->
let res =
match Babillard.report ~nick ~reason post_id with
match Babillard.report ~user_id ~reason post_id with
| Error e -> e
| Ok () -> "The post was reported!"
in
@ -179,11 +179,12 @@ let user request =
let user_profile request =
let nick = Dream.param request "user" in
if User.exist nick then
match User.get_user_id_from_nick nick with
| Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
| Ok user_id ->
render_unsafe
(Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile nick))
(Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile user_id))
request
else Dream.respond ~status:`Not_Found "User does not exists"
let logout request =
let _ = Dream.invalidate_session request in
@ -191,11 +192,11 @@ let logout request =
render_unsafe content request
let account_get request =
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in "/account" request
| Some nick ->
| Some user_id ->
let res =
match User.get_user nick with
match User.get_user user_id with
| Error e -> e
| Ok user -> User_account.f user request
in
@ -203,23 +204,23 @@ let account_get request =
(*TODO ask for password *)
let account_post request =
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in "/account" request
| Some nick -> (
| Some user_id -> (
match%lwt Dream.form request with
| `Ok [ ("delete", _) ] ->
(*TODO ask for confirmation *)
let res =
Result.fold ~error:Fun.id
~ok:(fun _ -> "Your account was deleted")
(User.delete_user nick)
(User.delete_user user_id)
in
render_unsafe res request
| `Ok [ ("email", email) ] ->
let res =
Result.fold ~error:Fun.id
~ok:(fun _ -> "Your email was updated!")
(User.update_email email nick)
(User.update_email email user_id)
in
render_unsafe res request
| `Ok
@ -230,7 +231,7 @@ let account_post request =
if password = confirm_password then
Result.fold ~error:Fun.id
~ok:(fun _ -> "Your password was updated!")
(User.update_password password nick)
(User.update_password password user_id)
else "Password confimation does not match"
in
render_unsafe res request
@ -239,30 +240,30 @@ let account_post request =
Dream.empty `Bad_Request )
let profile_get request =
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in "/profile" request
| Some nick ->
| Some user_id ->
let res =
match User.get_user nick with
match User.get_user user_id with
| Error e -> e
| Ok user -> User_profile.f user request
in
render_unsafe res request
let profile_post request =
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in "/profile" request
| Some nick -> (
| Some user_id -> (
match%lwt Dream.form request with
| `Ok [ ("bio", bio) ] -> (
match User.update_bio bio nick with
match User.update_bio bio user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your bio was updated!"
| Error e -> render_unsafe e request )
| `Ok [ ("display-nick", display_nick) ] -> (
match User.update_display_nick display_nick nick with
| `Ok [ ("nick", nick) ] -> (
match User.update_nick nick user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
@ -272,7 +273,7 @@ let profile_post request =
match int_of_string_opt count with
| None -> render_unsafe "Error: invalid count" request
| Some count -> (
match User.update_metadata count label content nick with
match User.update_metadata count label content user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
@ -282,7 +283,7 @@ let profile_post request =
| `Wrong_session _ | `Expired _ | `Wrong_content_type -> (
match%lwt Dream.multipart request with
| `Ok [ ("file", file) ] -> (
match User.upload_avatar file nick with
match User.upload_avatar file user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
@ -294,8 +295,10 @@ let profile_post request =
let avatar_image request =
let nick = Dream.param request "user" in
if User.exist nick then
let avatar = User.get_avatar nick in
match User.get_user_id_from_nick nick with
| Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
| Ok user_id -> (
let avatar = User.get_avatar user_id in
match avatar with
| Ok (Some avatar) ->
Dream.respond ~headers:[ ("Content-Type", "image") ] avatar
@ -303,8 +306,7 @@ let avatar_image request =
match Content.read "/assets/img/default_avatar.png" with
| None -> failwith "can't find default avatar"
| Some avatar ->
Dream.respond ~headers:[ ("Content-Type", "image") ] avatar )
else Dream.respond ~status:`Not_Found "User does not exists"
Dream.respond ~headers:[ ("Content-Type", "image") ] avatar ) )
let post_image request =
let post_id = Dream.param request "post_id" in
@ -325,9 +327,9 @@ let markers request =
let babillard_get request = render_unsafe (Babillard_page.f request) request
let babillard_post request =
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in "/" request
| Some nick -> (
| Some user_id -> (
match%lwt Dream.multipart request with
| `Ok
[ ("alt", [ (_, alt) ])
@ -344,11 +346,11 @@ let babillard_post request =
| Some lat, Some lng -> (
let res =
match file with
| [] -> Babillard.make_op ~comment ~lat ~lng ~subject ~tags nick
| [] -> Babillard.make_op ~comment ~lat ~lng ~subject ~tags user_id
| _ :: _ :: _ -> Error "More than one image"
| [ (image_name, image_content) ] ->
let image = ((image_name, alt), image_content) in
Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags nick
Babillard.make_op ~comment ~image ~lat ~lng ~subject ~tags user_id
in
match res with
| Ok thread_id ->
@ -386,9 +388,9 @@ let thread_get request =
(*form to reply to a thread *)
let reply_post request =
let parent_id = Dream.param request "thread_id" in
match Dream.session "nick" request with
match Dream.session "user_id" request with
| None -> not_logged_in (Format.sprintf "/thread/%s" parent_id) request
| Some nick -> (
| Some user_id -> (
match%lwt Dream.multipart request with
| `Ok
[ ("alt", [ (_, alt) ])
@ -398,10 +400,10 @@ let reply_post request =
] -> (
let res =
match file with
| [] -> Babillard.make_reply ~comment ~tags ~parent_id nick
| [] -> Babillard.make_reply ~comment ~tags ~parent_id user_id
| [ (image_name, image_content) ] ->
let image = ((image_name, alt), image_content) in
Babillard.make_reply ~comment ~image ~tags ~parent_id nick
Babillard.make_reply ~comment ~image ~tags ~parent_id user_id
| _ :: _ :: _ -> Error "More than one image"
in
match res with

11
src/pp_babillard.ml
View file

@ -11,8 +11,8 @@ let pp_post fmt t =
let { id
; parent_id = _parent_id
; date
; user_id
; nick
; display_nick
; comment
; image_info
; tags
@ -80,7 +80,7 @@ let pp_post fmt t =
Format.fprintf fmt
{|
<div class="post-info">
<span class="display-nick" data-nick="%s">%s</span>
<span class="nick" data-user-id="%s">%s</span>
<span class="date" data-time="%f"></span>
<div class="dropend post-menu-div">
<a class="dropdown-toggle post-menu-link" href="#" role="button" id="dropdownMenuLink" data-bs-toggle="dropdown" aria-expanded="false">
@ -93,7 +93,7 @@ let pp_post fmt t =
</div>
%a
</div>|}
nick display_nick date id id id post_links_view ()
user_id nick date id id id post_links_view ()
in
let pp_print_tag fmt tag =
@ -162,7 +162,7 @@ let catalog_content () =
let pp_report fmt post report request =
let url = "/admin" in
let nick, reason, _date, id = report in
let _reporter_id, reporter_nick, reason, _date, id = report in
let input_post_id fmt id =
Format.fprintf fmt
{|<input value="%s" name="post_id" type="hidden"></input>|} id
@ -200,7 +200,8 @@ let pp_report fmt post report request =
</div>
</div><br>
|}
pp_post (Post post) nick reason form "ignore" form "delete" form "banish"
pp_post (Post post) reporter_nick reason form "ignore" form "delete" form
"banish"
let admin_page_content posts reports request =
let posts_reports = List.combine posts reports in

185
src/user.ml
View file

@ -2,8 +2,8 @@ include Bindings
open Db
type t =
{ nick : string
; display_nick : string
{ user_id : string
; nick : string
; password : string
; email : string
; bio : string
@ -14,8 +14,8 @@ type t =
module Q = struct
let create_user_table =
Caqti_request.exec Caqti_type.unit
"CREATE TABLE IF NOT EXISTS user (nick TEXT, display_nick TEXT, password \
TEXT, email TEXT, bio TEXT, avatar BLOB, PRIMARY KEY(nick));"
"CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
TEXT, email TEXT, bio TEXT, avatar BLOB, PRIMARY KEY(user_id));"
let create_banished_table =
Caqti_request.exec Caqti_type.unit
@ -23,14 +23,14 @@ module Q = struct
let create_metadata_table =
Caqti_request.exec Caqti_type.unit
"CREATE TABLE IF NOT EXISTS metadata (nick TEXT, count INT, label TEXT, \
content TEXT, FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \
CASCADE);"
"CREATE TABLE IF NOT EXISTS metadata (user_id TEXT, count INT, label \
TEXT, content TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
DELETE CASCADE);"
let get_metadata =
Caqti_request.collect Caqti_type.string
Caqti_type.(tup3 int string string)
"SELECT count, label, content FROM metadata WHERE nick=?;"
"SELECT count, label, content FROM metadata WHERE user_id=?;"
let upload_metadata =
Caqti_request.exec
@ -40,14 +40,23 @@ module Q = struct
let delete_metadata =
Caqti_request.exec
Caqti_type.(tup2 string int)
"DELETE FROM metadata WHERE nick=? AND count=?;"
"DELETE FROM metadata WHERE user_id=? AND count=?;"
let get_user_id_from_nick =
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT user_id FROM user WHERE nick=?;"
let get_user_id_from_login =
Caqti_request.find
Caqti_type.(tup2 string string)
Caqti_type.string "SELECT user_id FROM user WHERE nick=? OR email=?;"
let get_password =
Caqti_request.find_opt Caqti_type.string Caqti_type.string
"SELECT password FROM user WHERE nick=?;"
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT password FROM user WHERE user_id=?;"
let is_already_user =
Caqti_request.find_opt
Caqti_request.find
Caqti_type.(tup2 string string)
Caqti_type.int
"SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?);"
@ -67,51 +76,51 @@ module Q = struct
(* there is no "tup6" *)
Caqti_type.(
tup4 string string string Caqti_type.(tup3 string string string))
"SELECT * FROM user WHERE nick=?;"
"SELECT * FROM user WHERE user_id=?;"
let update_bio =
Caqti_request.exec
Caqti_type.(tup2 string string)
"UPDATE user SET bio=? WHERE nick=?;"
"UPDATE user SET bio=? WHERE user_id=?;"
let update_display_nick =
let update_nick =
Caqti_request.exec
Caqti_type.(tup2 string string)
"UPDATE user SET display_nick=? WHERE nick=?;"
"UPDATE user SET nick=? WHERE user_id=?;"
let update_email =
Caqti_request.exec
Caqti_type.(tup2 string string)
"UPDATE user SET email=? WHERE nick=?;"
"UPDATE user SET email=? WHERE user_id=?;"
let update_password =
Caqti_request.exec
Caqti_type.(tup2 string string)
"UPDATE user SET password=? WHERE nick=?;"
"UPDATE user SET password=? WHERE user_id=?;"
let get_display_nick =
let get_nick =
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT display_nick FROM user WHERE nick=?;"
"SELECT nick FROM user WHERE user_id=?;"
let get_bio =
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT bio FROM user WHERE nick=?;"
"SELECT bio FROM user WHERE user_id=?;"
let get_email =
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT email FROM user WHERE nick=?;"
"SELECT email FROM user WHERE user_id=?;"
let get_avatar =
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT avatar FROM user WHERE nick=?;"
"SELECT avatar FROM user WHERE user_id=?;"
let upload_avatar =
Caqti_request.exec
Caqti_type.(tup2 string string)
"UPDATE user SET avatar=? WHERE nick=?;"
"UPDATE user SET avatar=? WHERE user_id=?;"
let delete_user =
Caqti_request.exec Caqti_type.string "DELETE FROM user WHERE nick=?;"
Caqti_request.exec Caqti_type.string "DELETE FROM user WHERE user_id=?;"
let upload_banished =
Caqti_request.exec
@ -119,9 +128,10 @@ module Q = struct
"INSERT INTO banished VALUES (?,?);"
let get_banished =
Caqti_request.find Caqti_type.string
Caqti_request.find
Caqti_type.(tup2 string string)
"SELECT * FROM banished WHERE nick=?;"
Caqti_type.(tup2 string string)
"SELECT * FROM banished WHERE nick=? OR email=?;"
end
let () =
@ -133,32 +143,44 @@ let () =
(Array.map (fun query -> Db.exec query ()) tables)
then Dream.error (fun log -> log "can't create user tables")
let exist nick = Result.is_ok (Db.find Q.get_user nick)
let exist_nick nick = Result.is_ok (Db.find Q.get_user nick)
let get_metadata nick =
let^ metadata = Db.collect_list Q.get_metadata nick in
let metadata = List.sort (fun (a, _, _) (b, _, _) -> compare a b) metadata in
Ok metadata
let get_user nick =
let^? nick, display_nick, password, (email, bio, avatar) =
Db.find_opt Q.get_user nick
let get_user_id_from_nick nick =
let^ user_id = Db.find Q.get_user_id_from_nick nick in
Ok user_id
let get_user user_id =
let^? user_id, nick, password, (email, bio, avatar) =
Db.find_opt Q.get_user user_id
in
let* metadata = get_metadata nick in
Ok { nick; display_nick; password; email; bio; avatar; metadata }
let* metadata = get_metadata user_id in
Ok { user_id; nick; password; email; bio; avatar; metadata }
let is_banished nick = Result.is_ok (Db.find Q.get_banished nick)
let is_banished login = Result.is_ok (Db.find Q.get_banished (login, login))
let login ~nick ~password request =
if exist nick then
let^? good_password = Db.find_opt Q.get_password nick 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 "nick" nick request in
Ok ()
else Error "wrong password"
else if is_banished nick then Error "YOU ARE BANISHED"
else Error "wrong user name"
let get_nick user_id =
let^ nick = Db.find Q.get_nick user_id in
Ok nick
let login ~login ~password request =
if is_banished login then Error "YOU ARE BANISHED"
else
match Db.find Q.get_user_id_from_login (login, login) with
| Error _e -> Error "wrong login"
| Ok user_id ->
let^ good_password = Db.find 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
let* nick = get_nick user_id in
let _unit_lwt = Dream.put_session "nick" nick request in
Ok ()
else Error "wrong password"
let valid_nick nick =
String.length nick < 64
@ -179,9 +201,12 @@ let register ~email ~nick ~password =
if not valid then Error "Something is wrong"
else
let^? nb = Db.find_opt Q.is_already_user (nick, email) in
let^ nb = Db.find Q.is_already_user (nick, email) in
if nb = 0 then
let^ () = Db.exec Q.upload_user (nick, nick, password, (email, "", "")) in
let user_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
let^ () =
Db.exec Q.upload_user (user_id, nick, password, (email, "", ""))
in
Ok ()
else Error "nick or email already exists"
@ -199,83 +224,83 @@ let profile request =
| None -> "not logged in"
| Some nick -> Format.sprintf "Hello %s !" nick
let update_bio bio nick =
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, nick) in
let^ () = Db.exec Q.update_bio (bio, user_id) in
Ok ()
let get_bio nick =
let^? bio = Db.find_opt Q.get_bio nick in
let get_bio user_id =
let^ bio = Db.find Q.get_bio user_id in
Ok bio
let get_email nick =
let^? email = Db.find_opt Q.get_email nick in
let get_email user_id =
let^ email = Db.find Q.get_email user_id in
Ok email
let get_display_nick nick =
let^? display_nick = Db.find_opt Q.get_display_nick nick in
Ok display_nick
let get_avatar nick =
let^? avatar = Db.find_opt Q.get_avatar nick in
let get_avatar user_id =
let^ avatar = Db.find Q.get_avatar user_id in
if String.length avatar = 0 then Ok None else Ok (Some avatar)
let upload_avatar files nick =
let upload_avatar files user_id =
match files with
| [] -> Error "No file provided"
| [ (_, content) ] ->
if not (is_valid_image content) then Error "Invalid image"
else
let^ () = Db.exec Q.upload_avatar (content, nick) in
let^ () = Db.exec Q.upload_avatar (content, user_id) in
Ok ()
| _files -> Error "More than one file provided"
let is_admin nick = List.mem nick App.admins
let is_admin user_id =
match get_nick user_id with
| Error _e -> false
| Ok nick -> List.mem nick App.admins
let banish nick =
let* email = get_email nick in
let^ () = Db.exec Q.delete_user nick in
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 delete_user nick =
let^ () = Db.exec Q.delete_user nick in
let delete_user user_id =
let^ () = Db.exec Q.delete_user user_id in
Ok ()
let update_display_nick display_nick nick =
if valid_nick display_nick then
let^ () = Db.exec Q.update_display_nick (display_nick, nick) in
let update_nick nick user_id =
if valid_nick nick then
let^ () = Db.exec Q.update_nick (nick, user_id) in
Ok ()
else Error "invalid display nick"
let update_email email nick =
let update_email email user_id =
if valid_email email then
let^ () = Db.exec Q.update_email (email, nick) in
let^ () = Db.exec Q.update_email (email, user_id) in
Ok ()
else Error "invalid email"
let update_password password nick =
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, nick) in
let^ () = Db.exec Q.update_password (password, user_id) in
Ok ()
else Error "invalid password"
let update_metadata count label content nick =
let update_metadata count label content user_id =
let label = Dream.html_escape label in
let content = Dream.html_escape content in
if String.length label > 200 || String.length content > 400 then
Error "label or content is too long"
else
(* rewrite all user's metadata *)
let* metadata = get_metadata nick in
let* metadata = get_metadata user_id in
let^ _unit_list =
unwrap_list
(fun (count, _l, _c) -> Db.exec Q.delete_metadata (nick, count))
(fun (count, _l, _c) -> Db.exec Q.delete_metadata (user_id, count))
metadata
in
let l = List.filter (fun (i, _, _) -> i <> count) metadata in
@ -288,7 +313,7 @@ let update_metadata count label content nick =
let^ _unit_list =
unwrap_list
(fun (i, label, content) ->
Db.exec Q.upload_metadata (nick, i, label, content) )
Db.exec Q.upload_metadata (user_id, i, label, content) )
l
in
Ok ()
@ -346,8 +371,8 @@ let pp_metadata_table_form fmt metadata request =
pp_metadata_form fmt metadata request ) )
metadata new_metadata_field ()
let public_profile nick =
let* user = get_user nick in
let public_profile user_id =
let* user = get_user user_id in
let user_info =
Format.asprintf
{|
@ -365,6 +390,6 @@ let public_profile nick =
</div>
</div>
|}
user.display_nick user.bio user.nick pp_metadata_table user.metadata
user.nick user.bio user.nick pp_metadata_table user.metadata
in
Ok user_info

4
src/user_profile.eml.html
View file

@ -5,8 +5,8 @@ let f (user: User.t) request =
<h2>Display nickname</h2>
<%s! Dream.form_tag ~action:"/profile" request %>
<div class="mb-3">
<label for="display-nick" class="form-label">Change display name</label>
<input name="display-nick" type="text" class="form-control" id="display-nick" value="<%s! user.display_nick %>"></input>
<label for="nick" class="form-label">Change display name</label>
<input name="nick" type="text" class="form-control" id="nick" value="<%s! user.nick %>"></input>
</div>
<button type="submit" class="btn btn-primary">Save</button>
</form>