Merge branch 'master' of github.com:mirage/ocaml-cohttp into header_a…

…ssoc

.github/workflows/workflow.yml

@@ -28,7 +28,6 @@ jobs:
         uses: actions-ml/setup-ocaml@master
         with:
           ocaml-version: ${{ matrix.ocaml-version }}
-          dune-cache: true
           opam-depext: false
           opam-pin: false
 

.ocamlformat

@@ -1,2 +1,5 @@
-version = 0.15.0
-disable = true
+version = 0.16.0
+profile = conventional
+break-infix = fit-or-vertical
+parse-docstrings = true
+module-item-spacing = compact

CHANGES.md

@@ -1,5 +1,6 @@
 ## current
 
+- Remove dependency to base (@samoht #745)
 - fix opam files and dependencies
 - add GitHub Actions workflow (@smorimoto #739)
 - lwt_jsoo: Forward exceptions to caller when response is null (@mefyl #738)

cohttp-async/bin/cohttp_curl_async.ml

@@ -24,13 +24,15 @@ let show_headers h =
 let make_net_req uri meth' body () =
   let meth = Cohttp.Code.method_of_string meth' in
   let uri = Uri.of_string uri in
-  let headers = Cohttp.Header.of_list [ "connection", "close" ] in
+  let headers = Cohttp.Header.of_list [ ("connection", "close") ] in
   Client.call meth ~headers ~body:Body.(of_string body) uri
   >>= fun (res, body) ->
   show_headers (Cohttp.Response.headers res);
   body
   |> Body.to_pipe
-  |> Pipe.iter ~f:(fun b -> Stdlib.print_string b; return ())
+  |> Pipe.iter ~f:(fun b ->
+         Stdlib.print_string b;
+         return ())
 
 let _ =
   (* enable logging to stdout *)
@@ -42,10 +44,9 @@ let _ =
     Spec.(
       empty
       +> anon ("url" %: string)
-      +> flag "-X" (optional_with_default "GET" string)
-        ~doc:" Set HTTP method"
-      +> flag "data-binary" (optional_with_default "" string)
-        ~doc:" Data to send when using POST"
-    )
+      +> flag "-X" (optional_with_default "GET" string) ~doc:" Set HTTP method"
+      +> flag "data-binary"
+           (optional_with_default "" string)
+           ~doc:" Data to send when using POST")
     make_net_req
   |> run

cohttp-async/bin/cohttp_server_async.ml

@@ -18,87 +18,84 @@
 open Base
 open Async_kernel
 open Async_unix
-
 open Cohttp_async
 open Cohttp_server
 
-let method_filter meth (res,body) = match meth with
-  | `HEAD -> return (res,`Empty)
-  | _ -> return (res,body)
+let method_filter meth (res, body) =
+  match meth with `HEAD -> return (res, `Empty) | _ -> return (res, body)
 
 let serve_file ~docroot ~uri =
