open Syntax open Caqti_request.Infix open Caqti_type type t = { user_id : string ; nick : string ; password : string ; email : string } let () = let tables = [| (unit ->. unit) "CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \ TEXT, email TEXT, PRIMARY KEY(user_id))" ; (unit ->. unit) "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)" |] 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 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 string ->. unit) "INSERT INTO user VALUES (?, ?, ?, ?)" let list_nicks = Db.collect_list @@ (unit ->* string) "SELECT nick FROM user" let get_user = Db.find @@ (string ->! tup4 string string 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_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_user user_id = let* user_id, nick, password, email = Q.get_user user_id in Ok { user_id; nick; password; email } let is_banished login = Result.is_ok (Q.get_banished (login, login)) let login ~login ~password request = let login = String.trim login in 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 (`Forbidden, "YOU ARE BANISHED") else Error (`Forbidden, "wrong password") 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 ] in try List.iter (fun id -> if Result.is_ok @@ try_password id then raise Exit) user_id_list; Error (`Forbidden, "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 let register ~email ~nick ~password = let email = String.trim email in let nick = String.trim nick 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 if not valid then Error (`Bad_Request, "invalid nick, email or password") 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 Q.upload_user (user_id, nick, password, email) else Error (`Conflict, "nick or email already exists") let list () = let* users = Q.list_nicks () in Ok (Format.asprintf "
%s