add HEAD support

src/client.ml

@@ -1,9 +1,9 @@
 let default_authenticator = Ca_certs.authenticator ()
 
-let connect_via_tls ?authenticator  url socket =
+let connect_via_tls ?authenticator url socket =
   let authenticator =
-    match authenticator, default_authenticator with
-  | Some auth, _ | None, Ok auth -> auth
+    match (authenticator, default_authenticator) with
+    | Some auth, _ | None, Ok auth -> auth
     | _ -> failwith "tls certs authenticator not found"
   in
   let tls_config = Tls.Config.client ~authenticator () in
@@ -65,6 +65,7 @@ let request ?headers ?body ?authenticator ~meth env ~sw (url : string) =
   in
   Response.{ resp; body }
 
+let head = request ~meth:`HEAD
 let get = request ~meth:`GET
 let post = request ~meth:`POST
 let put = request ~meth:`PUT

src/server.ml

@@ -313,12 +313,19 @@ module Router = struct
         let param, handler =
           routes
           |> List.find_map (fun (meth', pat, handler) ->
-                 if req.meth <> meth' then None
+                 let matched =
+                   match (req.meth, meth') with
+                   | m1, m2 when m1 = m2 -> true
+                   | `HEAD, `GET -> true
+                   | _ -> false
+                 in
+                 if not matched then None
                  else
                    Path_pattern.perform ~pat req.path
                    |> Option.map (fun param -> (param, handler)))
           |> Option.value ~default:([], inner_handler)
         in
+        let truncate_body = req.meth = `HEAD in
         let req = Request { req with param } in
         let resp =
           try handler env req with
@@ -333,6 +340,11 @@ module Router = struct
                     (Printexc.get_backtrace ()));
               respond ~status:`Internal_server_error ""
         in
+        let resp =
+          match (truncate_body, resp) with
+          | false, _ | _, BareResponse _ -> resp
+          | true, Response r -> Response { r with body = "" }
+        in
         match resp with
         | Response ({ status; tags; _ } as r) when Status.is_error status ->
             Response { r with tags = "log" :: tags }

test/test_http_server.ml

@@ -30,6 +30,12 @@ let test_basics () =
           | _ -> assert false
         in
 
+        let resp =
+          Yume.Client.head env ~sw
+            (Printf.sprintf "http://localhost:%d/" listening_port)
+        in
+        assert (Yume.Client.Response.status resp = `OK);
+
         let resp =
           Yume.Client.get env ~sw
             (Printf.sprintf "http://localhost:%d/" listening_port)