-  Server.resolve_local_file ~docroot ~uri
-  |> Server.respond_with_file
+  Server.resolve_local_file ~docroot ~uri |> Server.respond_with_file
 
 let serve ~info ~docroot ~index uri path =
   (* Get a canonical filename from the URL and docroot *)
   let file_name = Server.resolve_local_file ~docroot ~uri in
   try_with (fun () ->
-    Unix.stat file_name
-    >>= fun stat ->
-    Logs.debug (fun f -> f "%s" (Sexp.to_string_hum (Unix.Stats.sexp_of_t stat)));
-    match stat.Unix.Stats.kind with
-    (* Get a list of current files and map to HTML *)
-    | `Directory -> begin
-      let path_len = String.length path in
-      if Int.(path_len <> 0) && Char.(path.[path_len - 1] <> '/')
-      then Server.respond_with_redirect (Uri.with_path uri (path^"/"))
-      (* Check if the index file exists *)
-      else Sys.file_exists (file_name / index)
-      >>= function
-      | `Yes -> (* Serve the index file directly *)
-        let uri = Uri.with_path uri (path / index) in
-        serve_file ~docroot ~uri
-      | `No | `Unknown -> (* Do a directory listing *)
-        Sys.ls_dir file_name
-        >>= Deferred.List.map ~f:(fun f ->
-          let file_name = file_name / f in
-          try_with (fun () ->
-            Unix.stat file_name
-            >>| fun stat -> (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f)
-          ) >>| function Ok v -> v | Error _ -> (None, 0L, f))
-        >>= fun listing ->
-        html_of_listing uri path (sort ((Some `Directory,0L,"..")::listing)) info
-      |> Server.respond_string
-    end
-    (* Serve the local file contents *)
-    | `File -> serve_file ~docroot ~uri
-    (* Any other file type is simply forbidden *)
-    | `Socket | `Block | `Fifo | `Char | `Link ->
-      Server.respond_string ~status:`Forbidden
-        (html_of_forbidden_unnormal path info)
-  )
-  >>= (function
+      Unix.stat file_name >>= fun stat ->
+      Logs.debug (fun f ->
+          f "%s" (Sexp.to_string_hum (Unix.Stats.sexp_of_t stat)));
+      match stat.Unix.Stats.kind with
+      (* Get a list of current files and map to HTML *)
+      | `Directory -> (
+          let path_len = String.length path in
+          if Int.(path_len <> 0) && Char.(path.[path_len - 1] <> '/') then
+            Server.respond_with_redirect (Uri.with_path uri (path ^ "/"))
+            (* Check if the index file exists *)
+          else
+            Sys.file_exists (file_name / index) >>= function
+            | `Yes ->
+                (* Serve the index file directly *)
+                let uri = Uri.with_path uri (path / index) in
+                serve_file ~docroot ~uri
+            | `No | `Unknown ->
+                (* Do a directory listing *)
+                Sys.ls_dir file_name
+                >>= Deferred.List.map ~f:(fun f ->
+                        let file_name = file_name / f in
+                        try_with (fun () ->
+                            Unix.stat file_name >>| fun stat ->
+                            (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f))
+                        >>| function
+                        | Ok v -> v
+                        | Error _ -> (None, 0L, f))
+                >>= fun listing ->
+                html_of_listing uri path
+                  (sort ((Some `Directory, 0L, "..") :: listing))
+                  info
+                |> Server.respond_string)
+      (* Serve the local file contents *)
+      | `File -> serve_file ~docroot ~uri
+      (* Any other file type is simply forbidden *)
+      | `Socket | `Block | `Fifo | `Char | `Link ->
+          Server.respond_string ~status:`Forbidden
+            (html_of_forbidden_unnormal path info))
+  >>= function
   | Ok res -> return res
-  | Error exn ->
-    begin match Monitor.extract_exn exn with
-    | Unix.Unix_error (Unix.Error.ENOENT, "stat", p) ->
-      if String.equal p ("((filename "^file_name^"))") (* Really? *)
-      then Server.respond_string ~status:`Not_found
-        (html_of_not_found path info)
-      else raise exn
-    | _ -> raise exn
-    end
-  )
+  | Error exn -> (
+      match Monitor.extract_exn exn with
+      | Unix.Unix_error (Unix.Error.ENOENT, "stat", p) ->
+          if String.equal p ("((filename " ^ file_name ^ "))") (* Really? *)
+          then
+            Server.respond_string ~status:`Not_found
+              (html_of_not_found path info)
+          else raise exn
+      | _ -> raise exn)
 
 (** HTTP handler *)
 let handler ~info ~docroot ~index ~body:_ _sock req =
   let uri = Cohttp.Request.uri req in
   let path = Uri.path uri in
   (* Log the request to the console *)
-  printf "%s %s%!"
-    (Cohttp.(Code.string_of_method (Request.meth req)))
-    path;
+  printf "%s %s%!" Cohttp.(Code.string_of_method (Request.meth req)) path;
   match Request.meth req with
   | (`GET | `HEAD) as meth ->
-    serve ~info ~docroot ~index uri path
-    >>= method_filter meth
+      serve ~info ~docroot ~index uri path >>= method_filter meth
   | meth ->
-    let meth = Cohttp.Code.string_of_method meth in
-    let allowed = "GET, HEAD" in
-    let headers = Cohttp.Header.of_list ["allow", allowed] in
-    Server.respond_string ~headers ~status:`Method_not_allowed
-      (html_of_method_not_allowed meth allowed path info)
+      let meth = Cohttp.Code.string_of_method meth in
+      let allowed = "GET, HEAD" in
+      let headers = Cohttp.Header.of_list [ ("allow", allowed) ] in
+      Server.respond_string ~headers ~status:`Method_not_allowed
+        (html_of_method_not_allowed meth allowed path info)
 
 let determine_mode cert_file_path key_file_path =
   (* Determines if the server runs in http or https *)
@@ -110,31 +107,38 @@ let determine_mode cert_file_path key_file_path =
 let start_server docroot port index cert_file key_file verbose () =
   (* enable logging to stdout *)
   Fmt_tty.setup_std_outputs ();
-  Logs.set_level @@ if verbose then (Some Logs.Debug) else (Some Logs.Info);
+  Logs.set_level @@ if verbose then Some Logs.Debug else Some Logs.Info;
   Logs.set_reporter (Logs_fmt.reporter ());
   let mode = determine_mode cert_file key_file in
-  let mode_str = (match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP") in
+  let mode_str = match mode with `OpenSSL _ -> "HTTPS" | `TCP -> "HTTP" in
   Logs.info (fun f -> f "Listening for %s requests on %d" mode_str port);
   let info = Printf.sprintf "Served by Cohttp/Async listening on %d" port in
   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)))
-   ~mode
+    ~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)))
+    ~mode
     (Tcp.Where_to_listen.of_port port)
