refactor
This commit is contained in:
zapashcanon
parent
190d086206
commit
ce7bb9d386
9 changed files with 442 additions and 500 deletions
273
src/user.ml
273
src/user.ml
|
|
@ -1,5 +1,6 @@
|
|||
open Db
|
||||
open Syntax
|
||||
open Caqti_request.Infix
|
||||
open Caqti_type
|
||||
|
||||
type t =
|
||||
{ user_id : string
|
||||
|
|
@ -10,125 +11,123 @@ type t =
|
|||
; metadata : (string * string) list
|
||||
}
|
||||
|
||||
module Q = struct
|
||||
open Caqti_request.Infix
|
||||
open Caqti_type
|
||||
|
||||
let create_user_table =
|
||||
(unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
|
||||
TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
|
||||
|
||||
let create_banished_table =
|
||||
(unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
|
||||
|
||||
let create_metadata_table =
|
||||
(unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS user_metadata (user_id TEXT, metadata TEXT, \
|
||||
FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
|
||||
|
||||
let get_metadata =
|
||||
(string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?"
|
||||
|
||||
let upload_metadata =
|
||||
(tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
|
||||
|
||||
let delete_metadata =
|
||||
(string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
|
||||
|
||||
let get_user_id_from_nick =
|
||||
(string ->! string) "SELECT user_id FROM user WHERE nick=?"
|
||||
|
||||
let get_user_id_from_email =
|
||||
(string ->! string) "SELECT user_id FROM user WHERE email=?"
|
||||
|
||||
let get_password =
|
||||
(string ->! string) "SELECT password FROM user WHERE user_id=?"
|
||||
|
||||
let is_already_user =
|
||||
(tup2 string string ->! int)
|
||||
"SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
|
||||
|
||||
let upload_user =
|
||||
(tup4 string string string (tup2 string string) ->. unit)
|
||||
"INSERT INTO user VALUES (?, ?, ?, ?, ?)"
|
||||
|
||||
let list_nicks = (unit ->* string) "SELECT nick FROM user"
|
||||
|
||||
let get_user =
|
||||
(* there is no "tup6" *)
|
||||
(string ->! tup4 string string string (tup2 string string))
|
||||
"SELECT * FROM user WHERE user_id=?"
|
||||
|
||||
let update_bio =
|
||||
(tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
|
||||
|
||||
let update_nick =
|
||||
(tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
|
||||
|
||||
let update_email =
|
||||
(tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
|
||||
|
||||
let update_password =
|
||||
(tup2 string string ->. unit) "UPDATE user SET password=? WHERE user_id=?"
|
||||
|
||||
let get_nick = (string ->! string) "SELECT nick FROM user WHERE user_id=?"
|
||||
|
||||
let get_bio = (string ->! string) "SELECT bio FROM user WHERE user_id=?"
|
||||
|
||||
let get_email = (string ->! string) "SELECT email FROM user WHERE user_id=?"
|
||||
|
||||
let delete_user = (string ->. unit) "DELETE FROM user WHERE user_id=?"
|
||||
|
||||
let upload_banished =
|
||||
(tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
|
||||
|
||||
let get_banished =
|
||||
(tup2 string string ->! tup2 string string)
|
||||
"SELECT * FROM banished WHERE nick=? OR email=?"
|
||||
end
|
||||
|
||||
let () =
|
||||
let tables =
|
||||
[| Q.create_user_table; Q.create_banished_table; Q.create_metadata_table |]
|
||||
[| (unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
|
||||
TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
|
||||
; (unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
|
||||
; (unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS user_metadata (user_id TEXT, metadata \
|
||||
TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE \
|
||||
CASCADE)"
|
||||
|]
|
||||
in
|
||||
if
|
||||
Array.exists Result.is_error
|
||||
(Array.map (fun query -> Db.exec query ()) tables)
|
||||
then Dream.error (fun log -> log "can't create user tables")
|
||||
|
||||
let exist id = Result.is_ok (Db.find Q.get_user id)
|
||||
module Q = struct
|
||||
let upload_metadata =
|
||||
Db.exec
|
||||
@@ (tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
|
||||
|
||||
let exist_nick nick = Result.is_ok (Db.find Q.get_user_id_from_nick nick)
|
||||
let delete_metadata =
|
||||
Db.exec @@ (string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
|
||||
|
||||
let exist_email email = Result.is_ok (Db.find Q.get_user_id_from_email email)
|
||||
let get_user_id_from_email =
|
||||
Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE email=?"
|
||||
|
||||
let get_metadata nick =
|
||||
let^ metadata = Db.find Q.get_metadata nick in
|
||||
let metadata : (string * string) list = Marshal.from_string metadata 0 in
|
||||
Ok metadata
|
||||
let get_password =
|
||||
Db.find @@ (string ->! string) "SELECT password FROM user WHERE user_id=?"
|
||||
|
||||
let get_user_id_from_nick nick =
|
||||
let^ user_id = Db.find Q.get_user_id_from_nick nick in
|
||||
Ok user_id
|
||||
let is_already_user =
|
||||
Db.find
|
||||
@@ (tup2 string string ->! int)
|
||||
"SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
|
||||
|
||||
let upload_user =
|
||||
Db.exec
|
||||
@@ (tup4 string string string (tup2 string string) ->. unit)
|
||||
"INSERT INTO user VALUES (?, ?, ?, ?, ?)"
|
||||
|
||||
let list_nicks = Db.collect_list @@ (unit ->* string) "SELECT nick FROM user"
|
||||
|
||||
let get_user =
|
||||
Db.find
|
||||
@@ (* there is no "tup6" *)
|
||||
(string ->! tup4 string string string (tup2 string string))
|
||||
"SELECT * FROM user WHERE user_id=?"
|
||||
|
||||
let update_bio =
|
||||
Db.exec
|
||||
@@ (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
|
||||
|
||||
let update_nick =
|
||||
Db.exec
|
||||
@@ (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
|
||||
|
||||
let update_email =
|
||||
Db.exec
|
||||
@@ (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
|
||||
|
||||
let update_password =
|
||||
Db.exec
|
||||
@@ (tup2 string string ->. unit)
|
||||
"UPDATE user SET password=? WHERE user_id=?"
|
||||
|
||||
let get_bio =
|
||||
Db.find @@ (string ->! string) "SELECT bio FROM user WHERE user_id=?"
|
||||
|
||||
let get_email =
|
||||
Db.find @@ (string ->! string) "SELECT email FROM user WHERE user_id=?"
|
||||
|
||||
let delete_user =
|
||||
Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?"
|
||||
|
||||
let upload_banished =
|
||||
Db.exec @@ (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
|
||||
|
||||
let get_banished =
|
||||
Db.find
|
||||
@@ (tup2 string string ->! tup2 string string)
|
||||
"SELECT * FROM banished WHERE nick=? OR email=?"
|
||||
end
|
||||
|
||||
let get_nick =
|
||||
Db.find @@ (string ->! string) "SELECT nick FROM user WHERE user_id=?"
|
||||
|
||||
let get_id_from_nick =
|
||||
Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE nick=?"
|
||||
|
||||
let exist id = Result.is_ok (Q.get_user id)
|
||||
|
||||
let exist_nick nick = Result.is_ok (get_id_from_nick nick)
|
||||
|
||||
let exist_email email = Result.is_ok (Q.get_user_id_from_email email)
|
||||
|
||||
let get_metadata =
|
||||
let query =
|
||||
Db.find
|
||||
@@ (string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?"
|
||||
in
|
||||
fun nick ->
|
||||
let* metadata = query nick in
|
||||
let metadata : (string * string) list = Marshal.from_string metadata 0 in
|
||||
Ok metadata
|
||||
|
||||
let get_user user_id =
|
||||
let^? user_id, nick, password, (email, bio) =
|
||||
Db.find_opt Q.get_user user_id
|
||||
in
|
||||
let* user_id, nick, password, (email, bio) = Q.get_user user_id in
|
||||
let* metadata = get_metadata user_id in
|
||||
Ok { user_id; nick; password; email; bio; metadata }
|
||||
|
||||
let is_banished login = Result.is_ok (Db.find Q.get_banished (login, login))
|
||||
|
||||
let get_nick user_id =
|
||||
let^ nick = Db.find Q.get_nick user_id in
|
||||
Ok nick
|
||||
let is_banished login = Result.is_ok (Q.get_banished (login, login))
|
||||
|
||||
let login ~login ~password request =
|
||||
let try_password user_id =
|
||||
let^ good_password = Db.find Q.get_password user_id in
|
||||
let* good_password = Q.get_password user_id in
|
||||
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
|
||||
let _unit_lwt = Dream.invalidate_session request in
|
||||
let _unit_lwt = Dream.put_session "user_id" user_id request in
|
||||
|
|
@ -139,17 +138,17 @@ let login ~login ~password request =
|
|||
else Error "wrong password"
|
||||
in
|
||||
|
||||
let^ id_from_nick = Db.find_opt Q.get_user_id_from_nick login in
|
||||
let^ id_from_email = Db.find_opt Q.get_user_id_from_email login in
|
||||
let user_id_list = List.filter_map Fun.id [ id_from_nick; id_from_email ] in
|
||||
match user_id_list with
|
||||
| [] -> Error "Invalid login"
|
||||
| [ id ] -> try_password id
|
||||
| [ id_1; id_2 ] -> (
|
||||
match try_password id_1 with
|
||||
| Ok () -> Ok ()
|
||||
| Error _e -> try_password id_2 )
|
||||
| _to_many_ids -> assert false
|
||||
let id_from_nick = get_id_from_nick login in
|
||||
let id_from_email = Q.get_user_id_from_email login in
|
||||
let user_id_list =
|
||||
List.filter_map Result.to_option [ id_from_nick; id_from_email ]
|
||||
in
|
||||
try
|
||||
List.iter
|
||||
(fun id -> if Result.is_ok @@ try_password id then raise Exit)
|
||||
user_id_list;
|
||||
Error "invalid login"
|
||||
with Exit -> Ok ()
|
||||
|
||||
let valid_nick nick =
|
||||
String.length nick < 64
|
||||
|
|
@ -169,16 +168,15 @@ let register ~email ~nick ~password =
|
|||
|
||||
if not valid then Error "Something is wrong"
|
||||
else
|
||||
let^ nb = Db.find Q.is_already_user (nick, email) in
|
||||
let* nb = Q.is_already_user (nick, email) in
|
||||
if nb = 0 then
|
||||
let user_id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in
|
||||
let^ () = Db.exec Q.upload_user (user_id, nick, password, (email, "")) in
|
||||
let^ () = Db.exec Q.upload_metadata (user_id, Marshal.to_string [] []) in
|
||||
Ok ()
|
||||
let* () = Q.upload_user (user_id, nick, password, (email, "")) in
|
||||
Q.upload_metadata (user_id, Marshal.to_string [] [])
|
||||
else Error "nick or email already exists"
|
||||
|
||||
let list () =
|
||||
let^ users = Db.collect_list Q.list_nicks () in
|
||||
let* users = Q.list_nicks () in
|
||||
Ok
|
||||
(Format.asprintf "<ul>%a</ul>"
|
||||
(Format.pp_print_list (fun fmt -> function
|
||||
|
|
@ -194,18 +192,7 @@ let profile request =
|
|||
let update_bio bio user_id =
|
||||
let bio = Dream.html_escape bio in
|
||||
let valid = String.length bio < 10000 in
|
||||
if not valid then Error "Not biologic"
|
||||
else
|
||||
let^ () = Db.exec Q.update_bio (bio, user_id) in
|
||||
Ok ()
|
||||
|
||||
let get_bio user_id =
|
||||
let^ bio = Db.find Q.get_bio user_id in
|
||||
Ok bio
|
||||
|
||||
let get_email user_id =
|
||||
let^ email = Db.find Q.get_email user_id in
|
||||
Ok email
|
||||
if not valid then Error "Not biologic" else Q.update_bio (bio, user_id)
|
||||
|
||||
let upload_avatar files user_id =
|
||||
match files with
|
||||
|
|
@ -223,37 +210,28 @@ let is_admin user_id =
|
|||
|
||||
let banish user_id =
|
||||
let* nick = get_nick user_id in
|
||||
let* email = get_email user_id in
|
||||
let^ () = Db.exec Q.delete_user user_id in
|
||||
let^ () = Db.exec Q.upload_banished (nick, email) in
|
||||
Ok ()
|
||||
let* email = Q.get_email user_id in
|
||||
let* () = Q.delete_user user_id in
|
||||
Q.upload_banished (nick, email)
|
||||
|
||||
let delete_user user_id =
|
||||
let^ () = Db.exec Q.delete_user user_id in
|
||||
Ok ()
|
||||
let delete_user user_id = Q.delete_user user_id
|
||||
|
||||
let update_nick nick user_id =
|
||||
if valid_nick nick then
|
||||
if not (exist_nick nick) then
|
||||
let^ () = Db.exec Q.update_nick (nick, user_id) in
|
||||
Ok ()
|
||||
if not (exist_nick nick) then Q.update_nick (nick, user_id)
|
||||
else Error "nick already taken"
|
||||
else Error "invalid nick"
|
||||
|
||||
let update_email email user_id =
|
||||
if valid_email email then
|
||||
if not (exist_email email) then
|
||||
let^ () = Db.exec Q.update_email (email, user_id) in
|
||||
Ok ()
|
||||
if not (exist_email email) then Q.update_email (email, user_id)
|
||||
else Error "email already taken"
|
||||
else Error "invalid email"
|
||||
|
||||
let update_password password user_id =
|
||||
if valid_password password then
|
||||
let password = Bcrypt.hash password in
|
||||
let password = Bcrypt.string_of_hash password in
|
||||
let^ () = Db.exec Q.update_password (password, user_id) in
|
||||
Ok ()
|
||||
let password = Bcrypt.hash password |> Bcrypt.string_of_hash in
|
||||
Q.update_password (password, user_id)
|
||||
else Error "invalid password"
|
||||
|
||||
let update_metadata count label content user_id =
|
||||
|
|
@ -278,9 +256,8 @@ let update_metadata count label content user_id =
|
|||
if List.length metadata >= 42 then Error "to many metadata"
|
||||
else
|
||||
let s = Marshal.to_string metadata [] in
|
||||
let^ () = Db.exec Q.delete_metadata user_id in
|
||||
let^ () = Db.exec Q.upload_metadata (user_id, s) in
|
||||
Ok ()
|
||||
let* () = Q.delete_metadata user_id in
|
||||
Q.upload_metadata (user_id, s)
|
||||
|
||||
let pp_metadata fmt (label, content) =
|
||||
Format.fprintf fmt
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue