1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
module Database = Sihl_database
module Utils = Sihl_utils
module Error = struct
type t =
| AlreadyRegistered
| IncorrectPassword
| InvalidPasswordProvided of string
| DoesNotExist
end
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 =
{ 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
;
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))))))))
;;