objective categorical abstract machine language personal data server
Pass through non-200 proxied status codes
+30
-50
+5
-4
pegasus/lib/util.ml
+5
-4
pegasus/lib/util.ml
···
407
407
|> String.split_on_char ',' |> List.hd |> String.split_on_char ':' |> List.hd
408
408
|> String.trim
409
409
410
-
let rec http_get ?(max_redirects = 5) ?headers uri =
410
+
let rec http_get ?(max_redirects = 5) ?(no_drain = false) ?headers uri =
411
411
let ua = "pegasus (" ^ Env.host_endpoint ^ ")" in
412
412
let headers =
413
413
match headers with
···
417
417
Http.Header.of_list [("User-Agent", ua)]
418
418
in
419
419
let%lwt ans = Cohttp_lwt_unix.Client.get ~headers uri in
420
-
follow_redirect ~max_redirects uri ans
420
+
follow_redirect ~max_redirects ~no_drain uri ans
421
421
422
-
and follow_redirect ~max_redirects request_uri (response, body) =
422
+
and follow_redirect ~max_redirects ~no_drain request_uri (response, body) =
423
423
let status = Http.Response.status response in
424
424
(* the unconsumed body would otherwise leak memory *)
425
425
let%lwt () =
426
-
if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit
426
+
if status <> `OK && not no_drain then Cohttp_lwt.Body.drain_body body
427
+
else Lwt.return_unit
427
428
in
428
429
match status with
429
430
| `Permanent_redirect | `Moved_permanently ->
+25
-46
pegasus/lib/xrpc.ml
+25
-46
pegasus/lib/xrpc.ml
···
251
251
let rpc_aud = aud ^ fragment in
252
252
Auth.assert_rpc_scope ctx.auth ~aud:rpc_aud ~lxm ;
253
253
match%lwt Id_resolver.Did.resolve service_did with
254
-
| Ok did_doc -> (
254
+
| Ok did_doc ->
255
255
let scheme, host =
256
256
match Id_resolver.Did.Document.get_service did_doc fragment with
257
257
| Some service -> (
···
286
286
, Dream.header ctx.req "atproto-accept-labelers" )
287
287
; ("authorization", Some ("Bearer " ^ jwt)) ]
288
288
in
289
-
match Dream.method_ ctx.req with
290
-
| `GET -> (
291
-
let%lwt res, body =
292
-
try%lwt
293
-
Lwt_unix.with_timeout 15.0 (fun () -> Util.http_get uri ~headers)
294
-
with Lwt_unix.Timeout ->
295
-
Errors.internal_error ~msg:"proxy request timed out" ()
296
-
in
297
-
let res_headers =
298
-
Cohttp.Response.headers res |> Cohttp.Header.to_list
299
-
in
300
-
match res.status with
301
-
| `OK ->
302
-
Dream.stream ~status:`OK ~headers:res_headers (fun stream ->
303
-
Body.to_stream body |> Lwt_stream.iter_s (Dream.write stream) )
304
-
| e ->
305
-
let%lwt () = Body.drain_body body in
306
-
Log.err (fun log ->
307
-
log "error when proxying to %s: %s" (Uri.to_string uri)
308
-
(Http.Status.to_string e) ) ;
309
-
Errors.internal_error ~msg:"failed to proxy request" () )
310
-
| `POST -> (
311
-
let%lwt req_body = Dream.body ctx.req in
312
-
let%lwt res, body =
313
-
try%lwt
314
-
Lwt_unix.with_timeout 15.0 (fun () ->
315
-
Client.post uri ~headers ~body:(Body.of_string req_body) )
316
-
with Lwt_unix.Timeout ->
317
-
Errors.internal_error ~msg:"proxy request timed out" ()
318
-
in
319
-
let res_headers =
320
-
Cohttp.Response.headers res |> Cohttp.Header.to_list
321
-
in
322
-
match res.status with
323
-
| `OK ->
324
-
Dream.stream ~status:`OK ~headers:res_headers (fun stream ->
325
-
Body.to_stream body |> Lwt_stream.iter_s (Dream.write stream) )
326
-
| e ->
327
-
let%lwt () = Body.drain_body body in
328
-
Log.err (fun log ->
329
-
log "error when proxying to %s: %s" (Uri.to_string uri)
330
-
(Http.Status.to_string e) ) ;
331
-
Errors.internal_error ~msg:"failed to proxy request" () )
332
-
| _ ->
333
-
Errors.invalid_request "unsupported method" )
289
+
let%lwt res, body =
290
+
try%lwt
291
+
Lwt_unix.with_timeout 30.0 (fun () ->
292
+
match Dream.method_ ctx.req with
293
+
| `GET ->
294
+
Util.http_get uri ~headers ~no_drain:true
295
+
| `POST ->
296
+
let%lwt req_body = Dream.body ctx.req in
297
+
Client.post uri ~headers ~body:(Body.of_string req_body)
298
+
| _ ->
299
+
Errors.invalid_request "unsupported method" )
300
+
with Lwt_unix.Timeout ->
301
+
Errors.internal_error ~msg:"proxy request timed out" ()
302
+
in
303
+
let res_headers = Cohttp.Response.headers res |> Cohttp.Header.to_list in
304
+
if res.status <> `OK then
305
+
Log.err (fun log ->
306
+
log "error when proxying to %s: %s" (Uri.to_string uri)
307
+
(Http.Status.to_string res.status) ) ;
308
+
Dream.stream
309
+
~status:(Dream.int_to_status (Http.Status.to_int res.status))
310
+
~headers:res_headers
311
+
(fun stream ->
312
+
Body.to_stream body |> Lwt_stream.iter_s (Dream.write stream) )
334
313
| Error e ->
335
314
Log.err (fun log -> log "error when resolving destination service: %s" e) ;
336
315
Errors.internal_error ~msg:"failed to resolve destination service" ()