-    (handler ~info ~docroot ~index) >>= fun _serv ->
-  Deferred.never ()
+    (handler ~info ~docroot ~index)
+  >>= fun _serv -> Deferred.never ()
 
 let () =
   let open Async_command in
-  run @@
-  async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS"
-    Spec.(
-      empty
-      +> anon (maybe_with_default "." ("docroot" %: string))
-      +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on"
-      +> flag "-i" (optional_with_default "index.html" string) ~doc:"file Name of index file in directory"
-      +> flag "-cert-file" (optional string) ~doc:"File of cert for https"
-      +> flag "-key-file" (optional string) ~doc:"File of private key for https"
-      +> flag "-v" no_arg ~doc:" Verbose logging output to console"
-    ) start_server
+  run
+  @@ async_spec ~summary:"Serve the local directory contents via HTTP or HTTPS"
+       Spec.(
+         empty
+         +> anon (maybe_with_default "." ("docroot" %: string))
+         +> flag "-p"
+              (optional_with_default 8080 int)
+              ~doc:"port TCP port to listen on"
+         +> flag "-i"
+              (optional_with_default "index.html" string)
+              ~doc:"file Name of index file in directory"
+         +> flag "-cert-file" (optional string) ~doc:"File of cert for https"
+         +> flag "-key-file" (optional string)
+              ~doc:"File of private key for https"
+         +> flag "-v" no_arg ~doc:" Verbose logging output to console")
+       start_server

cohttp-async/src/body.mli

@@ -2,10 +2,8 @@ open! Base
 open! Async_kernel
 open! Cohttp
 
-type t = [
-  | Cohttp.Body.t
-  | `Pipe of string Pipe.Reader.t
-] [@@deriving sexp_of]
+type t = [ Cohttp.Body.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of]
+
 include Cohttp.S.Body with type t := t
 
 val drain : t -> unit Deferred.t
@@ -16,4 +14,4 @@ val to_pipe : t -> string Pipe.Reader.t
 val of_pipe : string Pipe.Reader.t -> t
 val map : t -> f:(string -> string) -> t
 val as_pipe : t -> f:(string Pipe.Reader.t -> string Pipe.Reader.t) -> t
-val to_form : t -> (string * string list) list Deferred.t
+val to_form : t -> (string * string list) list Deferred.t

cohttp-async/src/body_raw.ml

@@ -2,13 +2,10 @@ open Base
 open Async_kernel
 module B = Cohttp.Body
 
-type t = [
-  | B.t
-  | `Pipe of string Pipe.Reader.t
-] [@@deriving sexp_of]
+type t = [ B.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of]
 
 let empty = `Empty
-let of_string s = ((B.of_string s) :> t)
+let of_string s = (B.of_string s :> t)
 let of_pipe p = `Pipe p
 
 let to_string = function
