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 { id : string
; parent_id : string ; parent_id : string
; date : float ; date : float
; user_id : string
; nick : string ; nick : string
; display_nick : string
; comment : string ; comment : string
; image_info : (string * string) option ; image_info : (string * string) option
; tags : string list ; tags : string list
@ -27,9 +27,9 @@ type t =
module Q = struct module Q = struct
let create_post_user_table = let create_post_user_table =
Caqti_request.exec Caqti_type.unit Caqti_request.exec Caqti_type.unit
"CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, nick TEXT, PRIMARY \ "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, user_id TEXT, \
KEY(post_id), FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \ PRIMARY KEY(post_id), FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
CASCADE);" DELETE CASCADE);"
(* one row for each thread, with thread's data *) (* one row for each thread, with thread's data *)
let create_thread_info_table = let create_thread_info_table =
@ -86,10 +86,10 @@ module Q = struct
let create_report_table = let create_report_table =
Caqti_request.exec Caqti_type.unit 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) \ FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) \
ON DELETE CASCADE, FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \ ON DELETE CASCADE, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
CASCADE);" DELETE CASCADE);"
let upload_report = let upload_report =
Caqti_request.exec Caqti_request.exec
@ -149,9 +149,9 @@ module Q = struct
Caqti_type.(tup2 string float) Caqti_type.(tup2 string float)
"INSERT INTO post_date VALUES (?,?);" "INSERT INTO post_date VALUES (?,?);"
let get_post_nick = let get_post_user_id =
Caqti_request.find Caqti_type.string Caqti_type.string 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 = let get_post_comment =
Caqti_request.find Caqti_type.string Caqti_type.string 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) | Op (thread_data, reply) -> (Some thread_data, reply)
| Post reply -> (None, reply) | Post reply -> (None, reply)
in 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 reply
in 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_comment (id, comment) in
let^ () = Db.exec Q.upload_post_date (id, date) in let^ () = Db.exec Q.upload_post_date (id, date) in
let^ () = Db.exec Q.upload_thread_post (parent_id, id) 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 let^ () = Db.exec Q.upload_thread_info (id, subject, lat, lng) in
Ok id 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 comment = Dream.html_escape comment in
let tags = Dream.html_escape tags in let tags = Dream.html_escape tags in
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) 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 in
let date = Unix.time () in let date = Unix.time () in
let comment, citations = parse_comment comment 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 = let reply =
{ id { id
; parent_id ; parent_id
; date ; date
; user_id
; nick ; nick
; display_nick
; comment ; comment
; image_info ; image_info
; tags = tag_list ; tags = tag_list
@ -386,7 +387,7 @@ let build_reply ~comment ?image ~tags ?parent_id nick =
in in
Ok reply 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 let subject = Dream.html_escape subject in
(* TODO latlng validation? *) (* TODO latlng validation? *)
let is_valid_latlng = true in 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 thread_data = { subject; lng; lat } in
let* reply = let* reply =
match image with match image with
| Some image -> build_reply ~comment ~image ~tags nick | Some image -> build_reply ~comment ~image ~tags user_id
| None -> build_reply ~comment ~tags nick | None -> build_reply ~comment ~tags user_id
in in
let op = Op (thread_data, reply) in let op = Op (thread_data, reply) in
Ok op Ok op
let make_reply ~comment ?image ~tags ~parent_id nick = let make_reply ~comment ?image ~tags ~parent_id user_id =
let* reply = build_reply ~comment ?image ~tags ~parent_id nick in let* reply = build_reply ~comment ?image ~tags ~parent_id user_id in
let post = Post reply in let post = Post reply in
match image with match image with
| None -> upload_post post | None -> upload_post post
| Some (_image_info, image_content) -> upload_post ~image_content post | Some (_image_info, image_content) -> upload_post ~image_content post
let make_op ~comment ?image ~tags ~subject ~lat ~lng nick = let make_op ~comment ?image ~tags ~subject ~lat ~lng user_id =
let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng nick in let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng user_id in
match image with match image with
| None -> upload_post op | None -> upload_post op
| Some (_image_info, image_content) -> upload_post ~image_content 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 get_post id =
let^ parent_id = Db.find Q.get_post_thread id in let^ parent_id = Db.find Q.get_post_thread id in
let^ nick = Db.find Q.get_post_nick id in let^ user_id = Db.find Q.get_post_user_id id in
let* display_nick = User.get_display_nick nick in let* nick = User.get_nick user_id in
let^ comment = Db.find Q.get_post_comment id in let^ comment = Db.find Q.get_post_comment id in
let^ date = Db.find Q.get_post_date 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 let^ image_info = Db.find_opt Q.get_post_image_info id in
@ -439,8 +440,8 @@ let get_post id =
{ id { id
; parent_id ; parent_id
; date ; date
; user_id
; nick ; nick
; display_nick
; comment ; comment
; image_info ; image_info
; tags ; tags
@ -466,20 +467,20 @@ let get_posts ids = unwrap_list get_post ids
let get_ops ids = unwrap_list get_op 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 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 let^ () = Db.exec Q.delete_post id in
Ok () Ok ()
else Error "You can only delete your posts" 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" 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 if String.length reason > 2000 then Error "Your reason is too long.."
else else
let reason = Dream.html_escape reason in let reason = Dream.html_escape reason in
let date = Unix.time () in let date = Unix.time () in
let^ () = Db.exec Q.upload_report (nick, reason, date, id) in let^ () = Db.exec Q.upload_report (user_id, reason, date, id) in
Ok () Ok ()
let ignore_report id = let ignore_report id =
@ -489,6 +490,14 @@ let ignore_report id =
let get_reports () = let get_reports () =
let^ reports = Db.collect_list Q.get_reports () in let^ reports = Db.collect_list Q.get_reports () in
let* posts = 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 in
Ok (posts, reports) Ok (posts, reports)

6
src/login.eml.html
View file

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

11
src/pp_babillard.ml
View file

@ -11,8 +11,8 @@ let pp_post fmt t =
let { id let { id
; parent_id = _parent_id ; parent_id = _parent_id
; date ; date
; user_id
; nick ; nick
; display_nick
; comment ; comment
; image_info ; image_info
; tags ; tags
@ -80,7 +80,7 @@ let pp_post fmt t =
Format.fprintf fmt Format.fprintf fmt
{| {|
<div class="post-info"> <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> <span class="date" data-time="%f"></span>
<div class="dropend post-menu-div"> <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"> <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> </div>
%a %a
</div>|} </div>|}
nick display_nick date id id id post_links_view () user_id nick date id id id post_links_view ()
in in
let pp_print_tag fmt tag = let pp_print_tag fmt tag =
@ -162,7 +162,7 @@ let catalog_content () =
let pp_report fmt post report request = let pp_report fmt post report request =
let url = "/admin" in 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 = let input_post_id fmt id =
Format.fprintf fmt Format.fprintf fmt
{|<input value="%s" name="post_id" type="hidden"></input>|} id {|<input value="%s" name="post_id" type="hidden"></input>|} id
@ -200,7 +200,8 @@ let pp_report fmt post report request =
</div> </div>
</div><br> </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 admin_page_content posts reports request =
let posts_reports = List.combine posts reports in let posts_reports = List.combine posts reports in

175
src/user.ml
View file

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