objective categorical abstract machine language personal data server
Add email functionality
+189
-36
+7
-2
dune-project
+7
-2
dune-project
···
21
21
(name bin_prot)
22
22
(version v0.17~preview.128.20+135))) ; this is actually v0.16~preview.128.20+135 but core requires >=v0.17
23
23
24
-
(pin ; these 3 all need to be pinned or they'll conflict
25
-
(url "git+https://github.com/aantron/dream.git#af3c9bff7b4f11777190946e2f3453697bf5a07b")
24
+
(pin ; these 4 all need to be pinned or they'll conflict
25
+
(url "git+https://github.com/lthms/dream.git#h2-0-13") ; unmerged patch that prevents conflict with letters
26
26
(package (name dream)))
27
+
(pin
28
+
(url "git+https://github.com/lthms/dream.git#h2-0-13") ; unmerged patch that prevents conflict with letters
29
+
(package (name dream-httpaf)))
27
30
(pin
28
31
(url "git+https://github.com/roddyyaga/ppx_rapper.git#5b0e62def2d5cc6cbe3dedec1ecb289bee350f9a")
29
32
(package (name ppx_rapper)))
···
53
56
(cohttp-lwt-unix (>= 6.1.1))
54
57
(dns-client (>= 10.2.0))
55
58
dream
59
+
(emile (>= 1.1))
60
+
(letters (>= 0.4.0))
56
61
(re (>= 1.13.2))
57
62
(safepass (>= 3.1))
58
63
server-reason-react
+3
-1
frontend/src/templates/AccountPage.mlx
+3
-1
frontend/src/templates/AccountPage.mlx
···
90
90
<ClientOnly fallback=(
91
91
<Input
92
92
name="email"
93
+
type_="email"
93
94
label="Email"
94
95
placeholder=email
95
96
show_optional_indicator=false
···
109
110
<Aria.DialogTrigger defaultOpen=email_change_pending>
110
111
<Input
111
112
name="email"
113
+
type_="email"
112
114
label="Email"
113
115
placeholder=email
114
116
show_optional_indicator=false
···
158
160
<Input
159
161
name="token"
160
162
label="Verification code"
161
-
placeholder="email-..."
163
+
placeholder="eml-..."
162
164
show_optional_indicator=false
163
165
/>
164
166
( match email_error with
+2
pegasus.opam
+2
pegasus.opam
+51
-24
pegasus/lib/api/account_/index.ml
+51
-24
pegasus/lib/api/account_/index.ml
···
5
5
| _ ->
6
6
false
7
7
8
-
let parse_email_change_code (actor : Data_store.Types.actor) =
8
+
let parse_email_change_code code =
9
+
if String.starts_with ~prefix:"eml-" code then
10
+
let rest =
11
+
String.sub code 4 (String.length code - 4)
12
+
|> Base64.decode_exn ~alphabet:Base64.uri_safe_alphabet ~pad:false
13
+
in
14
+
match String.split_on_char ':' rest with
15
+
| [token; new_email] ->
16
+
Some (token, new_email)
17
+
| _ ->
18
+
None
19
+
else None
20
+
21
+
let validate_actor_email_code (actor : Data_store.Types.actor) =
9
22
match (actor.auth_code, actor.auth_code_expires_at) with
10
23
| Some code, Some expires_at when expires_at > Util.now_ms () ->
11
-
if String.starts_with ~prefix:"eml-" code then
12
-
let rest = String.sub code 6 (String.length code - 6) in
13
-
match String.index_opt rest ':' with
14
-
| Some idx ->
15
-
let token = String.sub rest 0 idx in
16
-
let new_email =
17
-
String.sub rest (idx + 1) (String.length rest - idx - 1)
18
-
in
19
-
Some (token, new_email)
20
-
| None ->
21
-
None
22
-
else None
24
+
parse_email_change_code code
23
25
| _ ->
24
26
None
25
27
···
41
43
in
42
44
let csrf_token = Dream.csrf_token ctx.req in
43
45
let deactivated = actor.deactivated_at <> None in
44
-
let email_change_info = parse_email_change_code actor in
46
+
let email_change_info = validate_actor_email_code actor in
45
47
let email_change_pending = Option.is_some email_change_info in
46
48
let pending_email = Option.map snd email_change_info in
47
49
let delete_pending = has_valid_delete_code actor in
···
85
87
in
86
88
let actor = Option.get actor_opt in
87
89
let deactivated = actor.deactivated_at <> None in
88
-
let email_change_info = parse_email_change_code actor in
90
+
let email_change_info = validate_actor_email_code actor in
89
91
let email_change_pending = Option.is_some email_change_info in
90
92
let pending_email = Option.map snd email_change_info in
91
93
let delete_pending = has_valid_delete_code actor in
···
173
175
let%lwt () =
174
176
Data_store.set_auth_code ~did ~code ~expires_at ctx.db
175
177
in
176
-
(* TODO: send email with code *)
177
-
Dream.log "delete account code for %s: %s" did code ;
178
+
let%lwt () =
179
+
Util.send_email_or_log ~recipients:[To actor.email]
180
+
~subject:"Account deletion confirmation"
181
+
~body:
182
+
(Plain
183
+
(Printf.sprintf
184
+
"Confirm that you would like to delete the \
185
+
account %s (%s) by entering the following \
186
+
code: %s"
187
+
actor.handle did code ) )
188
+
in
178
189
render_page ()
179
190
| Some "confirm_delete" -> (
180
191
let token =
···
219
230
()
220
231
| None ->
221
232
let token = Mist.Tid.now () in
222
-
let code = "eml-" ^ token ^ ":" ^ new_email in
233
+
let code = token ^ ":" ^ new_email in
234
+
let code =
235
+
Base64.encode_exn
236
+
~alphabet:Base64.uri_safe_alphabet ~pad:false
237
+
code
238
+
in
239
+
let code = "eml-" ^ code in
223
240
let expires_at =
224
241
Util.now_ms () + (15 * 60 * 1000)
225
242
in
···
227
244
Data_store.set_auth_code ~did ~code ~expires_at
228
245
ctx.db
229
246
in
230
-
(* TODO: send email with code *)
231
-
Dream.log "email change code for %s: %s" actor.email
232
-
code ;
247
+
let%lwt () =
248
+
Util.send_email_or_log
249
+
~recipients:[To actor.email]
250
+
~subject:"Email change confirmation"
251
+
~body:
252
+
(Plain
253
+
(Printf.sprintf
254
+
"Confirm that you would like to update \
255
+
the email address for @%s (%s) from \
256
+
%s to %s by entering the following \
257
+
code: %s"
258
+
actor.handle did actor.email new_email
259
+
code ) )
260
+
in
233
261
render_page () )
234
262
| Some "confirm_email_change" -> (
235
263
let token =
236
264
List.assoc_opt "token" fields
237
265
|> Option.value ~default:"" |> String.trim
238
266
in
239
-
match parse_email_change_code actor with
240
-
| Some (stored_token, new_email) when stored_token = token
241
-
->
267
+
match validate_actor_email_code actor with
268
+
| Some (_, new_email) when Some token = actor.auth_code ->
242
269
let%lwt () =
243
270
Data_store.update_email ~did ~email:new_email ctx.db
244
271
in
+13
-2
pegasus/lib/api/identity/requestPlcOperationSignature.ml
+13
-2
pegasus/lib/api/identity/requestPlcOperationSignature.ml
···
10
10
in
11
11
let expires_at = Util.now_ms () + (60 * 60 * 1000) in
12
12
let%lwt () = Data_store.set_auth_code ~did ~code ~expires_at db in
13
-
(* TODO: something that isn't this *)
14
-
Dream.log "auth code for %s: %s" did code ;
13
+
let%lwt {email; handle; _} =
14
+
Data_store.get_actor_by_identifier did db |> Lwt.map Option.get
15
+
in
16
+
let%lwt () =
17
+
Util.send_email_or_log ~recipients:[To email]
18
+
~subject:"Confirm PLC operation"
19
+
~body:
20
+
(Plain
21
+
(Printf.sprintf
22
+
"Confirm that you would like to update your PLC identity for \
23
+
%s (%s) using the following token: %s"
24
+
handle did code ) )
25
+
in
15
26
Dream.empty `OK )
+11
-2
pegasus/lib/api/server/requestAccountDelete.ml
+11
-2
pegasus/lib/api/server/requestAccountDelete.ml
···
4
4
match%lwt Data_store.get_actor_by_identifier did db with
5
5
| None ->
6
6
Errors.internal_error ~msg:"actor not found" ()
7
-
| Some _actor ->
7
+
| Some actor ->
8
8
let code =
9
9
"del-"
10
10
^ String.sub
···
15
15
in
16
16
let expires_at = Util.now_ms () + (15 * 60 * 1000) in
17
17
let%lwt () = Data_store.set_auth_code ~did ~code ~expires_at db in
18
-
Dream.log "account deletion code for %s: %s" did code ;
18
+
let%lwt () =
19
+
Util.send_email_or_log ~recipients:[To actor.email]
20
+
~subject:
21
+
(Printf.sprintf "Account deletion request for %s" actor.handle)
22
+
~body:
23
+
(Plain
24
+
(Printf.sprintf
25
+
"Delete your account using the following token: %s" code )
26
+
)
27
+
in
19
28
Dream.empty `OK )
+10
-1
pegasus/lib/api/server/requestEmailConfirmation.ml
+10
-1
pegasus/lib/api/server/requestEmailConfirmation.ml
···
22
22
in
23
23
let expires_at = Util.now_ms () + (10 * 60 * 1000) in
24
24
let%lwt () = Data_store.set_auth_code ~did ~code ~expires_at db in
25
-
Dream.log "email confirmation code for %s: %s" did code ;
25
+
let%lwt () =
26
+
Util.send_email_or_log ~recipients:[To actor.email]
27
+
~subject:(Printf.sprintf "Confirm email for %s" actor.handle)
28
+
~body:
29
+
(Plain
30
+
(Printf.sprintf
31
+
"Confirm your email address using the following token: \
32
+
%s"
33
+
code ) )
34
+
in
26
35
Dream.empty `OK ) )
+12
-3
pegasus/lib/api/server/requestEmailUpdate.ml
+12
-3
pegasus/lib/api/server/requestEmailUpdate.ml
···
12
12
| Some actor ->
13
13
let token_required = Option.is_some actor.email_confirmed_at in
14
14
let%lwt () =
15
-
if token_required then (
15
+
if token_required then
16
16
let code =
17
17
"eml-"
18
18
^ String.sub
···
23
23
in
24
24
let expires_at = Util.now_ms () + (10 * 60 * 1000) in
25
25
let%lwt () = Data_store.set_auth_code ~did ~code ~expires_at db in
26
-
Dream.log "email update code for %s: %s" did code ;
27
-
Lwt.return_unit )
26
+
let%lwt () =
27
+
Util.send_email_or_log ~recipients:[To actor.email]
28
+
~subject:(Printf.sprintf "Email update for %s" actor.handle)
29
+
~body:
30
+
(Plain
31
+
(Printf.sprintf
32
+
"Confirm your email address using the following \
33
+
token: %s"
34
+
code ) )
35
+
in
36
+
Lwt.return_unit
28
37
else Lwt.return_unit
29
38
in
30
39
Dream.json @@ Yojson.Safe.to_string
+9
-1
pegasus/lib/api/server/requestPasswordReset.ml
+9
-1
pegasus/lib/api/server/requestPasswordReset.ml
···
37
37
let%lwt () =
38
38
Data_store.set_auth_code ~did:actor.did ~code ~expires_at db
39
39
in
40
-
Dream.log "password reset code for %s: %s" actor.did code ;
40
+
let%lwt () =
41
+
Util.send_email_or_log ~recipients:[To actor.email]
42
+
~subject:(Printf.sprintf "Password reset for %s" actor.handle)
43
+
~body:
44
+
(Plain
45
+
(Printf.sprintf
46
+
"Reset your password using the following token: %s" code )
47
+
)
48
+
in
41
49
Dream.empty `OK )
+2
pegasus/lib/dune
+2
pegasus/lib/dune
+44
pegasus/lib/env.ml
+44
pegasus/lib/env.ml
···
37
37
( Base64.(encode ~alphabet:uri_safe_alphabet ~pad:false) secret
38
38
|> Result.get_ok ) ) ;
39
39
Bytes.of_string secret
40
+
41
+
let smtp_config, smtp_sender =
42
+
begin
43
+
let with_starttls =
44
+
Option.value ~default:"false" @@ Sys.getenv_opt "SMTP_STARTTLS" = "true"
45
+
in
46
+
match
47
+
( Option.map Uri.of_string (Sys.getenv_opt "SMTP_AUTH_URI")
48
+
, Sys.getenv_opt "SMTP_SENDER" )
49
+
with
50
+
| Some uri, Some sender -> (
51
+
match
52
+
( Uri.scheme uri
53
+
, Uri.user uri
54
+
, Uri.password uri
55
+
, Uri.host uri
56
+
, Uri.port uri )
57
+
with
58
+
| Some scheme, Some username, Some password, Some hostname, port
59
+
when scheme = "smtp" || scheme = "smtps" -> (
60
+
match Emile.of_string sender with
61
+
| Ok _ ->
62
+
( Some
63
+
Letters.Config.(
64
+
create ~username ~password ~hostname ~with_starttls ()
65
+
|> set_port port )
66
+
, Some sender )
67
+
| Error _ ->
68
+
failwith
69
+
"SMTP_SENDER should be a valid mailbox, e.g. `e@mail.com` or \
70
+
`Name <e@mail.com>`" )
71
+
| _ ->
72
+
failwith
73
+
"SMTP_AUTH_URI must be a valid smtp:// or smtps:// URI with \
74
+
username, password, and hostname" )
75
+
| Some _, None ->
76
+
failwith
77
+
"SMTP_SENDER must be set alongside SMTP_AUTH_URI; it should look \
78
+
like `e@mail.com` or `Name <e@mail.com>`"
79
+
| None, Some _ ->
80
+
failwith "SMTP_AUTH_URI must be set alongside SMTP_SENDER"
81
+
| None, None ->
82
+
(None, None)
83
+
end
+25
pegasus/lib/util.ml
+25
pegasus/lib/util.ml
···
486
486
let make_at_uri ~repo ~collection ~rkey ~fragment =
487
487
Printf.sprintf "at://%s/%s/%s%s" repo collection rkey
488
488
(Option.value ~default:"" fragment)
489
+
490
+
let send_email_or_log ~(recipients : Letters.recipient list) ~subject
491
+
~(body : Letters.body) =
492
+
let log_email () =
493
+
match body with
494
+
| Plain text | Html text | Mixed (text, _, _) ->
495
+
let to_addr =
496
+
List.find_map
497
+
(fun (r : Letters.recipient) ->
498
+
match r with To addr -> Some addr | _ -> None )
499
+
recipients
500
+
|> Option.get
501
+
in
502
+
Dream.log "email to %s: %s" to_addr text
503
+
in
504
+
match (Env.smtp_config, Env.smtp_sender) with
505
+
| Some config, Some sender -> (
506
+
match Letters.create_email ~from:sender ~recipients ~subject ~body () with
507
+
| Error e ->
508
+
failwith (Printf.sprintf "failed to construct email: %s" e)
509
+
| Ok message -> (
510
+
try%lwt Letters.send ~config ~sender ~recipients ~message
511
+
with _ -> Lwt.return (log_email ()) ) )
512
+
| _ ->
513
+
Lwt.return (log_email ())