diff --git a/src/dune b/src/dune index 1f15753..c62730e 100644 --- a/src/dune +++ b/src/dune @@ -17,6 +17,7 @@ template thread_page user + user_account user_profile) (libraries bos @@ -85,6 +86,12 @@ (action (run dream_eml %{deps} --workspace %{workspace_root}))) +(rule + (targets user_account.ml) + (deps user_account.eml.html) + (action + (run dream_eml %{deps} --workspace %{workspace_root}))) + (rule (targets user_profile.ml) (deps user_profile.eml.html) diff --git a/src/permap.ml b/src/permap.ml index 8b98fb2..f1fb6b9 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -20,6 +20,14 @@ let render_unsafe ?title content request = in Dream.html @@ Template.render_unsafe ~title ~content request +let not_logged_in redirect request = + let content = + Format.sprintf + {|Not logged in, please login to access this page|} + (Dream.to_percent_encoded redirect) + in + render_unsafe content request + let asset_loader _root path _request = match Content.read ("assets/" ^ path) with | None -> Dream.empty `Not_Found @@ -84,7 +92,7 @@ let admin_get request = let admin_post request = match Dream.session "nick" request with - | None -> render_unsafe "Not logged in" request + | None -> not_logged_in "/admin" request | Some nick -> ( if not (User.is_admin nick) then Dream.respond ~status:`Forbidden "" else @@ -127,7 +135,7 @@ let delete_get request = let delete_post request = let post_id = Dream.param request "post_id" in match Dream.session "nick" request with - | None -> render_unsafe "Not logged in" request + | None -> not_logged_in (Format.sprintf "/delete/%s" post_id) request | Some nick -> ( (* match on Dream.form needed for hidden csrf field *) match%lwt Dream.form request with @@ -152,7 +160,7 @@ let report_get request = let report_post request = let post_id = Dream.param request "post_id" in match Dream.session "nick" request with - | None -> render_unsafe "Not logged in" request + | None -> not_logged_in (Format.sprintf "/report/%s" post_id) request | Some nick -> ( match%lwt Dream.form request with | `Ok [ ("reason", reason) ] -> @@ -182,9 +190,57 @@ let logout request = let content = "Logged out !" in render_unsafe content request +let account_get request = + match Dream.session "nick" request with + | None -> not_logged_in "/account" request + | Some nick -> + let res = + match User.get_user nick with + | Error e -> e + | Ok user -> User_account.f user request + in + render_unsafe res request + +(*TODO ask for password *) +let account_post request = + match Dream.session "nick" request with + | None -> not_logged_in "/account" request + | Some nick -> ( + 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) + 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) + in + render_unsafe res request + | `Ok + [ ("confirm-new-password", confirm_password) + ; ("new-password", password) + ] -> + let res = + if password = confirm_password then + Result.fold ~error:Fun.id + ~ok:(fun _ -> "Your password was updated!") + (User.update_password password nick) + else "Password confimation does not match" + in + render_unsafe res request + | `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ + | `Wrong_session _ | `Expired _ | `Wrong_content_type -> + Dream.empty `Bad_Request ) + let profile_get request = match Dream.session "nick" request with - | None -> render_unsafe "Not logged in" request + | None -> not_logged_in "/profile" request | Some nick -> let res = match User.get_user nick with @@ -195,7 +251,7 @@ let profile_get request = let profile_post request = match Dream.session "nick" request with - | None -> render_unsafe "Not logged in" request + | None -> not_logged_in "/profile" request | Some nick -> ( match%lwt Dream.form request with | `Ok [ ("bio", bio) ] -> ( @@ -222,9 +278,8 @@ let profile_post request = ~headers:[ ("Location", "/profile") ] "Your avatar was updated!" | Error e -> render_unsafe e request ) - | `Ok _ -> Dream.empty `Bad_Request - | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ - | `Wrong_session _ | `Wrong_content_type -> + | `Ok _ | `Expired _ | `Many_tokens _ | `Missing_token _ + | `Invalid_token _ | `Wrong_session _ | `Wrong_content_type -> Dream.empty `Bad_Request ) ) let avatar_image request = @@ -261,7 +316,7 @@ let babillard_get request = render_unsafe (Babillard_page.f request) request let babillard_post request = match Dream.session "nick" request with - | None -> render_unsafe "Not logged in" request + | None -> not_logged_in "/" request | Some nick -> ( match%lwt Dream.multipart request with | `Ok @@ -320,8 +375,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 - | None -> render_unsafe "Not logged in" request + | None -> not_logged_in (Format.sprintf "/thread/%s" parent_id) request | Some nick -> ( match%lwt Dream.multipart request with | `Ok @@ -330,7 +386,6 @@ let reply_post request = ; ("reply-comment", [ (_, comment) ]) ; ("tags", [ (_, tags) ]) ] -> ( - let parent_id = Dream.param request "thread_id" in let res = match file with | [] -> Babillard.make_reply ~comment ~tags ~parent_id nick @@ -371,6 +426,8 @@ let routes = [ get_ "/" babillard_get ; post "/" babillard_post ; get_ "/about" about + ; get_ "/account" account_get + ; post "/account" account_post ; get_ "/admin" admin_get ; post "/admin" admin_post ; get_ "/assets/**" (Dream.static ~loader:asset_loader "") diff --git a/src/template.eml.html b/src/template.eml.html index 296f898..a545581 100644 --- a/src/template.eml.html +++ b/src/template.eml.html @@ -45,6 +45,7 @@ let render_unsafe ~title ~content request = <%s! nick %>
diff --git a/src/user.ml b/src/user.ml index 51241f5..18d2a3a 100644 --- a/src/user.ml +++ b/src/user.ml @@ -135,18 +135,14 @@ let valid_nick nick = && String.length nick > 0 && Dream.html_escape nick = nick +let valid_password password = + String.length password < 128 && String.length password > 0 + +let valid_email email = + match Emile.of_string email with Ok _ -> true | Error _ -> false + let register ~email ~nick ~password = - let valid_nick = valid_nick nick in - - let valid_email = - match Emile.of_string email with Ok _ -> true | Error _ -> false - in - - let valid_password = - String.length password < 128 && String.length password > 0 - in - - let valid = valid_nick && valid_email && valid_password in + let valid = valid_nick nick && valid_email email && valid_password password in let password = Bcrypt.hash password in let password = Bcrypt.string_of_hash password in @@ -235,8 +231,26 @@ let banish nick = let^ () = Db.exec Q.upload_banished (nick, email) in Ok () +let delete_user nick = + let^ () = Db.exec Q.delete_user nick 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 Ok () else Error "invalid display nick" + +let update_email email nick = + if valid_email email then + let^ () = Db.exec Q.update_email (email, nick) in + Ok () + else Error "invalid email" + +let update_password password nick = + 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 + Ok () + else Error "invalid password" diff --git a/src/user_account.eml.html b/src/user_account.eml.html new file mode 100644 index 0000000..305bf0c --- /dev/null +++ b/src/user_account.eml.html @@ -0,0 +1,28 @@ +let f (user: User.t) request = +