Source file model.ml

(* TODO add Status.Active and Status.Inactive *)

module Database = Sihl_database
module Utils = Sihl_utils

type t =
  { id : string
  ; email : string
  ; username : string option
  ; password : string
  ; status : string
  ; admin : bool
  ; confirmed : bool
  ; created_at : Ptime.t
        [@to_yojson Utils.Time.ptime_to_yojson] [@of_yojson Utils.Time.ptime_of_yojson]
  }
[@@deriving fields, yojson, show, make]

let equal u1 u2 = String.equal u1.id u2.id
let confirm user = { user with confirmed = true }

let sexp_of_t { id; email; _ } =
  let open Sexplib0.Sexp_conv in
  let open Sexplib0.Sexp in
  List
    [ List [ Atom "id"; sexp_of_string id ]; List [ Atom "email"; sexp_of_string email ] ]
;;

let set_user_password user new_password =
  let hash = new_password |> Utils.Hashing.hash in
  Result.map (fun hash -> { user with password = hash }) hash
;;

let set_user_details user ~email ~username =
  (* TODO add support for lowercase UTF-8
   * String.lowercase only supports US-ASCII, but
   * email addresses can contain other letters
   * (https://tools.ietf.org/html/rfc6531) like umlauts.
   *)
  { user with email = String.lowercase_ascii email; username }
;;

let is_admin user = user.admin
let is_owner user id = String.equal user.id id
let is_confirmed user = user.confirmed

let matches_password password user =
  Utils.Hashing.matches ~hash:user.password ~plain:password
;;

let default_password_policy password =
  if String.length password >= 8
  then Ok ()
  else Error "Password has to contain at least 8 characters"
;;

let validate_new_password ~password ~password_confirmation ~password_policy =
  let is_same =
    if String.equal password password_confirmation
    then Ok ()
    else Error "Password confirmation doesn't match provided password"
  in
  let complies_with_policy = password_policy password in
  match is_same, complies_with_policy with
  | Ok (), Ok () -> Ok ()
  | Error msg, _ -> Error msg
  | _, Error msg -> Error msg
;;

let validate_change_password
    user
    ~old_password
    ~new_password
    ~new_password_confirmation
    ~password_policy
  =
  let matches_old_password =
    match matches_password old_password user with
    | true -> Ok ()
    | false -> Error "Invalid current password provided"
  in
  let new_password_valid =
    validate_new_password
      ~password:new_password
      ~password_confirmation:new_password_confirmation
      ~password_policy
  in
  match matches_old_password, new_password_valid with
  | Ok (), Ok () -> Ok ()
  | Error msg, _ -> Error msg
  | _, Error msg -> Error msg
;;

let create ~email ~password ~username ~admin ~confirmed =
  let hash = password |> Utils.Hashing.hash in
  Result.map
    (fun hash ->
      { id = Database.Id.random () |> Database.Id.to_string
      ; (* TODO add support for lowercase UTF-8
         * String.lowercase only supports US-ASCII, but
         * email addresses can contain other letters
         * (https://tools.ietf.org/html/rfc6531) like umlauts.
         *)
        email = String.lowercase_ascii email
      ; password = hash
      ; username
      ; admin
      ; confirmed
      ; status = "active"
      ; created_at = Ptime_clock.now ()
      })
    hash
;;

let t =
  let encode m =
    Ok
      ( m.id
      , ( m.email
        , (m.username, (m.password, (m.status, (m.admin, (m.confirmed, m.created_at)))))
        ) )
  in
  let decode
      (id, (email, (username, (password, (status, (admin, (confirmed, created_at)))))))
    =
    Ok { id; email; username; password; status; admin; confirmed; created_at }
  in
  Caqti_type.(
    custom
      ~encode
      ~decode
      (tup2
         string
         (tup2
            string
            (tup2
               (option string)
               (tup2 string (tup2 string (tup2 bool (tup2 bool ptime))))))))
;;