Ocsigen_response: Eio-compatible Body

This changes the representation of the body of the response to be
compatible with Cohttp-eio.

This now uses 'Cohttp_lwt_unix.Server.make_expert', which expect a
representation for the body that is closer to direct-style instead of
using the same Body type as for requests.

The setting of cookie headers is moved into 'Ocsigen_response', with the
goal of building a safer API.

Author: Julow

src/server/dune

@@ -5,6 +5,7 @@
  (libraries
   xml-light
   cohttp-lwt-unix
+  http
   polytables
   ocsigen_cookie_map
   baselib

src/server/ocsigen_cohttp.ml

@@ -54,32 +54,6 @@ module Cookie = struct
     Ocsigen_cookie_map.Map_path.fold serialize_cookies cookies headers
 end
 
-(* FIXME: secure *)
-let make_cookies_header path exp name c _secure =
-  Format.sprintf "%s=%s%s%s" name c
-    (*VVV encode = true? *)
-    ("; path=/" ^ Ocsigen_lib.Url.string_of_url_path ~encode:true path)
-    (* (if secure && slot.sl_ssl then "; secure" else "")^ *)
-    ""
-  ^
-  match exp with
-  | Some s -> "; expires=" ^ Ocsigen_lib.Date.to_string s
-  | None -> ""
-
-let make_cookies_headers path t hds =
-  Ocsigen_cookie_map.Map_inner.fold
-    (fun name c h ->
-       let open Ocsigen_cookie_map in
-       let exp, v, secure =
-         match c with
-         | OUnset -> Some 0., "", false
-         | OSet (t, v, secure) -> t, v, secure
-       in
-       Cohttp.Header.add h
-         Ocsigen_header.Name.(to_string set_cookie)
-         (make_cookies_header path exp name v secure))
-    t hds
-
 let handler ~ssl ~address ~port ~connector (flow, conn) request body =
   let filenames = ref [] in
   let edn = Conduit_lwt_unix.endp_of_flow flow in
@@ -133,6 +107,7 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body =
     Cohttp_lwt_unix.Server.respond_error ?headers
       ~status:(ret_code :> Cohttp.Code.status_code)
       ~body ()
+    >>= fun resp -> Lwt.return (Ocsigen_response.of_cohttp resp)
   in
   (* TODO: equivalent of Ocsigen_range *)
   let request =
@@ -155,32 +130,17 @@ let handler ~ssl ~address ~port ~connector (flow, conn) request body =
                   Ocsigen_header.Name.x_forwarded_for))
             (Uri.path (Ocsigen_request.uri request)));
        Lwt.catch
