Implement cookie (not tested)

examples/01-hello/main.ml

@@ -1,7 +1,10 @@
 #require "vif" ;;
 
-let default req target server () =
+open Vif ;;
-  Vif.Response.with_string server `OK "Hello World!\n"
+
+let default req target _server () =
+  let* () = Response.with_string req "Hello World!\n" in
+  Response.respond `OK
 ;;
 
 let () = Miou_unix.run @@ fun () ->

examples/02-counter/main.ml

@@ -3,9 +3,13 @@
 
 let counter = Atomic.make 0 ;;
 
-let default req target server () =
+open Vif ;;
+
+let default req target _server () =
   let v = Atomic.fetch_and_add counter 1 in
-  Vif.Response.with_string server `OK (Fmt.str "%d request(s)\n" (succ v))
+  let str = Fmt.str "%d request(s)\n" (succ v) in
+  let* () = Response.with_string req str in
+  Response.respond `OK
 ;;
 
 let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;;

examples/04-device/main.ml

@@ -1,12 +1,5 @@
-#require "mirage-crypto-rng-miou-unix" ;;
 #require "vif" ;;
 
-let rng =
-  let open Mirage_crypto_rng_miou_unix in
-  let finally = kill in
-  Vif.D.device ~name:"rng" ~finally [] @@ fun () -> initialize (module Pfortuna)
-;;
-
 type foo = Foo ;;
 
 let foo =
@@ -14,12 +7,14 @@ let foo =
   Vif.D.device ~name:"foo" ~finally [] @@ fun () -> Foo
 ;;
 
+open Vif ;;
+
 let default req target server () =
-  let _rng = Vif.S.device rng server in
   let Foo = Vif.S.device foo server in
-  Vif.Response.with_string server `OK "ok\n"
+  let* () = Response.with_string req "ok\n" in
+  Response.respond `OK
 ;;
 
 let () =
-  Miou_unix.run @@ fun () -> Vif.run ~default ~devices:Vif.Ds.[ rng; foo ] [] ()
+  Miou_unix.run @@ fun () -> Vif.run ~default ~devices:Vif.Ds.[ foo ] [] ()
 ;;

examples/05-json/main.ml

@@ -23,7 +23,9 @@ let foo =
   conv prj inj foo
 ;;
 
-let deserialize req server () =
+open Vif ;;
+
+let deserialize req _server () =
   match Vif.Request.of_json req with
   | Ok (foo : foo) ->
       let str =
@@ -34,8 +36,11 @@ let deserialize req server () =
           Fmt.(Dump.option string)
           foo.address
       in