@@ -19,30 +16,23 @@ let to_string_list = function
   | #B.t as body -> return (B.to_string_list body)
   | `Pipe s -> Pipe.to_list s
 
-let drain = function
-  | #B.t -> return ()
-  | `Pipe p -> Pipe.drain p
+let drain = function #B.t -> return () | `Pipe p -> Pipe.drain p
 
-let is_empty (body:t) =
+let is_empty (body : t) =
   match body with
   | #B.t as body -> return (B.is_empty body)
-  | `Pipe pipe ->
+  | `Pipe pipe -> (
       Deferred.repeat_until_finished () @@ fun () ->
-        Pipe.values_available pipe
-        >>= function
-          | `Eof -> return (`Finished true)
-          | `Ok -> begin
-            match Pipe.peek pipe with
-            | None -> return (`Finished true)
-            | Some "" ->
-                begin
-                  Pipe.read pipe
-                  >>| function
-                    | `Eof -> `Finished true
-                    | `Ok _ -> `Repeat ()
-                end
-            | Some _ -> return (`Finished false)
-          end
+      Pipe.values_available pipe >>= function
+      | `Eof -> return (`Finished true)
+      | `Ok -> (
+          match Pipe.peek pipe with
+          | None -> return (`Finished true)
+          | Some "" -> (
+              Pipe.read pipe >>| function
+              | `Eof -> `Finished true
+              | `Ok _ -> `Repeat ())
+          | Some _ -> return (`Finished false)))
 
 let to_pipe = function
   | `Empty -> Pipe.of_list []
@@ -53,10 +43,10 @@ let to_pipe = function
 let disable_chunked_encoding = function
   | #B.t as body -> return (body, B.length body)
   | `Pipe s ->
-    Pipe.to_list s >>| fun l ->
-    let body = `Strings l in
-    let len = B.length body in
-    body, len
+      Pipe.to_list s >>| fun l ->
+      let body = `Strings l in
+      let len = B.length body in
+      (body, len)
 
 let transfer_encoding = function
   | #B.t as t -> B.transfer_encoding t
@@ -70,7 +60,6 @@ let map t ~f =
   | `Pipe p -> `Pipe (Pipe.map p ~f)
 
 let as_pipe t ~f = `Pipe (t |> to_pipe |> f)
-
 let to_form t = to_string t >>| Uri.query_of_encoded
 let of_form ?scheme f = Uri.encoded_of_query ?scheme f |> of_string
 
@@ -87,19 +76,18 @@ let pipe_of_body read_chunk ic =
       Deferred.repeat_until_finished () (fun () ->
           read_chunk ic >>= function
           | Chunk buf ->
-            (* Even if [writer] has been closed, the loop must continue reading
-             * from the input channel to ensure that it is left in a proper state
-             * for the next request to be processed (in the case of keep-alive).
-             *
-             * The only case where [writer] will be closed is when
-             * [Pipe.close_read] has been called on its read end. This could be
-             * done by a request handler to signal that it does not need to
-             * inspect the remainder of the body to fulfill the request.
-            *)
-            Pipe.write_when_ready writer ~f:(fun write -> write buf)
-            >>| fun _ -> `Repeat ()
+              (* Even if [writer] has been closed, the loop must continue reading
+               * from the input channel to ensure that it is left in a proper state
+               * for the next request to be processed (in the case of keep-alive).
+               *
+               * The only case where [writer] will be closed is when
+               * [Pipe.close_read] has been called on its read end. This could be
+               * done by a request handler to signal that it does not need to
+               * inspect the remainder of the body to fulfill the request.
+               *)
+              Pipe.write_when_ready writer ~f:(fun write -> write buf)
+              >>| fun _ -> `Repeat ()
           | Final_chunk buf ->
-            Pipe.write_when_ready writer ~f:(fun write -> write buf)
-            >>| fun _ -> `Finished ()
-          | Done -> return (`Finished ()))
-    )
+              Pipe.write_when_ready writer ~f:(fun write -> write buf)
+              >>| fun _ -> `Finished ()
+          | Done -> return (`Finished ())))