-         (fun () ->
-            connector request >>= fun response ->
-            let response, body = Ocsigen_response.to_cohttp response
-            and cookies = Ocsigen_response.cookies response in
-            let response =
-              let headers =
-                Cohttp.Header.add_unless_exists
-                  (Cohttp.Header.add_unless_exists
-                     (Ocsigen_cookie_map.Map_path.fold make_cookies_headers
-                        cookies
-                        (Cohttp.Response.headers response))
-                     "server" Ocsigen_config.server_name)
-                  "date"
-                  (Ocsigen_lib.Date.to_string (Unix.time ()))
-              in
-              {response with Cohttp.Response.headers}
-            in
-            Lwt.return (response, body))
+         (fun () -> connector request)
          (function
            | Ocsigen_is_dir fun_request ->
                let headers =
                  fun_request request |> Uri.to_string
                  |> Cohttp.Header.init_with "location"
                and status = `Moved_permanently in
-               Cohttp_lwt_unix.Server.respond ~headers ~status ~body:`Empty ()
-           | exn -> handle_error exn))
+               Lwt.return (Ocsigen_response.respond ~headers ~status ())
+           | exn -> handle_error exn)
+       >>= fun response ->
+       Lwt.return (Ocsigen_response.to_response_expert response))
     (fun () ->
        if !filenames <> []
        then
@@ -235,7 +195,7 @@ let service ?ssl ~address ~port ~connector () =
     and ssl = match ssl with Some _ -> true | None -> false in
     handler ~ssl ~address ~port ~connector
   in
-  let config = Cohttp_lwt_unix.Server.make ~conn_closed ~callback () in
+  let config = Cohttp_lwt_unix.Server.make_expert ~conn_closed ~callback () in
   let mode =
     match tls_own_key with
     | `None -> `TCP (`Port port)

src/server/ocsigen_response.ml

@@ -1,15 +1,37 @@
+module Body = struct
+  type t = ((string -> unit Lwt.t) -> unit Lwt.t) * Cohttp.Transfer.encoding
+
+  let empty : t = (fun _write -> Lwt.return_unit), Fixed 0L
+  let make encoding writer = writer, encoding
+
+  let of_cohttp body =
+    ( (fun write -> Cohttp_lwt.Body.write_body write body)
+    , Cohttp_lwt.Body.transfer_encoding body )
+
+  let write (w, _) = w
+  let transfer_encoding = snd
+end
+
 type t =
   { a_response : Cohttp.Response.t
-  ; a_body : Cohttp_lwt.Body.t
+  ; a_body : Body.t
   ; a_cookies : Ocsigen_cookie_map.t }
 
-let make
-      ?(body = Cohttp_lwt.Body.empty)
-      ?(cookies = Ocsigen_cookie_map.empty)
-      a_response
-  =
+let make ?(body = Body.empty) ?(cookies = Ocsigen_cookie_map.empty) a_response =
   {a_response; a_body = body; a_cookies = cookies}
 
+let respond ?headers ~status ?(body = Body.empty) () =
+  let encoding =
+    match headers with
+    | None -> Body.transfer_encoding body
+    | Some headers -> (
+      match Cohttp.Header.get_transfer_encoding headers with
+      | Cohttp.Transfer.Unknown -> Body.transfer_encoding body
+      | t -> t)
+  in
+  let response = Cohttp.Response.make ~status ~encoding ?headers () in
+  make ~body response
+
 let update ?response ?body ?cookies {a_response; a_body; a_cookies} =
   let a_response =
     match response with Some response -> response | None -> a_response
@@ -19,10 +41,53 @@ let update ?response ?body ?cookies {a_response; a_body; a_cookies} =
   in
   {a_response; a_body; a_cookies}
 
-let of_cohttp ?(cookies = Ocsigen_cookie_map.empty) (a_response, a_body) =
+let of_cohttp ?(cookies = Ocsigen_cookie_map.empty) (a_response, body) =
+  let a_body = Body.of_cohttp body in
   {a_response; a_body; a_cookies = cookies}
 
-let to_cohttp {a_response; a_body; _} = a_response, a_body
+(* FIXME: secure *)
+let make_cookies_header path exp name c _secure =
+  Format.sprintf "%s=%s%s%s" name c
+    (*VVV encode = true? *)
+    ("; path=/" ^ Ocsigen_lib.Url.string_of_url_path ~encode:true path)
+    (* (if secure && slot.sl_ssl then "; secure" else "")^ *)
+    ""
+  ^
+  match exp with
+  | Some s -> "; expires=" ^ Ocsigen_lib.Date.to_string s
+  | None -> ""
+
+let make_cookies_headers path t hds =
+  Ocsigen_cookie_map.Map_inner.fold
+    (fun name c h ->
+       let open Ocsigen_cookie_map in
+       let exp, v, secure =
+         match c with
+         | OUnset -> Some 0., "", false
+         | OSet (t, v, secure) -> t, v, secure
+       in
+       Cohttp.Header.add h
+         Ocsigen_header.Name.(to_string set_cookie)
+         (make_cookies_header path exp name v secure))
+    t hds
+
+let to_cohttp_response {a_response; a_cookies; _} =
+  let headers =
+    Cohttp.Header.add_unless_exists
+      (Cohttp.Header.add_unless_exists
+         (Ocsigen_cookie_map.Map_path.fold make_cookies_headers a_cookies
+            (Cohttp.Response.headers a_response))
+         "server" Ocsigen_config.server_name)
+      "date"
+      (Ocsigen_lib.Date.to_string (Unix.time ()))
+  in
+  {a_response with Cohttp.Response.headers}
+
+let to_response_expert t =
+  to_cohttp_response t, fun _ic oc -> fst t.a_body (Lwt_io.write oc)
+
+let response t = t.a_response
+let body t = t.a_body
 
 let status {a_response = {Cohttp.Response.status; _}; _} =
   match status with

src/server/ocsigen_response.mli

@@ -1,14 +1,40 @@
 type t
 
+module Body : sig
+  type t
+
+  val empty : t
+
+  val make :
+     Cohttp.Transfer.encoding
+    -> ((string -> unit Lwt.t) -> unit Lwt.t)
+    -> t
+  (** [make writer] makes a reponse body whose content is generated by
+      [writer write]. [write str] blocks until [str] is fully written. *)
+
+  val of_cohttp : Cohttp_lwt.Body.t -> t
+  val write : t -> (string -> unit Lwt.t) -> unit Lwt.t
+  val transfer_encoding : t -> Cohttp.Transfer.encoding
+end
+
 val make :
-   ?body:Cohttp_lwt.Body.t
+   ?body:Body.t
   -> ?cookies:Ocsigen_cookie_map.t
   -> Cohttp.Response.t
   -> t
 
+val respond :
+   ?headers:Cohttp.Header.t
+  -> status:Http.Status.t
+  -> ?body:Body.t
+  -> unit
+  -> t
+(** Like [make] but with an interface similar to
+    [Cohttp_lwt_unix.Server.respond]. *)
+
 val update :
    ?response:Cohttp.Response.t
-  -> ?body:Cohttp_lwt.Body.t
+  -> ?body:Body.t
   -> ?cookies:Ocsigen_cookie_map.t
   -> t
   -> t
@@ -18,7 +44,13 @@ val of_cohttp :
   -> Cohttp.Response.t * Cohttp_lwt.Body.t
   -> t
 
-val to_cohttp : t -> Cohttp.Response.t * Cohttp_lwt.Body.t
+val to_response_expert :
+   t
+  -> Cohttp.Response.t * ('ic -> Lwt_io.output_channel -> unit Lwt.t)
+(** Response for [Cohttp_lwt_unix.Server.make_expert]. *)
+
+val response : t -> Cohttp.Response.t
+val body : t -> Body.t
 val status : t -> Cohttp.Code.status
 val set_status : t -> Cohttp.Code.status -> t
 val cookies : t -> Ocsigen_cookie_map.t