jobs:
tests:
runs-on: ubuntu-latest
- env:
- NIXPKGS_ALLOW_INSECURE: 1
steps:
- name: Checkout tree
uses: actions/checkout@v4
submodules: true
- uses: cachix/install-nix-action@v30
with:
- nix_path: nixpkgs=channel:nixos-unstable
- - run: nix develop -c dune build @runtest @check
+ extra_nix_config: |
+ extra-substituters = https://anmonteiro.nix-cache.workers.dev
+ extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
+ - run: nix develop -L .# -c dune build @runtest @check
- ubuntu-latest
- macos-latest
ocaml-compiler:
- - "5"
+ - "5.2"
local-packages:
- |
*.opam
os:
- ubuntu-latest
ocaml-compiler:
- - "5"
+ - "5.2"
local-packages:
- |
*.opam
-version = 0.26.2
+version=0.27.0
profile=conventional
break-infix=fit-or-vertical
parse-docstrings=true
+# v6.1.0 (2025-03-03)
+
+- cohttp-lwt-unix: Add http/https proxy support for client requests (@art-w @MisterDA, #1080)
+- cohttp-mirage: Support conduit 8.0.0 (@hannesm, #1104)
+
## v6.0.0 (2024-11-21)
- bump minimum dune version to 3.8 (@avsm)
- cohttp: `Cohttp.Request.make_for_client` no longer allows setting both
`~chunked:true` and `~body_length`.
- cohttp-lwt-unix: Don't blow up when certificates are not available and no-network requests are made. (akuhlens #1027)
- + Makes `cohttp-lwt.S.default_ctx` lazy.
+ + Makes `cohttp-lwt.S.default_ctx` lazy.
## v6.0.0~beta2 (2024-01-05)
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for the Async concurrency library"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"dune" {>= "3.8"}
- "ocaml" {>= "4.14"}
+ "ocaml" {>= "4.14" & < "5.3.0"}
"http" {= version}
"cohttp" {= version}
"async_kernel" {>= "v0.16.0"}
Server.create
~on_handler_error:
(`Call
- (fun addr exn ->
- Logs.err (fun f -> f "Error from %s" (Socket.Address.to_string addr));
- Logs.err (fun f -> f "%s" @@ Exn.to_string exn)))
+ (fun addr exn ->
+ Logs.err (fun f -> f "Error from %s" (Socket.Address.to_string addr));
+ Logs.err (fun f -> f "%s" @@ Exn.to_string exn)))
~mode
(Tcp.Where_to_listen.of_port port)
(handler ~info ~docroot ~index)
]
(* pipelined_chunk *)
@ (response_bodies |> List.map ~f:(Fn.compose const ok))
- @ (* large response chunked *)
- [
- (fun _ _ ->
- let body =
- let r, w = Pipe.create () in
- let chunk = chunk chunk_size in
- for _ = 0 to chunks - 1 do
- Pipe.write_without_pushback w chunk
- done;
- Pipe.close w;
- r
- in
- Server.respond_with_pipe ~code:`OK body >>| response);
- (* pipelined_expert *)
- expert (fun _ic oc ->
- Async_unix.Writer.write oc "8\r\nexpert 1\r\n0\r\n\r\n";
- Async_unix.Writer.flushed oc);
- expert (fun ic oc ->
- Async_unix.Writer.write oc "8\r\nexpert 2\r\n0\r\n\r\n";
- Async_unix.Writer.flushed oc >>= fun () -> Async_unix.Reader.close ic);
- ]
+ (* large response chunked *)
+ @ [
+ (fun _ _ ->
+ let body =
+ let r, w = Pipe.create () in
+ let chunk = chunk chunk_size in
+ for _ = 0 to chunks - 1 do
+ Pipe.write_without_pushback w chunk
+ done;
+ Pipe.close w;
+ r
+ in
+ Server.respond_with_pipe ~code:`OK body >>| response);
+ (* pipelined_expert *)
+ expert (fun _ic oc ->
+ Async_unix.Writer.write oc "8\r\nexpert 1\r\n0\r\n\r\n";
+ Async_unix.Writer.flushed oc);
+ expert (fun ic oc ->
+ Async_unix.Writer.write oc "8\r\nexpert 2\r\n0\r\n\r\n";
+ Async_unix.Writer.flushed oc >>= fun () -> Async_unix.Reader.close ic);
+ ]
|> response_sequence
let ts =
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Benchmarks binaries for Cohttp"
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Cohttp client using Curl & Async as the backend"
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Cohttp client using Curl & Lwt as the backend"
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Shared code between the individual cohttp-curl clients"
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation with eio backend"
"logs"
"uri"
"tls-eio" {with-test & >= "1.0.0"}
- "mirage-crypto-rng-eio" {with-test & >= "0.11.2"}
+ "mirage-crypto-rng" {with-test & >= "1.2.0"}
"ca-certs" {with-test & >= "1.0.0"}
"fmt"
"ptime"
let () =
Eio_main.run @@ fun env ->
- Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+ Mirage_crypto_rng_unix.use_default ();
let client = Client.make ~https:(Some (https ~authenticator)) env#net in
Eio.Switch.run @@ fun sw ->
let resp, body =
logs.threaded
tls-eio
ca-certs
- mirage-crypto-rng-eio))
+ mirage-crypto-rng.unix))
(alias
(name runtest)
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for the Js_of_ocaml JavaScript compiler"
let chunkerizer () =
if !pos = body_len then Lwt.return C.Transfer.Done
else if !pos + P.chunk_size >= body_len then (
- let str = text ## (substring_toEnd !pos) in
+ let str = text##(substring_toEnd !pos) in
pos := body_len;
Lwt.return (C.Transfer.Final_chunk (P.convert_body_string str)))
else
- let str = text ## (substring !pos (!pos + P.chunk_size)) in
+ let str = text##(substring !pos (!pos + P.chunk_size)) in
pos := !pos + P.chunk_size;
Lwt.return (C.Transfer.Chunk (P.convert_body_string str))
in
xml##.responseType := Js.string "arraybuffer";
let (res : (Http.Response.t Lwt.t * CLB.t) Lwt.t), wake = Lwt.task () in
let () =
- xml
- ## (_open
- (Js.string (C.Code.string_of_method meth))
- (Js.string (Uri.to_string uri))
- Js._true)
+ xml##(_open
+ (Js.string (C.Code.string_of_method meth))
+ (Js.string (Uri.to_string uri))
+ Js._true)
(* asynchronous call *)
in
(* set request headers *)
(fun k v ->
(* some headers lead to errors in the javascript console, should
we filter then out here? *)
- xml ## (setRequestHeader (Js.string k) (Js.string v)))
+ xml##(setRequestHeader (Js.string k) (Js.string v)))
headers
in
(* perform call *)
(match body with
- | None -> Lwt.return xml ## (send Js.null)
+ | None -> Lwt.return xml##(send Js.null)
| Some body ->
CLB.to_string body >>= fun body ->
let bs = binary_string body in
if Lazy.force xhr_response_supported then
xml##.responseType := Js.string "arraybuffer";
let () =
- xml
- ## (_open
- (Js.string (C.Code.string_of_method meth))
- (Js.string (Uri.to_string uri))
- Js._false)
+ xml##(_open
+ (Js.string (C.Code.string_of_method meth))
+ (Js.string (Uri.to_string uri))
+ Js._false)
(* synchronous call *)
in
(* set request headers *)
(fun k v ->
(* some headers lead to errors in the javascript console, should
we filter then out here? *)
- xml ## (setRequestHeader (Js.string k) (Js.string v)))
+ xml##(setRequestHeader (Js.string k) (Js.string v)))
headers
in
(* perform call *)
(match body with
- | None -> Lwt.return xml ## (send Js.null)
+ | None -> Lwt.return xml##(send Js.null)
| Some body ->
CLB.to_string body >|= fun body ->
let bs = binary_string body in
- xml ## (send (Js.Opt.return (Obj.magic bs))))
+ xml##(send (Js.Opt.return (Obj.magic bs))))
>>= fun _body ->
let body = Bb.construct_body xml in
(* (re-)construct the response *)
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for Unix and Windows using Lwt"
"cohttp-lwt" {= version}
"cmdliner" {>= "1.1.0"}
"lwt" {>= "3.0.0"}
- "conduit-lwt" {>= "5.0.0"}
- "conduit-lwt-unix" {>= "5.0.0"}
+ "conduit-lwt" {>= "7.1.0"}
+ "conduit-lwt-unix" {>= "7.1.0"}
"fmt" {>= "0.8.2"}
"base-unix"
"ppx_sexp_conv" {>= "v0.13.0"}
--- /dev/null
+open Lwt
+open Cohttp
+open Cohttp_lwt_unix
+
+let () =
+ if not @@ Debug.debug_active () then (
+ Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ();
+ Logs.set_level ~all:true (Some Logs.Debug);
+ Logs.set_reporter Debug.default_reporter)
+
+let proxy_uri = ref None
+let uri = ref []
+let proxy_authorization = ref None
+let set_proxy_uri uri = proxy_uri := Some (Uri.of_string uri)
+
+let set_proxy_authorization auth =
+ proxy_authorization :=
+ Some (Cohttp.Auth.credential_of_string ("Basic " ^ Base64.encode_exn auth))
+
+let usage_msg =
+ {|Usage: test_client_proxy -proxy <uri> <resource>
+Examples:
+$ test_client_proxy -proxy http://localhost:8080 http://example.com
+$ test_client_proxy -proxy https://localhost:8080 https://example.com
+Options:|}
+
+let anon_fun args = uri := !uri @ [ args ]
+
+let speclist =
+ [
+ ("-proxy", Arg.String set_proxy_uri, "<uri> Proxy uri");
+ ("-proxyauth", Arg.String set_proxy_authorization, " Proxy authorization");
+ ]
+
+(* Boilerplate code to handle redirects *)
+
+let rec http_get_and_follow ~max_redirects ?headers uri =
+ let open Lwt.Syntax in
+ let* ans = Cohttp_lwt_unix.Client.get ?headers uri in
+ follow_redirect ~max_redirects ?headers uri ans
+
+and follow_redirect ~max_redirects ?headers request_uri (response, body) =
+ let open Lwt.Syntax in
+ let status = Http.Response.status response in
+ (* The unconsumed body would otherwise leak memory *)
+ let* () =
+ if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit
+ in
+ match status with
+ | `OK -> Lwt.return (response, body)
+ | `Permanent_redirect | `Moved_permanently ->
+ handle_redirect ~permanent:true ~max_redirects ?headers request_uri
+ response
+ | `Found | `Temporary_redirect ->
+ handle_redirect ~permanent:false ~max_redirects ?headers request_uri
+ response
+ | `Not_found | `Gone -> failwith "Not found"
+ | status ->
+ Printf.ksprintf failwith "Unhandled status: %s"
+ (Cohttp.Code.string_of_status status)
+
+and handle_redirect ~permanent ~max_redirects ?headers request_uri response =
+ if max_redirects <= 0 then failwith "Too many redirects"
+ else
+ let headers' = Http.Response.headers response in
+ let location = Http.Header.get headers' "location" in
+ match location with
+ | None -> failwith "Redirection without Location header"
+ | Some url ->
+ let open Lwt.Syntax in
+ let uri = Uri.of_string url in
+ let* () =
+ if permanent then
+ Logs_lwt.warn (fun m ->
+ m "Permanent redirection from %s to %s"
+ (Uri.to_string request_uri)
+ url)
+ else Lwt.return_unit
+ in
+ http_get_and_follow ?headers uri ~max_redirects:(max_redirects - 1)
+
+(* Interesting stuff *)
+
+let getenv_opt k =
+ match Sys.getenv_opt k with
+ | Some v -> Some (k, Uri.of_string v)
+ | None -> None
+
+let getenv_opt_case k =
+ match getenv_opt (String.lowercase_ascii k) with
+ | None -> getenv_opt (String.uppercase_ascii k)
+ | v -> v
+
+let main ~proxy ~uri ~credential () =
+ let all_proxy, no_proxy, scheme_proxy =
+ match proxy with
+ | None ->
+ ( Option.map Uri.of_string (Sys.getenv_opt "ALL_PROXY"),
+ Sys.getenv_opt "NO_PROXY",
+ [
+ getenv_opt_case "httpunix_proxy";
+ getenv_opt_case "https_proxy";
+ getenv_opt "http_proxy";
+ ]
+ |> List.filter_map (function
+ | Some (k, v) -> Some (String.(sub k 0 (rindex k '_')), v)
+ | n -> n) )
+ | v -> (v, None, [])
+ in
+
+ let proxy_headers =
+ Option.map
+ (fun credential ->
+ Http.Header.init_with "Proxy-Authorization"
+ (Cohttp.Auth.string_of_credential credential))
+ credential
+ in
+
+ let module Cache = Cohttp_lwt_unix.Connection_proxy in
+ let cache =
+ Cache.create ?all_proxy ~scheme_proxy ?no_proxy ?proxy_headers ()
+ in
+ Client.set_cache (Cache.call cache);
+
+ http_get_and_follow ~max_redirects:2 (Uri.of_string uri)
+ >>= fun (resp, body) ->
+ let code = resp |> Response.status |> Code.code_of_status in
+ Printf.printf "Response code: %d\n" code;
+ Printf.printf "Headers: %s\n" (resp |> Response.headers |> Header.to_string);
+ body |> Cohttp_lwt.Body.to_string >|= fun body ->
+ Printf.printf "Body of length: %d\n" (String.length body);
+ print_endline ("Received body\n" ^ body)
+
+(* Argument parsing *)
+
+let () =
+ Arg.parse speclist anon_fun usage_msg;
+ if List.length !uri <> 1 then (
+ prerr_endline "Expected a single resource uri.";
+ prerr_endline usage_msg;
+ exit 1);
+ let proxy = !proxy_uri
+ and uri = List.hd !uri
+ and credential = !proxy_authorization in
+ Lwt_main.run (main ~proxy ~uri ~credential ())
(executables
- (names client_lwt client_lwt_timeout docker_lwt server_lwt)
- (libraries cohttp-lwt-unix))
+ (names client_lwt client_lwt_timeout docker_lwt server_lwt client_lwt_proxy)
+ (libraries cohttp-lwt-unix fmt.tty))
(alias
(name runtest)
(package cohttp-lwt-unix)
- (deps client_lwt.exe client_lwt_timeout.exe docker_lwt.exe server_lwt.exe))
+ (deps
+ client_lwt.exe
+ client_lwt_timeout.exe
+ docker_lwt.exe
+ server_lwt.exe
+ client_lwt_proxy.exe))
let sleep_ns ns = Lwt_unix.sleep (Int64.to_float ns /. 1_000_000_000.)
end)
+module Connection_proxy =
+ Cohttp_lwt.Connection_cache.Make_proxy
+ (Connection)
+ (struct
+ (* : Mirage_time.S *)
+ let sleep_ns ns = Lwt_unix.sleep (Int64.to_float ns /. 1_000_000_000.)
+ end)
+
module Client : sig
(** The [Client] module implements the full UNIX HTTP client interface,
including the UNIX-specific functions defined in {!C}. *)
}
type endp = Conduit.endp
+type client = Conduit_lwt_unix.client
let resolve ~ctx uri = Resolver_lwt.resolve_uri ~uri ctx.resolver
-let connect_endp ~ctx:{ ctx; _ } endp =
- Conduit_lwt_unix.endp_to_client ~ctx endp >>= fun client ->
+let tunnel hostname (channels : IO.ic * IO.oc) : client =
+ `TLS_tunnel (`Hostname hostname, (fst channels).chan, snd channels)
+
+let connect_client ~ctx:{ ctx; _ } client =
Conduit_lwt_unix.connect ~ctx client >|= fun (flow, ic, oc) ->
let ic = Input_channel.create ic in
(flow, ic, oc)
+let connect_endp ~ctx endp =
+ Conduit_lwt_unix.endp_to_client ~ctx:ctx.ctx endp >>= connect_client ~ctx
+
let connect_uri ~ctx uri = resolve ~ctx uri >>= connect_endp ~ctx
let close c =
with module IO = Io
and type ctx := ctx
and type endp = Conduit.endp
+ and type client = Conduit_lwt_unix.client
val init : ?ctx:Conduit_lwt_unix.ctx -> ?resolver:Resolver_lwt.t -> unit -> ctx
(** [init ?ctx ?resolver ()] is a network context that is the same as the
assert_equal ~printer:Fun.id "Spring" body;
(* simple request function accepting custom requests. *)
- let handler ?headers ?body meth uri = Client.call ?headers ?body meth uri in
+ let handler ?headers ?body ?absolute_form meth uri =
+ ignore absolute_form;
+ Client.call ?headers ?body meth uri
+ in
tests handler uri
(* The Client.{call, get, put, ...} functions by default use a new
(* the resolved endpoint may be buffered to avoid stressing the resolver: *)
Connection.Net.resolve ~ctx:(Lazy.force Connection.Net.default_ctx) uri
>>= fun endp ->
- let handler ?headers ?body meth uri =
+ let handler ?headers ?body ?absolute_form meth uri =
+ ignore absolute_form;
Connection.connect ~persistent:false endp >>= fun connection ->
Connection.call connection ?headers ?body meth uri
in
Connection.connect ~persistent:false endp >>= fun c ->
let connection = ref c in
(* reference to open connection *)
- let rec handler ?headers ?body meth uri =
+ let rec handler ?headers ?body ?absolute_form meth uri =
+ ignore absolute_form;
Lwt.catch
(fun () -> Connection.call !connection ?headers ?body meth uri)
(function
(fun _ _ ->
Lwt.return
(`Expert
- (let headers =
- Http.(
- Header.add_transfer_encoding (Header.init ()) Transfer.Chunked)
- in
- ( Http.Response.make ~headers (),
- fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" ))));
+ (let headers =
+ Http.(
+ Header.add_transfer_encoding (Header.init ()) Transfer.Chunked)
+ in
+ ( Http.Response.make ~headers (),
+ fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" ))));
(fun _ _ ->
Lwt.return
(`Expert
- ( (* Alternatively, cohttp.response.make injects the Chunked encoding when no
+ ( (* Alternatively, cohttp.response.make injects the Chunked encoding when no
encoding is already in the headers. *)
- Cohttp.Response.make (),
- fun ic oc ->
- Lwt_io.write oc "8\r\nexpert 2\r\n0\r\n\r\n" >>= fun () ->
- Lwt_io.flush oc >>= fun () ->
- Cohttp_lwt_unix.Private.Input_channel.close ic )));
+ Cohttp.Response.make (),
+ fun ic oc ->
+ Lwt_io.write oc "8\r\nexpert 2\r\n0\r\n\r\n" >>= fun () ->
+ Lwt_io.flush oc >>= fun () ->
+ Cohttp_lwt_unix.Private.Input_channel.close ic )));
]
|> response_sequence
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation using the Lwt concurrency library"
"cohttp" {= version}
"lwt" {>= "5.4.0"}
"sexplib0"
+ "ipaddr" {>= "5.6.0"}
"ppx_sexp_conv" {>= "v0.13.0"}
"logs"
"uri" {>= "2.0.0"}
(* enable warning when https://github.com/mirage/ocaml-conduit/pull/319 is released *)
type req_resr = {
+ absolute_form : bool;
uri : Uri.t;
meth : Cohttp.Code.meth;
headers : Header.t;
queue_fail connection connection.in_flight e;
Lwt.return_unit)
- let call connection ?headers ?(body = `Empty) meth uri =
+ let call connection ?headers ?(body = `Empty) ?(absolute_form = false) meth
+ uri =
let headers = match headers with Some h -> h | None -> Header.init () in
match connection.state with
| Connecting _ | Full _ ->
let res, res_r = Lwt.wait () in
- Queue.push { uri; meth; headers; body; res_r } connection.waiting;
+ Queue.push
+ { absolute_form; uri; meth; headers; body; res_r }
+ connection.waiting;
Lwt_condition.broadcast connection.condition ();
res
| Closing _ | Half _ | Closed | Failed _ -> raise Retry
*)
Lwt.return_unit
| Full (ic, oc) | Closing (ic, oc) ->
- let ({ uri; meth; headers; body; res_r } as work) =
+ let ({ absolute_form; uri; meth; headers; body; res_r } as work) =
Queue.take connection.waiting
in
else headers
in
- let req = Request.make ~encoding ~meth ~headers uri in
+ let req = Request.make ~encoding ~meth ~headers ~absolute_form uri in
Queue.push work connection.in_flight;
on_failure;
connection
+ let create_tunnel ?(finalise = fun _ -> Lwt.return_unit)
+ ?(ctx = Lazy.force Net.default_ctx) proxy remote_host =
+ match proxy.state with
+ | Full (ic, oc) ->
+ let client = Net.tunnel remote_host (ic, oc) in
+ let channels =
+ Net.connect_client ~ctx client >>= fun (_, ic, oc) -> return (ic, oc)
+ in
+ let connection =
+ {
+ finalise;
+ in_flight = Queue.create ();
+ waiting = Queue.create ();
+ state = Connecting channels;
+ condition = Lwt_condition.create ();
+ persistent = `True;
+ }
+ in
+ let on_failure e = connection.state <- Failed e in
+ Lwt.on_any channels
+ (fun channels ->
+ connection.state <- Full channels;
+ Lwt.dont_wait (fun () -> reader connection) on_failure;
+ Lwt.dont_wait (fun () -> writer connection) on_failure)
+ on_failure;
+ connection
+ | _ -> failwith "Proxy connection wasn't in right state."
+
let connect ?finalise ?persistent ?ctx uri =
let connection = create ?finalise ?persistent ?ctx uri in
match connection.state with
exception Retry = Connection.Retry
-(** This functor establishes a new connection for each request. *)
-module Make_no_cache (Connection : S.Connection) : sig
- include S.Connection_cache
-
- val create : ?ctx:Connection.Net.ctx -> unit -> t
- (** [create ?ctx ()] creates a connection for handling a single request. The
- connection accepts only a single request and will automatically be closed
- as soon as possible.
- @param ctx See {!Connection.Net.ctx} *)
-end = struct
+module Make_no_cache (Connection : S.Connection) = struct
module Net = Connection.Net
module IO = Net.IO
open IO
let call = Fun.id
- let create ?(ctx = Lazy.force Net.default_ctx) () ?headers ?body meth uri =
+ let create ?(ctx = Lazy.force Net.default_ctx) () ?headers ?body
+ ?absolute_form meth uri =
Net.resolve ~ctx uri
(* TODO: Support chunked encoding without ~persistent:true ? *)
>>= Connection.connect ~ctx ~persistent:true
>>= fun connection ->
- let res = Connection.call connection ?headers ?body meth uri in
+ let res =
+ Connection.call connection ?headers ?body ?absolute_form meth uri
+ in
(* this can be simplified when https://github.com/mirage/ocaml-conduit/pull/319 is released. *)
Lwt.dont_wait
(fun () ->
res
end
-(** This functor keeps a cache of connections for reuse. Connections are reused
- based on their remote {!type:Conduit.endp} (effectively IP / port). *)
-module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
- include S.Connection_cache
-
- val create :
- ?ctx:Connection.Net.ctx ->
- ?keep:int64 ->
- ?retry:int ->
- ?parallel:int ->
- ?depth:int ->
- unit ->
- t
- (** Create a new connection cache
-
- @param ctx Conduit context to use. See {!type:Connection.Net.ctx}.
- @param keep Number of nanoseconds to keep an idle connection around.
- @param retry
- Number of times a {e gracefully} failed request is automatically
- retried. {e graceful} means failed with {!exception:Connection.Retry}.
- Requests with a [`Stream] {!module:Body} cannot be retried
- automatically. Such requests will fail with
- {!exception:Connection.Retry} and a new {!module:Body} will need to be
- provided to retry.
- @param parallel
- maximum number of connections to establish to a single endpoint. Beware:
- A single hostname may resolve to multiple endpoints. In such a case
- connections may be created in excess to what was intended.
- @param depth
- maximum number of requests to queue and / or send on a single
- connection. *)
-end = struct
+module Make (Connection : S.Connection) (Sleep : S.Sleep) = struct
module Net = Connection.Net
module IO = Net.IO
open IO
retry : int;
parallel : int;
depth : int;
+ proxy : Uri.t option;
}
let create ?(ctx = Lazy.force Net.default_ctx) ?(keep = 60_000_000_000L)
- ?(retry = 2) ?(parallel = 4) ?(depth = 100) () =
+ ?(retry = 2) ?(parallel = 4) ?(depth = 100) ?proxy () =
{
cache = Hashtbl.create ~random:true 10;
ctx;
retry;
parallel;
depth;
+ proxy;
}
let rec get_connection self endp =
Lwt.return_unit
in
let create () =
- let connection = Connection.create ~finalise ~ctx:self.ctx endp
+ let connection =
+ Connection.create ~persistent:true ~finalise ~ctx:self.ctx endp
and timeout = ref Lwt.return_unit in
let rec busy () =
Lwt.cancel !timeout;
(fun _ -> get_connection self endp)
(fun _ -> get_connection self endp))
- let call self ?headers ?body meth uri =
- Net.resolve ~ctx:self.ctx uri >>= fun endp ->
+ let prepare self ?headers ?absolute_form meth uri =
+ match self.proxy with
+ | None ->
+ let absolute_form = Option.value ~default:false absolute_form in
+ Net.resolve ~ctx:self.ctx uri >>= fun endp ->
+ Lwt.return (endp, absolute_form, headers)
+ | Some proxy_uri ->
+ let absolute_form =
+ Option.value
+ ~default:
+ (not
+ (meth = `CONNECT
+ || (meth = `OPTIONS && Uri.path_and_query uri = "*")))
+ absolute_form
+ in
+ Net.resolve ~ctx:self.ctx proxy_uri >>= fun endp ->
+ Lwt.return (endp, absolute_form, headers)
+
+ let call self ?headers ?body ?absolute_form meth uri =
+ prepare self ?headers ?absolute_form meth uri
+ >>= fun (endp, absolute_form, headers) ->
let rec request retry =
get_connection self endp >>= fun conn ->
Lwt.catch
- (fun () -> Connection.call conn ?headers ?body meth uri)
+ (fun () -> Connection.call conn ?headers ?body ~absolute_form meth uri)
(function
| Retry -> (
match body with
in
request self.retry
end
+
+module Make_tunnel (Connection : S.Connection) (Sleep : S.Sleep) : sig
+ include S.Connection_cache
+
+ val create :
+ ?ctx:Connection.Net.ctx ->
+ ?keep:int64 ->
+ ?retry:int ->
+ ?parallel:int ->
+ ?depth:int ->
+ ?proxy_headers:Http.Header.t ->
+ Uri.t ->
+ unit ->
+ t
+end = struct
+ module Net = Connection.Net
+ module IO = Net.IO
+ open IO
+
+ type ctx = Net.ctx
+ type tunnel = { proxy : Connection.t; remote : Connection.t }
+
+ type t = {
+ cache : (string, tunnel) Hashtbl.t; (* remote host * tunnel *)
+ proxy_uri : Uri.t;
+ mutable proxy_endp : Net.endp option;
+ proxy_headers : Http.Header.t;
+ ctx : ctx;
+ keep : int64;
+ retry : int;
+ parallel : int;
+ depth : int;
+ }
+
+ let proxy_default_scheme uri =
+ match Uri.scheme uri with
+ | None -> Uri.with_scheme uri (Some "http")
+ | _ -> uri
+
+ let create ?(ctx = Lazy.force Net.default_ctx) ?(keep = 60_000_000_000L)
+ ?(retry = 2) ?(parallel = 4) ?(depth = 100)
+ ?(proxy_headers = Http.Header.init ()) proxy_uri () =
+ if Uri.host proxy_uri = None then
+ Printf.ksprintf invalid_arg "No host was provided in URI %s."
+ (Uri.to_string proxy_uri);
+ {
+ cache = Hashtbl.create ~random:true 10;
+ proxy_uri = proxy_default_scheme proxy_uri;
+ proxy_endp = None;
+ proxy_headers;
+ ctx;
+ keep;
+ retry;
+ parallel;
+ depth;
+ }
+
+ let rec request conn ?headers ?body ?absolute_form meth uri retry =
+ Lwt.catch
+ (fun () -> Connection.call conn ?headers ?body ?absolute_form meth uri)
+ (function
+ | Retry -> (
+ match body with
+ | Some (`Stream _) -> Lwt.fail Retry
+ | None | Some `Empty | Some (`String _) | Some (`Strings _) ->
+ if retry <= 0 then Lwt.fail Retry
+ else
+ request conn ?headers ?body ?absolute_form meth uri (retry - 1)
+ )
+ | e -> Lwt.fail e)
+
+ let rec get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri =
+ let finalise connection =
+ let rec remove keep =
+ let current = Hashtbl.find self.cache remote in
+ Hashtbl.remove self.cache remote;
+ if current.proxy == connection || current.remote == connection then
+ List.iter (Hashtbl.add self.cache remote) keep
+ else remove (current :: keep)
+ in
+ remove [];
+ Lwt.return_unit
+ in
+ let create () =
+ let proxy =
+ Connection.create ~persistent:true ~finalise ~ctx:self.ctx proxy_endp
+ in
+ request proxy ~headers:self.proxy_headers `CONNECT remote_uri self.retry
+ >>= fun (resp, _body) ->
+ let code = resp |> Http.Response.status |> Cohttp.Code.code_of_status in
+ if not (Cohttp.Code.is_success code) then
+ Printf.ksprintf failwith "Could not setup tunnel. Response code: %d\n"
+ code;
+ let remote =
+ Connection.create_tunnel ~finalise ~ctx:self.ctx proxy remote_host
+ and timeout = ref Lwt.return_unit in
+ let rec busy () =
+ Lwt.cancel !timeout;
+ if Connection.length remote = 0 then (
+ timeout :=
+ Sleep.sleep_ns self.keep >>= fun () ->
+ Connection.close remote;
+ Connection.close proxy;
+ (* failure is ignored *)
+ Lwt.return_unit);
+ Lwt.on_termination (Connection.notify remote) busy
+ in
+ busy ();
+ Lwt.return { proxy; remote }
+ in
+ match Hashtbl.find_all self.cache remote with
+ | [] ->
+ create () >>= fun tunnel ->
+ Hashtbl.add self.cache remote tunnel;
+ Lwt.return tunnel
+ | tunnels -> (
+ let rec search length = function
+ | [ a ] -> (a, length + 1)
+ | a :: b :: tl
+ when Connection.length a.remote < Connection.length b.remote ->
+ search (length + 1) (a :: tl)
+ | _ :: tl -> search (length + 1) tl
+ | [] -> assert false
+ in
+ match search 0 tunnels with
+ | shallowest, _ when Connection.length shallowest.remote = 0 ->
+ Lwt.return shallowest
+ | _, length when length < self.parallel ->
+ create () >>= fun tunnel ->
+ Hashtbl.add self.cache remote tunnel;
+ Lwt.return tunnel
+ | shallowest, _ when Connection.length shallowest.remote < self.depth ->
+ Lwt.return shallowest
+ | _ ->
+ Lwt.try_bind
+ (fun () ->
+ Lwt.choose
+ (List.map
+ (fun { remote; _ } -> Connection.notify remote)
+ tunnels))
+ (fun _ ->
+ get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri)
+ (fun _ ->
+ get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri)
+ )
+
+ let call self ?headers ?body ?absolute_form meth uri =
+ (match self.proxy_endp with
+ | None ->
+ Net.resolve ~ctx:self.ctx self.proxy_uri >>= fun proxy_endp ->
+ self.proxy_endp <- Some proxy_endp;
+ Lwt.return proxy_endp
+ | Some proxy_endp -> Lwt.return proxy_endp)
+ >>= fun proxy_endp ->
+ let remote_port =
+ match Uri_services.tcp_port_of_uri uri with
+ | Some p -> p
+ | None -> failwith "A port is required for the CONNECT method."
+ in
+ let remote_host = Option.get (Uri.host uri) in
+ let remote = remote_host ^ ":" ^ string_of_int remote_port
+ and remote_uri = Uri.with_port uri (Some remote_port) in
+ get_connection self ~proxy_endp ~remote ~remote_host ~remote_uri
+ >>= fun tunnel ->
+ request tunnel.remote ?headers ?body ?absolute_form meth uri self.retry
+end
+
+type no_proxy_pattern = Name of string | Ipaddr_prefix of Ipaddr.Prefix.t
+type no_proxy = Wildcard | Patterns of no_proxy_pattern list
+
+let trim_dots ~first_leading s =
+ let len = String.length s in
+ let i = ref 0 in
+ if first_leading && !i < len && String.unsafe_get s !i = '.' then incr i;
+ let j = ref (len - 1) in
+ while !j >= !i && String.unsafe_get s !j = '.' do
+ decr j
+ done;
+ if !j >= !i then String.sub s !i (!j - !i + 1) else ""
+
+let strncasecompare a b n =
+ let a = String.(sub a 0 (min (length a) n) |> lowercase_ascii)
+ and b = String.(sub b 0 (min (length b) n) |> lowercase_ascii) in
+ String.compare a b = 0
+
+let no_proxy_from_env no_proxy =
+ if no_proxy = "*" then Wildcard
+ else
+ let patterns =
+ no_proxy
+ |> String.split_on_char ','
+ |> List.filter_map (fun pattern ->
+ if pattern = "" then None else Some (String.trim pattern))
+ |> List.map (fun pattern ->
+ match Ipaddr.of_string pattern with
+ | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr)
+ | Error _ -> (
+ match Ipaddr.Prefix.of_string pattern with
+ | Ok prefix -> Ipaddr_prefix prefix
+ | Error _ -> Name (trim_dots ~first_leading:true pattern)))
+ in
+ Patterns patterns
+
+let check_no_proxy_patterns host = function
+ | Wildcard -> true
+ | _ when String.length host = 0 -> true
+ | Patterns patterns -> (
+ match Ipaddr.of_string host with
+ | Ok hostip ->
+ List.exists
+ (function
+ | Name _ -> false
+ | Ipaddr_prefix network -> Ipaddr.Prefix.mem hostip network)
+ patterns
+ | Error _ ->
+ let name = trim_dots ~first_leading:false host in
+ List.exists
+ (function
+ | Ipaddr_prefix _ -> false
+ | Name pattern ->
+ let patternlen = String.length pattern
+ and namelen = String.length name in
+ if patternlen = namelen then
+ strncasecompare pattern name namelen
+ else if patternlen < namelen then
+ name.[namelen - patternlen - 1] = '.'
+ && strncasecompare pattern
+ (String.sub name (namelen - patternlen)
+ (patternlen - namelen - patternlen))
+ patternlen
+ else false)
+ patterns)
+
+let tunnel_schemes = [ "https" ]
+
+module Make_proxy (Connection : S.Connection) (Sleep : S.Sleep) = struct
+ module Connection_cache = Make (Connection) (Sleep)
+ module Connection_tunnel = Make_tunnel (Connection) (Sleep)
+
+ type proxy = Direct of Connection_cache.t | Tunnel of Connection_tunnel.t
+
+ type t = {
+ proxies : (string * proxy) list;
+ direct : proxy option;
+ tunnel : proxy option;
+ no_proxy : Connection_cache.t;
+ no_proxy_patterns : no_proxy;
+ }
+
+ let create ?ctx ?keep ?retry ?parallel ?depth ?(scheme_proxy = []) ?all_proxy
+ ?no_proxy ?proxy_headers () =
+ let create_default () =
+ Connection_cache.create ?ctx ?keep ?retry ?parallel ?depth ()
+ and create_direct proxy =
+ Connection_cache.create ?ctx ?keep ?retry ?parallel ?depth ~proxy ()
+ and create_tunnel proxy_uri =
+ Connection_tunnel.create ?ctx ?keep ?retry ?parallel ?depth ?proxy_headers
+ proxy_uri ()
+ in
+ let no_proxy_patterns =
+ match no_proxy with
+ | None -> Patterns []
+ | Some no_proxy -> no_proxy_from_env no_proxy
+ in
+ let no_proxy = create_default () in
+ let proxies =
+ List.map
+ (fun (scheme, uri) ->
+ let proxy =
+ if List.mem scheme tunnel_schemes then Tunnel (create_tunnel uri)
+ else Direct (create_direct uri)
+ in
+ (scheme, proxy))
+ scheme_proxy
+ in
+ let direct, tunnel =
+ match all_proxy with
+ | Some uri ->
+ (Some (Direct (create_direct uri)), Some (Tunnel (create_tunnel uri)))
+ | None -> (None, None)
+ in
+ { no_proxy; direct; tunnel; proxies; no_proxy_patterns }
+
+ let call self ?headers ?body ?absolute_form meth uri =
+ let proxy =
+ if
+ check_no_proxy_patterns
+ (Uri.host_with_default ~default:"" uri)
+ self.no_proxy_patterns
+ then None
+ (* Connection_cache.call self.no_proxy ?headers ?body ?absolute_form meth uri *)
+ else
+ let scheme = Option.value ~default:"" (Uri.scheme uri) in
+ match List.assoc scheme self.proxies with
+ | proxy -> Some proxy
+ | exception Not_found ->
+ if List.mem scheme tunnel_schemes then self.tunnel else self.direct
+ in
+ match proxy with
+ | None ->
+ Connection_cache.call self.no_proxy ?headers ?body ?absolute_form meth
+ uri
+ | Some (Tunnel proxy) ->
+ Connection_tunnel.call proxy ?headers ?body ?absolute_form meth uri
+ | Some (Direct proxy) ->
+ Connection_cache.call proxy ?headers ?body ?absolute_form meth uri
+end
--- /dev/null
+(** This functor establishes a new connection for each request. *)
+module Make_no_cache (Connection : S.Connection) : sig
+ include S.Connection_cache
+
+ val create : ?ctx:Connection.Net.ctx -> unit -> t
+ (** [create ?ctx ()] creates a connection for handling a single request. The
+ connection accepts only a single request and will automatically be closed
+ as soon as possible.
+ @param ctx See {!Connection.Net.ctx} *)
+end
+
+(** This functor keeps a cache of connections for reuse. Connections are reused
+ based on their remote {!type:Conduit.endp} (effectively IP / port). *)
+module Make (Connection : S.Connection) (Sleep : S.Sleep) : sig
+ include S.Connection_cache
+
+ val create :
+ ?ctx:Connection.Net.ctx ->
+ ?keep:int64 ->
+ ?retry:int ->
+ ?parallel:int ->
+ ?depth:int ->
+ ?proxy:Uri.t ->
+ unit ->
+ t
+ (** Create a new connection cache
+
+ @param ctx Conduit context to use. See {!type:Connection.Net.ctx}.
+ @param keep Number of nanoseconds to keep an idle connection around.
+ @param retry
+ Number of times a {e gracefully} failed request is automatically
+ retried. {e graceful} means failed with {!exception:Connection.Retry}.
+ Requests with a [`Stream] {!module:Body} cannot be retried
+ automatically. Such requests will fail with
+ {!exception:Connection.Retry} and a new {!module:Body} will need to be
+ provided to retry.
+ @param parallel
+ maximum number of connections to establish to a single endpoint. Beware:
+ A single hostname may resolve to multiple endpoints. In such a case
+ connections may be created in excess to what was intended.
+ @param depth
+ maximum number of requests to queue and / or send on a single
+ connection.
+ @param proxy A direct (non-tunneling) proxy to use. *)
+end
+[@@warning "-unused-functor-parameter"]
+
+(** This functor keeps a cache of connections for reuse. Connections are reused
+ based on their remote {!type:Conduit.endp} (effectively IP / port). It also
+ supports automatically connecting and reconnecting to direct and tunneling
+ proxies, based on the remote URI scheme (HTTP will select direct proxies,
+ HTTPS tunneling proxies). *)
+module Make_proxy (Connection : S.Connection) (Sleep : S.Sleep) : sig
+ include S.Connection_cache
+
+ val create :
+ ?ctx:Connection.Net.ctx ->
+ ?keep:int64 ->
+ ?retry:int ->
+ ?parallel:int ->
+ ?depth:int ->
+ ?scheme_proxy:(string * Uri.t) list ->
+ ?all_proxy:Uri.t ->
+ ?no_proxy:string ->
+ ?proxy_headers:Http.Header.t ->
+ unit ->
+ t
+ (** Create a new connection cache. The outer connections to the proxy and the
+ inner connections share the same parameters.
+
+ @param ctx Conduit context to use. See {!type:Connection.Net.ctx}.
+ @param keep Number of nanoseconds to keep an idle connection around.
+ @param retry
+ Number of times a {e gracefully} failed request is automatically
+ retried. {e graceful} means failed with {!exception:Connection.Retry}.
+ Requests with a [`Stream] {!module:Body} cannot be retried
+ automatically. Such requests will fail with
+ {!exception:Connection.Retry} and a new {!module:Body} will need to be
+ provided to retry.
+ @param parallel
+ maximum number of connections to establish to a single endpoint. Beware:
+ A single hostname may resolve to multiple endpoints. In such a case
+ connections may be created in excess to what was intended.
+ @param depth
+ maximum number of requests to queue and / or send on a single
+ connection.
+ @param scheme_proxy The proxy URI associated to each (remote) scheme.
+ @param all_proxy
+ The default proxy to use. Proxy for specific schemes have precedence
+ over this.
+ @param no_proxy
+ Disable proxies for specific hosts, specified as curl's [NO_PROXY].
+ @see <https://everything.curl.dev/usingcurl/proxies/env.html#no-proxy>
+ @param proxy_headers Headers to pass to the proxy. *)
+end
+[@@warning "-unused-functor-parameter"]
(synopsis "Lwt backend")
(preprocess
(pps ppx_sexp_conv))
- (libraries lwt uri http_bytebuffer cohttp logs logs.lwt))
+ (libraries lwt uri uri.services http_bytebuffer cohttp logs logs.lwt ipaddr))
module type Net = sig
module IO : IO
+ type client
type endp
type ctx [@@deriving sexp_of]
(** [resolve ~ctx uri] resolves [uri] into an endpoint description. This is
[Resolver_lwt.resolve_uri ~uri ctx.resolver]. *)
+ val tunnel : string -> IO.ic * IO.oc -> client
+
val connect_uri : ctx:ctx -> Uri.t -> (IO.conn * IO.ic * IO.oc) IO.t
(** [connect_uri ~ctx uri] starts a {i flow} on the given [uri]. The choice of
the protocol (with or without encryption) is done by the {i scheme} of the
(** [connect_endp ~ctx endp] starts a {i flow} to the given [endp]. [endp]
describes address and protocol of the endpoint to connect to. *)
+ val connect_client : ctx:ctx -> client -> (IO.conn * IO.ic * IO.oc) IO.t
val close_in : IO.ic -> unit
val close_out : IO.oc -> unit
val close : IO.ic -> IO.oc -> unit
type call =
?headers:Http.Header.t ->
?body:Body.t ->
+ ?absolute_form:bool ->
Http.Method.t ->
Uri.t ->
(Cohttp.Response.t * Body.t) Lwt.t
module can be used to consume [response_body]. Use {!Body.drain_body} if
you don't consume the body by other means.
- Leaks are detected by the GC and logged as debug messages, these can be
- enabled activating the debug logging. For example, this can be done as
- follows in
- [cohttp-lwt-unix]
+ Leaks are detected by the GC and logged as debug messages, these can be
+ enabled activating the debug logging. For example, this can be done as
+ follows in [cohttp-lwt-unix]
- {[
- Cohttp_lwt_unix.Debug.activate_debug ();
- Logs.set_level (Some Logs.Warning)
- ]}
+ {[
+ Cohttp_lwt_unix.Debug.activate_debug ();
+ Logs.set_level (Some Logs.Warning)
+ ]}
@raise {!Connection.Retry}
on recoverable errors like the remote endpoint closing the connection
@param ctx See [Net.ctx]
@param endp The remote address, port and protocol to connect to. *)
+ val create_tunnel :
+ ?finalise:(t -> unit Net.IO.t) -> ?ctx:Net.ctx -> t -> string -> t
+
val connect :
?finalise:(t -> unit Net.IO.t) ->
?persistent:bool ->
{!val:Connection_cache.Make_no_cache.create} is used to resolve uri and
create a dedicated connection with [ctx].
- In most cases you should use the more specific helper calls in the
- interface rather than invoke this function directly. See {!head}, {!get}
- and {!post} for some examples. *)
+ In most cases you should use the more specific helper calls in the
+ interface rather than invoke this function directly. See {!head}, {!get}
+ and {!post} for some examples. *)
include
Cohttp.Generic.Client.S
with type 'a io = 'a Lwt.t
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for the MirageOS unikernel"
"ocaml" {>= "4.08"}
"mirage-flow" {>= "2.0.0"}
"mirage-channel" {>= "4.0.0"}
- "conduit" {>= "2.0.2"}
- "conduit-mirage" {>= "2.3.0"}
+ "conduit" {>= "8.0.0"}
+ "conduit-mirage" {>= "8.0.0"}
"mirage-kv" {>= "3.0.0"}
"lwt" {>= "2.4.3"}
"cohttp-lwt" {= version}
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.0.0
+ * cohttp v6.1.0
*)
-module Make
- (P : Mirage_clock.PCLOCK)
- (R : Resolver_mirage.S)
- (S : Conduit_mirage.S) =
-struct
- module Net = Net.Make (P) (R) (S)
+module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct
+ module Net = Net.Make (R) (S)
module Connection = Cohttp_lwt.Connection.Make (Net)
include Cohttp_lwt.Client.Make (Connection)
-module Make
- (_ : Mirage_clock.PCLOCK)
- (R : Resolver_mirage.S)
- (S : Conduit_mirage.S) : sig
+module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) : sig
module Connection : Cohttp_lwt.S.Connection
include Cohttp_lwt.S.Client with type ctx = Connection.Net.ctx
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.0.0
+ * cohttp v6.1.0
*)
open Lwt.Infix
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.0.0
+ * cohttp v6.1.0
*)
(** Cohttp IO implementation using Mirage channels. *)
-module Make
- (P : Mirage_clock.PCLOCK)
- (R : Resolver_mirage.S)
- (S : Conduit_mirage.S) =
-struct
+module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct
module Channel = Mirage_channel.Make (S.Flow)
module Input_channel = Input_channel.Make (Channel)
- module Endpoint = Conduit_mirage.Endpoint (P)
module IO = Io.Make (Channel)
open IO
lazy { resolver = R.localhost; conduit = None; authenticator = None }
type endp = Conduit.endp
+ type client
+ let tunnel = failwith "Unimplemented"
+ let connect_client = failwith "Unimplemented"
let resolve ~ctx uri = R.resolve_uri ~uri ctx.resolver
let connect_endp ~ctx endp =
- Endpoint.client ?tls_authenticator:ctx.authenticator endp >>= fun client ->
+ Conduit_mirage.Endpoint.client ?tls_authenticator:ctx.authenticator endp
+ >>= fun client ->
match ctx.conduit with
| None -> failwith "conduit not initialised"
| Some c ->
-module Make
- (_ : Mirage_clock.PCLOCK)
- (R : Resolver_mirage.S)
- (S : Conduit_mirage.S) : sig
+module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) : sig
type ctx = {
resolver : R.t;
conduit : S.t option;
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.0.0
+ * cohttp v6.1.0
*)
module Key = Mirage_kv.Key
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.0.0
+ * cohttp v6.1.0
*)
(** Serve static HTTP sites from a Mirage key-value store. *)
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Lightweight Cohttp + Lwt based HTTP server"
Int64.of_string_opt ("0x" ^ hex)
let step_chunked :
- 'a.
- t ->
- f:(Body.Substring.t -> 'acc -> 'acc Lwt.t) ->
- init:'acc ->
- 'acc option Lwt.t =
+ 'a.
+ t ->
+ f:(Body.Substring.t -> 'acc -> 'acc Lwt.t) ->
+ init:'acc ->
+ 'acc option Lwt.t =
fun t ~f ~init ->
Input_channel.read_line_opt t.ic >>= function
| None -> Lwt.return_none (* TODO invalid input *)
(** [stream ?encoding f] respond with body generated by repeatedly applying
[f]. When [f] returns [None], it will be considered terminated.
- [?encoding] is the encoding to use. By default this is [Encoding.chunked]. *)
+ [?encoding] is the encoding to use. By default this is [Encoding.chunked].
+ *)
end
module Context : sig
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP toplevel pretty printers for HTTP types"
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "An OCaml library for HTTP clients and servers"
(** Basic language range tag. ["en-gb"] is represented as
[Language ["en"; "gb"]].
- @see <https://tools.ietf.org/html/rfc7231#section-5.3.5> the specification. *)
+ @see <https://tools.ietf.org/html/rfc7231#section-5.3.5> the specification.
+*)
type language = Accept_types.language = Language of string list | AnyLanguage
[@@deriving sexp]
(** Give a description of the given int code. *)
val is_informational : int -> bool
-(** Is the given int code belong to the class of "informational" return code ? *)
+(** Is the given int code belong to the class of "informational" return code ?
+*)
val is_success : int -> bool
(** Is the given int code belong to the class of "success" return code ? *)
sexplib0
stringext
uri
- uri-sexp))
+ uri-sexp
+ uri.services))
(ocamllex accept_lexer)
(** [to_list h] converts HTTP headers [h] to a list. Order and case is
preserved.
- {e Invariant (with case insensitive comparison):} [to_list (of_list l) = l] *)
+ {e Invariant (with case insensitive comparison):} [to_list (of_list l) = l]
+*)
val init_with : string -> string -> t
(** [init_with k v] construct a fresh HTTP headers with a single header with
the last value paired with [k] in [h].
{e Invariant:}
- [forall h, k not a list-value header. get_multi_concat ~list-value-only:true h k = get h k] *)
+ [forall h, k not a list-value header. get_multi_concat ~list-value-only:true
+ h k = get h k] *)
val update : t -> string -> (string option -> string option) -> t
(** [update h k f] returns an header list containing the same headers as [h],
Finally, following
{{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}, the
- header [Set-cookie] is treated as an exception and ignored by [clean_dup]. *)
+ header [Set-cookie] is treated as an exception and ignored by [clean_dup].
+*)
val get_content_range : t -> Int64.t option
val get_media_type : t -> string option
val get_links : t -> Link.t list
val user_agent : string
-(** The User-Agent header used by this library, including the version of cohttp. *)
+(** The User-Agent header used by this library, including the version of cohttp.
+*)
val prepend_user_agent : t -> string -> t
(** Prepend [user_agent] to the product token already declared in the
let encoding t = Header.get_transfer_encoding t.headers
let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding
- ?(headers = Header.init ()) uri =
- let headers =
- Header.add_unless_exists headers "host"
- (match Uri.scheme uri with
- | Some "httpunix" -> ""
- | _ -> (
- Uri.host_with_default ~default:"localhost" uri
- ^
- match Uri.port uri with Some p -> ":" ^ string_of_int p | None -> ""))
+ ?(headers = Header.init ()) ?(absolute_form = false) uri =
+ let port () =
+ match Uri.port uri with
+ | Some p -> ":" ^ string_of_int p
+ | None when meth = `CONNECT -> (
+ match Uri_services.tcp_port_of_uri uri with
+ | None -> failwith "A port is required for the CONNECT method."
+ | Some p -> ":" ^ string_of_int p)
+ | None -> ""
+ in
+ let host =
+ match Header.get headers "host" with
+ | None -> (
+ match Uri.scheme uri with
+ | Some "httpunix" -> ""
+ | _ -> Uri.host_with_default ~default:"localhost" uri ^ port ())
+ | Some host -> if String.contains host ':' then host else host ^ port ()
in
+
+ let headers = Header.replace headers "host" host in
let headers =
Header.add_unless_exists headers "user-agent" Header.user_agent
in
Header.add_authorization headers auth
| _, _, _ -> headers
in
- let resource = Uri.path_and_query uri in
+ let resource =
+ if absolute_form then Uri.to_string uri else Uri.path_and_query uri
+ in
let headers =
match encoding with
| None -> headers
adding content headers if appropriate.
@param chunked Forces chunked encoding
*)
-let make_for_client ?headers ?chunked ?body_length meth uri =
+let make_for_client ?headers ?chunked ?body_length ?absolute_form meth uri =
let encoding =
match (chunked, body_length) with
| Some true, None -> Transfer.Chunked
| Some true, Some _ ->
invalid_arg "cannot set both ?chunked and ?body_length:"
in
- make ~meth ~encoding ?headers uri
+ make ~meth ~encoding ?headers ?absolute_form uri
let pp_hum ppf r =
Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum)
| Some _ -> (
Uri.(
(* we have an absoluteURI *)
- match path uri with "" -> with_path uri "/" | _ -> uri))
+ match path uri with
+ | "" -> with_path uri "/"
+ | _ -> uri))
| None -> (
let empty = Uri.of_string "" in
let empty_base = Uri.of_string "///" in
let fst_line =
Printf.sprintf "%s %s %s\r\n"
(Http.Method.to_string req.meth)
- (if req.resource = "" then "/" else req.resource)
+ (if req.meth = `CONNECT then Option.get (Header.get req.headers "host")
+ else if req.resource = "" then "/"
+ else req.resource)
(Http.Version.to_string req.version)
in
IO.write oc fst_line >>= fun _ -> Header_IO.write req.headers oc
?version:Code.version ->
?encoding:Transfer.encoding ->
?headers:Header.t ->
+ ?absolute_form:bool ->
Uri.t ->
t
(** [make ()] is a value of {!type:t}. The default values for the request, if
?headers:Header.t ->
?chunked:bool ->
?body_length:int64 ->
+ ?absolute_form:bool ->
Code.meth ->
Uri.t ->
t
module A = Cohttp.Accept
-let suite_of :
- type a.
+let suite_of : type a.
(string option -> a) -> a Alcotest.testable -> (string * a) list -> _ list =
fun pf t ->
List.map (fun (s, expected) ->
let test () = Alcotest.check t s (pf (Some s)) expected in
(s, `Quick, test))
-let suite_of_fail :
- type a.
+let suite_of_fail : type a.
(string option -> a) -> a Alcotest.testable -> (string * exn) list -> _ list
=
fun pf _ ->
let test () = Alcotest.(check string expected_str expected_str (pf v)) in
(expected_str, `Quick, test))
-let suite_to_string_of_fail :
- type a. (a -> string) -> (a * string * exn) list -> _ list =
+let suite_to_string_of_fail : type a.
+ (a -> string) -> (a * string * exn) list -> _ list =
fun pf ->
List.map (fun (v, descr, e) ->
let test () = Alcotest.(check_raises descr e (fun () -> ignore (pf v))) in
(lang dune 3.8)
(name cohttp)
-(version v6.0.0)
+(version v6.1.0)
(license ISC)
(lwt
(>= 5.4.0))
sexplib0
+ (ipaddr
+ (>= 5.6.0))
(ppx_sexp_conv
(>= v0.13.0))
logs
(lwt
(>= 3.0.0))
(conduit-lwt
- (>= 5.0.0))
+ (>= 7.1.0))
(conduit-lwt-unix
- (>= 5.0.0))
+ (>= 7.1.0))
(fmt
(>= 0.8.2))
base-unix
"An implementation of an HTTP client and server using the Async\nconcurrency library. See the `Cohttp_async` module for information\non how to use this. The package also installs `cohttp-curl-async`\nand a `cohttp-server-async` binaries for quick uses of a HTTP(S)\nclient and server respectively.\n")
(depends
(ocaml
- (>= 4.14))
+ (and (>= 4.14) (< 5.3.0)))
(http
(= :version))
(cohttp
(mirage-channel
(>= 4.0.0))
(conduit
- (>= 2.0.2))
+ (>= 8.0.0))
(conduit-mirage
- (>= 2.3.0))
+ (>= 8.0.0))
(mirage-kv
(>= 3.0.0))
(lwt
logs
uri
(tls-eio (and :with-test (>= 1.0.0)))
- (mirage-crypto-rng-eio (and :with-test (>= 0.11.2)))
+ (mirage-crypto-rng (and :with-test (>= 1.2.0)))
(ca-certs (and :with-test (>= "1.0.0")))
fmt
ptime
"systems": "systems"
},
"locked": {
- "lastModified": 1710146030,
- "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
+ "lastModified": 1731533236,
+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
"owner": "numtide",
"repo": "flake-utils",
- "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
- "type": "github"
- },
- "original": {
- "owner": "numtide",
- "repo": "flake-utils",
- "type": "github"
- }
- },
- "flake-utils_2": {
- "inputs": {
- "systems": "systems_2"
- },
- "locked": {
- "lastModified": 1710146030,
- "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
- "owner": "numtide",
- "repo": "flake-utils",
- "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
"type": "github"
},
"original": {
},
"nixpkgs": {
"inputs": {
- "flake-utils": "flake-utils_2",
"nixpkgs": "nixpkgs_2"
},
"locked": {
- "lastModified": 1725916231,
- "narHash": "sha256-kaU41Z43Uv2As0Sor8FPACJfWjkbUsWnZMtbCgqicvU=",
+ "lastModified": 1734153276,
+ "narHash": "sha256-/cvtpMFp0HArEpFi0PrPMsheauc3IJ7qWpSHnw8so2M=",
"owner": "nix-ocaml",
"repo": "nix-overlays",
- "rev": "d63aa7b62251c70bbf0a28a67c30555077a2b758",
+ "rev": "4247b28ce426ccdea09a1ec014fa52785bc7ba1d",
"type": "github"
},
"original": {
},
"nixpkgs_2": {
"locked": {
- "lastModified": 1725857262,
- "narHash": "sha256-m9n0PncgZepVgmjOO1rfVXMgUACDOwZbhjSRjJ/NUpM=",
+ "lastModified": 1734100912,
+ "narHash": "sha256-93T/KB1ppdhnaV4u5uSwO6HutSq2RzcnkqVX9YKYslE=",
"owner": "NixOS",
"repo": "nixpkgs",
- "rev": "5af6aefbcc55670e36663fd1f8a796e1e323001a",
+ "rev": "2a7ebf12140f6d97941d5f8cc38e9323212ecbad",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
- "rev": "5af6aefbcc55670e36663fd1f8a796e1e323001a",
+ "rev": "2a7ebf12140f6d97941d5f8cc38e9323212ecbad",
"type": "github"
}
},
"repo": "default",
"type": "github"
}
- },
- "systems_2": {
- "locked": {
- "lastModified": 1681028828,
- "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
- "owner": "nix-systems",
- "repo": "default",
- "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
- "type": "github"
- },
- "original": {
- "owner": "nix-systems",
- "repo": "default",
- "type": "github"
- }
}
},
"root": "root",
default = http;
http = pkg {
pname = "http";
+ propagatedBuildInputs = [ ppx_expect ];
checkInputs = [ alcotest base_quickcheck ppx_expect crowbar ];
};
cohttp = pkg {
pname = "cohttp";
checkInputs = [ fmt alcotest ];
propagatedBuildInputs = [
- stringext http re uri uri-sexp logs sexplib0 ppx_sexp_conv
+ base64 stringext http re uri uri-sexp logs sexplib0 ppx_sexp_conv
];
};
cohttp-top = pkg {
};
cohttp-curl-lwt = pkg {
pname = "cohttp-curl-lwt";
- checkInputs = [ cohttp-lwt-unix cohttp cohttp-lwt conduit-lwt ounit2 uri ];
- propagatedBuildInputs = [ ocurl http stringext lwt ];
+ checkInputs = [ alcotest cohttp-lwt-unix cohttp cohttp-lwt conduit-lwt ounit2 uri ];
+ propagatedBuildInputs = [ ocurl cohttp-curl http stringext lwt ];
+ __darwinAllowLocalNetworking = true;
};
cohttp-curl-async = pkg {
pname = "cohttp-curl-async";
http cohttp cohttp-lwt cmdliner lwt conduit-lwt
conduit-lwt-unix fmt ppx_sexp_conv magic-mime logs
];
+ __darwinAllowLocalNetworking = true;
};
cohttp-server-lwt-unix = pkg {
pname = "cohttp-server-lwt-unix";
-version: "6.0.0"
+version: "6.1.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Type definitions of HTTP essentials"
returned value is the last value paired with [k] in [h].
{e Invariant:}
- [forall h, k not a list-value header. get_multi_concat ~list-value-only:true h k = get h k] *)
+ [forall h, k not a list-value header. get_multi_concat
+ ~list-value-only:true h k = get h k] *)
val update : t -> string -> (string option -> string option) -> t
(** [update h k f] returns an header list containing the same headers as [h],
Finally, following
{{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}, the
- header [Set-cookie] is treated as an exception and ignored by [clean_dup]. *)
+ header [Set-cookie] is treated as an exception and ignored by [clean_dup].
+ *)
val get_content_range : t -> Int64.t option
val get_connection_close : t -> bool
projects / ocaml-cohttp.git / commitdiff