wrap cohttp-lwt and cohttp-lwt-unix

cohttp-lwt-jsoo/src/cohttp_lwt_xhr.ml

@@ -152,12 +152,14 @@ module Make_api(X : sig
 
 end
 
+module String_io = Cohttp__String_io
+module IO = Cohttp_lwt__String_io
+module Header_io = Cohttp__Header_io.Make(IO)
+
 module Make_client_async(P : Params) = Make_api(struct
 
-    module IO = String_io_lwt
     module Response = Cohttp.Response
     module Request = Cohttp.Request
-    module Header_io = Cohttp.Header_io.Make(IO)
     module Bb = Body_builder(P)
 
     let call ?headers ?body meth uri =
@@ -208,7 +210,7 @@ module Make_client_async(P : Params) = Make_api(struct
                  (* (re-)construct the response *)
                  let response =
                    let resp_headers = Js.to_string (xml##getAllResponseHeaders) in
-                   let channel = C.String_io.open_in resp_headers in
+                   let channel = String_io.open_in resp_headers in
                    Lwt.(Header_io.parse channel >|= fun resp_headers ->
                         Response.make
                           ~version:`HTTP_1_1
@@ -248,10 +250,8 @@ module Make_client_async(P : Params) = Make_api(struct
 
 module Make_client_sync(P : Params) = Make_api(struct
 
-    module IO = String_io_lwt
     module Response = Cohttp.Response
     module Request = Cohttp.Request
-    module Header_io = Cohttp.Header_io.Make(IO)
     module Bb = Body_builder(P)
 
     let call ?headers ?body meth uri =
@@ -303,7 +303,7 @@ module Make_client_sync(P : Params) = Make_api(struct
 
   (* (re-)construct the response *)
   let resp_headers = Js.to_string (xml##getAllResponseHeaders) in
-  Header_io.parse (C.String_io.open_in resp_headers)
+  Header_io.parse (String_io.open_in resp_headers)
   >>= fun resp_headers ->
 
   let response = Response.make

cohttp-lwt-unix/bin/cohttp_curl_lwt.ml

@@ -18,7 +18,7 @@
 open Lwt
 open Cohttp
 open Cohttp_lwt_unix
-module D = Cohttp_lwt_unix_debug
+module D = Cohttp_lwt_unix.Debug
 
 let debug f = if D.debug_active () then Logs_lwt.debug f else return ()
 
@@ -50,7 +50,7 @@ let run_client verbose ofile uri meth =
   Lwt_main.run (
     (if verbose
     then (
-      Cohttp_lwt_unix_debug.activate_debug ();
+      Cohttp_lwt_unix.Debug.activate_debug ();
       debug (fun d -> d ">>> Debug active") >>= fun () -> return ())
     else return ())
     >>= fun () ->

cohttp-lwt-unix/src/client.ml

@@ -0,0 +1,4 @@
+
+include Cohttp_lwt.Make_client(Io)(Net)
+
+let custom_ctx = Net.init

cohttp-lwt-unix/src/client.mli

@@ -0,0 +1,17 @@
+
+(** The [Client] module implements the full UNIX HTTP client interface,
+    including the UNIX-specific functions defined in {!C }. *)
+
+include Cohttp_lwt.S.Client with type ctx = Net.ctx
+
+(** [custom_ctx ?ctx ?resolver ()] will return a context that is the
+    same as the {!default_ctx}, but with either the connection handling
+    or resolution module overridden with [ctx] or [resolver] respectively.
+
+    This is useful to supply a {!Conduit_lwt_unix.ctx} with a custom
+    source network interface, or a {!Resolver_lwt.t} with a different
+    name resolution strategy (for instance to override a hostname to
+    point it to a Unix domain socket). *)
+val custom_ctx:
+  ?ctx:Conduit_lwt_unix.ctx ->
+  ?resolver:Resolver_lwt.t -> unit -> ctx

cohttp-lwt-unix/src/cohttp_lwt_unix.ml

@@ -16,77 +16,18 @@
 
 module Request = struct
   include Cohttp.Request
-  include (Make(Cohttp_lwt_unix_io)
-           : module type of Make(Cohttp_lwt_unix_io) with type t := t)
+  include (Make(Io)
+           : module type of Make(Io) with type t := t)
 end
 
 module Response = struct
   include Cohttp.Response
-  include (Make(Cohttp_lwt_unix_io)
-           : module type of Make(Cohttp_lwt_unix_io) with type t := t)
+  include (Make(Io)
+           : module type of Make(Io) with type t := t)
 end
 
-module Net = Cohttp_lwt_unix_net
-
-module Client = struct
-  include
-    Cohttp_lwt.Make_client
-      (Cohttp_lwt_unix_io)(Cohttp_lwt_unix_net)
-
-  let custom_ctx = Cohttp_lwt_unix_net.init
-end
-
-module Server_core = Cohttp_lwt.Make_server (Cohttp_lwt_unix_io)
-
-module Server = struct
-  include Server_core
-  open Lwt
-
-  let blank_uri = Uri.of_string ""
-
-  let resolve_file ~docroot ~uri =
-    (* This normalises the Uri and strips out .. characters *)
-    let frag = Uri.path (Uri.resolve "" blank_uri uri) in
-    Filename.concat docroot frag
-
-  exception Isnt_a_file
-  let respond_file ?headers ~fname () =
-    Lwt.catch (fun () ->
-      (* Check this isnt a directory first *)
-      (fname |> Lwt_unix.stat >>= fun s ->
-       if Unix.(s.st_kind <> S_REG)
-       then fail Isnt_a_file
-       else return_unit) >>= fun () ->
-      let count = 16384 in
-      Lwt_io.open_file
-        ~buffer:(Lwt_bytes.create count)
-        ~mode:Lwt_io.input fname >>= fun ic ->
-      Lwt_io.length ic >>= fun len ->
-      let encoding = Cohttp.Transfer.Fixed len in
-      let stream = Lwt_stream.from (fun () ->
-        Lwt.catch (fun () ->
-          Lwt_io.read ~count ic >|= function
-          | "" -> None
-          | buf -> Some buf)
-          (fun exn ->
-             Lwt_log.ign_debug ~exn ("Error resolving file " ^ fname);
-             return_none)
-      ) in
-      Lwt_stream.on_terminate stream (fun () ->
-        ignore_result (Lwt_io.close ic));
-      let body = Cohttp_lwt.Body.of_stream stream in
-      let mime_type = Magic_mime.lookup fname in
-      let headers = Cohttp.Header.add_opt_unless_exists
-                      headers "content-type" mime_type in
-      let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in
-      return (res, body)
-    ) (function
-      | Unix.Unix_error(Unix.ENOENT,_,_) | Isnt_a_file ->
-        respond_not_found ()
-      | exn -> Lwt.fail exn)
-
-  let create ?timeout ?stop ?on_exn ?(ctx=Cohttp_lwt_unix_net.default_ctx)
-        ?(mode=`TCP (`Port 8080)) spec =
-    Conduit_lwt_unix.serve ?timeout ?stop ?on_exn ~ctx:ctx.Cohttp_lwt_unix_net.ctx
-      ~mode (callback spec)
-end
+module Client = Client
+module Server = Server
+module Debug = Debug
+module Net = Net
+module IO = Io

cohttp-lwt-unix/src/cohttp_lwt_unix_io.ml → cohttp-lwt-unix/src/io.ml

@@ -14,7 +14,7 @@
  *
   }}}*)
 
-module CD = Cohttp_lwt_unix_debug
+module CD = Debug
 let () =
   if Sys.os_type <> "Win32" then
     Sys.(set_signal sigpipe Signal_ignore);

cohttp-lwt-unix/src/jbuild

@@ -5,5 +5,11 @@
   (public_name cohttp-lwt-unix)
   (synopsis "Lwt/Unix backend for Cohttp")
   (preprocess (pps (ppx_sexp_conv)))
-  (wrapped false)
-  (libraries (fmt logs.lwt conduit-lwt-unix magic-mime lwt.unix cohttp cohttp-lwt))))
+  (libraries
+   (fmt
+    logs.lwt
+    conduit-lwt-unix
+    magic-mime
+    lwt.unix
+    cohttp
+    cohttp-lwt))))

cohttp-lwt-unix/src/cohttp_lwt_unix_net.ml → cohttp-lwt-unix/src/net.ml

@@ -19,7 +19,7 @@
 
 open Lwt
 
-module IO = Cohttp_lwt_unix_io
+module IO = Io
 
 type ctx = {
   ctx: Conduit_lwt_unix.ctx;

cohttp-lwt-unix/src/server.ml

@@ -0,0 +1,53 @@
+
+module Server_core = Cohttp_lwt.Make_server (Io)
+
+include Server_core
+open Lwt
+
+let blank_uri = Uri.of_string ""
+
+let resolve_file ~docroot ~uri =
+  (* This normalises the Uri and strips out .. characters *)
+  let frag = Uri.path (Uri.resolve "" blank_uri uri) in
+  Filename.concat docroot frag
+
+exception Isnt_a_file
+let respond_file ?headers ~fname () =
+  Lwt.catch (fun () ->
+      (* Check this isnt a directory first *)
+      (fname |> Lwt_unix.stat >>= fun s ->
+       if Unix.(s.st_kind <> S_REG)
+       then fail Isnt_a_file
+       else return_unit) >>= fun () ->
+      let count = 16384 in
+      Lwt_io.open_file
+        ~buffer:(Lwt_bytes.create count)
+        ~mode:Lwt_io.input fname >>= fun ic ->
+      Lwt_io.length ic >>= fun len ->
+      let encoding = Cohttp.Transfer.Fixed len in
+      let stream = Lwt_stream.from (fun () ->
+          Lwt.catch (fun () ->
+              Lwt_io.read ~count ic >|= function
+              | "" -> None
+              | buf -> Some buf)
+            (fun exn ->
+               Lwt_log.ign_debug ~exn ("Error resolving file " ^ fname);
+               return_none)
+        ) in
+      Lwt_stream.on_terminate stream (fun () ->
+          ignore_result (Lwt_io.close ic));
+      let body = Cohttp_lwt.Body.of_stream stream in
+      let mime_type = Magic_mime.lookup fname in
+      let headers = Cohttp.Header.add_opt_unless_exists
+          headers "content-type" mime_type in
+      let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in
+      return (res, body)
+    ) (function
+      | Unix.Unix_error(Unix.ENOENT,_,_) | Isnt_a_file ->
+        respond_not_found ()
+      | exn -> Lwt.fail exn)
+
+let create ?timeout ?stop ?on_exn ?(ctx=Net.default_ctx)
+    ?(mode=`TCP (`Port 8080)) spec =
+  Conduit_lwt_unix.serve ?timeout ?stop ?on_exn ~ctx:ctx.Net.ctx
+    ~mode (callback spec)

cohttp-lwt-unix/src/server.mli

@@ -0,0 +1,17 @@
+(** The [Server] module implements the full UNIX HTTP server interface,
+    including the UNIX-specific functions defined in {!S}. *)
+
+include Cohttp_lwt.S.Server with module IO = Io
+
+val resolve_file : docroot:string -> uri:Uri.t -> string
+
+val respond_file :
+  ?headers:Cohttp.Header.t ->
+  fname:string -> unit -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t
+
+val create :
+  ?timeout:int ->
+  ?stop:unit Lwt.t ->
+  ?on_exn:(exn -> unit) ->
+  ?ctx:Net.ctx ->
+  ?mode:Conduit_lwt_unix.server -> t -> unit Lwt.t