objective categorical abstract machine language personal data server
Add OAuth scopes module
+426
+426
pegasus/lib/oauth/scopes.ml
+426
pegasus/lib/oauth/scopes.ml
···
1
+
type account_attr = Email | Repo | Status
2
+
3
+
type account_action = Read | Manage
4
+
5
+
type account_permission = {attr: account_attr; actions: account_action list}
6
+
7
+
type identity_attr = Handle | Any
8
+
9
+
type identity_permission = {attr: identity_attr}
10
+
11
+
type repo_action = Create | Update | Delete
12
+
13
+
type repo_collection = All | Collection of string
14
+
15
+
type repo_permission =
16
+
{collections: repo_collection list; actions: repo_action list}
17
+
18
+
type rpc_lxm = AnyLxm | Lxm of string
19
+
20
+
type rpc_aud = AnyAud | Aud of string
21
+
22
+
type rpc_permission = {lxm: rpc_lxm list; aud: rpc_aud}
23
+
24
+
type accept_pattern =
25
+
| AnyMime (** */* *)
26
+
| TypeWildcard of string (** e.g. image/* *)
27
+
| ExactMime of string * string (** e.g. image/png *)
28
+
29
+
type blob_permission = {accept: accept_pattern list}
30
+
31
+
type static_scope =
32
+
| Atproto
33
+
| TransitionEmail
34
+
| TransitionGeneric
35
+
| TransitionChatBsky
36
+
37
+
type scope =
38
+
| Static of static_scope
39
+
| Account of account_permission
40
+
| Identity of identity_permission
41
+
| Repo of repo_permission
42
+
| Rpc of rpc_permission
43
+
| Blob of blob_permission
44
+
45
+
let is_valid_nsid s =
46
+
let segments = String.split_on_char '.' s in
47
+
let valid_segment seg =
48
+
String.length seg > 0
49
+
&& String.for_all
50
+
(fun c ->
51
+
(c >= 'a' && c <= 'z')
52
+
|| (c >= 'A' && c <= 'Z')
53
+
|| (c >= '0' && c <= '9')
54
+
|| c = '-' )
55
+
seg
56
+
in
57
+
List.length segments >= 3 && List.for_all valid_segment segments
58
+
59
+
let parse_params s =
60
+
if s = "" then []
61
+
else
62
+
String.split_on_char '&' s
63
+
|> List.filter_map (fun pair ->
64
+
match String.split_on_char '=' pair with
65
+
| [k; v] ->
66
+
Some (Uri.pct_decode k, Uri.pct_decode v)
67
+
| [k] ->
68
+
Some (Uri.pct_decode k, "")
69
+
| _ ->
70
+
None )
71
+
72
+
let get_all_params key params =
73
+
List.filter_map (fun (k, v) -> if k = key then Some v else None) params
74
+
75
+
let get_single_param key params =
76
+
match get_all_params key params with [v] -> Some v | _ -> None
77
+
78
+
let parse_scope_syntax s =
79
+
let qmark_idx = String.index_opt s '?' in
80
+
let colon_idx = String.index_opt s ':' in
81
+
let prefix_end =
82
+
match (qmark_idx, colon_idx) with
83
+
| None, None ->
84
+
String.length s
85
+
| Some q, None ->
86
+
q
87
+
| None, Some c ->
88
+
c
89
+
| Some q, Some c ->
90
+
min q c
91
+
in
92
+
let prefix = String.sub s 0 prefix_end in
93
+
let positional =
94
+
match colon_idx with
95
+
| Some c when c = prefix_end ->
96
+
let end_pos =
97
+
match qmark_idx with Some q -> q | None -> String.length s
98
+
in
99
+
if end_pos > c + 1 then
100
+
Some (Uri.pct_decode (String.sub s (c + 1) (end_pos - c - 1)))
101
+
else None
102
+
| _ ->
103
+
None
104
+
in
105
+
let params =
106
+
match qmark_idx with
107
+
| Some q when q < String.length s - 1 ->
108
+
parse_params (String.sub s (q + 1) (String.length s - q - 1))
109
+
| _ ->
110
+
[]
111
+
in
112
+
(prefix, positional, params)
113
+
114
+
let parse_account_attr = function
115
+
| "email" ->
116
+
Some Email
117
+
| "repo" ->
118
+
Some Repo
119
+
| "status" ->
120
+
Some Status
121
+
| _ ->
122
+
None
123
+
124
+
let parse_account_action = function
125
+
| "read" ->
126
+
Some Read
127
+
| "manage" ->
128
+
Some Manage
129
+
| _ ->
130
+
None
131
+
132
+
let parse_account_permission positional params =
133
+
let attr = positional |> Option.map parse_account_attr |> Option.join in
134
+
let action_strs = get_all_params "action" params in
135
+
let actions =
136
+
if action_strs = [] then [Read]
137
+
else List.filter_map parse_account_action action_strs
138
+
in
139
+
match (actions, attr) with
140
+
| _action :: _, Some attr ->
141
+
Some {attr; actions}
142
+
| _ ->
143
+
None
144
+
145
+
let parse_identity_attr = function
146
+
| "handle" ->
147
+
Some Handle
148
+
| "*" ->
149
+
Some Any
150
+
| _ ->
151
+
None
152
+
153
+
let parse_identity_permission positional _params =
154
+
positional
155
+
|> Option.map parse_identity_attr
156
+
|> Option.join
157
+
|> Option.map (fun attr -> {attr})
158
+
159
+
let parse_repo_action = function
160
+
| "create" ->
161
+
Some Create
162
+
| "update" ->
163
+
Some Update
164
+
| "delete" ->
165
+
Some Delete
166
+
| _ ->
167
+
None
168
+
169
+
let all_repo_actions = [Create; Update; Delete]
170
+
171
+
let parse_repo_collection s =
172
+
if s = "*" then Some All
173
+
else if is_valid_nsid s then Some (Collection s)
174
+
else None
175
+
176
+
let parse_repo_permission positional params =
177
+
let collection_strs =
178
+
match positional with
179
+
| Some p ->
180
+
[p]
181
+
| None ->
182
+
get_all_params "collection" params
183
+
in
184
+
if collection_strs = [] then None
185
+
else
186
+
let collections = List.filter_map parse_repo_collection collection_strs in
187
+
if collections = [] then None
188
+
else
189
+
let action_strs = get_all_params "action" params in
190
+
let actions =
191
+
if action_strs = [] then all_repo_actions
192
+
else List.filter_map parse_repo_action action_strs
193
+
in
194
+
if actions = [] then None else Some {collections; actions}
195
+
196
+
let parse_rpc_lxm s =
197
+
if s = "*" then Some AnyLxm
198
+
else if is_valid_nsid s then Some (Lxm s)
199
+
else None
200
+
201
+
let is_valid_atproto_audience s =
202
+
let parts = String.split_on_char '#' s in
203
+
match parts with
204
+
| [did] | [did; _] -> (
205
+
match String.split_on_char ':' did with
206
+
| "did" :: method_ :: _ when String.length method_ > 0 ->
207
+
true
208
+
| _ ->
209
+
false )
210
+
| _ ->
211
+
false
212
+
213
+
let parse_rpc_aud s =
214
+
if s = "*" then Some AnyAud
215
+
else if is_valid_atproto_audience s then Some (Aud s)
216
+
else None
217
+
218
+
let parse_rpc_permission positional params =
219
+
let lxm_strs =
220
+
match positional with Some p -> [p] | None -> get_all_params "lxm" params
221
+
in
222
+
if lxm_strs = [] then None
223
+
else
224
+
let lxms = List.filter_map parse_rpc_lxm lxm_strs in
225
+
if lxms = [] then None
226
+
else
227
+
match get_single_param "aud" params with
228
+
| None ->
229
+
None (* aud is required *)
230
+
| Some aud_str -> (
231
+
match parse_rpc_aud aud_str with
232
+
| None ->
233
+
None
234
+
| Some aud ->
235
+
(* rpc:*?aud=* is forbidden *)
236
+
if aud = AnyAud && List.mem AnyLxm lxms then None
237
+
else Some {lxm= lxms; aud} )
238
+
239
+
let parse_accept_pattern s =
240
+
if s = "*/*" then Some AnyMime
241
+
else
242
+
match String.split_on_char '/' s with
243
+
| [type_; "*"] when String.length type_ > 0 ->
244
+
Some (TypeWildcard type_)
245
+
| [type_; subtype]
246
+
when String.length type_ > 0
247
+
&& String.length subtype > 0
248
+
&& (not (String.contains type_ '*'))
249
+
&& not (String.contains subtype '*') ->
250
+
Some (ExactMime (type_, subtype))
251
+
| _ ->
252
+
None
253
+
254
+
let parse_blob_permission positional params =
255
+
let accept_strs =
256
+
match positional with
257
+
| Some p ->
258
+
[p]
259
+
| None ->
260
+
get_all_params "accept" params
261
+
in
262
+
if accept_strs = [] then None
263
+
else
264
+
let accepts = List.filter_map parse_accept_pattern accept_strs in
265
+
if accepts = [] then None else Some {accept= accepts}
266
+
267
+
let parse_static_scope = function
268
+
| "atproto" ->
269
+
Some (Static Atproto)
270
+
| "transition:email" ->
271
+
Some (Static TransitionEmail)
272
+
| "transition:generic" ->
273
+
Some (Static TransitionGeneric)
274
+
| "transition:chat.bsky" ->
275
+
Some (Static TransitionChatBsky)
276
+
| _ ->
277
+
None
278
+
279
+
let parse_scope s =
280
+
match parse_static_scope s with
281
+
| Some scope ->
282
+
Some scope
283
+
| None -> (
284
+
let prefix, positional, params = parse_scope_syntax s in
285
+
match prefix with
286
+
| "account" ->
287
+
Option.map
288
+
(fun p -> Account p)
289
+
(parse_account_permission positional params)
290
+
| "identity" ->
291
+
Option.map
292
+
(fun p -> Identity p)
293
+
(parse_identity_permission positional params)
294
+
| "repo" ->
295
+
Option.map (fun p -> Repo p) (parse_repo_permission positional params)
296
+
| "rpc" ->
297
+
Option.map (fun p -> Rpc p) (parse_rpc_permission positional params)
298
+
| "blob" ->
299
+
Option.map (fun p -> Blob p) (parse_blob_permission positional params)
300
+
| _ ->
301
+
None )
302
+
303
+
let parse_scopes s =
304
+
if s = "" then []
305
+
else
306
+
String.split_on_char ' ' s
307
+
|> List.filter (fun s -> s <> "")
308
+
|> List.filter_map parse_scope
309
+
310
+
type account_match = {attr: account_attr; action: account_action}
311
+
312
+
type identity_match = {attr: identity_attr}
313
+
314
+
type repo_match = {collection: string; action: repo_action}
315
+
316
+
type rpc_match = {lxm: string; aud: string}
317
+
318
+
type blob_match = {mime: string}
319
+
320
+
let account_permission_matches (perm : account_permission) (opts : account_match)
321
+
=
322
+
perm.attr = opts.attr
323
+
&& (List.mem Manage perm.actions || List.mem opts.action perm.actions)
324
+
325
+
let identity_permission_matches (perm : identity_permission)
326
+
(opts : identity_match) =
327
+
perm.attr = Any || perm.attr = opts.attr
328
+
329
+
let repo_permission_matches perm (opts : repo_match) =
330
+
List.mem opts.action perm.actions
331
+
&& ( List.mem All perm.collections
332
+
|| List.mem (Collection opts.collection) perm.collections )
333
+
334
+
let rpc_permission_matches (perm : rpc_permission) (opts : rpc_match) =
335
+
(perm.aud = AnyAud || perm.aud = Aud opts.aud)
336
+
&& (List.mem AnyLxm perm.lxm || List.mem (Lxm opts.lxm) perm.lxm)
337
+
338
+
let accept_matches_mime pattern mime =
339
+
match pattern with
340
+
| AnyMime ->
341
+
true
342
+
| TypeWildcard t -> (
343
+
match String.split_on_char '/' mime with
344
+
| [type_; _subtype]
345
+
when (not (String.contains type_ '*'))
346
+
&& not (String.contains _subtype '*') ->
347
+
String.lowercase_ascii type_ = String.lowercase_ascii t
348
+
| _ ->
349
+
false )
350
+
| ExactMime (t, s) -> (
351
+
match String.split_on_char '/' mime with
352
+
| [type_; subtype]
353
+
when (not (String.contains type_ '*'))
354
+
&& not (String.contains subtype '*') ->
355
+
String.lowercase_ascii type_ = String.lowercase_ascii t
356
+
&& String.lowercase_ascii subtype = String.lowercase_ascii s
357
+
| _ ->
358
+
false )
359
+
360
+
let blob_permission_matches perm (opts : blob_match) =
361
+
List.exists (fun pat -> accept_matches_mime pat opts.mime) perm.accept
362
+
363
+
type t = scope list
364
+
365
+
let of_string s = parse_scopes s
366
+
367
+
let of_list strs = List.filter_map parse_scope strs
368
+
369
+
let allows_account scopes opts =
370
+
List.exists
371
+
(fun scope ->
372
+
match scope with
373
+
| Account perm ->
374
+
account_permission_matches perm opts
375
+
| _ ->
376
+
false )
377
+
scopes
378
+
379
+
let allows_identity scopes opts =
380
+
List.exists
381
+
(fun scope ->
382
+
match scope with
383
+
| Identity perm ->
384
+
identity_permission_matches perm opts
385
+
| _ ->
386
+
false )
387
+
scopes
388
+
389
+
let allows_repo scopes opts =
390
+
List.exists
391
+
(fun scope ->
392
+
match scope with
393
+
| Repo perm ->
394
+
repo_permission_matches perm opts
395
+
| _ ->
396
+
false )
397
+
scopes
398
+
399
+
let allows_rpc scopes opts =
400
+
List.exists
401
+
(fun scope ->
402
+
match scope with
403
+
| Rpc perm ->
404
+
rpc_permission_matches perm opts
405
+
| _ ->
406
+
false )
407
+
scopes
408
+
409
+
let allows_blob scopes opts =
410
+
List.exists
411
+
(fun scope ->
412
+
match scope with
413
+
| Blob perm ->
414
+
blob_permission_matches perm opts
415
+
| _ ->
416
+
false )
417
+
scopes
418
+
419
+
let has_atproto scopes = List.mem (Static Atproto) scopes
420
+
421
+
let has_transition_email scopes = List.mem (Static TransitionEmail) scopes
422
+
423
+
let has_transition_generic scopes = List.mem (Static TransitionGeneric) scopes
424
+
425
+
let has_transition_chat_bsky scopes =
426
+
List.mem (Static TransitionChatBsky) scopes