b

src/user.ml

@@ -0,0 +1,213 @@
+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 "YOU ARE BANISHED"
+    else Error "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 "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 "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
+      Q.upload_user (user_id, nick, password, email)
+    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 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 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>
+      <div class="col-md-6">
+        %a
+      </div>
+    </div>
+|}
+      user.nick user.nick
+  in
+  Ok user_info