-      Vif.Response.with_string server `OK str
+      let* () = Response.with_string req str in
-  | Error (`Msg msg) -> Vif.Response.with_string server (`Code 422) msg
+      Response.respond `OK
+  | Error (`Msg msg) ->
+      let* () = Response.with_string req msg in
+      Response.respond (`Code 422)
 ;;
 
 let routes =
@@ -45,9 +50,10 @@ let routes =
   [ post (json_encoding foo) (rel /?? nil) --> deserialize ]
 ;;
 
-let default req target server () =
+let default req target _server () =
   let str = Fmt.str "%s not found\n" target in
-  Vif.Response.with_string server `Not_found str
+  let* () = Response.with_string req str in
+  Response.respond `Not_found
 ;;
 
 let () = Miou_unix.run @@ fun () -> Vif.run ~default routes () ;;

examples/06-caqti/main.ml

@@ -18,34 +18,45 @@ let caqti =
       Fmt.failwith "%a" Caqti_error.pp err
 ;;
 
+open Vif ;;
 open Caqti_request.Infix ;;
 
 let add req n server _cfg =
   let (module Conn) = Vif.S.device caqti server in
-  let req = Caqti_type.(int ->. unit) ("INSERT INTO t (f) VALUES (?)") in
+  let sql = Caqti_type.(int ->. unit) ("INSERT INTO t (f) VALUES (?)") in
-  match Conn.exec req n with
+  match Conn.exec sql n with
   | Ok () ->
-    Vif.Response.with_string server `OK (Fmt.str "%d Added\n" n)
+    let str = (Fmt.str "%d Added\n" n) in
+    let field = "content-type" in
+    let* () = Response.add ~field "text/plain; charset=utf-8" in
+    let* () = Response.with_string req str in
+    Response.respond `OK
   | Error err ->
     let str = Fmt.str "SQL error: %a" Caqti_error.pp err in
-    Vif.Response.with_string server `Internal_server_error str
+    let* () = Response.with_string req str in
+    Response.respond `Internal_server_error
 ;;
 
 let list req server _cfg =
   let (module Conn) = Vif.S.device caqti server in
-  let req = Caqti_type.(unit ->* int) ("SELECT f FROM t") in
+  let sql = Caqti_type.(unit ->* int) ("SELECT f FROM t") in
-  match Conn.collect_list req () with
+  match Conn.collect_list sql () with
   | Ok lst ->
     let str = Fmt.str "%a" Fmt.(Dump.list int) lst in
-    Vif.Response.with_string server `OK str
+    let field = "content-type" in
+    let* () = Response.add ~field "text/plain; charset=utf-8" in
+    let* () = Response.with_string req str in
+    Response.respond `OK
   | Error err ->
     let str = Fmt.str "SQL error: %a" Caqti_error.pp err in
-    Vif.Response.with_string server `Internal_server_error str
+    let* () = Response.with_string req str in
+    Response.respond `Internal_server_error
 ;;
 
 let default req target server _ =
   let str = Fmt.str "%s not found\n" target in
-  Vif.Response.with_string server `Not_found str
+  let* () = Response.with_string req str in
+  Response.respond `Not_found 
 ;;
 
 let routes =

examples/07-deflate/main.ml

@@ -1,7 +1,12 @@
 #require "vif" ;;
 
+open Vif ;;
+
 let default req target server () =
-  Vif.Response.with_string ~compression:`DEFLATE server `OK "Hello World!\n"
+  let* () = Response.with_string ~compression:`DEFLATE req "Hello World!\n" in
+  let field = "content-type" in
+  let* () = Response.add ~field "text/plain; charset=utf-8" in
+  Response.respond `OK
 ;;
 
 let () = Miou_unix.run @@ fun () ->

lib/vif/stream.ml

@@ -156,42 +156,6 @@ module Bstr = struct
 end
 
 module Sink = struct
-  module Hdrs = Vif_headers
-
-  let response ?headers:(hdrs = []) status server =
-    match Vif_s.reqd server with
-    | `V1 reqd ->
-        let hdrs = Hdrs.add_unless_exists hdrs "transfer-encoding" "chunked" in
-        let hdrs = H1.Headers.of_list hdrs in
-        let status =
-          match status with
-          | #H1.Status.t as status -> status
-          | _ -> invalid_arg "Sink.response: invalid status"
-        in
-        let resp = H1.Response.create ~headers:hdrs status in
-        let init () = H1.Reqd.respond_with_streaming reqd resp in
-        let push body str =
-          H1.Body.Writer.write_string body str;
-          body
-        in
-        let full _ = false in
-        (* TODO(dinosaure): content-length? *)
-        let stop = H1.Body.Writer.close in
-        (Sink { init; push; full; stop } : (string, unit) sink)
-    | `V2 reqd ->
-        let hdrs = Hdrs.add_unless_exists hdrs "transfer-encoding" "chunked" in
-        let hdrs = H2.Headers.of_list hdrs in
-        let resp = H2.Response.create ~headers:hdrs status in
-        let init () = H2.Reqd.respond_with_streaming reqd resp in
-        let push body str =
-          H2.Body.Writer.write_string body str;
-          body
-        in
-        let full _ = false in
-        (* TODO(dinosaure): content-length? *)
-        let stop = H2.Body.Writer.close in
-        (Sink { init; push; full; stop } : (string, unit) sink)
-
   type value = [ `Null | `Bool of bool | `String of string | `Float of float ]
   type await = [ `Await ]
   type error = [ `Error of Jsonm.error ]

lib/vif/stream.mli

@@ -30,9 +30,6 @@ type ('a, 'r) sink =
       -> ('a, 'r) sink
 
 module Sink : sig
-  val response :
-    ?headers:Vif_headers.t -> Vif_status.t -> Vif_s.t -> (string, unit) sink
-
   val json : (string, (Json.t, [ `Msg of string ]) result) sink
 end
 

lib/vif/vif.ml

@@ -77,96 +77,82 @@ module Status = Vif_status
 module Headers = Vif_headers
 module Request = Vif_request
 module Response = Vif_response
+module Cookie = Vif_cookie
+
+type e = Response.e = Empty
+type f = Response.f = Filled
+type s = Response.s = Sent
+
+let ( let* ) = Response.bind
+let return = Response.return
 
 let is_application_json { Multipart_form.Content_type.ty; subty; _ } =
   match (ty, subty) with `Application, `Iana_token "json" -> true | _ -> false
 
-let content_type server =
+let content_type req0 =
-  let headers =
+  let headers = Vif_request0.headers req0 in
-    match server.S.reqd with
-    | `V1 reqd ->
-        let request = H1.Reqd.request reqd in
-        H1.Headers.to_list request.H1.Request.headers
-    | `V2 reqd ->
-        let request = H2.Reqd.request reqd in
-        H2.Headers.to_list request.H2.Request.headers
-  in
   let c = List.assoc_opt "content-type" headers in
   let c = Option.map (fun c -> c ^ "\r\n") c in
   let c = Option.to_result ~none:`Not_found c in
   Result.bind c Multipart_form.Content_type.of_string
 
-let method_of_request server =
+let recognize_request ~env req0 =
-  match server.S.reqd with
-  | `V1 reqd -> ((H1.Reqd.request reqd).H1.Request.meth :> H2.Method.t)
-  | `V2 reqd -> ((H2.Reqd.request reqd).H2.Request.meth :> H2.Method.t)
-
-let request ~env server =
   let extract : type c a.
          Vif_method.t option
       -> (c, a) Vif_content_type.t
       -> (c, a) Vif_request.t option =
    fun meth c ->
-    let meth' = method_of_request server in
+    let meth' = Vif_request0.meth req0 in
     match (meth, meth', c) with
     | None, _, (Vif_content_type.Any as encoding) ->
-        Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
+        Some (Vif_request.of_req0 ~encoding ~env req0)
     | Some a, b, (Vif_content_type.Any as encoding) ->
-        if a = b then Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
+        if a = b then Some (Vif_request.of_req0 ~encoding ~env req0) else None
-        else None
     | None, _, (Null as encoding) ->
-        Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
+        Some (Vif_request.of_req0 ~encoding ~env req0)
     | Some a, b, (Null as encoding) ->
-        if a = b then Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
+        if a = b then Some (Vif_request.of_req0 ~encoding ~env req0) else None
-        else None
     | None, _, (Json_encoding _ as encoding) ->
-        let c = content_type server in
+        let c = content_type req0 in
         let application_json = Result.map is_application_json c in
         let application_json = Result.value ~default:false application_json in
-        if application_json then
+        if application_json then Some (Vif_request.of_req0 ~encoding ~env req0)
-          Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
         else None
     | Some a, b, (Json_encoding _ as encoding) ->
-        let c = content_type server in
+        let c = content_type req0 in
         let application_json = Result.map is_application_json c in
         let application_json = Result.value ~default:false application_json in
         if application_json && a = b then
-          Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
+          Some (Vif_request.of_req0 ~encoding ~env req0)
         else None
     | None, _, (Json as encoding) ->
-        let c = content_type server in
+        let c = content_type req0 in
         let application_json = Result.map is_application_json c in
         let application_json = Result.value ~default:false application_json in
-        if application_json then
+        if application_json then Some (Vif_request.of_req0 ~encoding ~env req0)
-          Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
         else None
     | Some a, b, (Json as encoding) ->
-        let c = content_type server in
+        let c = content_type req0 in
         let application_json = Result.map is_application_json c in
         let application_json = Result.value ~default:false application_json in
         if application_json && a = b then
-          Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
+          Some (Vif_request.of_req0 ~encoding ~env req0)
         else None
   in
   { Vif_r.extract }
 
-let handler ~default ~middlewares routes devices user's_value =
+let handler cfg ~default ~middlewares routes devices user's_value =
   ();
   fun socket reqd ->
-    let target =
+    let server = { Vif_s.devices; cookie_key= cfg.Vif_config.cookie_key } in
-      match reqd with
+    let req0 = Vif_request0.of_reqd socket reqd in
-      | `V1 reqd -> (H1.Reqd.request reqd).H1.Request.target
+    let target = Vif_request0.target req0 in
-      | `V2 reqd -> (H2.Reqd.request reqd).H2.Request.target
+    let ctx = { Ms.server; request= req0; target; user's_value } in
-    in
-    let server = { Vif_s.reqd; socket; devices } in
-    let ctx =
-      { Ms.server; request= Vif_request0.of_reqd reqd; target; user's_value }
-    in
     let env = Ms.run middlewares ctx Vif_m.Hmap.empty in
-    let request = request ~env server in
+    let request = recognize_request ~env req0 in
-    Log.debug (fun m -> m "Handle a new request to %s" target);
     let fn = R.dispatch ~default routes ~request ~target in
-    match fn server user's_value with Vif_response.Response -> ()
+    match Vif_response.(run req0 empty) (fn server user's_value) with
+    | Response.Sent, () -> ()
 
 type config = Vif_config.config
 
@@ -197,6 +183,9 @@ let store_pid = function
 
 let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[])
     ?(middlewares = Ms.[]) ~default routes user's_value =
+  let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
+  let finally () = Mirage_crypto_rng_miou_unix.kill rng in
+  Fun.protect ~finally @@ fun () ->
   let interactive = !Sys.interactive in
   let domains = Miou.Domain.available () in
   store_pid cfg.pid;
@@ -215,11 +204,11 @@ let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[])
     Ds.run Vif_d.empty devices user's_value
   in
   Logs.debug (fun m -> m "devices launched");
-  let fn0 = handler ~default ~middlewares routes devices user's_value in
+  let fn0 = handler cfg ~default ~middlewares routes devices user's_value in
   let prm = Miou.async @@ fun () -> handle stop cfg fn0 in
   let tasks =
     List.init domains (fun _ ->
-        handler ~default ~middlewares routes devices user's_value)
+        handler cfg ~default ~middlewares routes devices user's_value)
   in
   let tasks =
     if domains > 0 then Miou.parallel (handle stop cfg) tasks else []

lib/vif/vif.mli

@@ -175,9 +175,7 @@ end
 
 module S : sig
   type t
-  type reqd = [ `V1 of H1.Reqd.t | `V2 of H2.Reqd.t ]
 
-  val reqd : t -> reqd
   val device : ('value, 'a) D.device -> t -> 'a
 end
 
@@ -242,29 +240,79 @@ module Status : sig
 end
 
 module Response : sig
-  type t
+  type ('p, 'q, 'a) t
+  type e
+  type f
+  type s
 
   val with_stream :
-       ?compression:[ `DEFLATE ]
+       ?compression:[< `DEFLATE ]
-    -> S.t
+    -> ('c, 'a) Request.t
-    -> ?headers:Headers.t
-    -> Status.t
     -> string Stream.stream
-    -> t
+    -> (e, f, unit) t
 
   val with_string :
-       ?compression:[ `DEFLATE ]
+    ?compression:[< `DEFLATE ] -> ('c, 'a) Request.t -> string -> (e, f, unit) t
+
+  val respond : Status.t -> (f, s, unit) t
+
+  (** Headers manipulation. *)
+
+  val add : field:string -> string -> ('p, 'p, unit) t
+  val rem : field:string -> ('p, 'p, unit) t
+  val set : field:string -> string -> ('p, 'p, unit) t
+  val add_unless_exists : field:string -> string -> ('p, 'p, bool) t
+end
+
+module Cookie : sig
+  type config
+
+  val config :
+       ?expires:float
+    -> ?max_age:float
+    -> ?domain:[ `host ] Domain_name.t
+    -> ?path:bool
+    -> ?secure:bool
+    -> ?http_only:bool
+    -> ?same_site:[ `Lax | `Strict | `None ]
+    -> unit
+    -> config
+
+  val get :
+       ?encrypted:bool
+    -> name:string
     -> S.t
-    -> ?headers:Headers.t
+    -> ('c, 'a) Request.t
-    -> Status.t
+    -> ( string
+       , [> `Invalid_encrypted_cookie | `Msg of string | `Not_found ] )
+       result
+
+  val set :
+       ?encrypt:bool
+    -> ?cfg:config
+    -> ?path:string
+    -> name:string
+    -> S.t
+    -> ('c, 'a) Request.t
     -> string
-    -> t
+    -> ('p, 'p, unit) Response.t
 end
 
 type config
+type e = Response.e
+type f = Response.f
+type s = Response.s
+
+val ( let* ) :
+     ('p, 'q, 'a) Response.t
+  -> ('a -> ('q, 'r, 'b) Response.t)
+  -> ('p, 'r, 'b) Response.t
+
+val return : 'a -> ('p, 'p, 'a) Response.t
 
 val config :
-     ?pid:Fpath.t
+     ?cookie_key:Mirage_crypto.AES.GCM.key
+  -> ?pid:Fpath.t
   -> ?http:
        [ `H1 of H1.Config.t
        | `H2 of H2.Config.t
@@ -278,8 +326,13 @@ val run :
      ?cfg:config
   -> ?devices:'value Ds.t
   -> ?middlewares:'value Ms.t
-  -> default:(('c, string) Request.t -> string -> S.t -> 'value -> Response.t)
+  -> default:
-  -> (S.t -> 'value -> Response.t) R.route list
+       (   ('c, string) Request.t
+        -> string
+        -> S.t
+        -> 'value
+        -> (e, s, unit) Response.t)
+  -> (S.t -> 'value -> (e, s, unit) Response.t) R.route list
   -> 'value
   -> unit
 

lib/vif/vif_config.ml

@@ -8,9 +8,17 @@ type config = {
   ; backlog: int
   ; sockaddr: Unix.sockaddr
   ; pid: Fpath.t option
+  ; cookie_key: Mirage_crypto.AES.GCM.key
 }
 
-let config ?pid ?http ?tls ?(backlog = 64) sockaddr =
+let really_bad_secret =
+  let open Digestif in
+  let hash = SHA256.digest_string "\xde\xad\xbe\xef" in
+  let hash = SHA256.to_raw_string hash in
+  Mirage_crypto.AES.GCM.of_secret hash
+
+let config ?(cookie_key = really_bad_secret) ?pid ?http ?tls ?(backlog = 64)
+    sockaddr =
   let http =
     match http with
     | Some (`H1 cfg) -> Some (`HTTP_1_1 cfg)
@@ -18,4 +26,4 @@ let config ?pid ?http ?tls ?(backlog = 64) sockaddr =
     | Some (`Both (h1, h2)) -> Some (`Both (h1, h2))
     | None -> None
   in
-  { http; tls; backlog; sockaddr; pid }
+  { http; tls; backlog; sockaddr; pid; cookie_key }

lib/vif/vif_cookie.ml

@@ -0,0 +1,134 @@
+let prefix req0 =
+  let target = Vif_request0.target req0 in
+  let secure =
+    Option.is_some (Vif_request0.tls req0) || Vif_request0.on_localhost req0
+  in
+  match (target, secure) with
+  | "/", true -> "__Host-"
+  | _, true -> "__Secure-"
+  | _ -> ""
+
+let is_cookie key = String.lowercase_ascii key = "cookie"
+
+let all_cookies req =
+  let hdrs = Vif_request0.headers req in
+  let cookies = List.filter (fun (k, _) -> is_cookie k) hdrs in
+  let cookies = List.map snd cookies in
+  let cookies = List.map (String.split_on_char ';') cookies in
+  let cookies = List.flatten cookies in
+  let fn acc str =
+    match String.split_on_char '=' str with
+    | [] -> assert false
+    | [ k; v ] ->
+        let k = String.trim k and v = String.trim v in
+        (k, v) :: acc
+    | _ -> acc
+  in
+  List.fold_left fn [] cookies
+
+let guard error fn = if fn () then Ok () else Error error
+let err_cookie = `Invalid_encrypted_cookie
+
+let get ?(encrypted = true) ~name server req0 =
+  let prefix = prefix req0 in
+  let name = prefix ^ name in
+  match List.assoc_opt name (all_cookies req0) with
+  | None -> Error `Not_found
+  | Some value when encrypted ->
+      let ( let* ) = Result.bind in
+      let alphabet = Base64.uri_safe_alphabet in
+      let* value = Base64.decode ~pad:false ~alphabet value in
+      let err = `Invalid_encrypted_cookie in
+      let* () = guard err @@ fun () -> String.length value >= 14 in
+      let* () = guard err @@ fun () -> value.[0] == '\x00' in
+      let nonce = String.sub value 1 12 in
+      let adata = "vif.cookie-" ^ name in
+      let vdata = String.sub value 13 (String.length value - 13) in
+      let key = Vif_s.cookie_key server in
+      let value =
+        Mirage_crypto.AES.GCM.authenticate_decrypt ~key ~nonce ~adata vdata
+      in
+      let* () = guard err @@ fun () -> Option.is_some value in
+      Ok (Option.get value)
+  | Some value -> Ok value
+
+let get ?encrypted ~name server req =
+  get ?encrypted ~name server req.Vif_request.request
+
+type config = {
+    expires: float option
+  ; max_age: float option
+  ; domain: [ `host ] Domain_name.t option
+  ; path: bool
+  ; secure: bool
+  ; http_only: bool
+  ; same_site: [ `Strict | `Lax | `None ]
+}
+
+let default_config =
+  {
+    expires= None
+  ; max_age= None
+  ; domain= None
+  ; path= true
+  ; secure= true
+  ; http_only= true
+  ; same_site= `Lax
+  }
+
+let config ?expires ?max_age ?domain ?(path = true) ?(secure = true)
+    ?(http_only = true) ?(same_site = `Lax) () =
+  { expires; max_age; domain; path; secure; http_only; same_site }
+
+let set_cookie cfg ~path name value =
+  let expires = None in
+  let max_age = None in
+  let domain = Option.map (Fmt.str "Domain=%a" Domain_name.pp) cfg.domain in
+  (* TODO(dinosaure): warn if cfg.domain != req0.tls.peer_name? *)
+  let path = if cfg.path then Some (Fmt.str "Path=%s" path) else None in
+  let secure = if cfg.secure then Some "Secure" else None in
+  let http_only = if cfg.http_only then Some "HttpOnly" else None in
+  let same_site =
+    match cfg.same_site with
+    | `Lax -> Some "SameSite=Lax"
+    | `Strict -> Some "SameSite=Strict"
+    | `None -> Some "SameSite=None"
+  in
+  let attributes =
+    List.filter_map Fun.id
+      [ expires; max_age; domain; path; secure; http_only; same_site ]
+  in
+  Fmt.str "%s=%s; %a" name value Fmt.(list ~sep:(any "; ") string) attributes
+
+let random len = Mirage_crypto_rng.generate len
+
+let set ?(encrypt = true) ?(cfg = default_config) ?(path = "/") ~name server
+    req0 value =
+  let secure =
+    Option.is_some (Vif_request0.tls req0) || Vif_request0.on_localhost req0
+  in
+  let prefix =
+    match (cfg.secure, cfg.domain, cfg.path, secure, path) with
+    | true, None, true, true, "/" -> "__Host-"
+    | true, _, _, true, _ -> "__Secure-"
+    | _ -> ""
+  in
+  let name = prefix ^ name in
+  if encrypt then
+    let key = Vif_s.cookie_key server in
+    let nonce = random 12 in
+    let adata = "vif.cookie-" ^ name in
+    let value = "\x00" ^ nonce ^ value in
+    let value =
+      Mirage_crypto.AES.GCM.authenticate_encrypt ~key ~nonce ~adata value
+    in
+    let alphabet = Base64.uri_safe_alphabet in
+    let value = Base64.encode_exn ~pad:false ~alphabet value in
+    let value = set_cookie cfg ~path name value in
+    Vif_response.add ~field:"set-cookie" value
+  else
+    let value = set_cookie cfg ~path name value in
+    Vif_response.add ~field:"set-cookie" value
+
+let set ?encrypt ?cfg ?path ~name server req value =
+  set ?encrypt ?cfg ?path ~name server req.Vif_request.request value

lib/vif/vif_request.ml

@@ -3,43 +3,26 @@ let src = Logs.Src.create "vif.request"
 module Log = (val Logs.src_log src : Logs.LOG)
 
 type ('c, 'a) t = {
-    request: [ `V1 of H1.Request.t | `V2 of H2.Request.t ]
+    body: [ `V1 of H1.Body.Reader.t | `V2 of H2.Body.Reader.t ]
-  ; body: [ `V1 of H1.Body.Reader.t | `V2 of H2.Body.Reader.t ]
   ; encoding: ('c, 'a) Vif_content_type.t
   ; env: Vif_m.Hmap.t
+  ; request: Vif_request0.t
 }
 
-let of_reqd : type c a.
+let of_req0 : type c a.
        encoding:(c, a) Vif_content_type.t
     -> env:Vif_m.Hmap.t
-    -> Httpcats.Server.reqd
+    -> Vif_request0.t
     -> (c, a) t =
- fun ~encoding ~env -> function
+ fun ~encoding ~env request ->
-  | `V1 reqd ->
+  let body = Vif_request0.request_body request in
-      let request = `V1 (H1.Reqd.request reqd) in
+  { request; body; encoding; env }
-      let body = `V1 (H1.Reqd.request_body reqd) in
-      { request; body; encoding; env }
-  | `V2 reqd ->
-      let request = `V2 (H2.Reqd.request reqd) in
-      let body = `V2 (H2.Reqd.request_body reqd) in
-      { request; body; encoding; env }
 
-let target { request; _ } =
+let target { request; _ } = Vif_request0.target request
-  match request with
+let meth { request; _ } = Vif_request0.meth request
-  | `V1 request -> request.H1.Request.target
+let version { request; _ } = Vif_request0.version request
-  | `V2 request -> request.H2.Request.target
+let headers { request; _ } = Vif_request0.headers request
-
+let reqd { request; _ } = Vif_request0.reqd request
-let meth { request; _ } =
-  match request with
-  | `V1 request -> request.H1.Request.meth
-  | `V2 request -> request.H2.Request.meth
-
-let version { request; _ } = match request with `V1 _ -> 1 | `V2 _ -> 2
-
-let headers { request; _ } =
-  match request with
-  | `V1 request -> H1.Headers.to_list request.H1.Request.headers
-  | `V2 request -> H2.Headers.to_list request.H2.Request.headers
 
 let to_string ~schedule ~close body =
   let buf = Buffer.create 0x7ff in

lib/vif/vif_request0.ml

@@ -1,17 +1,61 @@
-type t = V1 of H1.Request.t | V2 of H2.Request.t
+type t = {
+    request: request
+  ; tls: Tls.Core.epoch_data option
+  ; reqd: reqd
+  ; socket: socket
+  ; on_localhost: bool
+}
 
-let of_reqd = function
+and reqd = Httpcats.Server.reqd
-  | `V1 reqd -> V1 (H1.Reqd.request reqd)
+and socket = [ `Tcp of Miou_unix.file_descr | `Tls of Tls_miou_unix.t ]
-  | `V2 reqd -> V2 (H2.Reqd.request reqd)
+and request = V1 of H1.Request.t | V2 of H2.Request.t
 
-let headers = function
+let of_reqd socket reqd =
+  let request =
+    match reqd with
+    | `V1 reqd -> V1 (H1.Reqd.request reqd)
+    | `V2 reqd -> V2 (H2.Reqd.request reqd)
+  in
+  let tls =
+    match socket with `Tls tls -> Tls_miou_unix.epoch tls | `Tcp _ -> None
+  in
+  let fd =
+    match socket with
+    | `Tls tls ->
+        let fd = Tls_miou_unix.file_descr tls in
+        Miou_unix.to_file_descr fd
+    | `Tcp fd -> Miou_unix.to_file_descr fd
+  in
+  let on_localhost =
+    match Unix.getpeername fd with
+    | Unix.ADDR_UNIX _ -> false
+    | Unix.ADDR_INET (inet_addr, _) ->
+        inet_addr = Unix.inet_addr_loopback
+        || inet_addr = Unix.inet6_addr_loopback
+  in
+  { request; tls; reqd; socket; on_localhost }
+
+let headers { request; _ } =
+  match request with
   | V1 req -> H1.Headers.to_list req.H1.Request.headers
   | V2 req -> H2.Headers.to_list req.H2.Request.headers
 
-let meth = function
+let meth { request; _ } =
+  match request with
   | V1 req -> req.H1.Request.meth
   | V2 req -> req.H2.Request.meth
 
-let target = function
+let target { request; _ } =
+  match request with
   | V1 req -> req.H1.Request.target
   | V2 req -> req.H2.Request.target
+
+let request_body { reqd; _ } =
+  match reqd with
+  | `V1 reqd -> `V1 (H1.Reqd.request_body reqd)
+  | `V2 reqd -> `V2 (H2.Reqd.request_body reqd)
+
+let version { request; _ } = match request with V1 _ -> 1 | V2 _ -> 2
+let tls { tls; _ } = tls
+let on_localhost { on_localhost; _ } = on_localhost
+let reqd { reqd; _ } = reqd

lib/vif/vif_response.ml

@@ -2,8 +2,38 @@ let src = Logs.Src.create "vif.response"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 
-type t = Response
+type e = Empty
+and f = Filled
+and s = Sent
 
+type 'a state =
+  | Empty : e state
+  | Filled : string Stream.stream -> f state
+  | Sent : s state
+
+let empty = Empty
+let filled stream = Filled stream
+let sent = Sent
+
+type ('p, 'q, 'a) t =
+  | Add_header : string * string -> ('p, 'p, unit) t
+  | Add_unless_exists : string * string -> ('p, 'p, bool) t
+  | Set_header : string * string -> ('p, 'p, unit) t
+  | Rem_header : string -> ('p, 'p, unit) t
+  | Return : 'a -> ('p, 'p, 'a) t
+  | Bind : ('p, 'q, 'a) t * ('a -> ('q, 'r, 'b) t) -> ('p, 'r, 'b) t
+  | Stream : string Stream.stream -> (e, f, unit) t
+  | String : string -> (e, f, unit) t
+  | Respond : Vif_status.t -> (f, s, unit) t
+
+let bind x fn = Bind (x, fn)
+let respond status = Respond status
+let return x = Return x
+let add ~field value = Add_header (field, value)
+let add_unless_exists ~field value = Add_unless_exists (field, value)
+let set ~field value = Set_header (field, value)
+let rem ~field = Rem_header field
+let ( let* ) = bind
 let strf fmt = Format.asprintf fmt
 
 module Hdrs = Vif_headers
@@ -13,8 +43,8 @@ let compress_string ~headers str =
   | Some "gzip" -> assert false
   | _ -> str
 
-let can_compress alg server =
+let can_compress alg req =
-  match Vif_s.reqd server with
+  match Vif_request.reqd req with
   | `V1 reqd ->
       let req = H1.Reqd.request reqd in
       let hdrs = req.H1.Request.headers in
@@ -38,23 +68,116 @@ let can_compress alg server =
             List.exists (( = ) alg) algs
       end
 
-let with_stream ?compression server ?headers status stream =
+let compression alg req =
-  let headers, stream =
+  match alg with
-    match compression with
+  | `DEFLATE when can_compress "deflate" req ->
-    | Some `DEFLATE when can_compress "deflate" server ->
+      let* () = set ~field:"content-encoding" "deflate" in
-        let headers =
+      return true
-          match headers with
+  | `DEFLATE -> return false
-          | None -> Some [ ("content-encoding", "deflate") ]
-          | Some hdrs ->
-              Vif_headers.add_unless_exists hdrs "content-encoding" "deflate"
-              |> Option.some
-        in
-        (headers, Stream.Stream.via (Stream.Flow.deflate ()) stream)
-    | _ -> (headers, stream)
-  in
-  let sink = Stream.Sink.response ?headers status server in
-  Stream.Stream.into sink stream;
-  Response
 
-let with_string ?compression server ?headers status str =
+let with_stream ?compression:alg req stream =
-  with_stream ?compression server ?headers status (Stream.Stream.singleton str)
+  match alg with
+  | Some alg ->
+      let* _ = compression alg req in
+      let field = "transfer-encoding" in
+      let v = "chunked" in
+      let* _ = add_unless_exists ~field v in
+      Stream stream
+  | None ->
+      let field = "transfer-encoding" in
+      let v = "chunked" in
+      let* _ = add_unless_exists ~field v in
+      Stream stream
+
+let with_string ?compression:alg req str =
+  match alg with
+  | Some alg ->
+      let* _ = compression alg req in
+      let field = "content-length" in
+      let v = string_of_int (String.length str) in
+      let* _ = add_unless_exists ~field v in
+      String str
+  | None ->
+      let field = "content-length" in
+      let v = string_of_int (String.length str) in
+      let* _ = add_unless_exists ~field v in
+      String str
+
+let response ?headers:(hdrs = []) status req0 =
+  match Vif_request0.reqd req0 with
+  | `V1 reqd ->
+      let hdrs = H1.Headers.of_list hdrs in
+      let status =
+        match status with
+        | #H1.Status.t as status -> status
+        | _ -> invalid_arg "Sink.response: invalid status"
+      in
+      let resp = H1.Response.create ~headers:hdrs status in
+      let init () = H1.Reqd.respond_with_streaming reqd resp in
+      let push body str =
+        H1.Body.Writer.write_string body str;
+        body
+      in
+      let full _ = false in
+      let stop = H1.Body.Writer.close in
+      (Sink { init; push; full; stop } : (string, unit) Stream.sink)
+  | `V2 reqd ->
+      let hdrs = H2.Headers.of_list hdrs in
+      let resp = H2.Response.create ~headers:hdrs status in
+      let init () = H2.Reqd.respond_with_streaming reqd resp in
+      let push body str =
+        H2.Body.Writer.write_string body str;
+        body
+      in
+      let full _ = false in
+      (* TODO(dinosaure): content-length? *)
+      let stop = H2.Body.Writer.close in
+      (Sink { init; push; full; stop } : (string, unit) Stream.sink)
+
+let run : type a p q. Vif_request0.t -> p state -> (p, q, a) t -> q state * a =
+ fun req s t ->
+  let headers = ref [] in
+  let rec go : type a p q. p state -> (p, q, a) t -> q state * a =
+   fun s t ->
+    match (s, t) with
+    | state, Bind (x, fn) ->
+        let state, x = go state x in
+        go state (fn x)
+    | state, Return x -> (state, x)
+    | state, Add_unless_exists (k, v) -> begin
+        match List.assoc_opt k !headers with
+        | Some _ -> (state, false)
+        | None ->
+            headers := (k, v) :: !headers;
+            (state, true)
+      end
+    | state, Add_header (k, v) ->
+        headers := (k, v) :: !headers;
+        (state, ())
+    | state, Rem_header k ->
+        headers := List.remove_assoc k !headers;
+        (state, ())
+    | state, Set_header (k, v) ->
+        headers := (k, v) :: List.remove_assoc k !headers;
+        (state, ())
+    | Empty, Stream stream -> (Filled stream, ())
+    | Empty, String str -> (Filled (Stream.Stream.singleton str), ())
+    | Filled stream, Respond status ->
+        let headers = !headers in
+        let headers, stream =
+          match List.assoc_opt "content-encoding" headers with
+          | Some "deflate" ->
+              let flow = Stream.Flow.deflate () in
+              let stream = Stream.Stream.via flow stream in
+              let headers = List.remove_assoc "content-length" headers in
+              let headers =
+                Vif_headers.add_unless_exists headers "transfer-encoding"
+                  "chunked"
+              in
+              (headers, stream)
+          | _ -> (headers, stream)
+        in
+        let sink = response ~headers status req in
+        (Sent, Stream.Stream.into sink stream)
+  in
+  go s t

lib/vif/vif_s.ml

@@ -1,8 +1,4 @@
-type t = { reqd: reqd; socket: socket; devices: Vif_d.Hmap.t }
+type t = { devices: Vif_d.Hmap.t; cookie_key: Mirage_crypto.AES.GCM.key }
-and reqd = Httpcats.Server.reqd
-and socket = [ `Tcp of Miou_unix.file_descr | `Tls of Tls_miou_unix.t ]
-
-let reqd { reqd; _ } = reqd
 
 let device : type a. ('value, a) Vif_d.device -> t -> a =
  fun (Vif_d.Device (_, _, k)) { devices; _ } ->
@@ -11,3 +7,5 @@ let device : type a. ('value, a) Vif_d.device -> t -> a =
   | None ->
       Fmt.failwith "Device %s not found"
         (Vif_d.Hmap.Key.info k).Vif_d.Device.name
+
+let cookie_key { cookie_key; _ } = cookie_key