diff --git a/README.md b/README.md
index e41c6c7..1614a01 100644
--- a/README.md
+++ b/README.md
@@ -1,4 +1,6 @@
-# Vif, a small framework for building a web server from an OCaml script
+# νιϝ, a small framework for building a web server from an OCaml script
+
+(nu)(iota)(digamma)
**disclaimer**: Please note that this is an experimental project. It's also an
opportunity to build something that can be satisfying for web development.
diff --git a/examples/09-jwt/cookie.txt b/examples/09-jwt/cookie.txt
new file mode 100644
index 0000000..005fc86
--- /dev/null
+++ b/examples/09-jwt/cookie.txt
@@ -0,0 +1,5 @@
+# Netscape HTTP Cookie File
+# https://curl.se/docs/http-cookies.html
+# This file was generated by libcurl! Edit at your own risk.
+
+#HttpOnly_localhost FALSE / TRUE 0 __Host-vif-token AIT3qkbKq7NBg7ePl7Xbs9ikzUNdcxLuKYbinTM3KQdTVm2jAHY36a8c9mOFSf5opEudhbozpU2oXxt_bfCkR9YlqAlzjK8OYcLwgBVMLZaJBiontKM9BdS70yUDdPawY4h883n9P0A9lEUhMNMQr7-NVieuIgZTGbtTV-B7Xrcf9pipVYOIiyiPcILaoDwa-ycs-_b9yqlyzDYfMPOwsWphSPR0Ji9lVg
diff --git a/examples/09-jwt/main.ml b/examples/09-jwt/main.ml
index e09591a..3160fd1 100644
--- a/examples/09-jwt/main.ml
+++ b/examples/09-jwt/main.ml
@@ -14,11 +14,8 @@ type cfg =
let jwt = Vif.Ms.make ~name:"jwt" @@ fun req target server { secret } ->
Logs.debug (fun m -> m "Search vif-token cookie");
match Cookie.get server req ~name:"vif-token" with
- | Error err ->
- Logs.err (fun m -> m "jwt: %a" Cookie.pp_error err);
- None
+ | Error err -> None
| Ok token ->
- Logs.debug (fun m -> m "Token found: %S" token);
let ( let* ) = Option.bind in
let* token = Result.to_option (Jwto.decode_and_verify secret token) in
let* username = List.assoc_opt "username" (Jwto.get_payload token) in
@@ -42,27 +39,39 @@ let credential =
conv prj inj credential
;;
+let form =
+ let open Vif.Multipart_form in
+ let fn username password =
+ { username; password } in
+ record fn
+ |+ field "username" string
+ |+ field "password" string
+ |> sealr
+;;
+
let users =
[ "dinosaure", "foo" ]
;;
-let login req server { secret }=
+let login req server { secret } { username; password } =
+ match List.assoc_opt username users with
+ | Some p' when password = p' ->
+ let token = Jwto.encode HS512 secret [ "username", username ] in
+ let token = Result.get_ok token in
+ let* () = Vif.Cookie.set ~name:"vif-token" server req token in
+ let field = "content-type" in
+ let* () = Response.add ~field "text/plain; charset=utf-8" in
+ let* () = Response.with_string req "Authenticated!\n" in
+ Response.respond `OK
+ | _ ->
+ let field = "content-type" in
+ let* () = Response.add ~field "text/plain; charset= utf-8" in
+ let* () = Response.with_string req "Bad credentials\n" in
+ Response.respond `Unauthorized
+
+let login_by_json req server cfg =
match Vif.Request.of_json req with
- | Ok { username; password } ->
- begin match List.assoc_opt username users with
- | Some p' when password = p' ->
- let token = Jwto.encode HS512 secret [ "username", username ] in
- let token = Result.get_ok token in
- let* () = Vif.Cookie.set ~name:"vif-token" server req token in
- let field = "content-type" in
- let* () = Response.add ~field "text/plain; charset=utf-8" in
- let* () = Response.with_string req "Authenticated!\n" in
- Response.respond `OK
- | _ ->
- let field = "content-type" in
- let* () = Response.add ~field "text/plain; charset= utf-8" in
- let* () = Response.with_string req "Bad credentials\n" in
- Response.respond `Unauthorized end
+ | Ok credential -> login req server cfg credential
| Error _ ->
let field = "content-type" in
let* () = Response.add ~field "text/plain; charset=utf-8" in
@@ -70,6 +79,16 @@ let login req server { secret }=
Response.respond (`Code 422)
;;
+let login_by_form req server cfg =
+ match Vif.Request.of_multipart_form req with
+ | Ok credential -> login req server cfg credential
+ | Error _ ->
+ let field = "content-type" in
+ let* () = Response.add ~field "text/plain; charset=utf-8" in
+ let* () = Response.with_string req "Invalid multipart-form\n" in
+ Response.respond (`Code 422)
+;;
+
let default req server _cfg =
match Request.get jwt req with
| None ->
@@ -88,8 +107,9 @@ let default req server _cfg =
let routes =
let open Vif.U in
let open Vif.R in
- let open Vif.Content_type in
- [ post (json_encoding credential) (rel / "login" /?? nil) --> login
+ let open Vif.T in
+ [ post (m form) (rel / "login" /?? nil) --> login_by_form
+ ; post (json_encoding credential) (rel / "login" /?? nil) --> login_by_json
; get (rel /?? nil) --> default ]
;;
diff --git a/examples/12-static/index.html b/examples/12-static/index.html
index d8a2cd6..2850e0f 100644
--- a/examples/12-static/index.html
+++ b/examples/12-static/index.html
@@ -1 +1,8 @@
-Hello from Vif!
+
+
+ Vif
+
+
+ Hello from Vif!
+
+
diff --git a/examples/12-static/main.ml b/examples/12-static/main.ml
index c26c1bf..e01545d 100644
--- a/examples/12-static/main.ml
+++ b/examples/12-static/main.ml
@@ -2,6 +2,17 @@
open Vif ;;
-let () = Miou_unix.run @@ fun () ->
- Vif.run ~handlers:[ Handler.static ] [] ()
+let default req server _ =
+ Response.with_file ~compression:`DEFLATE req (Fpath.v "index.html")
+;;
+
+let routes =
+ let open Vif.U in
+ let open Vif.R in
+ let open Vif.Content_type in
+ [ get (rel /?? nil) --> default ]
+;;
+
+let () = Miou_unix.run @@ fun () ->
+ Vif.run ~handlers:[ Handler.static ] routes ()
;;
diff --git a/lib/bin.ml b/lib/bin.ml
new file mode 100644
index 0000000..e69de29
diff --git a/lib/vif/dune b/lib/vif/dune
index 743808d..a8e70f7 100644
--- a/lib/vif/dune
+++ b/lib/vif/dune
@@ -15,5 +15,6 @@
decompress.zl
decompress.gz
mirage-crypto-rng-miou-unix
+ multipart_form-miou
httpcats
tyre))
diff --git a/lib/vif/stream.ml b/lib/vif/stream.ml
index 37e24dc..243e7b9 100644
--- a/lib/vif/stream.ml
+++ b/lib/vif/stream.ml
@@ -178,6 +178,17 @@ module Sink = struct
let stop = Buffer.contents in
Sink { init; push; full; stop }
+ let into_bstream bstream =
+ let open Multipart_form_miou in
+ let init () = bstream in
+ let push bstream str =
+ Bounded_stream.put bstream (Some str);
+ bstream
+ in
+ let full = Fun.const false in
+ let stop bstream = Bounded_stream.put bstream None in
+ Sink { init; push; full; stop }
+
let json () =
let decoder = Jsonm.decoder `Manual in
let rec error (`Error err) =
diff --git a/lib/vif/stream.mli b/lib/vif/stream.mli
index 74d3207..9a44b64 100644
--- a/lib/vif/stream.mli
+++ b/lib/vif/stream.mli
@@ -31,6 +31,7 @@ type ('a, 'r) sink =
module Sink : sig
val json : unit -> (string, (Json.t, [ `Msg of string ]) result) sink
+ val into_bstream : 'a Multipart_form_miou.Bounded_stream.t -> ('a, unit) sink
val string : (string, string) sink
end
diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml
index c4f72f0..e9bd4b9 100644
--- a/lib/vif/vif.ml
+++ b/lib/vif/vif.ml
@@ -6,7 +6,7 @@ module U = Vif_u
module R = struct
include Vif_r
- open Vif_content_type
+ open Vif_t
type ('fu, 'return) t =
| Handler : ('f, 'x) Vif_r.req * ('x, 'r) Vif_u.t -> ('f, 'r) t
@@ -70,13 +70,51 @@ module Ms = struct
end
end
-module Content_type = Vif_content_type
+module T = Vif_t
module Stream = Stream
module Method = Vif_method
module Status = Vif_status
module Headers = Vif_headers
-module Request = Vif_request
-module Response = Vif_response
+
+module Response = struct
+ include Vif_response
+
+ let mime_type path =
+ let default = "application/octet-stream" in
+ match Conan_unix.run_with_tree Conan_light.tree (Fpath.to_string path) with
+ | Ok m -> Option.value ~default (Conan.Metadata.mime m)
+ | Error _ -> default
+ | exception _ -> default
+
+ let with_file ?mime ?compression:alg req path =
+ if
+ Sys.file_exists (Fpath.to_string path) = false
+ || Sys.is_directory (Fpath.to_string path)
+ then Fmt.invalid_arg "Response.with_file %a" Fpath.pp path;
+ if Vif_handler.cache req path then
+ let* () = with_string req "" in
+ respond `Not_modified
+ else
+ let mime = Option.value ~default:(mime_type path) mime in
+ let src = Stream.Source.file (Fpath.to_string path) in
+ let src = Stream.Stream.from src in
+ let field = "connection" in
+ let* () =
+ if Vif_request.version req = 1 then add ~field "close" else return ()
+ in
+ let field = "content-type" in
+ let* () = add ~field mime in
+ let stat = Unix.stat (Fpath.to_string path) in
+ let field = "content-length" in
+ let* () = add ~field (string_of_int stat.Unix.st_size) in
+ let none = return false in
+ let* _ = Option.fold ~none ~some:(fun alg -> compression alg req) alg in
+ let field = "etag" in
+ let* () = add ~field (Vif_handler.sha256sum path) in
+ let* () = with_stream req src in
+ respond `OK
+end
+
module Cookie = Vif_cookie
module Handler = Vif_handler
@@ -90,6 +128,11 @@ 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 is_multipart_form_data { Multipart_form.Content_type.ty; subty; _ } =
+ match (ty, subty) with
+ | `Multipart, `Iana_token "form-data" -> true
+ | _ -> false
+
let content_type req0 =
let headers = Vif_request0.headers req0 in
let c = Vif_headers.get headers "content-type" in
@@ -97,53 +140,125 @@ let content_type req0 =
let c = Option.to_result ~none:`Not_found c in
Result.bind c Multipart_form.Content_type.of_string
-[@@@warning "-8"]
-
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 =
+ Vif_method.t option -> (c, a) Vif_t.t -> (c, a) Vif_request.t option =
fun meth c ->
- let meth' = Vif_request0.meth req0 in
- match (meth, meth', c) with
- | None, _, (Vif_content_type.Any as encoding) ->
- 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_req0 ~encoding ~env req0) else None
- | None, _, (Null as encoding) ->
- Some (Vif_request.of_req0 ~encoding ~env req0)
- | Some a, b, (Null as encoding) ->
- if a = b then Some (Vif_request.of_req0 ~encoding ~env req0) else None
- | None, _, (Json_encoding _ as encoding) ->
- 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_req0 ~encoding ~env req0)
+ let none = true in
+ let some = ( = ) (Vif_request0.meth req0) in
+ let meth_match = Option.fold ~none ~some meth in
+ Log.debug (fun m -> m "method matches? %b" meth_match);
+ match c with
+ | Vif_t.Any as encoding ->
+ if meth_match then Some (Vif_request.of_req0 ~encoding ~env req0)
else None
- | Some a, b, (Json_encoding _ as encoding) ->
+ | Null as encoding ->
+ if meth_match then Some (Vif_request.of_req0 ~encoding ~env req0)
+ else None
+ | Json_encoding _ as encoding ->
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
+ let type_match = Result.map is_application_json c in
+ let type_match = Result.value ~default:false type_match in
+ if type_match && meth_match then
Some (Vif_request.of_req0 ~encoding ~env req0)
else None
- | None, _, (Json as encoding) ->
+ | Multipart_form_encoding _ as encoding ->
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_req0 ~encoding ~env req0)
- else None
- | Some a, b, (Json as encoding) ->
- 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
+ let type_match = Result.map is_multipart_form_data c in
+ let type_match = Result.value ~default:false type_match in
+ if type_match && meth_match then
Some (Vif_request.of_req0 ~encoding ~env req0)
else None
+ | Json as encoding ->
+ let c = content_type req0 in
+ let type_match = Result.map is_application_json c in
+ let type_match = Result.value ~default:false type_match in
+ if type_match && meth_match then
+ Some (Vif_request.of_req0 ~encoding ~env req0)
+ else None
+ | Multipart_form -> assert false (* TODO *)
in
{ Vif_r.extract }
+module Multipart_form = struct
+ include Vif_multipart_form
+
+ let parse req =
+ let open Multipart_form_miou in
+ let hdrs = Vif_request.headers req in
+ let ct =
+ match Vif_headers.get hdrs "content-type" with
+ | None -> Fmt.invalid_arg "Content-type field missing"
+ | Some str ->
+ let ct = Multipart_form.Content_type.of_string (str ^ "\r\n") in
+ Result.get_ok ct
+ in
+ let t = Bounded_stream.create 0x100 in
+ let prm0 =
+ Miou.async @@ fun () ->
+ let open Stream in
+ Stream.into (Sink.into_bstream t) (Vif_request.stream req)
+ in
+ let prm1 = Miou.async @@ fun () -> of_stream_to_list t ct in
+ Miou.await_exn prm0;
+ match Miou.await_exn prm1 with
+ | Ok (_tree, lst) ->
+ let fn (_id, hdrs) =
+ let hdrs = Multipart_form.Header.to_list hdrs in
+ let name = ref None in
+ let filename = ref None in
+ let size = ref None in
+ let mime = ref None in
+ let fn = function
+ | Multipart_form.Field.Field (_, Content_type, { ty; subty; _ }) ->
+ let open Multipart_form.Content_type in
+ let value = Fmt.str "%a/%a" Type.pp ty Subtype.pp subty in
+ mime := Some value;
+ None
+ | Field (_, Content_encoding, _) -> None
+ | Field (_, Content_disposition, t) ->
+ let open Multipart_form in
+ name := Content_disposition.name t;
+ filename := Content_disposition.filename t;
+ size := Content_disposition.size t;
+ None
+ | Field (fn, Field, unstrctrd) ->
+ let k = (fn :> string) in
+ let v = Unstrctrd.fold_fws unstrctrd in
+ let v = Unstrctrd.to_utf_8_string v in
+ Some (k, v)
+ in
+ let hdrs = List.filter_map fn hdrs in
+ let meta =
+ { name= !name; filename= !filename; size= !size; mime= !mime }
+ in
+ (meta, hdrs)
+ in
+ Ok (List.map (fun (k, v) -> (fn k, v)) lst)
+ | Error (`Msg msg) ->
+ Logs.err (fun m -> m "Invalid multipart/form-data: %s" msg);
+ Error `Invalid_multipart_form
+end
+
+module Request = struct
+ include Vif_request
+
+ let of_multipart_form : type a.
+ (Vif_t.multipart_form, a) Vif_request.t
+ -> (a, [> `Invalid_multipart_form | `Not_found of string ]) result =
+ function
+ | { encoding= Multipart_form_encoding r; _ } as req ->
+ let ( let* ) = Result.bind in
+ let* raw = Multipart_form.parse req in
+ begin
+ try Ok (Multipart_form.get_record r raw)
+ with Multipart_form.Field_not_found field ->
+ Error (`Not_found field)
+ end
+ | { encoding= Multipart_form; _ } -> assert false
+ | { encoding= Any; _ } -> assert false
+end
+
type 'value daemon = {
queue: 'value user's_function Queue.t
; mutex: Miou.Mutex.t
@@ -192,7 +307,7 @@ let rec user's_functions daemon =
in
let fn (User's_task (req0, fn)) =
let _prm =
- Miou.call ~orphans:daemon.orphans @@ fun () ->
+ Miou.async ~orphans:daemon.orphans @@ fun () ->
match
Vif_response.(run req0 empty) (fn daemon.server daemon.user's_value)
with
@@ -212,6 +327,11 @@ let handler _cfg ~default ~middlewares routes daemon =
let request = recognize_request ~env req0 in
let target = Vif_request0.target req0 in
let fn = R.dispatch ~default routes ~request ~target in
+ (* NOTE(dinosaure): the management of the http request must finish and above
+ all **not** block. Otherwise, the entire domain is blocked. Thus, the
+ management of a new request transfers the user task (which can block) to
+ our "daemon" instantiated in our current domain which runs cooperatively.
+ *)
begin
Miou.Mutex.protect daemon.mutex @@ fun () ->
Queue.push (User's_task (req0, fn)) daemon.queue;
@@ -223,20 +343,41 @@ type config = Vif_config.config
let () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore
let config = Vif_config.config
-let handle stop cfg fn =
+let process stop cfg server user's_value fn =
Logs.debug (fun m ->
m "new HTTP server on [%d]" (Stdlib.Domain.self () :> int));
+ let daemon =
+ {
+ queue= Queue.create ()
+ ; mutex= Miou.Mutex.create ()
+ ; orphans= Miou.orphans ()
+ ; condition= Miou.Condition.create ()
+ ; user's_value
+ ; server
+ }
+ in
+ let fn = fn daemon in
+ let user's_tasks = Miou.async @@ fun () -> user's_functions daemon in
+ let parallel = false in
+ (* NOTE(dinosaure): The user task **must** be executed cooperatively (instead
+ of in parallel) with the task managing the new http connection. [httpcats]
+ is therefore instructed to launch the task managing the http connection on
+ the same domain as the [process] domain. *)
match (cfg.Vif_config.http, cfg.Vif_config.tls) with
| config, Some tls ->
- Httpcats.Server.with_tls ?stop ?config ~backlog:cfg.backlog tls
- ~handler:fn cfg.sockaddr
+ Httpcats.Server.with_tls ~parallel ?stop ?config ~backlog:cfg.backlog tls
+ ~handler:fn cfg.sockaddr;
+ Miou.cancel user's_tasks
| Some (`H2 _), None ->
+ Miou.cancel user's_tasks;
failwith "Impossible to launch an h2 server without TLS."
| Some (`Both (config, _) | `HTTP_1_1 config), None ->
- Httpcats.Server.clear ?stop ~config ~handler:fn cfg.sockaddr
+ Httpcats.Server.clear ~parallel ?stop ~config ~handler:fn cfg.sockaddr;
+ Miou.cancel user's_tasks
| None, None ->
Log.debug (fun m -> m "Start a non-tweaked HTTP/1.1 server");
- Httpcats.Server.clear ?stop ~handler:fn cfg.sockaddr
+ Httpcats.Server.clear ~parallel ?stop ~handler:fn cfg.sockaddr;
+ Miou.cancel user's_tasks
let store_pid = function
| None -> ()
@@ -283,7 +424,7 @@ let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[])
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
+ let domains = cfg.domains in
store_pid cfg.pid;
let stop =
match interactive with
@@ -302,31 +443,21 @@ let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[])
let devices = Ds.run Vif_d.Hmap.empty devices user's_value in
Logs.debug (fun m -> m "devices launched");
let server = { Vif_s.devices; cookie_key= cfg.Vif_config.cookie_key } in
- let daemon =
- {
- queue= Queue.create ()
- ; mutex= Miou.Mutex.create ()
- ; orphans= Miou.orphans ()
- ; condition= Miou.Condition.create ()
- ; user's_value
- ; server
- }
- in
let default = default_from_handlers handlers in
- let user's_tasks = Miou.call @@ fun () -> user's_functions daemon in
- let fn0 = handler cfg ~default ~middlewares routes daemon in
- let prm0 = Miou.async @@ fun () -> handle stop cfg fn0 in
+ let fn0 = handler cfg ~default ~middlewares routes in
+ let prm0 = Miou.async @@ fun () -> process stop cfg server user's_value fn0 in
let tasks =
- let fn _ = handler cfg ~default ~middlewares routes daemon in
+ let fn _ = handler cfg ~default ~middlewares routes in
List.init domains fn
in
let tasks =
- if domains > 0 then Miou.parallel (handle stop cfg) tasks else []
+ if domains > 0 then
+ Miou.parallel (process stop cfg server user's_value) tasks
+ else []
in
Miou.await_exn prm0;
List.iter (function Ok () -> () | Error exn -> raise exn) tasks;
Ds.finally (Vif_d.Devices devices);
- Miou.cancel user's_tasks;
Log.debug (fun m -> m "Vif (and devices) terminated")
let setup_config = Vif_options.setup_config
diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli
index 1515b0c..dae6dbd 100644
--- a/lib/vif/vif.mli
+++ b/lib/vif/vif.mli
@@ -51,14 +51,33 @@ module Method : sig
| `Other of string ]
end
-module Content_type : sig
+module Multipart_form : sig
+ type 'a t
+ type 'a atom
+
+ val string : string atom
+
+ type ('a, 'b, 'c) orecord
+
+ val record : 'b -> ('a, 'b, 'b) orecord
+
+ type 'a field
+
+ val field : string -> 'a atom -> 'a field
+ val ( |+ ) : ('a, 'b, 'c -> 'd) orecord -> 'c field -> ('a, 'b, 'd) orecord
+ val sealr : ('a, 'b, 'a) orecord -> 'a t
+end
+
+module T : sig
type null
type json
+ type multipart_form
type ('c, 'a) t
val null : (null, unit) t
val json : (json, Json.t) t
val json_encoding : 'a Json_encoding.encoding -> (json, 'a) t
+ val m : 'a Multipart_form.t -> (multipart_form, 'a) t
val any : ('c, string) t
end
@@ -73,7 +92,12 @@ module Request : sig
val meth : ('c, 'a) t -> Method.t
val version : ('c, 'a) t -> int
val headers : ('c, 'a) t -> Headers.t
- val of_json : (Content_type.json, 'a) t -> ('a, [ `Msg of string ]) result
+ val of_json : (T.json, 'a) t -> ('a, [ `Msg of string ]) result
+
+ val of_multipart_form :
+ (T.multipart_form, 'a) t
+ -> ('a, [ `Not_found of string | `Invalid_multipart_form ]) result
+
val stream : ('c, 'a) t -> string Stream.stream
val get : ('cfg, 'v) M.t -> ('c, 'a) t -> 'v option
@@ -87,21 +111,10 @@ end
module R : sig
type 'r route
type ('fu, 'return) t
- type request
-
- val get : ('x, 'r) U.t -> ((Content_type.null, unit) Request.t -> 'x, 'r) t
-
- val post :
- ('c, 'a) Content_type.t -> ('x, 'r) U.t -> (('c, 'a) Request.t -> 'x, 'r) t
+ val get : ('x, 'r) U.t -> ((T.null, unit) Request.t -> 'x, 'r) t
+ val post : ('c, 'a) T.t -> ('x, 'r) U.t -> (('c, 'a) Request.t -> 'x, 'r) t
val ( --> ) : ('f, 'r) t -> 'f -> 'r route
-
- val dispatch :
- default:(('c, string) Request.t -> string -> 'r)
- -> 'r route list
- -> request:request
- -> target:string
- -> 'r
end
module C : sig
@@ -137,11 +150,11 @@ module C : sig
let readme =
let open U in
host "raw.githubusercontent.com"
- /% Tyre.string
- /% Tyre.string
+ /% string
+ /% string
/ "refs"
/ "heads"
- /% Tyre.string
+ /% string
/ "README.md"
/?? nil
@@ -151,6 +164,19 @@ module C : sig
end
module D : sig
+ (** {3 Devices.}
+
+ A device is a global instance on the http server with which a "finaliser"
+ is associated. A device is available from all requests from a {!type:S.t}
+ value. The same device instance is available from all domains —
+ interactions with a device must therefore be {i domain-safe}.
+
+ A device can be created from several values as well as from other devices.
+ Finally, a device is constructed from an end-user value specified by
+ {!val:Vif.run}. The idea is to allow the user to construct a value (from,
+ for example, command line parameters) corresponding to a configuration and
+ to construct these devices from this value. *)
+
type ('value, 'a) arg
type ('value, 'a) device
@@ -245,6 +271,14 @@ module Status : sig
end
module Response : sig
+ (** {3 Response.}
+
+ A response is a construction (monad) whose initial state is {i empty}
+ ({!type:e}) and must end in the state {i sent} ({!type:s}). Throughout
+ this construction, the user can {!val:add}/{!val:rem}/{!val:set}
+ information in the {i header}. Finally, the user must respond with content
+ (via {!val:with_string}/{!val:with_stream}) and a status code. *)
+
type ('p, 'q, 'a) t
type e
type f
@@ -259,6 +293,13 @@ module Response : sig
val with_string :
?compression:[< `DEFLATE ] -> ('c, 'a) Request.t -> string -> (e, f, unit) t
+ val with_file :
+ ?mime:string
+ -> ?compression:[< `DEFLATE ]
+ -> ('c, 'a) Request.t
+ -> Fpath.t
+ -> (e, s, unit) t
+
val respond : Status.t -> (f, s, unit) t
(** Headers manipulation. *)
@@ -283,17 +324,16 @@ module Cookie : sig
-> unit
-> config
+ type error = [ `Invalid_encrypted_cookie | `Msg of string | `Not_found ]
+
val get :
?encrypted:bool
-> name:string
-> S.t
-> Request.request
- -> ( string
- , [> `Invalid_encrypted_cookie | `Msg of string | `Not_found ] )
- result
+ -> (string, [> error ]) result
- val pp_error :
- [ `Invalid_encrypted_cookie | `Msg of string | `Not_found ] Fmt.t
+ val pp_error : error Fmt.t
val set :
?encrypt:bool
@@ -330,7 +370,8 @@ val ( let* ) :
val return : 'a -> ('p, 'p, 'a) Response.t
val config :
- ?cookie_key:Mirage_crypto.AES.GCM.key
+ ?domains:int
+ -> ?cookie_key:Mirage_crypto.AES.GCM.key
-> ?pid:Fpath.t
-> ?http:
[ `H1 of H1.Config.t
diff --git a/lib/vif/vif_config.ml b/lib/vif/vif_config.ml
index 074b6e1..cbe8e9e 100644
--- a/lib/vif/vif_config.ml
+++ b/lib/vif/vif_config.ml
@@ -9,6 +9,7 @@ type config = {
; sockaddr: Unix.sockaddr
; pid: Fpath.t option
; cookie_key: Mirage_crypto.AES.GCM.key
+ ; domains: int
}
let really_bad_secret =
@@ -17,8 +18,10 @@ let really_bad_secret =
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 default_domains = Int.min (Stdlib.Domain.recommended_domain_count ()) 4
+
+let config ?(domains = default_domains) ?(cookie_key = really_bad_secret) ?pid
+ ?http ?tls ?(backlog = 64) sockaddr =
let http =
match http with
| Some (`H1 cfg) -> Some (`HTTP_1_1 cfg)
@@ -26,4 +29,4 @@ let config ?(cookie_key = really_bad_secret) ?pid ?http ?tls ?(backlog = 64)
| Some (`Both (h1, h2)) -> Some (`Both (h1, h2))
| None -> None
in
- { http; tls; backlog; sockaddr; pid; cookie_key }
+ { http; tls; backlog; sockaddr; pid; cookie_key; domains }
diff --git a/lib/vif/vif_content_type.ml b/lib/vif/vif_content_type.ml
deleted file mode 100644
index e92cc3f..0000000
--- a/lib/vif/vif_content_type.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-type null = Null
-type json = Json
-type multipart_form = Multipart_form
-type stream = string Stream.source Multipart_form.elt Stream.source
-
-type ('c, 'a) t =
- | Null : (null, unit) t
- | Json_encoding : 'a Json_encoding.encoding -> (json, 'a) t
- | Multipart_form_encoding : 'a Multipart_form.t -> (multipart_form, 'a) t
- | Multipart_form : (multipart_form, stream) t
- | Json : (json, Json.t) t
- | Any : ('c, string) t
-
-let null = Null
-let json_encoding e = Json_encoding e
-let json = Json
-let any = Any
-
-module Witness = struct
- type (_, _) eq = Refl : ('a, 'a) eq
- type _ equality = ..
-
- module type Inst = sig
- type t
- type _ equality += Eq : t equality
- end
-
- type 'a t = (module Inst with type t = 'a)
-
- let make : type a. unit -> a t =
- fun () ->
- let module Inst = struct
- type t = a
- type _ equality += Eq : t equality
- end in
- (module Inst)
-
- let _eq : type a b. a t -> b t -> (a, b) eq option =
- fun (module A) (module B) -> match A.Eq with B.Eq -> Some Refl | _ -> None
-end
-
-module Multipart = struct
- type 'a t = { rwit: 'a Witness.t; rfields: 'a fields_and_constr }
-
- and 'a fields_and_constr =
- | Fields : ('a, 'b) fields * 'b -> 'a fields_and_constr
-
- and ('a, 'b) fields =
- | F0 : ('a, 'a) fields
- | F1 : ('a, 'b) field * ('a, 'c) fields -> ('a, 'b -> 'c) fields
-
- and ('a, 'b) field = { name: string; ftype: 'b ty; fget: 'a -> 'b }
- and 'a ty = Primary : 'a primary -> 'a ty | Record : 'a t -> 'a ty
- and 'a primary = String : string primary
-end
diff --git a/lib/vif/vif_cookie.ml b/lib/vif/vif_cookie.ml
index 62d7607..bac0866 100644
--- a/lib/vif/vif_cookie.ml
+++ b/lib/vif/vif_cookie.ml
@@ -32,6 +32,8 @@ let all_cookies hdrs =
let guard error fn = if fn () then Ok () else Error error
let err_cookie = `Invalid_encrypted_cookie
+type error = [ `Invalid_encrypted_cookie | `Msg of string | `Not_found ]
+
let pp_error ppf = function
| `Invalid_encrypted_cookie -> Fmt.string ppf "Invalid encrypted cookie"
| `Not_found -> Fmt.string ppf "Cookie not found"
diff --git a/lib/vif/vif_multipart_form.ml b/lib/vif/vif_multipart_form.ml
new file mode 100644
index 0000000..daa78c9
--- /dev/null
+++ b/lib/vif/vif_multipart_form.ml
@@ -0,0 +1,143 @@
+module Witness = struct
+ type (_, _) eq = Refl : ('a, 'a) eq
+ type _ equality = ..
+
+ module type Inst = sig
+ type t
+ type _ equality += Eq : t equality
+ end
+
+ type 'a t = (module Inst with type t = 'a)
+
+ let make : type a. unit -> a t =
+ fun () ->
+ let module Inst = struct
+ type t = a
+ type _ equality += Eq : t equality
+ end in
+ (module Inst)
+
+ let _eq : type a b. a t -> b t -> (a, b) eq option =
+ fun (module A) (module B) -> match A.Eq with B.Eq -> Some Refl | _ -> None
+end
+
+type 'a t = { rwit: 'a Witness.t; rfields: 'a fields_and_constr }
+
+and 'a fields_and_constr =
+ | Fields : ('a, 'b) fields * 'b -> 'a fields_and_constr
+
+and ('a, 'b) fields =
+ | F0 : ('a, 'a) fields
+ | F1 : 'b field * ('a, 'c) fields -> ('a, 'b -> 'c) fields
+
+and 'a field = { fname: string; ftype: 'a atom }
+and 'a atom = Primary : 'a primary -> 'a atom | Record : 'a t -> 'a atom
+and 'a primary = String : string primary
+
+type meta = {
+ name: string option
+ ; filename: string option
+ ; size: int option
+ ; mime: string option
+}
+
+let pp_meta ppf t =
+ match (t.name, t.filename) with
+ | Some name, _ -> Fmt.string ppf name
+ | _, Some filename -> Fmt.string ppf filename
+ | _ -> Fmt.pf ppf ""
+
+type raw = ((meta * Vif_headers.t) * string) list
+
+module Fields_folder (Acc : sig
+ type ('a, 'b) t
+end) =
+struct
+ type 'a t = {
+ nil: ('a, 'a) Acc.t
+ ; cons: 'b 'c. 'b field -> ('a, 'c) Acc.t -> ('a, 'b -> 'c) Acc.t
+ }
+
+ let rec fold : type a c. a t -> (a, c) fields -> (a, c) Acc.t =
+ fun folder -> function
+ | F0 -> folder.nil
+ | F1 (f, fs) -> folder.cons f (fold folder fs)
+end
+
+module Record_get = Fields_folder (struct
+ type ('a, 'b) t = raw -> 'b -> 'a
+end)
+
+exception Field_not_found of string
+
+let find_by_name name raw =
+ let fn ((meta, _), _) =
+ match meta.name with Some name' -> String.equal name name' | None -> false
+ in
+ let _, value =
+ try List.find fn raw with Not_found -> raise (Field_not_found name)
+ in
+ value
+
+let rec get_value : type a. a atom -> string -> raw -> a = function
+ | Primary String -> find_by_name
+ | Record r -> fun _ raw -> get_record r raw
+
+and get_record : type a. a t -> raw -> a =
+ fun { rfields= Fields (fs, constr); _ } ->
+ let nil _raw fn = fn in
+ let cons { fname; ftype } k =
+ let get = get_value ftype fname in
+ fun raw constr ->
+ let x = get raw in
+ let constr = constr x in
+ k raw constr
+ in
+ let fn = Record_get.fold { nil; cons } fs in
+ fun raw -> fn raw constr
+
+type ('a, 'b, 'c) orecord = ('a, 'c) fields -> 'b * ('a, 'b) fields
+type 'a a_field = Field : 'x field -> 'a a_field
+
+let field fname ftype = { fname; ftype }
+let record : 'b -> ('a, 'b, 'b) orecord = fun c fs -> (c, fs)
+
+module SSet = Set.Make (String)
+
+let check_unique fn =
+ let rec go s = function
+ | [] -> ()
+ | x :: xs -> (
+ match SSet.find_opt x s with
+ | None -> go (SSet.add x s) xs
+ | Some _ -> fn x)
+ in
+ go SSet.empty
+
+let check_uniq_field_names rfields =
+ let names = List.map (fun (Field { fname; _ }) -> fname) rfields in
+ let failure fname =
+ Fmt.invalid_arg "The name %s was used for two or more parts." fname
+ in
+ check_unique failure names
+
+let fields r =
+ let rec go : type a b. (a, b) fields -> a a_field list = function
+ | F0 -> []
+ | F1 (h, t) -> Field h :: go t
+ in
+ match r.rfields with Fields (f, _) -> go f
+
+let app : type a b c d. (a, b, c -> d) orecord -> c field -> (a, b, d) orecord =
+ fun r f fs -> r (F1 (f, fs))
+
+let sealr : type a b. (a, b, a) orecord -> a t =
+ fun r ->
+ let c, fs = r F0 in
+ let rwit = Witness.make () in
+ let sealed = { rwit; rfields= Fields (fs, c) } in
+ check_uniq_field_names (fields sealed);
+ sealed
+
+let ( |+ ) = app
+let string = Primary String
diff --git a/lib/vif/vif_options.ml b/lib/vif/vif_options.ml
index 0eaa7c2..41c528f 100644
--- a/lib/vif/vif_options.ml
+++ b/lib/vif/vif_options.ml
@@ -3,16 +3,18 @@ let port = ref 8080
let inet_addr = ref Unix.inet_addr_loopback
let backlog = ref 64
let pid = ref None
+let domains = ref None
-let setup_config port' inet_addr' backlog' pid' =
+let setup_config domains' port' inet_addr' backlog' pid' =
port := port';
inet_addr := inet_addr';
backlog := backlog';
- pid := pid'
+ pid := pid';
+ domains := domains'
let config_from_globals () =
let sockaddr = Unix.(ADDR_INET (!inet_addr, !port)) in
- Vif_config.config ?pid:!pid ~backlog:!backlog sockaddr
+ Vif_config.config ?domains:!domains ?pid:!pid ~backlog:!backlog sockaddr
open Cmdliner
@@ -34,13 +36,17 @@ let inet_addr =
& opt inet_addr Unix.inet_addr_loopback
& info [ "i"; "inet-addr" ] ~doc ~docv:"INET_ADDR"
+let is_not_directory str =
+ (Sys.file_exists str && Sys.is_directory str = false)
+ || Sys.file_exists str = false
+
let pid =
let doc = "Specify a file to record its process-id in." in
let non_existing_file =
let parser str =
match Fpath.of_string str with
- | Ok _ as v when Sys.file_exists str = false -> v
- | Ok v -> error_msgf "%a already exists" Fpath.pp v
+ | Ok _ as v when is_not_directory str -> v
+ | Ok v -> error_msgf "%a already exists as a directory" Fpath.pp v
| Error _ as err -> err
in
Arg.conv (parser, Fpath.pp)
@@ -50,6 +56,11 @@ let pid =
& opt (some non_existing_file) None
& info [ "pid-file" ] ~doc ~docv:"PATH"
+let domains =
+ let doc = "The number of number used by vif." in
+ let open Arg in
+ value & opt (some int) None & info [ "domains" ] ~doc ~docv:"DOMAINS"
+
let backlog =
let doc =
"The limit of outstanding connections in the socket's listen queue."
@@ -59,4 +70,4 @@ let backlog =
let setup_config =
let open Term in
- const setup_config $ port $ inet_addr $ backlog $ pid
+ const setup_config $ domains $ port $ inet_addr $ backlog $ pid
diff --git a/lib/vif/vif_r.ml b/lib/vif/vif_r.ml
index 3c94ce0..e3e557b 100644
--- a/lib/vif/vif_r.ml
+++ b/lib/vif/vif_r.ml
@@ -208,7 +208,7 @@ let extract t =
type ('fu, 'return) req =
| Request :
- Vif_method.t option * ('c, 'a) Vif_content_type.t
+ Vif_method.t option * ('c, 'a) Vif_t.t
-> (('c, 'a) Vif_request.t -> 'r, 'r) req
type 'r route = Route : ('f, 'x) req * ('x, 'r) Vif_u.t * 'f -> 'r route
@@ -228,21 +228,27 @@ let rec build_info_list idx = function
type request = {
extract:
'c 'a.
- Vif_method.t option
- -> ('c, 'a) Vif_content_type.t
- -> ('c, 'a) Vif_request.t option
+ Vif_method.t option -> ('c, 'a) Vif_t.t -> ('c, 'a) Vif_request.t option
}
let rec find_and_trigger : type r.
- original:string -> request:request -> Re.Group.t -> r re list -> r =
- fun ~original ~request subs -> function
+ original:string
+ -> uid:int
+ -> request:request
+ -> Re.Group.t
+ -> r re list
+ -> r =
+ fun ~original ~uid ~request subs -> function
| [] -> raise Not_found
| Re (Request (meth, c), f, id, ret) :: l ->
+ Log.debug (fun m ->
+ m "%S matches with %a (%03d)? %b" original Re.Group.pp subs uid
+ (Re.Mark.test subs id));
if Re.Mark.test subs id then
match request.extract meth c with
| Some request -> extract ~original ret subs (f request)
- | None -> find_and_trigger ~original ~request subs l
- else find_and_trigger ~original ~request subs l
+ | None -> find_and_trigger ~original ~uid:(succ uid) ~request subs l
+ else find_and_trigger ~original ~uid:(succ uid) ~request subs l
let dispatch : type r c.
default:((c, string) Vif_request.t -> string -> r)
@@ -260,7 +266,7 @@ let dispatch : type r c.
let[@warning "-8"] (Some request) = request.extract None Any in
default request target
| Some subs -> begin
- try find_and_trigger ~original:target ~request subs wl
+ try find_and_trigger ~original:target ~uid:0 ~request subs wl
with Not_found as exn ->
Log.debug (fun m ->
m "Fallback to the default route (exn: %s)"
diff --git a/lib/vif/vif_request.ml b/lib/vif/vif_request.ml
index dc912ff..6d01bd6 100644
--- a/lib/vif/vif_request.ml
+++ b/lib/vif/vif_request.ml
@@ -4,16 +4,13 @@ module Log = (val Logs.src_log src : Logs.LOG)
type ('c, 'a) t = {
body: [ `V1 of H1.Body.Reader.t | `V2 of H2.Body.Reader.t ]
- ; encoding: ('c, 'a) Vif_content_type.t
+ ; encoding: ('c, 'a) Vif_t.t
; env: Vif_m.Hmap.t
; request: Vif_request0.t
}
let of_req0 : type c a.
- encoding:(c, a) Vif_content_type.t
- -> env:Vif_m.Hmap.t
- -> Vif_request0.t
- -> (c, a) t =
+ encoding:(c, a) Vif_t.t -> env:Vif_m.Hmap.t -> Vif_request0.t -> (c, a) t =
fun ~encoding ~env request ->
let body = Vif_request0.request_body request in
{ request; body; encoding; env }
@@ -34,8 +31,8 @@ let destruct : type a. a Json_encoding.encoding -> Json.t -> a =
let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
-let of_json : type a.
- (Vif_content_type.json, a) t -> (a, [> `Msg of string ]) result = function
+let of_json : type a. (Vif_t.json, a) t -> (a, [> `Msg of string ]) result =
+ function
| { encoding= Any; _ } as req -> Ok (to_string req)
| { encoding= Json; _ } as req ->
let stream = stream req in
diff --git a/lib/vif/vif_response.ml b/lib/vif/vif_response.ml
index 1bbdbf3..0d7f283 100644
--- a/lib/vif/vif_response.ml
+++ b/lib/vif/vif_response.ml
@@ -72,36 +72,24 @@ let compression alg req =
match alg with
| `DEFLATE when can_compress "deflate" req ->
let* () = set ~field:"content-encoding" "deflate" in
+ let* () = rem ~field:"content-length" in
return true
| `DEFLATE -> return false
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 none = return false in
+ let* _ = Option.fold ~none ~some:(fun alg -> compression alg req) alg in
+ 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 field = "content-length" in
+ let* () = add ~field (string_of_int (String.length str)) in
+ let none = return false in
+ let* _ = Option.fold ~none ~some:(fun alg -> compression alg req) alg in
+ String str
let response ?headers:(hdrs = []) status req0 =
match Vif_request0.reqd req0 with
@@ -130,7 +118,6 @@ let response ?headers:(hdrs = []) status req0 =
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)
diff --git a/lib/vif/vif_t.ml b/lib/vif/vif_t.ml
new file mode 100644
index 0000000..f943a96
--- /dev/null
+++ b/lib/vif/vif_t.ml
@@ -0,0 +1,18 @@
+type null = Null
+type json = Json
+type multipart_form = Multipart_form
+type stream = string Stream.source Multipart_form.elt Stream.source
+
+type ('c, 'a) t =
+ | Null : (null, unit) t
+ | Json_encoding : 'a Json_encoding.encoding -> (json, 'a) t
+ | Multipart_form_encoding : 'a Vif_multipart_form.t -> (multipart_form, 'a) t
+ | Multipart_form : (multipart_form, stream) t
+ | Json : (json, Json.t) t
+ | Any : ('c, string) t
+
+let null = Null
+let json_encoding e = Json_encoding e
+let m e = Multipart_form_encoding e
+let json = Json
+let any = Any