From 57d94524f76f940ed5693549a3347a930b1035c5 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 13 Feb 2025 17:17:00 +0100 Subject: [PATCH] Implement cookie (not tested) --- examples/01-hello/main.ml | 7 +- examples/02-counter/main.ml | 8 +- examples/04-device/main.ml | 15 ++-- examples/05-json/main.ml | 16 ++-- examples/06-caqti/foo.sqlite | Bin 8192 -> 8192 bytes examples/06-caqti/main.ml | 29 ++++-- examples/07-deflate/main.ml | 7 +- lib/vif/stream.ml | 36 -------- lib/vif/stream.mli | 3 - lib/vif/vif.ml | 85 ++++++++---------- lib/vif/vif.mli | 83 +++++++++++++---- lib/vif/vif_config.ml | 12 ++- lib/vif/vif_cookie.ml | 134 ++++++++++++++++++++++++++++ lib/vif/vif_request.ml | 41 +++------ lib/vif/vif_request0.ml | 58 ++++++++++-- lib/vif/vif_response.ml | 167 ++++++++++++++++++++++++++++++----- lib/vif/vif_s.ml | 8 +- 17 files changed, 513 insertions(+), 196 deletions(-) create mode 100644 lib/vif/vif_cookie.ml diff --git a/examples/01-hello/main.ml b/examples/01-hello/main.ml index c62c275..101cc98 100644 --- a/examples/01-hello/main.ml +++ b/examples/01-hello/main.ml @@ -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 () -> diff --git a/examples/02-counter/main.ml b/examples/02-counter/main.ml index bde8fa6..730a7ad 100644 --- a/examples/02-counter/main.ml +++ b/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 [] () ;; diff --git a/examples/04-device/main.ml b/examples/04-device/main.ml index 2df8194..894d960 100644 --- a/examples/04-device/main.ml +++ b/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 ] [] () ;; diff --git a/examples/05-json/main.ml b/examples/05-json/main.ml index a294292..2a8c73f 100644 --- a/examples/05-json/main.ml +++ b/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 - | 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 () ;; diff --git a/examples/06-caqti/foo.sqlite b/examples/06-caqti/foo.sqlite index 846d3667506186980ddc84e633f2a8eb4eee6b27..c0386610ccc17309ce6115e7a723efa8c63bdcbd 100644 GIT binary patch delta 89 zcmZp0XmFSy&B#7c#+jd;L9b1Nmw|zSk^eRW|Lx6!0=fK?Z}V#ku<<`);Q!74jsGM6 r8~*3~kAO1g_~n?{m>6xCS(z9^m|2(@MVXnI7`2$0m>5l&8G$SS_-PXy delta 47 zcmZp0XmFSy&B!=W#+jdyL9fYymw|zSk^eRW|Lx6+0=fK?Z}V$1F$e(J2l*#9SONeL C91Io! diff --git a/examples/06-caqti/main.ml b/examples/06-caqti/main.ml index 8f28c37..098e23f 100644 --- a/examples/06-caqti/main.ml +++ b/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 - 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 = diff --git a/examples/07-deflate/main.ml b/examples/07-deflate/main.ml index b89593d..325eb98 100644 --- a/examples/07-deflate/main.ml +++ b/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 () -> diff --git a/lib/vif/stream.ml b/lib/vif/stream.ml index 606364e..7cc9067 100644 --- a/lib/vif/stream.ml +++ b/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 ] diff --git a/lib/vif/stream.mli b/lib/vif/stream.mli index 88dd446..9fe3269 100644 --- a/lib/vif/stream.mli +++ b/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 diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml index e2a3d47..da22742 100644 --- a/lib/vif/vif.ml +++ b/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 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 [] diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli index 8efbe67..0594749 100644 --- a/lib/vif/vif.mli +++ b/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 ] - -> 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 diff --git a/lib/vif/vif_config.ml b/lib/vif/vif_config.ml index c7b7bc8..074b6e1 100644 --- a/lib/vif/vif_config.ml +++ b/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 } diff --git a/lib/vif/vif_cookie.ml b/lib/vif/vif_cookie.ml new file mode 100644 index 0000000..5645a67 --- /dev/null +++ b/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 diff --git a/lib/vif/vif_request.ml b/lib/vif/vif_request.ml index b084fea..7de53b4 100644 --- a/lib/vif/vif_request.ml +++ b/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 - | `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 diff --git a/lib/vif/vif_request0.ml b/lib/vif/vif_request0.ml index abe1107..d65f8dc 100644 --- a/lib/vif/vif_request0.ml +++ b/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 - | `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 diff --git a/lib/vif/vif_response.ml b/lib/vif/vif_response.ml index c9dbe4c..12efbe0 100644 --- a/lib/vif/vif_response.ml +++ b/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 = - 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 diff --git a/lib/vif/vif_s.ml b/lib/vif/vif_s.ml index dc004a2..d6721a6 100644 --- a/lib/vif/vif_s.ml +++ b/lib/vif/vif_s.ml @@ -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