robur/vif
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement cookie (not tested)

Browse source
This commit is contained in:
Calascibetta Romain 2025-02-13 17:17:00 +01:00
parent 392bb3bd88
commit 57d94524f7
17 changed files with 513 additions and 196 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
examples/01-hello/main.ml
View file

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

8
examples/02-counter/main.ml
View file

@ -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 [] () ;;

15
examples/04-device/main.ml
View file

@ -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 ] [] ()
;;

16
examples/05-json/main.ml
View file

@ -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
| Error (`Msg msg) -> Vif.Response.with_string server (`Code 422) msg
let* () = Response.with_string req str in
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 () ;;

BIN
examples/06-caqti/foo.sqlite
View file

Binary file not shown.

29
examples/06-caqti/main.ml
View file

@ -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
match Conn.exec req n with
let sql = Caqti_type.(int ->. unit) ("INSERT INTO t (f) VALUES (?)") in
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
match Conn.collect_list req () with
let sql = Caqti_type.(unit ->* int) ("SELECT f FROM t") in
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 =

7
examples/07-deflate/main.ml
View file

@ -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 () ->

36
lib/vif/stream.ml
View file

@ -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 ]

3
lib/vif/stream.mli
View file

@ -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

85
lib/vif/vif.ml
View file

@ -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 headers =
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 content_type req0 =
let headers = Vif_request0.headers req0 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 =
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 recognize_request ~env req0 =
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)
else None
if a = b then Some (Vif_request.of_req0 ~encoding ~env req0) 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)
else None
if a = b then Some (Vif_request.of_req0 ~encoding ~env req0) 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
Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
if application_json then Some (Vif_request.of_req0 ~encoding ~env req0)
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
Some (Vif_request.of_reqd ~encoding ~env server.S.reqd)
if application_json then Some (Vif_request.of_req0 ~encoding ~env req0)
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 =
match reqd with
| `V1 reqd -> (H1.Reqd.request reqd).H1.Request.target
| `V2 reqd -> (H2.Reqd.request reqd).H2.Request.target
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 server = { Vif_s.devices; cookie_key= cfg.Vif_config.cookie_key } in
let req0 = Vif_request0.of_reqd socket reqd in
let target = Vif_request0.target req0 in
let ctx = { Ms.server; request= req0; target; user's_value } in
let env = Ms.run middlewares ctx Vif_m.Hmap.empty in
let request = request ~env server in
Log.debug (fun m -> m "Handle a new request to %s" target);
let request = recognize_request ~env req0 in
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 []

83
lib/vif/vif.mli
View file

@ -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 ]
-> S.t
-> ?headers:Headers.t
-> Status.t
?compression:[< `DEFLATE ]
-> ('c, 'a) Request.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
-> Status.t
-> ('c, 'a) Request.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)
-> (S.t -> 'value -> Response.t) R.route list
-> default:
( ('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

12
lib/vif/vif_config.ml
View file

@ -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 }

134
lib/vif/vif_cookie.ml Normal file
View file

@ -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

41
lib/vif/vif_request.ml
View file

@ -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
| `V1 reqd ->
let request = `V1 (H1.Reqd.request reqd) in
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 }
fun ~encoding ~env request ->
let body = Vif_request0.request_body request in
{ request; body; encoding; env }
let target { request; _ } =
match request with
| `V1 request -> request.H1.Request.target
| `V2 request -> request.H2.Request.target
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 target { request; _ } = Vif_request0.target request
let meth { request; _ } = Vif_request0.meth request
let version { request; _ } = Vif_request0.version request
let headers { request; _ } = Vif_request0.headers request
let reqd { request; _ } = Vif_request0.reqd request
let to_string ~schedule ~close body =
let buf = Buffer.create 0x7ff in

58
lib/vif/vif_request0.ml
View file

@ -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
| `V1 reqd -> V1 (H1.Reqd.request reqd)
| `V2 reqd -> V2 (H2.Reqd.request reqd)
and reqd = Httpcats.Server.reqd
and socket = [ `Tcp of Miou_unix.file_descr | `Tls of Tls_miou_unix.t ]
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

167
lib/vif/vif_response.ml
View file

@ -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 =
match Vif_s.reqd server with
let can_compress alg req =
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 headers, stream =
match compression with
| Some `DEFLATE when can_compress "deflate" server ->
let headers =
match headers with
| 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 compression alg req =
match alg with
| `DEFLATE when can_compress "deflate" req ->
let* () = set ~field:"content-encoding" "deflate" in
return true
| `DEFLATE -> return false
let with_string ?compression server ?headers status str =
with_stream ?compression server ?headers status (Stream.Stream.singleton str)
let with_stream ?compression:alg req stream =
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

8
lib/vif/vif_s.ml
View file

@ -1,8 +1,4 @@
type t = { reqd: reqd; socket: socket; devices: Vif_d.Hmap.t }
and reqd = Httpcats.Server.reqd
and socket = [ `Tcp of Miou_unix.file_descr | `Tls of Tls_miou_unix.t ]
let reqd { reqd; _ } = reqd
type t = { devices: Vif_d.Hmap.t; cookie_key: Mirage_crypto.AES.GCM.key }
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