objective categorical abstract machine language personal data server
Various proxying-related fixes
+86
-74
+1
bin/main.ml
+1
bin/main.ml
+49
-49
pegasus/lib/api/proxy/appBskyFeedGetFeed.ml
+49
-49
pegasus/lib/api/proxy/appBskyFeedGetFeed.ml
···
11
11
| None ->
12
12
Errors.invalid_request ("invalid feed URI " ^ input.feed)
13
13
| Some {repo; collection; rkey; _} -> (
14
-
match%lwt Id_resolver.Did.resolve repo with
15
-
| Error e ->
16
-
Errors.internal_error
17
-
~msg:("failed to resolve feed publisher " ^ repo ^ ": " ^ e)
18
-
()
19
-
| Ok did_doc -> (
20
-
let pds_host =
21
-
match
22
-
Option.bind
23
-
(Id_resolver.Did.Document.get_service did_doc "#atproto_pds")
24
-
(fun s -> s |> Uri.of_string |> Uri.host )
25
-
with
26
-
| Some endpoint ->
27
-
endpoint
28
-
| None ->
29
-
Errors.invalid_request "feed publisher has no PDS endpoint"
30
-
in
31
-
let get_record_uri =
32
-
Uri.make ~scheme:"https" ~host:pds_host
33
-
~path:"/xrpc/com.atproto.repo.getRecord"
34
-
~query:
35
-
[ ("repo", [repo])
36
-
; ("collection", [collection])
37
-
; ("rkey", [rkey]) ]
14
+
match%lwt Id_resolver.Did.resolve repo with
15
+
| Error e ->
16
+
Errors.internal_error
17
+
~msg:("failed to resolve feed publisher " ^ repo ^ ": " ^ e)
38
18
()
39
-
in
40
-
let%lwt res, body = Util.http_get get_record_uri in
41
-
match res.status with
42
-
| `OK -> (
43
-
let%lwt body_str = Cohttp_lwt.Body.to_string body in
44
-
let json = Yojson.Safe.from_string body_str in
45
-
let value = Yojson.Safe.Util.(json |> member "value") in
46
-
let feed_generator_did =
47
-
Yojson.Safe.Util.(value |> member "did" |> to_string_option)
48
-
in
49
-
match feed_generator_did with
19
+
| Ok did_doc -> (
20
+
let pds_host =
21
+
match
22
+
Option.bind
23
+
(Id_resolver.Did.Document.get_service did_doc "#atproto_pds")
24
+
(fun s -> s |> Uri.of_string |> Uri.host )
25
+
with
26
+
| Some endpoint ->
27
+
endpoint
50
28
| None ->
51
-
Errors.invalid_request
52
-
"feed generator record missing 'did' field"
53
-
| Some fg_did -> (
54
-
match Dream.header ctx.req "atproto-proxy" with
55
-
| Some appview ->
56
-
Auth.assert_rpc_scope ctx.auth
57
-
~lxm:"app.bsky.feed.getFeed" ~aud:appview ;
58
-
Xrpc.service_proxy ctx ~aud:fg_did
59
-
~lxm:"app.bsky.feed.getFeedSkeleton"
29
+
Errors.invalid_request "feed publisher has no PDS endpoint"
30
+
in
31
+
let get_record_uri =
32
+
Uri.make ~scheme:"https" ~host:pds_host
33
+
~path:"/xrpc/com.atproto.repo.getRecord"
34
+
~query:
35
+
[ ("repo", [repo])
36
+
; ("collection", [collection])
37
+
; ("rkey", [rkey]) ]
38
+
()
39
+
in
40
+
let%lwt res, body = Util.http_get get_record_uri in
41
+
match res.status with
42
+
| `OK -> (
43
+
let%lwt body_str = Cohttp_lwt.Body.to_string body in
44
+
let json = Yojson.Safe.from_string body_str in
45
+
let value = Yojson.Safe.Util.(json |> member "value") in
46
+
let feed_generator_did =
47
+
Yojson.Safe.Util.(value |> member "did" |> to_string_option)
48
+
in
49
+
match feed_generator_did with
60
50
| None ->
61
-
Errors.invalid_request "missing proxy header" ) )
62
-
| _ ->
63
-
let%lwt () = Cohttp_lwt.Body.drain_body body in
64
-
Errors.internal_error
65
-
~msg:"failed to fetch feed generator record" () ) ) )
51
+
Errors.invalid_request
52
+
"feed generator record missing 'did' field"
53
+
| Some fg_did -> (
54
+
match Dream.header ctx.req "atproto-proxy" with
55
+
| Some appview ->
56
+
Auth.assert_rpc_scope ctx.auth
57
+
~lxm:"app.bsky.feed.getFeed" ~aud:appview ;
58
+
Xrpc.service_proxy ctx ~aud:fg_did
59
+
~lxm:"app.bsky.feed.getFeedSkeleton"
60
+
| None ->
61
+
Errors.invalid_request "missing proxy header" ) )
62
+
| _ ->
63
+
let%lwt () = Cohttp_lwt.Body.drain_body body in
64
+
Errors.internal_error
65
+
~msg:"failed to fetch feed generator record" () ) ) )
+2
-2
pegasus/lib/auth.ml
+2
-2
pegasus/lib/auth.ml
···
6
6
; email: string
7
7
; email_confirmed: bool [@key "emailConfirmed"]
8
8
; email_auth_factor: bool [@key "emailAuthFactor"]
9
-
; active: bool option
10
-
; status: string option }
9
+
; active: bool option [@default None]
10
+
; status: string option [@default None] }
11
11
[@@deriving yojson {strict= false}]
12
12
13
13
type credentials =
+5
-1
pegasus/lib/errors.ml
+5
-1
pegasus/lib/errors.ml
···
36
36
| AuthError (error, message) ->
37
37
format_response error message `Unauthorized
38
38
| UseDpopNonceError ->
39
-
Dream.json ~status:`Bad_Request {|{ "error": "use_dpop_nonce" }|}
39
+
Dream.json ~status:`Bad_Request
40
+
~headers:
41
+
[ ("WWW-Authenticate", {|DPoP error="use_dpop_nonce"|})
42
+
; ("Access-Control-Expose-Headers", "WWW-Authenticate") ]
43
+
{|{ "error": "use_dpop_nonce" }|}
40
44
| _ ->
41
45
format_response "InternalServerError" "Internal server error"
42
46
`Internal_Server_Error
+6
-9
pegasus/lib/util.ml
+6
-9
pegasus/lib/util.ml
···
339
339
if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit
340
340
in
341
341
match status with
342
-
| `OK ->
343
-
Lwt.return (response, body)
344
342
| `Permanent_redirect | `Moved_permanently ->
345
343
handle_redirect ~permanent:true ~max_redirects request_uri response
346
344
| `Found | `Temporary_redirect ->
347
345
handle_redirect ~permanent:false ~max_redirects request_uri response
348
-
| `Not_found | `Gone ->
349
-
failwith "not found"
350
-
| status ->
351
-
Printf.ksprintf failwith "unhandled status: %s"
352
-
(Cohttp.Code.string_of_status status)
346
+
| _ ->
347
+
Lwt.return (response, body)
353
348
354
349
and handle_redirect ~permanent ~max_redirects request_uri response =
355
350
if max_redirects <= 0 then failwith "too many redirects"
···
438
433
match Re.exec_opt at_uri_regexp uri with
439
434
| None ->
440
435
None
441
-
| Some m ->
436
+
| Some m -> (
437
+
try
442
438
Some
443
439
{ repo= Re.Group.get m 1
444
440
; collection= Re.Group.get m 2
445
441
; rkey= Re.Group.get m 3
446
-
; fragment= (match Re.Group.get m 4 with "" -> None | f -> Some f) }
442
+
; fragment= Re.Group.get_opt m 4 }
443
+
with _ -> None )
447
444
448
445
let make_at_uri ~repo ~collection ~rkey ~fragment =
449
446
Printf.sprintf "at://%s/%s/%s%s" repo collection rkey
+23
-13
pegasus/lib/xrpc.ml
+23
-13
pegasus/lib/xrpc.ml
···
27
27
(of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a =
28
28
try
29
29
let queries = Dream.all_queries req in
30
-
let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in
30
+
let query_json =
31
+
`Assoc
32
+
(List.map
33
+
(fun (k, v) ->
34
+
(k, try Yojson.Safe.from_string v with _ -> `String v) )
35
+
queries )
36
+
in
31
37
query_json |> of_yojson |> Result.get_ok
32
38
with _ -> Errors.invalid_request "invalid query string"
33
39
···
95
101
in
96
102
let signing_key = Kleidos.parse_multikey_str signing_multikey in
97
103
let jwt = Jwt.generate_service_jwt ~did ~aud ~lxm ~signing_key in
98
-
let uri =
99
-
Uri.make ~scheme ~host
100
-
~path:(String.concat "/" @@ (Dream.path [@warning "-3"]) ctx.req)
101
-
~query:(Util.copy_query ctx.req) ()
102
-
in
104
+
let path, _ = Dream.split_target (Dream.target ctx.req) in
105
+
let query = Util.copy_query ctx.req in
106
+
let uri = Uri.make ~scheme ~host ~path ~query () in
103
107
let headers =
104
108
Util.make_headers
105
109
[ ("accept-language", Dream.header ctx.req "accept-language")
···
111
115
match Dream.method_ ctx.req with
112
116
| `GET -> (
113
117
let%lwt res, body = Util.http_get uri ~headers in
118
+
let res_headers =
119
+
Cohttp.Response.headers res |> Cohttp.Header.to_list
120
+
in
114
121
match res.status with
115
122
| `OK ->
116
-
Dream.stream ~status:`OK (fun stream ->
123
+
Dream.stream ~status:`OK ~headers:res_headers (fun stream ->
117
124
Body.to_stream body |> Lwt_stream.iter_s (Dream.write stream) )
118
125
| e ->
119
126
let%lwt () = Body.drain_body body in
···
126
133
let%lwt res, body =
127
134
Client.post uri ~headers ~body:(Body.of_string req_body)
128
135
in
136
+
let res_headers =
137
+
Cohttp.Response.headers res |> Cohttp.Header.to_list
138
+
in
129
139
match res.status with
130
140
| `OK ->
131
-
Dream.stream ~status:`OK (fun stream ->
141
+
Dream.stream ~status:`OK ~headers:res_headers (fun stream ->
132
142
Body.to_stream body |> Lwt_stream.iter_s (Dream.write stream) )
133
143
| e ->
134
144
let%lwt () = Body.drain_body body in
···
154
164
let%lwt res = inner_handler req in
155
165
match Dream.header req "DPoP" with
156
166
| Some _ ->
157
-
Dream.add_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ;
167
+
Dream.set_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ;
158
168
Dream.add_header res "Access-Control-Expose-Headers" "DPoP-Nonce" ;
159
169
Lwt.return res
160
170
| None ->
···
163
173
let cors_middleware inner_handler req =
164
174
let%lwt res = inner_handler req in
165
175
let origin = Dream.header req "Origin" in
166
-
Dream.add_header res "Access-Control-Allow-Origin"
176
+
Dream.set_header res "Access-Control-Allow-Origin"
167
177
(Option.value origin ~default:"*") ;
168
-
Dream.add_header res "Access-Control-Allow-Methods"
178
+
Dream.set_header res "Access-Control-Allow-Methods"
169
179
"GET, POST, PUT, DELETE, OPTIONS" ;
170
-
Dream.add_header res "Access-Control-Allow-Headers" "*" ;
171
-
Dream.add_header res "Access-Control-Max-Age" "86400" ;
180
+
Dream.set_header res "Access-Control-Allow-Headers" "*" ;
181
+
Dream.set_header res "Access-Control-Max-Age" "86400" ;
172
182
Lwt.return res
173
183
174
184
let resolve_repo_did ctx repo =