pellest/src/user.ml

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 "<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 get_nick_unsafe request = Option.get @@ Dream.session "nick" request

let is_logged_in request = Option.is_some @@ Dream.session "nick" request

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 (`Conflict, "nick already taken")
  else Error (`Bad_Request, "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 (`Conflict, "email already taken")
  else Error (`Bad_Request, "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 (`Bad_Request, "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

let assert_logged request =
  if is_logged_in request then Ok ()
  else Error (`Forbidden, "you should be logged in")

let assert_not_logged request =
  if is_logged_in request then Error (`Forbidden, "you shoudn't be logged in")
  else Ok ()

(* TODO save states *)

let state_ht : (string, Shared.State.t) Hashtbl.t = Hashtbl.create 1

let set_state = Hashtbl.replace state_ht

let get_state user_id =
  match Hashtbl.find_opt state_ht user_id with
  | Some state -> Ok state
  | None -> Ok (Shared.State.init ())