big squish
This commit is contained in:
parent
fae867b35b
commit
55d2abefb4
124 changed files with 6931 additions and 8393 deletions
427
src/user.ml
427
src/user.ml
|
|
@ -1,336 +1,115 @@
|
|||
open Syntax
|
||||
open Caqti_request.Infix
|
||||
open Caqti_type
|
||||
open Types
|
||||
open Err
|
||||
|
||||
type t =
|
||||
{ user_id : string
|
||||
; nick : string
|
||||
; password : string
|
||||
; email : string
|
||||
; bio : string
|
||||
; metadata : (string * string) list
|
||||
}
|
||||
let check_nick nick =
|
||||
let* nick = Validate_str.nick nick in
|
||||
let* opt = Db_user.find_user_of_nick nick in
|
||||
match opt with
|
||||
| None -> Ok nick
|
||||
| Some _user -> Error (Unprocessable "nick already taken")
|
||||
|
||||
let () =
|
||||
let tables =
|
||||
[| (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")
|
||||
|
||||
module Q = struct
|
||||
let upload_metadata =
|
||||
Db.exec
|
||||
@@ (tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
|
||||
|
||||
let delete_metadata =
|
||||
Db.exec @@ (string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
|
||||
|
||||
let get_user_id_from_email =
|
||||
Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE email=?"
|
||||
|
||||
let get_password =
|
||||
Db.find @@ (string ->! string) "SELECT password FROM user WHERE 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 check_email email =
|
||||
let* email = Validate_str.email email in
|
||||
match Emile.of_string (email :> string) with
|
||||
| Error _ -> Error (Unprocessable "invalid email format")
|
||||
| Ok _ -> (
|
||||
let* opt = Db_user.find_user_of_email email in
|
||||
match opt with
|
||||
| None -> Ok email
|
||||
| Some _user -> Error (Unprocessable "email already taken") )
|
||||
|
||||
let get_user user_id =
|
||||
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* opt = Db_user.find_user user_id in
|
||||
match opt with None -> Error (Not_found_user user_id) | Some o -> Ok o
|
||||
|
||||
let is_banished login = Result.is_ok (Q.get_banished (login, login))
|
||||
let get_user_private user_id =
|
||||
let* opt = Db_user.find_user_private user_id in
|
||||
match opt with None -> Error (Not_found_user user_id) | Some o -> Ok o
|
||||
|
||||
let login ~login ~password request =
|
||||
let try_password user_id =
|
||||
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
|
||||
let* nick = get_nick user_id in
|
||||
let _unit_lwt = Dream.put_session "nick" nick request in
|
||||
Ok ()
|
||||
else if is_banished login then Error "YOU ARE BANISHED"
|
||||
else Error "wrong password"
|
||||
(* login can be nick or email *)
|
||||
let login ~login ~password =
|
||||
let f find s =
|
||||
let* opt = find s in
|
||||
match opt with
|
||||
| None -> Ok None
|
||||
| Some user ->
|
||||
let* good_password = Db_user.get_password_hash user.user_id in
|
||||
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
|
||||
let* opt = Db_user.find_user_private user.user_id in
|
||||
match opt with
|
||||
| None ->
|
||||
Error
|
||||
(Internal (Db_not_found (Fmt.str "user_private `%s`" user.user_id)))
|
||||
| Some o -> Ok (Some o)
|
||||
else Error (Unauthorized_login login)
|
||||
in
|
||||
|
||||
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 ]
|
||||
(* assume login is nick *)
|
||||
let* opt =
|
||||
match Validate_str.nick login with
|
||||
| Error _ -> Ok None
|
||||
| Ok nick -> f Db_user.find_user_of_nick nick
|
||||
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
|
||||
&& 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 = Result.is_ok @@ Emile.of_string email
|
||||
match opt with
|
||||
| Some u -> Ok u
|
||||
| None -> (
|
||||
(* assume login is email *)
|
||||
let* email = Validate_str.email login in
|
||||
let* opt = f Db_user.find_user_of_email email in
|
||||
match opt with Some u -> Ok u | None -> Error (Unauthorized_login login) )
|
||||
|
||||
let register ~email ~nick ~password =
|
||||
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
|
||||
|
||||
if not valid then Error "Something is wrong"
|
||||
else
|
||||
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* () = 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 = Q.list_nicks () in
|
||||
Ok
|
||||
(Format.asprintf "<ul>%a</ul>"
|
||||
(Format.pp_print_list (fun fmt -> function
|
||||
| s -> Format.fprintf fmt {|<li><a href="/user/%s">%s</a></li>|} s s )
|
||||
)
|
||||
users )
|
||||
|
||||
let profile request =
|
||||
match Dream.session "nick" request with
|
||||
| None -> "not logged in"
|
||||
| Some nick -> Format.sprintf "Hello %s !" 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 Q.update_bio (bio, user_id)
|
||||
|
||||
let upload_avatar files user_id =
|
||||
match files with
|
||||
| [] -> Error "No file provided"
|
||||
| [ (name_opt, content) ] ->
|
||||
let* image = Image.make_image (name_opt, "avatar", content) in
|
||||
let* () = Image.upload_avatar image user_id in
|
||||
Ok ()
|
||||
| _files -> Error "More than one file provided"
|
||||
|
||||
let is_admin user_id =
|
||||
match get_nick user_id with
|
||||
| Error _e -> false
|
||||
| Ok nick -> List.mem nick App.admins
|
||||
|
||||
let banish user_id =
|
||||
let* nick = get_nick user_id in
|
||||
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 = Q.delete_user user_id
|
||||
|
||||
let update_nick nick user_id =
|
||||
if valid_nick nick then
|
||||
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 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 |> Bcrypt.string_of_hash in
|
||||
Q.update_password (password, user_id)
|
||||
else Error "invalid password"
|
||||
|
||||
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
|
||||
let* metadata = get_metadata user_id in
|
||||
let length = List.length metadata in
|
||||
if count < 0 || count > length then Error "invalid count"
|
||||
else
|
||||
let n = max (count + 1) @@ length in
|
||||
let metadata = Array.of_list metadata in
|
||||
let metadata =
|
||||
List.init n (fun i ->
|
||||
if i = count then (label, content) else metadata.(i) )
|
||||
in
|
||||
let metadata =
|
||||
List.filter (fun (l, c) -> not (l = "" && c = "")) metadata
|
||||
in
|
||||
if List.length metadata >= 42 then Error "to many metadata"
|
||||
else
|
||||
let s = Marshal.to_string metadata [] in
|
||||
let* () = Q.delete_metadata user_id in
|
||||
Q.upload_metadata (user_id, s)
|
||||
|
||||
let pp_metadata fmt (label, content) =
|
||||
Format.fprintf fmt
|
||||
{|
|
||||
<div class="row">
|
||||
<div class="col metadata-label">%s</div>
|
||||
<div class="col metadata-content">%s</div>
|
||||
</div>
|
||||
|}
|
||||
label content
|
||||
|
||||
let pp_metadata_form fmt is_last count (label, content) request =
|
||||
let form_tag = Dream.form_tag ~action:"/profile" request in
|
||||
let button_text = if is_last then "Add" else "Save" in
|
||||
Format.fprintf fmt
|
||||
{|
|
||||
<div class="row">
|
||||
%s
|
||||
<input name="label" class="metadata-label" value="%s"/>
|
||||
<input name="content" class="metadata-content" value="%s"/>
|
||||
<button name="count" value="%d" type="submit" class="btn btn-primary">%s</button>
|
||||
</form>
|
||||
</div>
|
||||
|}
|
||||
form_tag label content count button_text
|
||||
|
||||
let pp_metadata_table fmt metadata =
|
||||
Format.fprintf fmt
|
||||
{|
|
||||
<div class="metadata-table">
|
||||
%a
|
||||
</div>
|
||||
|}
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_metadata)
|
||||
metadata
|
||||
|
||||
let pp_metadata_table_form fmt metadata request =
|
||||
let l = List.mapi (fun i e -> (i, e)) metadata in
|
||||
Format.fprintf fmt
|
||||
{|
|
||||
<div class="metadata-form-table">
|
||||
%a
|
||||
%a
|
||||
</div>
|
||||
|}
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space
|
||||
(fun fmt (count, metadata) ->
|
||||
pp_metadata_form fmt false count metadata request ) )
|
||||
l
|
||||
(fun fmt (count, metadata) ->
|
||||
pp_metadata_form fmt true count metadata request )
|
||||
(List.length l, ("", ""))
|
||||
|
||||
let public_profile user_id =
|
||||
let* user = get_user user_id in
|
||||
let user_info =
|
||||
Format.asprintf
|
||||
{|
|
||||
<h1>%s</h1>
|
||||
<br />
|
||||
<div class="row">
|
||||
<div class="col-md-6">
|
||||
<blockquote>%s</blockquote>
|
||||
</div>
|
||||
<div class="col-md-6">
|
||||
<img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">
|
||||
</div>
|
||||
<a href="/discuss/%s">Speak to me !</a>
|
||||
<div class="col-md-6">
|
||||
%a
|
||||
</div>
|
||||
</div>
|
||||
|}
|
||||
user.nick user.bio user.nick user_id pp_metadata_table user.metadata
|
||||
let* password = Validate_str.password password in
|
||||
let* nick = check_nick nick in
|
||||
let* email = check_email email in
|
||||
let* () =
|
||||
let* opt1 = Db_user.find_user_of_nick nick in
|
||||
let* opt2 = Db_user.find_user_of_email email in
|
||||
let loggin_not_taken = Option.is_none opt1 && Option.is_none opt2 in
|
||||
if loggin_not_taken then Ok ()
|
||||
else Error (Unprocessable "nick or email already taken")
|
||||
in
|
||||
Ok user_info
|
||||
let password_hash =
|
||||
Bcrypt.hash (password :> string) |> Bcrypt.string_of_hash
|
||||
in
|
||||
Db_user.add_user ~email ~nick ~password_hash
|
||||
|
||||
let delete_user user_id = Db_user.delete_user user_id
|
||||
|
||||
let update_bio user_id bio =
|
||||
let* bio = Validate_str.bio bio in
|
||||
Db_user.update_bio user_id bio
|
||||
|
||||
let update_nick user_id nick =
|
||||
let* nick = check_nick nick in
|
||||
Db_user.update_nick user_id nick
|
||||
|
||||
let update_email user_id email =
|
||||
let* email = check_email email in
|
||||
Db_user.update_email user_id email
|
||||
|
||||
let update_password user_id password =
|
||||
let* password = Validate_str.password password in
|
||||
let password_hash =
|
||||
Bcrypt.hash (password :> string) |> Bcrypt.string_of_hash
|
||||
in
|
||||
Db_user.update_password_hash user_id password_hash
|
||||
|
||||
let get_image user_id =
|
||||
let default_avatar_path = "/img/default_avatar.png" in
|
||||
let* opt = Db_image.U.data user_id in
|
||||
match opt with
|
||||
| Some data -> Ok data
|
||||
| None -> (
|
||||
match Assets.read default_avatar_path with
|
||||
| None -> Error (Internal (Db_not_found "can not find default avatar file"))
|
||||
| Some avatar -> Ok avatar )
|
||||
|
||||
(* TODO sql : rm image db functor, handle avatar image and transaction in db_user *)
|
||||
let upload_avatar user_id (name_opt, alt, content) =
|
||||
let name = Option.value ~default:"" name_opt in
|
||||
let* image = Image.build ~name ~alt content in
|
||||
Caqti_db.Db.do_transaction @@ fun () -> Db_image.U.upload user_id image
|
||||
|
||||
let delete_avatar user_id =
|
||||
Caqti_db.Db.do_transaction @@ fun () -> Db_image.U.delete user_id
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue