Merge pull request 'Add .gitignore and .ocamlformat' (#1) from ocamlformat into main
Reviewed-on: https://git.robur.io/robur/http-mirage-client/pulls/1
This commit is contained in:
commit
5fe7693c52
4 changed files with 270 additions and 179 deletions
11
.gitignore
vendored
Normal file
11
.gitignore
vendored
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
_build
|
||||||
|
setup.data
|
||||||
|
setup.log
|
||||||
|
doc/*.html
|
||||||
|
*.native
|
||||||
|
*.byte
|
||||||
|
*.so
|
||||||
|
*.tar.gz
|
||||||
|
_tests
|
||||||
|
*.merlin
|
||||||
|
*.install
|
17
.ocamlformat
Normal file
17
.ocamlformat
Normal file
|
@ -0,0 +1,17 @@
|
||||||
|
version=0.23.0
|
||||||
|
profile=conventional
|
||||||
|
break-struct=natural
|
||||||
|
break-infix=fit-or-vertical
|
||||||
|
break-sequences=false
|
||||||
|
break-collection-expressions=wrap
|
||||||
|
break-separators=before
|
||||||
|
exp-grouping=preserve
|
||||||
|
parens-tuple=multi-line-only
|
||||||
|
space-around-lists=false
|
||||||
|
space-around-records=false
|
||||||
|
space-around-arrays=false
|
||||||
|
break-fun-decl=smart
|
||||||
|
cases-exp-indent=2
|
||||||
|
sequence-style=before
|
||||||
|
field-space=tight
|
||||||
|
break-before-in=auto
|
|
@ -5,10 +5,11 @@ let tls_config = Mimic.make ~name:"tls-config"
|
||||||
|
|
||||||
open Lwt.Infix
|
open Lwt.Infix
|
||||||
|
|
||||||
type t =
|
type t = {
|
||||||
{ ctx : Mimic.ctx
|
ctx: Mimic.ctx
|
||||||
; alpn_protocol : Mimic.flow -> string option
|
; alpn_protocol: Mimic.flow -> string option
|
||||||
; authenticator : (X509.Authenticator.t, [ `Msg of string ]) result }
|
; authenticator: (X509.Authenticator.t, [ `Msg of string ]) result
|
||||||
|
}
|
||||||
|
|
||||||
module type S = sig
|
module type S = sig
|
||||||
type nonrec t = t
|
type nonrec t = t
|
||||||
|
@ -19,14 +20,18 @@ end
|
||||||
module Make
|
module Make
|
||||||
(Pclock : Mirage_clock.PCLOCK)
|
(Pclock : Mirage_clock.PCLOCK)
|
||||||
(TCP : Tcpip.Tcp.S)
|
(TCP : Tcpip.Tcp.S)
|
||||||
(Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct
|
(Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S =
|
||||||
|
struct
|
||||||
type nonrec t = t
|
type nonrec t = t
|
||||||
|
|
||||||
module TCP = struct
|
module TCP = struct
|
||||||
include TCP
|
include TCP
|
||||||
|
|
||||||
type endpoint = Happy_eyeballs.t * string * int
|
type endpoint = Happy_eyeballs.t * string * int
|
||||||
|
|
||||||
type nonrec write_error =
|
type nonrec write_error =
|
||||||
[ `Write of write_error | `Connect of string | `Closed ]
|
[ `Write of write_error | `Connect of string | `Closed ]
|
||||||
|
|
||||||
let pp_write_error ppf = function
|
let pp_write_error ppf = function
|
||||||
| `Connect err -> Fmt.string ppf err
|
| `Connect err -> Fmt.string ppf err
|
||||||
| `Write err -> pp_write_error ppf err
|
| `Write err -> pp_write_error ppf err
|
||||||
|
@ -44,7 +49,7 @@ module Make
|
||||||
| Error err -> Lwt.return_error (`Write err)
|
| Error err -> Lwt.return_error (`Write err)
|
||||||
|
|
||||||
let connect (happy_eyeballs, hostname, port) =
|
let connect (happy_eyeballs, hostname, port) =
|
||||||
Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
|
Happy_eyeballs.resolve happy_eyeballs hostname [port] >>= function
|
||||||
| Error (`Msg err) -> Lwt.return_error (`Connect err)
|
| Error (`Msg err) -> Lwt.return_error (`Connect err)
|
||||||
| Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
|
| Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
|
||||||
end
|
end
|
||||||
|
@ -58,22 +63,23 @@ module Make
|
||||||
|
|
||||||
let connect (happy_eyeballs, cfg, hostname, port) =
|
let connect (happy_eyeballs, cfg, hostname, port) =
|
||||||
let peer_name =
|
let peer_name =
|
||||||
Result.(to_option (bind (Domain_name.of_string hostname) Domain_name.host)) in
|
Result.(
|
||||||
Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
|
to_option (bind (Domain_name.of_string hostname) Domain_name.host))
|
||||||
|
in
|
||||||
|
Happy_eyeballs.resolve happy_eyeballs hostname [port] >>= function
|
||||||
| Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
|
| Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
|
||||||
| Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
|
| Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
|
||||||
end
|
end
|
||||||
|
|
||||||
let tls_edn, tls_protocol =
|
let tls_edn, tls_protocol = Mimic.register ~name:"tls" (module TLS)
|
||||||
Mimic.register ~name:"tls" (module TLS)
|
|
||||||
|
|
||||||
let alpn_protocol flow =
|
let alpn_protocol flow =
|
||||||
let module M = (val (Mimic.repr tls_protocol)) in
|
let module M = (val Mimic.repr tls_protocol) in
|
||||||
match flow with
|
match flow with
|
||||||
| M.T flow ->
|
| M.T flow -> (
|
||||||
( match TLS.epoch flow with
|
match TLS.epoch flow with
|
||||||
| Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol
|
| Ok {Tls.Core.alpn_protocol; _} -> alpn_protocol
|
||||||
| Error _ -> None )
|
| Error _ -> None)
|
||||||
| _ -> None
|
| _ -> None
|
||||||
|
|
||||||
let authenticator =
|
let authenticator =
|
||||||
|
@ -81,37 +87,50 @@ module Make
|
||||||
V.authenticator ()
|
V.authenticator ()
|
||||||
|
|
||||||
let connect ctx =
|
let connect ctx =
|
||||||
let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with
|
let k0 happy_eyeballs http_scheme http_hostname http_port =
|
||||||
|
match http_scheme with
|
||||||
| "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port)
|
| "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port)
|
||||||
| _ -> Lwt.return_none in
|
| _ -> Lwt.return_none in
|
||||||
let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = match http_scheme with
|
let k1 happy_eyeballs http_scheme http_hostname http_port tls_config =
|
||||||
| "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port)
|
match http_scheme with
|
||||||
|
| "https" ->
|
||||||
|
Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port)
|
||||||
| _ -> Lwt.return_none in
|
| _ -> Lwt.return_none in
|
||||||
let ctx = Mimic.fold tcp_edn
|
let ctx =
|
||||||
Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
|
Mimic.fold tcp_edn
|
||||||
; req http_scheme; req http_hostname; dft http_port 80 ]
|
Mimic.Fun.
|
||||||
|
[
|
||||||
|
req Happy_eyeballs.happy_eyeballs; req http_scheme; req http_hostname
|
||||||
|
; dft http_port 80
|
||||||
|
]
|
||||||
~k:k0 ctx in
|
~k:k0 ctx in
|
||||||
let ctx = Mimic.fold tls_edn
|
let ctx =
|
||||||
Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
|
Mimic.fold tls_edn
|
||||||
; req http_scheme; req http_hostname; dft http_port 443
|
Mimic.Fun.
|
||||||
; req tls_config ]
|
[
|
||||||
|
req Happy_eyeballs.happy_eyeballs; req http_scheme; req http_hostname
|
||||||
|
; dft http_port 443; req tls_config
|
||||||
|
]
|
||||||
~k:k1 ctx in
|
~k:k1 ctx in
|
||||||
Lwt.return { ctx; alpn_protocol; authenticator; }
|
Lwt.return {ctx; alpn_protocol; authenticator}
|
||||||
end
|
end
|
||||||
|
|
||||||
module Version = Httpaf.Version
|
module Version = Httpaf.Version
|
||||||
module Status = H2.Status
|
module Status = H2.Status
|
||||||
module Headers = H2.Headers
|
module Headers = H2.Headers
|
||||||
|
|
||||||
type response =
|
type response = {
|
||||||
{ version : Version.t
|
version: Version.t
|
||||||
; status : Status.t
|
; status: Status.t
|
||||||
; reason : string
|
; reason: string
|
||||||
; headers : Headers.t }
|
; headers: Headers.t
|
||||||
|
}
|
||||||
|
|
||||||
module HTTP_1_1 = struct
|
module HTTP_1_1 = struct
|
||||||
include Httpaf.Client_connection
|
include Httpaf.Client_connection
|
||||||
|
|
||||||
let yield_reader _ = assert false
|
let yield_reader _ = assert false
|
||||||
|
|
||||||
let next_read_operation t =
|
let next_read_operation t =
|
||||||
(next_read_operation t :> [ `Close | `Read | `Yield ])
|
(next_read_operation t :> [ `Close | `Read | `Yield ])
|
||||||
end
|
end
|
||||||
|
@ -125,10 +144,11 @@ let add_authentication ~add headers = function
|
||||||
let prepare_http_1_1_headers headers host user_pass body_length =
|
let prepare_http_1_1_headers headers host user_pass body_length =
|
||||||
let headers = Httpaf.Headers.of_list headers in
|
let headers = Httpaf.Headers.of_list headers in
|
||||||
let add = Httpaf.Headers.add_unless_exists in
|
let add = Httpaf.Headers.add_unless_exists in
|
||||||
let headers = add headers "user-agent" ("http-mirage-client/%%VERSION%%") in
|
let headers = add headers "user-agent" "http-mirage-client/%%VERSION%%" in
|
||||||
let headers = add headers "host" host in
|
let headers = add headers "host" host in
|
||||||
let headers = add headers "connection" "close" in
|
let headers = add headers "connection" "close" in
|
||||||
let headers = match body_length with
|
let headers =
|
||||||
|
match body_length with
|
||||||
| None -> headers
|
| None -> headers
|
||||||
| Some v -> add headers "content-length" (string_of_int v) in
|
| Some v -> add headers "content-length" (string_of_int v) in
|
||||||
add_authentication ~add headers user_pass
|
add_authentication ~add headers user_pass
|
||||||
|
@ -138,123 +158,157 @@ let single_http_1_1_request ?config flow user_pass host meth path headers body =
|
||||||
let headers = prepare_http_1_1_headers headers host user_pass body_length in
|
let headers = prepare_http_1_1_headers headers host user_pass body_length in
|
||||||
let req = Httpaf.Request.create ~headers meth path in
|
let req = Httpaf.Request.create ~headers meth path in
|
||||||
let finished, notify_finished = Lwt.wait () in
|
let finished, notify_finished = Lwt.wait () in
|
||||||
let wakeup = let w = ref false in
|
let wakeup =
|
||||||
fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
|
let w = ref false in
|
||||||
|
fun v ->
|
||||||
|
if not !w then Lwt.wakeup_later notify_finished v
|
||||||
|
; w := true in
|
||||||
let response_handler response body =
|
let response_handler response body =
|
||||||
let buf = Buffer.create 0x100 in
|
let buf = Buffer.create 0x100 in
|
||||||
let rec on_eof () =
|
let rec on_eof () =
|
||||||
let response =
|
let response =
|
||||||
{ version= response.Httpaf.Response.version
|
{
|
||||||
; status = (response.Httpaf.Response.status :> H2.Status.t)
|
version= response.Httpaf.Response.version
|
||||||
; reason = response.Httpaf.Response.reason
|
; status= (response.Httpaf.Response.status :> H2.Status.t)
|
||||||
; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
|
; reason= response.Httpaf.Response.reason
|
||||||
|
; headers=
|
||||||
|
H2.Headers.of_list
|
||||||
|
(Httpaf.Headers.to_list response.Httpaf.Response.headers)
|
||||||
|
} in
|
||||||
wakeup (Ok (response, Some (Buffer.contents buf)))
|
wakeup (Ok (response, Some (Buffer.contents buf)))
|
||||||
and on_read ba ~off ~len =
|
and on_read ba ~off ~len =
|
||||||
Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
|
Buffer.add_string buf (Bigstringaf.substring ~off ~len ba)
|
||||||
Httpaf.Body.schedule_read body ~on_read ~on_eof in
|
; Httpaf.Body.schedule_read body ~on_read ~on_eof in
|
||||||
let on_eof () =
|
let on_eof () =
|
||||||
let response =
|
let response =
|
||||||
{ version= response.Httpaf.Response.version
|
{
|
||||||
; status = (response.Httpaf.Response.status :> H2.Status.t)
|
version= response.Httpaf.Response.version
|
||||||
; reason = response.Httpaf.Response.reason
|
; status= (response.Httpaf.Response.status :> H2.Status.t)
|
||||||
; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
|
; reason= response.Httpaf.Response.reason
|
||||||
|
; headers=
|
||||||
|
H2.Headers.of_list
|
||||||
|
(Httpaf.Headers.to_list response.Httpaf.Response.headers)
|
||||||
|
} in
|
||||||
wakeup (Ok (response, None)) in
|
wakeup (Ok (response, None)) in
|
||||||
Httpaf.Body.schedule_read body ~on_read ~on_eof in
|
Httpaf.Body.schedule_read body ~on_read ~on_eof in
|
||||||
let error_handler e =
|
let error_handler e =
|
||||||
let err = match e with
|
let err =
|
||||||
|
match e with
|
||||||
| `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
|
| `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
|
||||||
| `Invalid_response_body_length _ -> Error (`Msg ("Invalid response body length"))
|
| `Invalid_response_body_length _ ->
|
||||||
|
Error (`Msg "Invalid response body length")
|
||||||
| `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
|
| `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
|
||||||
wakeup err in
|
wakeup err in
|
||||||
let request_body, conn = Httpaf.Client_connection.request ?config req ~error_handler
|
let request_body, conn =
|
||||||
|
Httpaf.Client_connection.request ?config req ~error_handler
|
||||||
~response_handler in
|
~response_handler in
|
||||||
Lwt.async (fun () -> Paf.run (module HTTP_1_1) conn flow) ;
|
Lwt.async (fun () -> Paf.run (module HTTP_1_1) conn flow)
|
||||||
Option.iter (Httpaf.Body.write_string request_body) body ;
|
; Option.iter (Httpaf.Body.write_string request_body) body
|
||||||
Httpaf.Body.close_writer request_body ;
|
; Httpaf.Body.close_writer request_body
|
||||||
finished
|
; finished
|
||||||
|
|
||||||
let prepare_h2_headers headers host user_pass body_length =
|
let prepare_h2_headers headers host user_pass body_length =
|
||||||
let headers = H2.Headers.of_list headers in
|
let headers = H2.Headers.of_list headers in
|
||||||
let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in
|
let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in
|
||||||
let headers = add headers ":authority" host in
|
let headers = add headers ":authority" host in
|
||||||
let headers = add headers "content-length" (string_of_int (Option.value ~default:0 body_length)) in
|
let headers =
|
||||||
|
add headers "content-length"
|
||||||
|
(string_of_int (Option.value ~default:0 body_length)) in
|
||||||
add_authentication ~add headers user_pass
|
add_authentication ~add headers user_pass
|
||||||
|
|
||||||
let single_h2_request ?config ~scheme flow user_pass host meth path headers body =
|
let single_h2_request ?config ~scheme flow user_pass host meth path headers body
|
||||||
|
=
|
||||||
let body_length = Option.map String.length body in
|
let body_length = Option.map String.length body in
|
||||||
let headers = prepare_h2_headers headers host user_pass body_length in
|
let headers = prepare_h2_headers headers host user_pass body_length in
|
||||||
let req = H2.Request.create ~scheme ~headers meth path in
|
let req = H2.Request.create ~scheme ~headers meth path in
|
||||||
let finished, notify_finished = Lwt.wait () in
|
let finished, notify_finished = Lwt.wait () in
|
||||||
let wakeup = let w = ref false in
|
let wakeup =
|
||||||
fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
|
let w = ref false in
|
||||||
|
fun v ->
|
||||||
|
if not !w then Lwt.wakeup_later notify_finished v
|
||||||
|
; w := true in
|
||||||
let response_handler response response_body =
|
let response_handler response response_body =
|
||||||
let buf = Buffer.create 0x100 in
|
let buf = Buffer.create 0x100 in
|
||||||
let rec on_eof () =
|
let rec on_eof () =
|
||||||
let response =
|
let response =
|
||||||
{ version= { major= 2; minor= 0; }
|
{
|
||||||
; status = response.H2.Response.status
|
version= {major= 2; minor= 0}
|
||||||
; reason = ""
|
; status= response.H2.Response.status
|
||||||
; headers= response.H2.Response.headers } in
|
; reason= ""
|
||||||
|
; headers= response.H2.Response.headers
|
||||||
|
} in
|
||||||
wakeup (Ok (response, Some (Buffer.contents buf)))
|
wakeup (Ok (response, Some (Buffer.contents buf)))
|
||||||
and on_read ba ~off ~len =
|
and on_read ba ~off ~len =
|
||||||
Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
|
Buffer.add_string buf (Bigstringaf.substring ~off ~len ba)
|
||||||
H2.Body.Reader.schedule_read response_body
|
; H2.Body.Reader.schedule_read response_body ~on_read ~on_eof in
|
||||||
~on_read ~on_eof in
|
|
||||||
let on_eof () =
|
let on_eof () =
|
||||||
let response =
|
let response =
|
||||||
{ version= { major= 2; minor= 0; }
|
{
|
||||||
; status = response.H2.Response.status
|
version= {major= 2; minor= 0}
|
||||||
; reason = ""
|
; status= response.H2.Response.status
|
||||||
; headers= response.H2.Response.headers } in
|
; reason= ""
|
||||||
|
; headers= response.H2.Response.headers
|
||||||
|
} in
|
||||||
wakeup (Ok (response, None)) in
|
wakeup (Ok (response, None)) in
|
||||||
H2.Body.Reader.schedule_read response_body
|
H2.Body.Reader.schedule_read response_body ~on_read ~on_eof in
|
||||||
~on_read ~on_eof in
|
|
||||||
let error_handler e =
|
let error_handler e =
|
||||||
let err = match e with
|
let err =
|
||||||
|
match e with
|
||||||
| `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
|
| `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
|
||||||
| `Invalid_response_body_length _ -> Error (`Msg "Invalid response body length")
|
| `Invalid_response_body_length _ ->
|
||||||
|
Error (`Msg "Invalid response body length")
|
||||||
| `Protocol_error (err, msg) ->
|
| `Protocol_error (err, msg) ->
|
||||||
let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in
|
let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in
|
||||||
Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum err msg
|
Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum
|
||||||
|
err msg
|
||||||
| `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
|
| `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
|
||||||
wakeup err in
|
wakeup err in
|
||||||
let conn = H2.Client_connection.create ?config ?push_handler:None
|
let conn =
|
||||||
~error_handler in
|
H2.Client_connection.create ?config ?push_handler:None ~error_handler in
|
||||||
let request_body = H2.Client_connection.request conn req ~error_handler ~response_handler in
|
let request_body =
|
||||||
Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow) ;
|
H2.Client_connection.request conn req ~error_handler ~response_handler in
|
||||||
Option.iter (H2.Body.Writer.write_string request_body) body ;
|
Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow)
|
||||||
H2.Body.Writer.close request_body ;
|
; Option.iter (H2.Body.Writer.write_string request_body) body
|
||||||
finished >|= fun v ->
|
; H2.Body.Writer.close request_body
|
||||||
H2.Client_connection.shutdown conn ;
|
; finished >|= fun v ->
|
||||||
v
|
H2.Client_connection.shutdown conn
|
||||||
|
; v
|
||||||
|
|
||||||
let decode_uri ~ctx uri =
|
let decode_uri ~ctx uri =
|
||||||
let ( >>= ) = Result.bind in
|
let ( >>= ) = Result.bind in
|
||||||
match String.split_on_char '/' uri with
|
match String.split_on_char '/' uri with
|
||||||
| proto :: "" :: user_pass_host_port :: path ->
|
| proto :: "" :: user_pass_host_port :: path ->
|
||||||
( if String.equal proto "http:"
|
(if String.equal proto "http:" then
|
||||||
then Ok ("http", Mimic.add http_scheme "http" ctx)
|
Ok ("http", Mimic.add http_scheme "http" ctx)
|
||||||
else if String.equal proto "https:"
|
else if String.equal proto "https:" then
|
||||||
then Ok ("https", Mimic.add http_scheme "https" ctx)
|
Ok ("https", Mimic.add http_scheme "https" ctx)
|
||||||
else Error (`Msg "Couldn't decode user and password") ) >>= fun (scheme, ctx) ->
|
else Error (`Msg "Couldn't decode user and password"))
|
||||||
let decode_user_pass up = match String.split_on_char ':' up with
|
>>= fun (scheme, ctx) ->
|
||||||
| [ user; pass; ] -> Ok (user, pass)
|
let decode_user_pass up =
|
||||||
|
match String.split_on_char ':' up with
|
||||||
|
| [user; pass] -> Ok (user, pass)
|
||||||
| _ -> Error (`Msg "Couldn't decode user and password") in
|
| _ -> Error (`Msg "Couldn't decode user and password") in
|
||||||
( match String.split_on_char '@' user_pass_host_port with
|
(match String.split_on_char '@' user_pass_host_port with
|
||||||
| [ host_port ] -> Ok (None, host_port)
|
| [host_port] -> Ok (None, host_port)
|
||||||
| [ user_pass; host_port ] ->
|
| [user_pass; host_port] ->
|
||||||
decode_user_pass user_pass >>= fun up ->
|
decode_user_pass user_pass >>= fun up -> Ok (Some up, host_port)
|
||||||
Ok (Some up, host_port)
|
| _ -> Error (`Msg "Couldn't decode URI"))
|
||||||
| _ -> Error (`Msg "Couldn't decode URI") ) >>= fun (user_pass, host_port) ->
|
>>= fun (user_pass, host_port) ->
|
||||||
( match String.split_on_char ':' host_port with
|
(match String.split_on_char ':' host_port with
|
||||||
| [] -> Error (`Msg "Empty host & port")
|
| [] -> Error (`Msg "Empty host & port")
|
||||||
| [ hostname ] -> Ok (hostname, Mimic.add http_hostname hostname ctx)
|
| [hostname] -> Ok (hostname, Mimic.add http_hostname hostname ctx)
|
||||||
| hd :: tl ->
|
| hd :: tl -> (
|
||||||
let port, hostname = match List.rev (hd :: tl) with
|
let port, hostname =
|
||||||
|
match List.rev (hd :: tl) with
|
||||||
| hd :: tl -> hd, String.concat ":" (List.rev tl)
|
| hd :: tl -> hd, String.concat ":" (List.rev tl)
|
||||||
| _ -> assert false in
|
| _ -> assert false in
|
||||||
( try Ok (hostname, Mimic.add http_hostname hostname (Mimic.add http_port (int_of_string port) ctx))
|
try
|
||||||
with Failure _ -> Error (`Msg "Couldn't decode port") ) ) >>= fun (hostname, ctx) ->
|
Ok
|
||||||
|
( hostname
|
||||||
|
, Mimic.add http_hostname hostname
|
||||||
|
(Mimic.add http_port (int_of_string port) ctx) )
|
||||||
|
with Failure _ -> Error (`Msg "Couldn't decode port")))
|
||||||
|
>>= fun (hostname, ctx) ->
|
||||||
Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path)
|
Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path)
|
||||||
| _ -> Error (`Msg "Couldn't decode URI on top")
|
| _ -> Error (`Msg "Couldn't decode URI on top")
|
||||||
|
|
||||||
|
@ -266,13 +320,15 @@ let alpn_protocol_of_string = function
|
||||||
| _ -> None
|
| _ -> None
|
||||||
|
|
||||||
let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri =
|
let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri =
|
||||||
Lwt.return (decode_uri ~ctx uri) >>? fun (ctx, scheme, host, user_pass, path) ->
|
Lwt.return (decode_uri ~ctx uri)
|
||||||
let ctx = match Lazy.force cfg with
|
>>? fun (ctx, scheme, host, user_pass, path) ->
|
||||||
|
let ctx =
|
||||||
|
match Lazy.force cfg with
|
||||||
| Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx
|
| Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx
|
||||||
| Ok (`Default cfg) ->
|
| Ok (`Default cfg) -> (
|
||||||
( match Result.bind (Domain_name.of_string host) Domain_name.host with
|
match Result.bind (Domain_name.of_string host) Domain_name.host with
|
||||||
| Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx
|
| Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx
|
||||||
| Error _ -> Mimic.add tls_config cfg ctx )
|
| Error _ -> Mimic.add tls_config cfg ctx)
|
||||||
| Error _ -> ctx in
|
| Error _ -> ctx in
|
||||||
Mimic.resolve ctx >>? fun flow ->
|
Mimic.resolve ctx >>? fun flow ->
|
||||||
(match Option.bind (alpn_protocol flow) alpn_protocol_of_string, config with
|
(match Option.bind (alpn_protocol flow) alpn_protocol_of_string, config with
|
||||||
|
@ -284,25 +340,29 @@ let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri =
|
||||||
single_h2_request ~config ~scheme flow user_pass host meth path headers body
|
single_h2_request ~config ~scheme flow user_pass host meth path headers body
|
||||||
| Some `H2, None ->
|
| Some `H2, None ->
|
||||||
single_h2_request ~scheme flow user_pass host meth path headers body
|
single_h2_request ~scheme flow user_pass host meth path headers body
|
||||||
| Some `H2, (Some (`HTTP_1_1 _)) ->
|
| Some `H2, Some (`HTTP_1_1 _) ->
|
||||||
single_h2_request ~scheme flow user_pass host meth path headers body
|
single_h2_request ~scheme flow user_pass host meth path headers body
|
||||||
| Some `HTTP_1_1, Some (`H2 _) ->
|
| Some `HTTP_1_1, Some (`H2 _) ->
|
||||||
single_http_1_1_request flow user_pass host meth path headers body) >>= fun r ->
|
single_http_1_1_request flow user_pass host meth path headers body)
|
||||||
Mimic.close flow >|= fun () ->
|
>>= fun r ->
|
||||||
r
|
Mimic.close flow >|= fun () -> r
|
||||||
|
|
||||||
let tls_config ?tls_config ?config authenticator user's_authenticator =
|
let tls_config ?tls_config ?config authenticator user's_authenticator =
|
||||||
lazy ( match tls_config with
|
lazy
|
||||||
|
(match tls_config with
|
||||||
| Some cfg -> Ok (`Custom cfg)
|
| Some cfg -> Ok (`Custom cfg)
|
||||||
| None ->
|
| None -> (
|
||||||
let alpn_protocols = match config with
|
let alpn_protocols =
|
||||||
| None -> [ "h2"; "http/1.1" ]
|
match config with
|
||||||
| Some (`H2 _) -> [ "h2" ]
|
| None -> ["h2"; "http/1.1"]
|
||||||
| Some (`HTTP_1_1 _) -> [ "http/1.1" ] in
|
| Some (`H2 _) -> ["h2"]
|
||||||
|
| Some (`HTTP_1_1 _) -> ["http/1.1"] in
|
||||||
match authenticator, user's_authenticator with
|
match authenticator, user's_authenticator with
|
||||||
| Ok authenticator, None -> Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
|
| Ok authenticator, None ->
|
||||||
| _, Some authenticator -> Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
|
Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
|
||||||
| (Error _ as err), None -> err )
|
| _, Some authenticator ->
|
||||||
|
Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
|
||||||
|
| (Error _ as err), None -> err))
|
||||||
|
|
||||||
let resolve_location ~uri ~location =
|
let resolve_location ~uri ~location =
|
||||||
match String.split_on_char '/' location with
|
match String.split_on_char '/' location with
|
||||||
|
@ -311,39 +371,41 @@ let resolve_location ~uri ~location =
|
||||||
| "" :: "" :: _ ->
|
| "" :: "" :: _ ->
|
||||||
let schema = String.sub uri 0 (String.index uri '/') in
|
let schema = String.sub uri 0 (String.index uri '/') in
|
||||||
Ok (schema ^ location)
|
Ok (schema ^ location)
|
||||||
| "" :: _ ->
|
| "" :: _ -> (
|
||||||
(match String.split_on_char '/' uri with
|
match String.split_on_char '/' uri with
|
||||||
| schema :: "" :: user_pass_host_port :: _ ->
|
| schema :: "" :: user_pass_host_port :: _ ->
|
||||||
Ok (String.concat "/" [schema ; "" ; user_pass_host_port ^ location])
|
Ok (String.concat "/" [schema; ""; user_pass_host_port ^ location])
|
||||||
| _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri)))
|
| _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri)))
|
||||||
| _ -> Error (`Msg ("unknown location (relative path): " ^ location))
|
| _ -> Error (`Msg ("unknown location (relative path): " ^ location))
|
||||||
|
|
||||||
let one_request
|
let one_request
|
||||||
?config
|
?config
|
||||||
?tls_config:cfg
|
?tls_config:cfg
|
||||||
{ ctx; alpn_protocol; authenticator; }
|
{ctx; alpn_protocol; authenticator}
|
||||||
?authenticator:user's_authenticator
|
?authenticator:user's_authenticator
|
||||||
?(meth= `GET)
|
?(meth = `GET)
|
||||||
?(headers= [])
|
?(headers = [])
|
||||||
?body
|
?body
|
||||||
?(max_redirect= 5)
|
?(max_redirect = 5)
|
||||||
?(follow_redirect= true) uri =
|
?(follow_redirect = true)
|
||||||
let tls_config = tls_config ?tls_config:cfg ?config authenticator user's_authenticator in
|
uri =
|
||||||
if not follow_redirect
|
let tls_config =
|
||||||
then single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
|
tls_config ?tls_config:cfg ?config authenticator user's_authenticator in
|
||||||
|
if not follow_redirect then
|
||||||
|
single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body
|
||||||
|
uri
|
||||||
else
|
else
|
||||||
let rec follow_redirect count uri =
|
let rec follow_redirect count uri =
|
||||||
if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded")
|
if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded")
|
||||||
else
|
else
|
||||||
single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
|
single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers
|
||||||
|
?body uri
|
||||||
>>? fun (resp, body) ->
|
>>? fun (resp, body) ->
|
||||||
if Status.is_redirection resp.status then
|
if Status.is_redirection resp.status then
|
||||||
( match Headers.get resp.headers "location" with
|
match Headers.get resp.headers "location" with
|
||||||
| Some location ->
|
| Some location ->
|
||||||
Lwt.return (resolve_location ~uri ~location) >>? fun uri ->
|
Lwt.return (resolve_location ~uri ~location) >>? fun uri ->
|
||||||
follow_redirect (pred count) uri
|
follow_redirect (pred count) uri
|
||||||
| None ->
|
| None -> Lwt.return_ok (resp, body)
|
||||||
Lwt.return_ok (resp, body) )
|
else Lwt.return_ok (resp, body) in
|
||||||
else
|
|
||||||
Lwt.return_ok (resp, body) in
|
|
||||||
follow_redirect max_redirect uri
|
follow_redirect max_redirect uri
|
||||||
|
|
|
@ -15,21 +15,22 @@ module Version = Httpaf.Version
|
||||||
module Status = H2.Status
|
module Status = H2.Status
|
||||||
module Headers = H2.Headers
|
module Headers = H2.Headers
|
||||||
|
|
||||||
type response =
|
type response = {
|
||||||
{ version : Version.t
|
version: Version.t
|
||||||
; status : Status.t
|
; status: Status.t
|
||||||
; reason : string
|
; reason: string
|
||||||
; headers : Headers.t }
|
; headers: Headers.t
|
||||||
|
}
|
||||||
|
|
||||||
val one_request :
|
val one_request :
|
||||||
?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] ->
|
?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ]
|
||||||
?tls_config:Tls.Config.client ->
|
-> ?tls_config:Tls.Config.client
|
||||||
t ->
|
-> t
|
||||||
?authenticator:X509.Authenticator.t ->
|
-> ?authenticator:X509.Authenticator.t
|
||||||
?meth:Httpaf.Method.t ->
|
-> ?meth:Httpaf.Method.t
|
||||||
?headers:(string * string) list ->
|
-> ?headers:(string * string) list
|
||||||
?body:string ->
|
-> ?body:string
|
||||||
?max_redirect:int ->
|
-> ?max_redirect:int
|
||||||
?follow_redirect:bool ->
|
-> ?follow_redirect:bool
|
||||||
string ->
|
-> string
|
||||||
(response * string option, [> Mimic.error ]) result Lwt.t
|
-> (response * string option, [> Mimic.error ]) result Lwt.t
|
||||||
|
|
Loading…
Reference in a new issue