objective categorical abstract machine language personal data server
Implement account page
+1323
-100
+9
-2
bin/main.ml
+9
-2
bin/main.ml
···
23
23
; (options, "/oauth/token", Xrpc.handler (fun _ -> Dream.empty `No_Content))
24
24
; (post, "/oauth/token", Api.Oauth_.Token.post_handler)
25
25
; (* account *)
26
-
(get, "/account/login", Api.Account_.Login.get_handler)
26
+
(get, "/account", Api.Account_.Index.get_handler)
27
+
; (post, "/account", Api.Account_.Index.post_handler)
28
+
; (get, "/account/permissions", Api.Account_.Permissions.get_handler)
29
+
; (post, "/account/permissions", Api.Account_.Permissions.post_handler)
30
+
; (get, "/account/login", Api.Account_.Login.get_handler)
27
31
; (post, "/account/login", Api.Account_.Login.post_handler)
28
32
; (get, "/account/logout", Api.Account_.Logout.handler)
29
33
; (* unauthed *)
···
147
151
| None ->
148
152
Dream.empty `Not_Found
149
153
| Some asset ->
150
-
Dream.respond asset
154
+
Dream.respond
155
+
~headers:[("Cache-Control", "public, max-age=31536000")]
156
+
asset
151
157
152
158
let static_routes =
153
159
[Dream.get "/public/**" (Dream.static ~loader:public_loader "")]
···
161
167
[ Dream.logger
162
168
; Dream.set_secret (Env.jwt_key |> Kleidos.privkey_to_multikey)
163
169
; Dream.cookie_sessions
170
+
; Dream.livereload
164
171
; Xrpc.dpop_middleware
165
172
; Xrpc.cors_middleware ]
166
173
@@ Dream.router
+2
frontend/client/Router.mlx
+2
frontend/client/Router.mlx
···
14
14
15
15
let routes =
16
16
[ {path= "/oauth/authorize"; template= (module OauthAuthorizePage)}
17
+
; {path= "/account"; template= (module AccountPage)}
18
+
; {path= "/account/permissions"; template= (module AccountPermissionsPage)}
17
19
; {path= "/account/login"; template= (module LoginPage)} ]
18
20
19
21
let find_by_path path_to_find =
+37
frontend/src/components/AccountSidebar.mlx
+37
frontend/src/components/AccountSidebar.mlx
···
1
+
[@@@ocaml.warning "-26-27"]
2
+
3
+
open React
4
+
5
+
type actor = AccountSwitcher.actor
6
+
7
+
type active_page = Account | Permissions
8
+
9
+
let pages =
10
+
[ (Account, "Account", "/account")
11
+
; (Permissions, "Permissions", "/account/permissions") ]
12
+
13
+
let[@react.component] make ~current_user ~logged_in_users ~active_page () =
14
+
let selected_class = "text-mana-100 font-medium" in
15
+
let unselected_class = "text-mist-100 hover:text-mana-100" in
16
+
let permissions_class =
17
+
match active_page with
18
+
| Account ->
19
+
"text-mist-100 hover:text-mana-100"
20
+
| Permissions ->
21
+
"text-mana-100 font-medium"
22
+
in
23
+
<aside className="flex flex-col gap-y-2 min-w-48 max-w-3xs">
24
+
<AccountSwitcher
25
+
current_user logged_in_users add_account_url="/account/login"
26
+
/>
27
+
<nav className="flex flex-col gap-y-1 mt-2">
28
+
( List.map
29
+
(fun (key, label, href) ->
30
+
let className =
31
+
if key = active_page then selected_class else unselected_class
32
+
in
33
+
<a href className key=label>(string label)</a> )
34
+
pages
35
+
|> Array.of_list |> array )
36
+
</nav>
37
+
</aside>
+93
frontend/src/components/AccountSwitcher.mlx
+93
frontend/src/components/AccountSwitcher.mlx
···
1
+
[@@@ocaml.warning "-26-27-33"]
2
+
3
+
open Melange_json.Primitives
4
+
open React
5
+
module Aria = ReactAria
6
+
7
+
type actor =
8
+
{did: string; handle: string; avatar_data_uri: string option [@default None]}
9
+
[@@deriving json]
10
+
11
+
let fallback handle =
12
+
<button className="flex px-2 py-1.5 -mx-2 rounded-lg">
13
+
<span className="text-mana-100 font-serif flex items-center gap-x-2">
14
+
<div className="w-5 h-5 mr-1 rounded-md bg-mist-20" />
15
+
<span className="self-baseline">(string ("@" ^ handle))</span>
16
+
<ChevronDownIcon
17
+
className="w-3 h-3 mt-0.5 text-mana-100"
18
+
strokeWidth="3"
19
+
/>
20
+
</span>
21
+
</button>
22
+
23
+
let[@react.component] make ~current_user ~logged_in_users ~add_account_url
24
+
?(name = "did") ?(inline = false) ?onChange () =
25
+
let button_class =
26
+
if inline then
27
+
"group inline-flex flex-row items-center px-1.5 py-1 -mx-0.75 -my-1 \
28
+
rounded-lg focus-visible:outline-none hover:bg-mist-20/40 \
29
+
active:bg-mist-20/40"
30
+
else
31
+
"group flex flex-row items-center gap-x-1 px-2 py-1.5 -mx-2 rounded-lg \
32
+
focus-visible:outline-none hover:bg-mist-20/40 active:bg-mist-20/40"
33
+
in
34
+
let value_class =
35
+
if inline then "text-mana-100 font-serif inline-flex items-center gap-x-1"
36
+
else "text-mana-100 font-serif flex items-center gap-x-1"
37
+
in
38
+
<ClientOnly fallback=(fallback current_user.handle)>
39
+
[%browser_only
40
+
(fun () ->
41
+
<Aria.Select name className="inline" defaultValue=current_user.did placeholder="select account" ?onChange>
42
+
<Aria.Button className=button_class>
43
+
<Aria.SelectValue className=value_class />
44
+
</Aria.Button>
45
+
<Aria.Popover
46
+
style=
47
+
(ReactDOM.Style.make
48
+
~minWidth:"calc(var(--trigger-width) + var(--spacing) * 3)" () )
49
+
className="focus-visible:outline-none">
50
+
<Aria.ListBox
51
+
className="w-full flex flex-col gap-y-1 p-1.5 -ml-1.5 rounded-lg \
52
+
bg-mist-20 font-light">
53
+
( List.map
54
+
(fun (user : actor) ->
55
+
<Aria.ListBoxItem
56
+
className="flex flex-row items-center py-1.5 px-2 gap-x-1 \
57
+
font-serif text-mist-100 rounded-md \
58
+
focus-visible:outline-none \
59
+
data-hovered:text-mist-20 \
60
+
data-focused:text-mist-20 \
61
+
data-hovered:bg-mana-100 \
62
+
data-focused:bg-mana-100"
63
+
key=user.did
64
+
id=user.did>
65
+
( match user.avatar_data_uri with
66
+
| Some src ->
67
+
<img src className="w-5 h-5 mr-1 rounded-md" />
68
+
| None ->
69
+
null )
70
+
<span className="self-baseline select-none">
71
+
(string ("@" ^ user.handle))
72
+
</span>
73
+
<ChevronDownIcon
74
+
className="w-3 h-3 mt-0.5 text-mana-100 hidden \
75
+
group-aria-[haspopup]:inline"
76
+
strokeWidth="3"
77
+
/>
78
+
</Aria.ListBoxItem> )
79
+
logged_in_users
80
+
|> Array.of_list |> array )
81
+
<Aria.ListBoxItem
82
+
className="flex flex-row items-center p-1 pl-2 text-mana-100 \
83
+
font-normal underline rounded-md \
84
+
focus-visible:outline-none \
85
+
data-hovered:text-mist-20 data-focused:text-mist-20 \
86
+
data-hovered:bg-mana-100 data-focused:bg-mana-100"
87
+
href=add_account_url>
88
+
(string "add account")
89
+
</Aria.ListBoxItem>
90
+
</Aria.ListBox>
91
+
</Aria.Popover>
92
+
</Aria.Select> )]
93
+
</ClientOnly>
+10
-5
frontend/src/components/Button.mlx
+10
-5
frontend/src/components/Button.mlx
···
23
23
| `Danger ->
24
24
base_classes
25
25
^ " bg-white font-serif text-phoenix-100 shadow-bleed hover:bg-mist-20 \
26
-
hover:text-phoenix-40 focus:bg-mist-20 focus:text-phoenix-40 \
27
-
focus-visible:outline-none active:bg-phoenix-40 active:text-mist-20 \
28
-
disabled:bg-mana-40"
26
+
focus:bg-mist-20 focus:text-phoenix-40 focus-visible:outline-none \
27
+
active:bg-phoenix-40 active:text-mist-20 disabled:bg-mana-40"
28
+
| `Danger_secondary ->
29
+
base_classes
30
+
^ " bg-feather font-serif underline text-phoenix-100 hover:no-underline \
31
+
focus-visible:shadow-bleed active:shadow-bleed disabled:no-underline \
32
+
disabled:text-mist-80"
29
33
30
34
let[@react.component] make ?id ?name ?(kind = `Primary) ?(type_ = "button")
31
-
?formMethod ?onClick ?value ?(className = "") ~children () =
35
+
?formMethod ?onClick ?value ?(className = "") ?ref ~children () =
32
36
<button
33
37
?id
34
38
?name
···
36
40
?formMethod
37
41
?onClick
38
42
?value
39
-
className=(classes kind ^ " " ^ className)>
43
+
className=(classes kind ^ " " ^ className)
44
+
?ref>
40
45
children
41
46
</button>
+3
-2
frontend/src/components/ClientOnly.mlx
+3
-2
frontend/src/components/ClientOnly.mlx
···
1
1
open React
2
2
3
-
let[@react.component] make ~(children : unit -> React.element) () =
3
+
let[@react.component] make ~(children : unit -> React.element)
4
+
?(fallback = null) () =
4
5
let is_mounted, set_mounted = useState (fun () -> false) in
5
6
useEffect (fun () ->
6
7
let () = set_mounted (fun _ -> true) in
7
8
None ) ;
8
-
if is_mounted then children () else null
9
+
if is_mounted then children () else fallback
+5
-4
frontend/src/components/Input.mlx
+5
-4
frontend/src/components/Input.mlx
···
4
4
let req_marker = " *"
5
5
6
6
let[@react.component] make ?id ~name ?(className = "") ?(type_ = "text") ?label
7
-
?(sr_only = false) ?value ?placeholder ?(required = false)
8
-
?(disabled = false) ?trailing () =
7
+
?(sr_only = false) ?value ?placeholder ?autoComplete ?(required = false)
8
+
?(disabled = false) ?trailing ?(show_optional_indicator = true) () =
9
9
let id = Option.value id ~default:name in
10
10
let placeholder = if label <> None && sr_only then label else placeholder in
11
11
let input =
···
14
14
type_
15
15
name
16
16
?placeholder
17
+
?autoComplete
17
18
required
18
19
disabled
19
20
?value
···
27
28
<div
28
29
className=( "flex justify-between text-sm"
29
30
^ if sr_only then " sr-only" else "" )>
30
-
<label htmlFor=id className="text-mist-100">
31
+
<label htmlFor=id className="text-mist-100 mb-1">
31
32
(string label)
32
33
( if required then
33
34
<span className="text-phoenix-100">(string req_marker)</span>
34
35
else null )
35
36
</label>
36
-
( if required then null
37
+
( if required || not show_optional_indicator then null
37
38
else <span className="text-mist-80">(string "optional")</span> )
38
39
</div>
39
40
| None ->
+58
frontend/src/components/ReactAria.mlx
+58
frontend/src/components/ReactAria.mlx
···
5
5
end
6
6
[@@platform js]
7
7
8
+
module Dialog = struct
9
+
external make :
10
+
children:React.element -> ?className:string -> ?role:string -> React.element
11
+
= "Dialog"
12
+
[@@mel.module "react-aria-components"] [@@react.component]
13
+
end
14
+
[@@platform js]
15
+
16
+
module DialogTrigger = struct
17
+
external make :
18
+
children:React.element
19
+
-> ?isOpen:bool
20
+
-> ?defaultOpen:bool
21
+
-> ?onOpenChange:(bool -> unit)
22
+
-> React.element = "DialogTrigger"
23
+
[@@mel.module "react-aria-components"] [@@react.component]
24
+
end
25
+
[@@platform js]
26
+
27
+
module Heading = struct
28
+
external make :
29
+
children:React.element -> ?slot:string -> ?className:string -> React.element
30
+
= "Heading"
31
+
[@@mel.module "react-aria-components"] [@@react.component]
32
+
end
33
+
[@@platform js]
34
+
8
35
module ListBox = struct
9
36
external make : children:React.element -> ?className:string -> React.element
10
37
= "ListBox"
···
23
50
end
24
51
[@@platform js]
25
52
53
+
module Modal = struct
54
+
external make :
55
+
children:React.element
56
+
-> ?className:string
57
+
-> ?isDismissable:bool
58
+
-> ?isOpen:bool
59
+
-> ?onOpenChange:(bool -> unit)
60
+
-> React.element = "Modal"
61
+
[@@mel.module "react-aria-components"] [@@react.component]
62
+
end
63
+
[@@platform js]
64
+
65
+
module ModalOverlay = struct
66
+
external make :
67
+
children:React.element
68
+
-> ?className:string
69
+
-> ?isDismissable:bool
70
+
-> ?isOpen:bool
71
+
-> ?onOpenChange:(bool -> unit)
72
+
-> React.element = "ModalOverlay"
73
+
[@@mel.module "react-aria-components"] [@@react.component]
74
+
end
75
+
[@@platform js]
76
+
26
77
module Popover = struct
27
78
external make :
28
79
children:React.element
···
33
84
end
34
85
[@@platform js]
35
86
87
+
module Pressable = struct
88
+
external make : children:React.element -> React.element = "Pressable"
89
+
[@@mel.module "react-aria-components"] [@@react.component]
90
+
end
91
+
[@@platform js]
92
+
36
93
module Select = struct
37
94
external make :
38
95
children:React.element
···
40
97
-> ?name:string
41
98
-> ?value:string
42
99
-> ?defaultValue:string
100
+
-> ?placeholder:string
43
101
-> ?onChange:(string -> unit)
44
102
-> React.element = "Select"
45
103
[@@mel.module "react-aria-components"] [@@react.component]
+15
frontend/src/icons/PencilLineIcon.mlx
+15
frontend/src/icons/PencilLineIcon.mlx
···
1
+
let[@react.component] make ?className ?(strokeWidth = "2") () =
2
+
<svg
3
+
?className
4
+
viewBox="0 0 24 24"
5
+
fill="none"
6
+
stroke="currentColor"
7
+
strokeLinecap="round"
8
+
strokeLinejoin="round"
9
+
strokeWidth>
10
+
<path
11
+
d="M13 21h8M15 5l4 4m2.174-2.188a2.819 2.819 0 1 0-3.986-3.987L3.842 \
12
+
16.175a2 2 0 0 0-.5.83L2.02 21.355a.5.5 0 0 0 .623.622l4.353-1.32a2 2 \
13
+
0 0 0 .83-.497z"
14
+
/>
15
+
</svg>
+426
frontend/src/templates/AccountPage.mlx
+426
frontend/src/templates/AccountPage.mlx
···
1
+
[@@@ocaml.warning "-26-27"]
2
+
3
+
open Melange_json.Primitives
4
+
open React
5
+
6
+
type actor = AccountSwitcher.actor =
7
+
{did: string; handle: string; avatar_data_uri: string option [@default None]}
8
+
[@@deriving json]
9
+
10
+
type props =
11
+
{ current_user: actor
12
+
; logged_in_users: actor list
13
+
; csrf_token: string
14
+
; handle: string
15
+
; email: string
16
+
; deactivated: bool [@default false]
17
+
; email_change_pending: bool [@default false]
18
+
; pending_email: string option [@default None]
19
+
; email_error: string option [@default None]
20
+
; delete_pending: bool [@default false]
21
+
; error: string option [@default None]
22
+
; success: string option [@default None]
23
+
; delete_error: string option [@default None] }
24
+
[@@deriving json]
25
+
26
+
let[@react.component] make
27
+
~props:
28
+
({ current_user
29
+
; logged_in_users
30
+
; csrf_token
31
+
; handle
32
+
; email
33
+
; deactivated
34
+
; email_change_pending
35
+
; pending_email
36
+
; email_error
37
+
; delete_pending
38
+
; error
39
+
; success
40
+
; delete_error } :
41
+
props ) () =
42
+
let emailModalOpen, setEmailModalOpen =
43
+
useState (fun () -> email_change_pending)
44
+
in
45
+
let deleteModalOpen, setDeleteModalOpen =
46
+
useState (fun () -> delete_pending)
47
+
in
48
+
<div className="w-auto h-auto px-4 sm:px-0 flex flex-col md:flex-row gap-12">
49
+
<AccountSidebar
50
+
current_user logged_in_users active_page=AccountSidebar.Account
51
+
/>
52
+
<main className="flex-1 w-full max-w-md">
53
+
<h1 className="text-2xl font-serif text-mana-200 mb-1">
54
+
(string "my account")
55
+
</h1>
56
+
( if deactivated then
57
+
<div>
58
+
<p className="text-mist-100 mb-4">
59
+
(string
60
+
"Your account is currently deactivated. Reactivate it to \
61
+
regain access." )
62
+
</p>
63
+
( match error with
64
+
| Some error ->
65
+
<span
66
+
className="inline-flex items-center text-phoenix-100 text-sm \
67
+
mb-4">
68
+
<CircleAlertIcon className="w-4 h-4 mr-2" /> (string error)
69
+
</span>
70
+
| None ->
71
+
null )
72
+
<form>
73
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
74
+
<Button
75
+
type_="submit"
76
+
formMethod="post"
77
+
name="action"
78
+
value="reactivate">
79
+
(string "reactivate account")
80
+
</Button>
81
+
</form>
82
+
</div>
83
+
else
84
+
<div>
85
+
<p className="text-mist-100 mb-4">
86
+
(string "Manage your identity.")
87
+
</p>
88
+
<form className="flex flex-col gap-y-3">
89
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
90
+
<ClientOnly fallback=(
91
+
<Input
92
+
name="email"
93
+
label="Email"
94
+
placeholder=email
95
+
show_optional_indicator=false
96
+
disabled=true
97
+
trailing=(
98
+
<button
99
+
type_="button"
100
+
className="p-1 hover:text-mana-100 cursor-pointer"
101
+
ariaLabel="Change email">
102
+
<PencilLineIcon className="w-4 h-4" />
103
+
</button>
104
+
) />
105
+
)>
106
+
[%browser_only
107
+
(fun () ->
108
+
let module Aria = ReactAria in
109
+
<Aria.DialogTrigger defaultOpen=email_change_pending>
110
+
<Input
111
+
name="email"
112
+
label="Email"
113
+
placeholder=email
114
+
show_optional_indicator=false
115
+
disabled=true
116
+
trailing=(
117
+
<Aria.Pressable>
118
+
<button
119
+
type_="button"
120
+
className="p-1 hover:text-mana-100 cursor-pointer"
121
+
ariaLabel="Change email"
122
+
onClick=(fun _ -> setEmailModalOpen (fun _ -> true))>
123
+
<PencilLineIcon className="w-4 h-4" />
124
+
</button>
125
+
</Aria.Pressable>
126
+
)
127
+
/>
128
+
<Aria.ModalOverlay
129
+
className="fixed inset-0 z-50 bg-feather-100/80 \
130
+
flex items-center justify-center"
131
+
isDismissable=(not email_change_pending)
132
+
isOpen=emailModalOpen
133
+
onOpenChange=(fun o -> setEmailModalOpen (fun _ -> o))
134
+
>
135
+
<Aria.Modal
136
+
className="bg-feather-100 border border-mist-40 rounded-xl \
137
+
p-6 w-full max-w-sm shadow-xl">
138
+
<Aria.Dialog className="outline-none">
139
+
<Aria.Heading
140
+
slot="title"
141
+
className="text-lg font-serif text-mana-200 mb-2">
142
+
(string "change email")
143
+
</Aria.Heading>
144
+
( if email_change_pending then
145
+
<form className="flex flex-col gap-y-3">
146
+
<input
147
+
type_="hidden"
148
+
name="dream.csrf"
149
+
value=csrf_token
150
+
/>
151
+
<p className="text-mist-100">
152
+
(string
153
+
( "Enter the verification code sent to "
154
+
^ Option.value pending_email
155
+
~default:"your new email"
156
+
^ "." ) )
157
+
</p>
158
+
<Input
159
+
name="token"
160
+
label="Verification code"
161
+
placeholder="email-..."
162
+
show_optional_indicator=false
163
+
/>
164
+
( match email_error with
165
+
| Some err ->
166
+
<span
167
+
className="inline-flex items-center \
168
+
text-phoenix-100 text-sm">
169
+
<CircleAlertIcon className="w-4 h-4 mr-2" />
170
+
(string err)
171
+
</span>
172
+
| None ->
173
+
null )
174
+
<div className="flex flex-row gap-x-3 mt-2">
175
+
<Button
176
+
type_="submit"
177
+
formMethod="post"
178
+
name="action"
179
+
value="confirm_email_change">
180
+
(string "verify")
181
+
</Button>
182
+
<Button
183
+
kind=`Secondary
184
+
type_="submit"
185
+
formMethod="post"
186
+
name="action"
187
+
value="cancel_email_change">
188
+
(string "cancel")
189
+
</Button>
190
+
</div>
191
+
</form>
192
+
else
193
+
<form className="flex flex-col gap-y-3">
194
+
<input
195
+
type_="hidden"
196
+
name="dream.csrf"
197
+
value=csrf_token
198
+
/>
199
+
<Input
200
+
name="new_email"
201
+
label="New email address"
202
+
type_="email"
203
+
show_optional_indicator=false
204
+
/>
205
+
( match email_error with
206
+
| Some err ->
207
+
<span
208
+
className="inline-flex items-center \
209
+
text-phoenix-100 text-sm">
210
+
<CircleAlertIcon className="w-4 h-4 mr-2" />
211
+
(string err)
212
+
</span>
213
+
| None ->
214
+
null )
215
+
<div className="flex flex-row gap-x-3 mt-2">
216
+
<Button
217
+
type_="submit"
218
+
formMethod="post"
219
+
name="action"
220
+
value="request_email_change">
221
+
(string "send code")
222
+
</Button>
223
+
<Button kind=`Tertiary
224
+
className="text-mist-100 hover:text-mana-100"
225
+
onClick=(fun _ -> setEmailModalOpen (fun _ -> false))>
226
+
(string "cancel")
227
+
</Button>
228
+
</div>
229
+
</form> )
230
+
</Aria.Dialog>
231
+
</Aria.Modal>
232
+
</Aria.ModalOverlay>
233
+
</Aria.DialogTrigger> )]
234
+
</ClientOnly>
235
+
<Input
236
+
name="handle"
237
+
label="Handle"
238
+
placeholder=handle
239
+
show_optional_indicator=false
240
+
/>
241
+
<Input
242
+
name="password"
243
+
type_="password"
244
+
label="Password"
245
+
placeholder="********"
246
+
autoComplete="current-password"
247
+
show_optional_indicator=false
248
+
/>
249
+
( match error with
250
+
| Some error ->
251
+
<span
252
+
className="inline-flex items-center text-phoenix-100 \
253
+
text-sm">
254
+
<CircleAlertIcon className="w-4 h-4 mr-2" /> (string error)
255
+
</span>
256
+
| None ->
257
+
null )
258
+
( match success with
259
+
| Some success ->
260
+
<span
261
+
className="inline-flex items-center text-mana-100 text-sm">
262
+
(string success)
263
+
</span>
264
+
| None ->
265
+
null )
266
+
<Button
267
+
type_="submit"
268
+
formMethod="post"
269
+
name="action"
270
+
value="save"
271
+
className="mt-2">
272
+
(string "save changes")
273
+
</Button>
274
+
</form>
275
+
<section className="mt-8">
276
+
<h2 className="text-xl font-serif text-mana-200 mb-1">
277
+
(string "download repository")
278
+
</h2>
279
+
<p className="text-mist-100 mb-3">
280
+
(string
281
+
"Export your data to back up or transfer to another PDS." )
282
+
</p>
283
+
<a
284
+
href=("/xrpc/com.atproto.sync.getRepo?did=" ^ current_user.did)
285
+
download=("repo-" ^ current_user.handle ^ ".car")>
286
+
<Button kind=`Primary className="max-w-1/2">
287
+
(string "download")
288
+
</Button>
289
+
</a>
290
+
</section>
291
+
<section className="mt-8">
292
+
<h2 className="text-xl font-serif text-mana-200 mb-1">
293
+
(string "danger zone")
294
+
</h2>
295
+
<p className="text-mist-100 mb-3">
296
+
(string
297
+
"Deactivating your account will temporarily render your \
298
+
data inaccessible until you reactivate it." )
299
+
<br />
300
+
(string
301
+
"Deleting your account will permanently remove all your \
302
+
data." )
303
+
</p>
304
+
<div className="flex flex-row gap-x-3 mt-2">
305
+
<form>
306
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
307
+
<Button
308
+
kind=`Danger_secondary
309
+
type_="submit"
310
+
formMethod="post"
311
+
name="action"
312
+
value="deactivate"
313
+
className="flex-1">
314
+
(string "deactivate account")
315
+
</Button>
316
+
</form>
317
+
<ClientOnly fallback=(
318
+
<Button kind=`Danger className="flex-1">(string "delete account")</Button>
319
+
)>
320
+
[%browser_only
321
+
(fun () ->
322
+
let module Aria = ReactAria in
323
+
<Aria.DialogTrigger defaultOpen=delete_pending>
324
+
<Aria.Pressable>
325
+
<Button kind=`Danger className="flex-1" onClick=(fun _ -> setDeleteModalOpen (fun _ -> true))>
326
+
(string "delete account")
327
+
</Button>
328
+
</Aria.Pressable>
329
+
<Aria.ModalOverlay
330
+
className="fixed inset-0 z-50 bg-feather-100/80 \
331
+
flex items-center justify-center"
332
+
isDismissable=(not delete_pending)
333
+
isOpen=deleteModalOpen onOpenChange=(fun o -> setDeleteModalOpen (fun _ -> o))>
334
+
<Aria.Modal
335
+
className="bg-feather-100 border border-mist-40 rounded-xl \
336
+
p-6 w-full max-w-sm shadow-xl">
337
+
<Aria.Dialog className="outline-none">
338
+
<Aria.Heading
339
+
slot="title"
340
+
className="text-lg font-serif text-mana-200 mb-2">
341
+
(string "delete account")
342
+
</Aria.Heading>
343
+
( if delete_pending then
344
+
<form className="flex flex-col gap-y-3">
345
+
<input
346
+
type_="hidden"
347
+
name="dream.csrf"
348
+
value=csrf_token
349
+
/>
350
+
<p className="text-mist-100 text-sm">
351
+
(string
352
+
"Enter the confirmation code sent to your email." )
353
+
</p>
354
+
<Input
355
+
name="token"
356
+
label="Confirmation code"
357
+
placeholder="del-..."
358
+
show_optional_indicator=false
359
+
/>
360
+
( match delete_error with
361
+
| Some err ->
362
+
<span
363
+
className="inline-flex items-center \
364
+
text-phoenix-100 text-sm">
365
+
<CircleAlertIcon className="w-4 h-4 mr-2" />
366
+
(string err)
367
+
</span>
368
+
| None ->
369
+
null )
370
+
<div className="flex flex-row gap-x-3 mt-2">
371
+
<Button
372
+
kind=`Danger
373
+
type_="submit"
374
+
formMethod="post"
375
+
name="action"
376
+
value="confirm_delete">
377
+
(string "confirm")
378
+
</Button>
379
+
<Button
380
+
kind=`Secondary
381
+
type_="submit"
382
+
formMethod="post"
383
+
name="action"
384
+
value="cancel_delete">
385
+
(string "cancel")
386
+
</Button>
387
+
</div>
388
+
</form>
389
+
else
390
+
<form className="flex flex-col gap-y-3">
391
+
<input
392
+
type_="hidden"
393
+
name="dream.csrf"
394
+
value=csrf_token
395
+
/>
396
+
<p className="text-mist-100">
397
+
(string
398
+
"This action is irreversible. A confirmation \
399
+
code will be sent to your email." )
400
+
</p>
401
+
<div className="flex flex-row gap-x-3 mt-2">
402
+
<Button
403
+
kind=`Danger
404
+
type_="submit"
405
+
formMethod="post"
406
+
name="action"
407
+
value="request_delete">
408
+
(string "send code")
409
+
</Button>
410
+
<Button kind=`Tertiary
411
+
onClick=(fun _ -> setDeleteModalOpen (fun _ -> false))
412
+
className="text-mist-100 hover:text-mana-100">
413
+
(string "cancel")
414
+
</Button>
415
+
</div>
416
+
</form> )
417
+
</Aria.Dialog>
418
+
</Aria.Modal>
419
+
</Aria.ModalOverlay>
420
+
</Aria.DialogTrigger> )]
421
+
</ClientOnly>
422
+
</div>
423
+
</section>
424
+
</div> )
425
+
</main>
426
+
</div>
+192
frontend/src/templates/AccountPermissionsPage.mlx
+192
frontend/src/templates/AccountPermissionsPage.mlx
···
1
+
[@@@ocaml.warning "-26-27"]
2
+
3
+
open Melange_json.Primitives
4
+
open React
5
+
6
+
type actor = AccountSwitcher.actor =
7
+
{did: string; handle: string; avatar_data_uri: string option [@default None]}
8
+
[@@deriving json]
9
+
10
+
type authorized_app =
11
+
{ client_id: string
12
+
; client_name: string option [@default None]
13
+
; client_host: string }
14
+
[@@deriving json]
15
+
16
+
type device =
17
+
{ last_ip: string
18
+
; last_user_agent: string option [@default None]
19
+
; last_refreshed_at: int
20
+
; is_current: bool }
21
+
[@@deriving json]
22
+
23
+
type props =
24
+
{ current_user: actor
25
+
; logged_in_users: actor list
26
+
; csrf_token: string
27
+
; authorized_apps: authorized_app list
28
+
; devices: device list }
29
+
[@@deriving json]
30
+
31
+
let parse_user_agent ua =
32
+
let ua = Option.value ua ~default:"Unknown" in
33
+
let os =
34
+
if String.length ua > 0 then
35
+
if
36
+
Js.String.includes ~search:"Mac" ua
37
+
|| Js.String.includes ~search:"Macintosh" ua
38
+
then "macOS"
39
+
else if Js.String.includes ~search:"Windows" ua then "Windows"
40
+
else if Js.String.includes ~search:"Linux" ua then "Linux"
41
+
else if Js.String.includes ~search:"Android" ua then "Android"
42
+
else if
43
+
Js.String.includes ~search:"iPhone" ua
44
+
|| Js.String.includes ~search:"iPad" ua
45
+
then "iOS"
46
+
else "Unknown OS"
47
+
else "Unknown OS"
48
+
in
49
+
let browser =
50
+
if String.length ua > 0 then
51
+
if
52
+
Js.String.includes ~search:"Chrome" ua
53
+
&& not (Js.String.includes ~search:"Edg" ua)
54
+
then "Chrome"
55
+
else if Js.String.includes ~search:"Firefox" ua then "Firefox"
56
+
else if
57
+
Js.String.includes ~search:"Safari" ua
58
+
&& not (Js.String.includes ~search:"Chrome" ua)
59
+
then "Safari"
60
+
else if Js.String.includes ~search:"Edg" ua then "Edge"
61
+
else "Unknown Browser"
62
+
else "Unknown Browser"
63
+
in
64
+
os ^ " · " ^ browser
65
+
66
+
let format_date timestamp_ms =
67
+
let date = Js.Date.fromFloat (float_of_int timestamp_ms) in
68
+
let month = Js.Date.getMonth date |> int_of_float in
69
+
let day = Js.Date.getDate date |> int_of_float in
70
+
let year = Js.Date.getFullYear date |> int_of_float in
71
+
Printf.sprintf "%d/%d/%d" year (month + 1) day
72
+
73
+
let[@react.component] make
74
+
~props:
75
+
({current_user; logged_in_users; csrf_token; authorized_apps; devices} :
76
+
props ) () =
77
+
<div className="w-auto h-auto px-4 sm:px-0 flex flex-col md:flex-row gap-12">
78
+
<AccountSidebar
79
+
current_user logged_in_users active_page=AccountSidebar.Permissions
80
+
/>
81
+
<main className="flex-1 w-full max-w-md">
82
+
<section>
83
+
<h1 className="text-2xl font-serif text-mana-200 mb-1">
84
+
(string "authorized applications")
85
+
</h1>
86
+
<p className="text-mist-100 mb-4">
87
+
(string "These applications have access to your account or identity.")
88
+
</p>
89
+
( if List.length authorized_apps = 0 then
90
+
<p className="text-mist-80 italic">
91
+
(string "No applications authorized.")
92
+
</p>
93
+
else
94
+
<ul className="space-y-2">
95
+
( List.map
96
+
(fun (app : authorized_app) ->
97
+
<li key=app.client_id className="flex items-center gap-x-2">
98
+
<span className="font-serif text-mana-100">
99
+
(string
100
+
(Option.value app.client_name
101
+
~default:app.client_host ) )
102
+
</span>
103
+
( match app.client_name with
104
+
| Some _ ->
105
+
<span className="text-mist-80">
106
+
(string ("(" ^ app.client_host ^ ")"))
107
+
</span>
108
+
| None ->
109
+
null )
110
+
<span className="text-mist-80">(string "-")</span>
111
+
<form className="inline">
112
+
<input type_="hidden" name="dream.csrf" value=csrf_token
113
+
/>
114
+
<input
115
+
type_="hidden" name="client_id" value=app.client_id
116
+
/>
117
+
<button
118
+
type_="submit"
119
+
formMethod="post"
120
+
name="action"
121
+
value="revoke_app"
122
+
className="text-mist-100 underline \
123
+
hover:text-mana-100">
124
+
(string "revoke access")
125
+
</button>
126
+
</form>
127
+
</li> )
128
+
authorized_apps
129
+
|> Array.of_list |> array )
130
+
</ul> )
131
+
</section>
132
+
<section className="mt-8">
133
+
<h2 className="text-xl font-serif text-mana-200 mb-1">
134
+
(string "my devices")
135
+
</h2>
136
+
<p className="text-mist-100 mb-4">
137
+
(string "Your account can be accessed from any of these devices.")
138
+
</p>
139
+
( if List.length devices = 0 then
140
+
<p className="text-mist-80 italic">(string "No devices found.")</p>
141
+
else
142
+
<ul className="space-y-3">
143
+
( List.mapi
144
+
(fun i (device : device) ->
145
+
let key = device.last_ip ^ "-" ^ string_of_int i in
146
+
<li key className="flex flex-col">
147
+
<div className="flex items-center gap-x-2">
148
+
<span className="font-serif text-mana-100">
149
+
(string (parse_user_agent device.last_user_agent))
150
+
</span>
151
+
( if device.is_current then
152
+
<span className="text-mist-80">
153
+
(string "(this device)")
154
+
</span>
155
+
else null )
156
+
<span className="text-mist-80">(string "-")</span>
157
+
<form className="inline">
158
+
<input
159
+
type_="hidden" name="dream.csrf" value=csrf_token
160
+
/>
161
+
<input
162
+
type_="hidden" name="last_ip" value=device.last_ip
163
+
/>
164
+
<input
165
+
type_="hidden"
166
+
name="last_user_agent"
167
+
value=(Option.value device.last_user_agent
168
+
~default:"" )
169
+
/>
170
+
<button
171
+
type_="submit"
172
+
formMethod="post"
173
+
name="action"
174
+
value="sign_out_device"
175
+
className="text-mist-100 underline \
176
+
hover:text-mana-100">
177
+
(string "sign out")
178
+
</button>
179
+
</form>
180
+
</div>
181
+
<span className="text-sm text-mist-80">
182
+
(string
183
+
( format_date device.last_refreshed_at
184
+
^ " from " ^ device.last_ip ) )
185
+
</span>
186
+
</li> )
187
+
devices
188
+
|> Array.of_list |> array )
189
+
</ul> )
190
+
</section>
191
+
</main>
192
+
</div>
+21
frontend/src/templates/Layout.mlx
+21
frontend/src/templates/Layout.mlx
···
5
5
<head>
6
6
<meta charSet="utf-8" />
7
7
<meta name="viewport" content="width=device-width, initial-scale=1" />
8
+
<link
9
+
rel="preload"
10
+
href="/public/fonts/FragmentLight.woff2"
11
+
as_="font"
12
+
type_="font/woff2"
13
+
crossOrigin="anonymous"
14
+
/>
15
+
<link
16
+
rel="preload"
17
+
href="/public/fonts/FragmentRegular.woff2"
18
+
as_="font"
19
+
type_="font/woff2"
20
+
crossOrigin="anonymous"
21
+
/>
22
+
<link
23
+
rel="preload"
24
+
href="https://fonts.gstatic.com/s/geist/v4/gyByhwUxId8gMEwcGFWNOITd.woff2"
25
+
as_="font"
26
+
type_="font/woff2"
27
+
crossOrigin="anonymous"
28
+
/>
8
29
<link rel="stylesheet" href="/public/index.css" />
9
30
<title>(string title)</title>
10
31
</head>
+11
-72
frontend/src/templates/OauthAuthorizePage.mlx
+11
-72
frontend/src/templates/OauthAuthorizePage.mlx
···
6
6
7
7
let cimd_suffix_len = String.length "/oauth-client-metadata.json"
8
8
9
-
type actor =
9
+
type actor = AccountSwitcher.actor =
10
10
{did: string; handle: string; avatar_data_uri: string option [@default None]}
11
11
[@@deriving json]
12
12
···
199
199
let email, identity, repos, rpcs, blobs, has_bluesky, has_chat, unknowns =
200
200
merge_parsed_scopes scopes
201
201
in
202
-
<div className="w-full mt-3 space-y-3">
202
+
<div className="w-full mt-3 space-y-1">
203
203
( match email with
204
204
| Some level ->
205
-
<div className="flex items-start gap-3 p-3 rounded-lg bg-mist-10/50">
205
+
<div className="flex items-start gap-3 p-3 rounded-lg">
206
206
<div
207
207
className="flex-shrink-0 w-8 h-8 flex items-center \
208
208
justify-center rounded-full bg-mist-20/50 \
···
245
245
| None ->
246
246
null )
247
247
( if has_bluesky then
248
-
<div className="flex items-start gap-3 p-3 rounded-lg bg-mist-10/50">
248
+
<div className="flex items-start gap-3 p-3 rounded-lg">
249
249
<div
250
250
className="flex-shrink-0 w-8 h-8 flex items-center \
251
251
justify-center rounded-full bg-mist-20/50 \
···
261
261
</div>
262
262
else null )
263
263
( if has_chat then
264
-
<div className="flex items-start gap-3 p-3 rounded-lg bg-mist-10/50">
264
+
<div className="flex items-start gap-3 p-3 rounded-lg">
265
265
<div
266
266
className="flex-shrink-0 w-8 h-8 flex items-center \
267
267
justify-center rounded-full bg-mist-20/50 \
···
290
290
| None ->
291
291
false
292
292
in
293
-
<div className="flex items-start gap-3 p-3 rounded-lg bg-mist-10/50">
293
+
<div className="flex items-start gap-3 p-3 rounded-lg">
294
294
<div
295
295
className="flex-shrink-0 w-8 h-8 flex items-center \
296
296
justify-center rounded-full bg-mist-20/50 \
···
394
394
(fun (aud, lxms) -> aud = "*" && List.mem "*" lxms)
395
395
aud_lxms_list
396
396
in
397
-
<div className="flex items-start gap-3 p-3 rounded-lg bg-mist-10/50">
397
+
<div className="flex items-start gap-3 p-3 rounded-lg">
398
398
<div
399
399
className="flex-shrink-0 w-8 h-8 flex items-center \
400
400
justify-center rounded-full bg-mist-20/50 \
···
482
482
</div>
483
483
else null )
484
484
( if List.length blobs > 0 && not has_bluesky then
485
-
<div className="flex items-start gap-3 p-3 rounded-lg bg-mist-10/50">
485
+
<div className="flex items-start gap-3 p-3 rounded-lg">
486
486
<div
487
487
className="flex-shrink-0 w-8 h-8 flex items-center \
488
488
justify-center rounded-full bg-mist-20/50 \
···
502
502
</div>
503
503
else null )
504
504
( if List.length unknowns > 0 then
505
-
<div className="flex items-start gap-3 p-3 rounded-lg bg-mist-10/50">
505
+
<div className="flex items-start gap-3 p-3 rounded-lg">
506
506
<div
507
507
className="flex-shrink-0 w-8 h-8 flex items-center \
508
508
justify-center rounded-full bg-mist-20/50 \
···
576
576
else null )
577
577
rendered_name
578
578
(string " as ")
579
-
<ClientOnly>
580
-
[%browser_only (fun () -> (
581
-
<Aria.Select
582
-
name="did" className="inline" defaultValue=current_user.did>
583
-
<Aria.Button
584
-
className="group inline-flex flex-row items-center px-1.5 py-1 \
585
-
-mx-0.75 -my-1 rounded-lg focus-visible:outline-none \
586
-
hover:bg-mist-20/40 active:bg-mist-20/40">
587
-
<Aria.SelectValue
588
-
className="text-mana-100 font-serif inline-flex items-center \
589
-
gap-x-1"
590
-
/>
591
-
</Aria.Button>
592
-
<Aria.Popover
593
-
style=(ReactDOM.Style.make
594
-
~minWidth:"calc(var(--trigger-width) + var(--spacing) * 3)"
595
-
() )
596
-
className="focus-visible:outline-none">
597
-
<Aria.ListBox
598
-
className="w-full flex flex-col gap-y-1 p-1.5 -ml-1.5 rounded-lg \
599
-
bg-mist-20 font-light">
600
-
( List.map
601
-
(fun user ->
602
-
<Aria.ListBoxItem
603
-
className="flex flex-row items-center py-1.5 px-2 \
604
-
gap-x-1 font-serif text-mist-100 rounded-md \
605
-
focus-visible:outline-none \
606
-
data-hovered:text-mist-20 \
607
-
data-focused:text-mist-20 \
608
-
data-hovered:bg-mana-100 \
609
-
data-focused:bg-mana-100"
610
-
key=user.did
611
-
id=user.did>
612
-
( match user.avatar_data_uri with
613
-
| Some src ->
614
-
<img src className="w-5 h-5 mr-1 rounded-md" />
615
-
| None ->
616
-
null )
617
-
<span className="self-baseline select-none">
618
-
(string ("@" ^ user.handle))
619
-
</span>
620
-
<ChevronDownIcon
621
-
className="w-3 h-3 mt-0.5 text-mana-100 hidden \
622
-
group-aria-[haspopup]:inline"
623
-
strokeWidth="3"
624
-
/>
625
-
</Aria.ListBoxItem> )
626
-
logged_in_users
627
-
|> Array.of_list |> array )
628
-
<Aria.ListBoxItem
629
-
className="flex flex-row items-center p-1 pl-2 text-mana-100 \
630
-
font-normal underline rounded-md \
631
-
focus-visible:outline-none \
632
-
data-hovered:text-mist-20 data-focused:text-mist-20 \
633
-
data-hovered:bg-mana-100 data-focused:bg-mana-100"
634
-
href=add_account_url>
635
-
(string "add account")
636
-
</Aria.ListBoxItem>
637
-
</Aria.ListBox>
638
-
</Aria.Popover>
639
-
</Aria.Select>
640
-
))]
641
-
</ClientOnly>
579
+
<AccountSwitcher current_user logged_in_users add_account_url inline=true
580
+
/>
642
581
(string " and granting it the following permissions:")
643
582
</span>
644
583
<ScopesTable scopes />
+257
pegasus/lib/api/account_/index.ml
+257
pegasus/lib/api/account_/index.ml
···
1
+
let has_valid_delete_code (actor : Data_store.Types.actor) =
2
+
match (actor.auth_code, actor.auth_code_expires_at) with
3
+
| Some code, Some expires_at ->
4
+
String.starts_with ~prefix:"del-" code && expires_at > Util.now_ms ()
5
+
| _ ->
6
+
false
7
+
8
+
let parse_email_change_code (actor : Data_store.Types.actor) =
9
+
match (actor.auth_code, actor.auth_code_expires_at) with
10
+
| 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
23
+
| _ ->
24
+
None
25
+
26
+
let get_handler =
27
+
Xrpc.handler (fun ctx ->
28
+
match%lwt Session.Raw.get_current_did ctx.req with
29
+
| None ->
30
+
Dream.redirect ctx.req "/account/login"
31
+
| Some did -> (
32
+
let%lwt logged_in_users =
33
+
Session.list_logged_in_actors ctx.req ctx.db
34
+
in
35
+
match%lwt Data_store.get_actor_by_identifier did ctx.db with
36
+
| None ->
37
+
Dream.redirect ctx.req "/account/login"
38
+
| Some actor ->
39
+
let current_user : Frontend.AccountSwitcher.actor =
40
+
{did= actor.did; handle= actor.handle; avatar_data_uri= None}
41
+
in
42
+
let csrf_token = Dream.csrf_token ctx.req in
43
+
let deactivated = actor.deactivated_at <> None in
44
+
let email_change_info = parse_email_change_code actor in
45
+
let email_change_pending = Option.is_some email_change_info in
46
+
let pending_email = Option.map snd email_change_info in
47
+
let delete_pending = has_valid_delete_code actor in
48
+
Util.render_html ~title:"Account"
49
+
(module Frontend.AccountPage)
50
+
~props:
51
+
{ current_user
52
+
; logged_in_users
53
+
; csrf_token
54
+
; handle= actor.handle
55
+
; email= actor.email
56
+
; deactivated
57
+
; email_change_pending
58
+
; pending_email
59
+
; email_error= None
60
+
; delete_pending
61
+
; error= None
62
+
; success= None
63
+
; delete_error= None } ) )
64
+
65
+
let post_handler =
66
+
Xrpc.handler (fun ctx ->
67
+
match%lwt Session.Raw.get_current_did ctx.req with
68
+
| None ->
69
+
Dream.redirect ctx.req "/account/login"
70
+
| Some did -> (
71
+
let%lwt logged_in_users =
72
+
Session.list_logged_in_actors ctx.req ctx.db
73
+
in
74
+
match%lwt Data_store.get_actor_by_identifier did ctx.db with
75
+
| None ->
76
+
Dream.redirect ctx.req "/account/login"
77
+
| Some actor -> (
78
+
let current_user : Frontend.AccountSwitcher.actor =
79
+
{did= actor.did; handle= actor.handle; avatar_data_uri= None}
80
+
in
81
+
let csrf_token = Dream.csrf_token ctx.req in
82
+
let render_page ?error ?success ?email_error ?delete_error () =
83
+
let%lwt actor_opt =
84
+
Data_store.get_actor_by_identifier did ctx.db
85
+
in
86
+
let actor = Option.get actor_opt in
87
+
let deactivated = actor.deactivated_at <> None in
88
+
let email_change_info = parse_email_change_code actor in
89
+
let email_change_pending = Option.is_some email_change_info in
90
+
let pending_email = Option.map snd email_change_info in
91
+
let delete_pending = has_valid_delete_code actor in
92
+
Util.render_html ~title:"Account"
93
+
(module Frontend.AccountPage)
94
+
~props:
95
+
{ current_user= {current_user with handle= actor.handle}
96
+
; logged_in_users
97
+
; csrf_token
98
+
; handle= actor.handle
99
+
; email= actor.email
100
+
; deactivated
101
+
; email_change_pending
102
+
; pending_email
103
+
; email_error
104
+
; delete_pending
105
+
; error
106
+
; success
107
+
; delete_error }
108
+
in
109
+
match%lwt Dream.form ctx.req with
110
+
| `Ok fields -> (
111
+
let action = List.assoc_opt "action" fields in
112
+
match action with
113
+
| Some "save" -> (
114
+
let new_handle =
115
+
List.assoc_opt "handle" fields
116
+
|> Option.value ~default:actor.handle
117
+
in
118
+
let new_password = List.assoc_opt "password" fields in
119
+
(* update handle if changed *)
120
+
let%lwt handle_result =
121
+
if new_handle <> actor.handle then
122
+
match Util.validate_handle new_handle with
123
+
| Error e ->
124
+
Lwt.return_error e
125
+
| Ok () -> (
126
+
match%lwt
127
+
Data_store.get_actor_by_identifier new_handle
128
+
ctx.db
129
+
with
130
+
| Some _ ->
131
+
Lwt.return_error "Handle already in use"
132
+
| None ->
133
+
let%lwt () =
134
+
Data_store.update_actor_handle ~did
135
+
~handle:new_handle ctx.db
136
+
in
137
+
Lwt.return_ok () )
138
+
else Lwt.return_ok ()
139
+
in
140
+
match handle_result with
141
+
| Error e ->
142
+
render_page ~error:e ()
143
+
| Ok () ->
144
+
(* update password if provided *)
145
+
let%lwt () =
146
+
match new_password with
147
+
| Some pw when String.length pw > 0 ->
148
+
Data_store.update_password ~did ~password:pw
149
+
ctx.db
150
+
| _ ->
151
+
Lwt.return_unit
152
+
in
153
+
render_page ~success:"Changes saved." () )
154
+
| Some "reactivate" ->
155
+
let%lwt () = Data_store.activate_actor did ctx.db in
156
+
let%lwt _ =
157
+
Sequencer.sequence_account ctx.db ~did ~active:true
158
+
~status:`Active ()
159
+
in
160
+
render_page ~success:"Your account has been reactivated."
161
+
()
162
+
| Some "deactivate" ->
163
+
let%lwt () = Data_store.deactivate_actor did ctx.db in
164
+
let%lwt _ =
165
+
Sequencer.sequence_account ctx.db ~did ~active:false
166
+
~status:`Deactivated ()
167
+
in
168
+
let%lwt () = Session.Raw.clear_session ctx.req in
169
+
Dream.redirect ctx.req "/account/login"
170
+
| Some "request_delete" ->
171
+
let code = "del-" ^ Mist.Tid.now () in
172
+
let expires_at = Util.now_ms () + (15 * 60 * 1000) in
173
+
let%lwt () =
174
+
Data_store.set_auth_code ~did ~code ~expires_at ctx.db
175
+
in
176
+
(* TODO: send email with code *)
177
+
Dream.log "delete account code for %s: %s" did code ;
178
+
render_page ()
179
+
| Some "confirm_delete" -> (
180
+
let token =
181
+
List.assoc_opt "token" fields
182
+
|> Option.value ~default:""
183
+
in
184
+
match (actor.auth_code, actor.auth_code_expires_at) with
185
+
| Some code, Some expires_at
186
+
when code = token && expires_at > Util.now_ms () ->
187
+
let%lwt () = Data_store.delete_actor did ctx.db in
188
+
let%lwt _ =
189
+
Sequencer.sequence_account ctx.db ~did ~active:false
190
+
~status:`Deleted ()
191
+
in
192
+
let%lwt () = Session.Raw.clear_session ctx.req in
193
+
Dream.redirect ctx.req "/account/login"
194
+
| _ ->
195
+
render_page
196
+
~delete_error:
197
+
"Invalid or expired confirmation code."
198
+
() )
199
+
| Some "cancel_delete" ->
200
+
let%lwt () = Data_store.clear_auth_code ~did ctx.db in
201
+
render_page ()
202
+
| Some "request_email_change" -> (
203
+
let new_email =
204
+
List.assoc_opt "new_email" fields
205
+
|> Option.value ~default:"" |> String.trim
206
+
in
207
+
if String.length new_email = 0 then
208
+
render_page
209
+
~email_error:"Please enter a new email address." ()
210
+
else if new_email = actor.email then
211
+
render_page
212
+
~email_error:"That's already your email address." ()
213
+
else
214
+
match%lwt
215
+
Data_store.get_actor_by_identifier new_email ctx.db
216
+
with
217
+
| Some _ ->
218
+
render_page ~email_error:"Email is already in use."
219
+
()
220
+
| None ->
221
+
let token = Mist.Tid.now () in
222
+
let code = "eml-" ^ token ^ ":" ^ new_email in
223
+
let expires_at =
224
+
Util.now_ms () + (15 * 60 * 1000)
225
+
in
226
+
let%lwt () =
227
+
Data_store.set_auth_code ~did ~code ~expires_at
228
+
ctx.db
229
+
in
230
+
(* TODO: send email with code *)
231
+
Dream.log "email change code for %s: %s" actor.email
232
+
code ;
233
+
render_page () )
234
+
| Some "confirm_email_change" -> (
235
+
let token =
236
+
List.assoc_opt "token" fields
237
+
|> Option.value ~default:"" |> String.trim
238
+
in
239
+
match parse_email_change_code actor with
240
+
| Some (stored_token, new_email) when stored_token = token
241
+
->
242
+
let%lwt () =
243
+
Data_store.update_email ~did ~email:new_email ctx.db
244
+
in
245
+
let%lwt () = Data_store.clear_auth_code ~did ctx.db in
246
+
render_page ~success:"Email address updated." ()
247
+
| _ ->
248
+
render_page
249
+
~email_error:"Invalid or expired verification code."
250
+
() )
251
+
| Some "cancel_email_change" ->
252
+
let%lwt () = Data_store.clear_auth_code ~did ctx.db in
253
+
render_page ()
254
+
| _ ->
255
+
render_page ~error:"Invalid action." () )
256
+
| _ ->
257
+
render_page ~error:"Invalid form submission." () ) ) )
+111
pegasus/lib/api/account_/permissions.ml
+111
pegasus/lib/api/account_/permissions.ml
···
1
+
let get_client_host client_id =
2
+
let uri = Uri.of_string client_id in
3
+
Uri.host uri |> Option.value ~default:client_id
4
+
5
+
let get_handler =
6
+
Xrpc.handler (fun ctx ->
7
+
match%lwt Session.Raw.get_current_did ctx.req with
8
+
| None ->
9
+
Dream.redirect ctx.req "/account/login"
10
+
| Some did -> (
11
+
let%lwt logged_in_users =
12
+
Session.list_logged_in_actors ctx.req ctx.db
13
+
in
14
+
match%lwt Data_store.get_actor_by_identifier did ctx.db with
15
+
| None ->
16
+
Dream.redirect ctx.req "/account/login"
17
+
| Some actor ->
18
+
let current_user : Frontend.AccountSwitcher.actor =
19
+
{did= actor.did; handle= actor.handle; avatar_data_uri= None}
20
+
in
21
+
let csrf_token = Dream.csrf_token ctx.req in
22
+
let%lwt clients =
23
+
Oauth.Queries.get_distinct_clients_by_did ctx.db did
24
+
in
25
+
let%lwt authorized_apps =
26
+
Lwt_list.filter_map_s
27
+
(fun (client_id, _last_refreshed) ->
28
+
try%lwt
29
+
let%lwt metadata =
30
+
Oauth.Client.fetch_client_metadata client_id
31
+
in
32
+
let app : Frontend.AccountPermissionsPage.authorized_app =
33
+
{ client_id
34
+
; client_name= metadata.client_name
35
+
; client_host= get_client_host client_id }
36
+
in
37
+
Lwt.return_some app
38
+
with _ ->
39
+
let app : Frontend.AccountPermissionsPage.authorized_app =
40
+
{ client_id
41
+
; client_name= None
42
+
; client_host= get_client_host client_id }
43
+
in
44
+
Lwt.return_some app )
45
+
clients
46
+
in
47
+
let%lwt device_rows =
48
+
Oauth.Queries.get_distinct_devices_by_did ctx.db did
49
+
in
50
+
let current_ip = Dream.client ctx.req in
51
+
let current_ua = Dream.header ctx.req "User-Agent" in
52
+
let devices =
53
+
List.map
54
+
(fun (last_ip, last_user_agent, last_refreshed_at) ->
55
+
let is_current =
56
+
last_ip = current_ip && last_user_agent = current_ua
57
+
in
58
+
( {last_ip; last_user_agent; last_refreshed_at; is_current}
59
+
: Frontend.AccountPermissionsPage.device ) )
60
+
device_rows
61
+
in
62
+
Util.render_html ~title:"Permissions"
63
+
(module Frontend.AccountPermissionsPage)
64
+
~props:
65
+
{ current_user
66
+
; logged_in_users
67
+
; csrf_token
68
+
; authorized_apps
69
+
; devices } ) )
70
+
71
+
let post_handler =
72
+
Xrpc.handler (fun ctx ->
73
+
match%lwt Session.Raw.get_current_did ctx.req with
74
+
| None ->
75
+
Dream.redirect ctx.req "/account/login"
76
+
| Some did -> (
77
+
match%lwt Dream.form ctx.req with
78
+
| `Ok fields -> (
79
+
let action = List.assoc_opt "action" fields in
80
+
match action with
81
+
| Some "revoke_app" -> (
82
+
let client_id = List.assoc_opt "client_id" fields in
83
+
match client_id with
84
+
| Some client_id ->
85
+
let%lwt () =
86
+
Oauth.Queries.delete_oauth_tokens_by_client ctx.db ~did
87
+
~client_id
88
+
in
89
+
Dream.redirect ctx.req "/account/permissions"
90
+
| None ->
91
+
Dream.redirect ctx.req "/account/permissions" )
92
+
| Some "sign_out_device" ->
93
+
let last_ip =
94
+
List.assoc_opt "last_ip" fields |> Option.value ~default:""
95
+
in
96
+
let last_user_agent =
97
+
match List.assoc_opt "last_user_agent" fields with
98
+
| Some "" ->
99
+
None
100
+
| other ->
101
+
other
102
+
in
103
+
let%lwt () =
104
+
Oauth.Queries.delete_oauth_tokens_by_device ctx.db ~did
105
+
~last_ip ~last_user_agent
106
+
in
107
+
Dream.redirect ctx.req "/account/permissions"
108
+
| _ ->
109
+
Dream.redirect ctx.req "/account/permissions" )
110
+
| _ ->
111
+
Dream.redirect ctx.req "/account/permissions" ) )
+5
pegasus/lib/auth.ml
+5
pegasus/lib/auth.ml
···
309
309
match%lwt Data_store.get_actor_by_identifier did db with
310
310
| Some {deactivated_at= None; _} ->
311
311
Lwt.return_ok (Access {did})
312
+
| Some {deactivated_at= Some _; _} when Dream.target req = "/account" ->
313
+
Lwt.return_ok (Access {did})
314
+
| Some {deactivated_at= Some _; _}
315
+
when String.starts_with ~prefix:"/account" (Dream.target req) ->
316
+
raise (Errors.Redirect "/account")
312
317
| Some {deactivated_at= Some _; _} ->
313
318
Lwt.return_error
314
319
@@ Errors.auth_required ~name:"AccountDeactivated"
+2
pegasus/lib/errors.ml
+2
pegasus/lib/errors.ml
+48
pegasus/lib/oauth/queries.ml
+48
pegasus/lib/oauth/queries.ml
···
140
140
|sql}
141
141
record_out]
142
142
~did
143
+
144
+
let get_distinct_clients_by_did conn did =
145
+
Util.use_pool conn
146
+
@@ [%rapper
147
+
get_many
148
+
{sql|
149
+
SELECT DISTINCT @string{client_id}, MAX(@int{last_refreshed_at}) as last_refreshed_at
150
+
FROM oauth_tokens
151
+
WHERE did = %string{did}
152
+
GROUP BY client_id
153
+
ORDER BY last_refreshed_at DESC
154
+
|sql}]
155
+
~did
156
+
157
+
let get_distinct_devices_by_did conn did =
158
+
Util.use_pool conn
159
+
@@ [%rapper
160
+
get_many
161
+
{sql|
162
+
SELECT @string{last_ip}, @string?{last_user_agent},
163
+
MAX(@int{last_refreshed_at}) as last_refreshed_at
164
+
FROM oauth_tokens
165
+
WHERE did = %string{did}
166
+
GROUP BY last_ip, last_user_agent
167
+
ORDER BY last_refreshed_at DESC
168
+
|sql}]
169
+
~did
170
+
171
+
let delete_oauth_tokens_by_client conn ~did ~client_id =
172
+
Util.use_pool conn
173
+
@@ [%rapper
174
+
execute
175
+
{sql|
176
+
DELETE FROM oauth_tokens
177
+
WHERE did = %string{did} AND client_id = %string{client_id}
178
+
|sql}]
179
+
~did ~client_id
180
+
181
+
let delete_oauth_tokens_by_device conn ~did ~last_ip ~last_user_agent =
182
+
Util.use_pool conn
183
+
@@ [%rapper
184
+
execute
185
+
{sql|
186
+
DELETE FROM oauth_tokens
187
+
WHERE did = %string{did} AND last_ip = %string{last_ip}
188
+
AND (last_user_agent = %string?{last_user_agent} OR (last_user_agent IS NULL AND %string?{last_user_agent} IS NULL))
189
+
|sql}]
190
+
~did ~last_ip ~last_user_agent
+2
-4
pegasus/lib/session.ml
+2
-4
pegasus/lib/session.ml
···
140
140
Lwt_list.filter_map_s
141
141
(fun did ->
142
142
match%lwt Data_store.get_actor_by_identifier did db with
143
-
| Some {deactivated_at= None; handle; _} -> (
143
+
| Some {handle; _} -> (
144
144
let actor : Frontend.OauthAuthorizePage.actor =
145
145
{did; handle; avatar_data_uri= None}
146
146
in
···
164
164
Lwt.return_some actor )
165
165
| None ->
166
166
Lwt.return_some actor )
167
-
| Some {deactivated_at= Some _; _} ->
168
-
Lwt.return_none
169
-
| None ->
167
+
| _ ->
170
168
Lwt.return_none )
171
169
dids
+16
-11
pegasus/lib/xrpc.ml
+16
-11
pegasus/lib/xrpc.ml
···
9
9
10
10
let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) =
11
11
let open Errors in
12
-
let auth = Auth.Verifiers.of_t auth in
13
-
try%lwt
14
-
match%lwt auth init with
15
-
| Ok creds -> (
16
-
try%lwt hdlr {req= init.req; db= init.db; auth= creds}
17
-
with e ->
12
+
try
13
+
let auth = Auth.Verifiers.of_t auth in
14
+
try%lwt
15
+
match%lwt auth init with
16
+
| Ok creds -> (
17
+
try%lwt hdlr {req= init.req; db= init.db; auth= creds}
18
+
with e ->
19
+
if not (is_xrpc_error e) then log_exn ~req:init.req e ;
20
+
exn_to_response e )
21
+
| Error e ->
22
+
exn_to_response e
23
+
with
24
+
| Redirect r ->
25
+
Dream.redirect init.req r
26
+
| e ->
18
27
if not (is_xrpc_error e) then log_exn ~req:init.req e ;
19
-
exn_to_response e )
20
-
| Error e ->
21
28
exn_to_response e
22
-
with e ->
23
-
if not (is_xrpc_error e) then log_exn ~req:init.req e ;
24
-
exn_to_response e
29
+
with Redirect r -> Dream.redirect init.req r
25
30
26
31
let parse_query (req : Dream.request)
27
32
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a =