geochan/src/user.ml

open Syntax
open Caqti_request.Infix
open Caqti_type

type t =
  { user_id : string
  ; nick : string
  ; password : string
  ; email : string
  ; bio : string
  ; metadata : (string * string) list
  }

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 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 is_banished login = Result.is_ok (Q.get_banished (login, login))

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"
  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 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
  in
  Ok user_info