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

Add multipart-form-data support

Browse source
This commit is contained in:
Calascibetta Romain 2025-02-19 15:06:18 +01:00
parent 189934db7a
commit 67ce65ea39
20 changed files with 558 additions and 216 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
README.md
View file

@ -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 **disclaimer**: Please note that this is an experimental project. It's also an
opportunity to build something that can be satisfying for web development. opportunity to build something that can be satisfying for web development.

5
examples/09-jwt/cookie.txt Normal file
View file

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

42
examples/09-jwt/main.ml
View file

@ -14,11 +14,8 @@ type cfg =
let jwt = Vif.Ms.make ~name:"jwt" @@ fun req target server { secret } -> let jwt = Vif.Ms.make ~name:"jwt" @@ fun req target server { secret } ->
Logs.debug (fun m -> m "Search vif-token cookie"); Logs.debug (fun m -> m "Search vif-token cookie");
match Cookie.get server req ~name:"vif-token" with match Cookie.get server req ~name:"vif-token" with
| Error err -> | Error err -> None
Logs.err (fun m -> m "jwt: %a" Cookie.pp_error err);
None
| Ok token -> | Ok token ->
Logs.debug (fun m -> m "Token found: %S" token);
let ( let* ) = Option.bind in let ( let* ) = Option.bind in
let* token = Result.to_option (Jwto.decode_and_verify secret token) in let* token = Result.to_option (Jwto.decode_and_verify secret token) in
let* username = List.assoc_opt "username" (Jwto.get_payload token) in let* username = List.assoc_opt "username" (Jwto.get_payload token) in
@ -42,14 +39,22 @@ let credential =
conv prj inj 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 = let users =
[ "dinosaure", "foo" ] [ "dinosaure", "foo" ]
;; ;;
let login req server { secret }= let login req server { secret } { username; password } =
match Vif.Request.of_json req with match List.assoc_opt username users with
| Ok { username; password } ->
begin match List.assoc_opt username users with
| Some p' when password = p' -> | Some p' when password = p' ->
let token = Jwto.encode HS512 secret [ "username", username ] in let token = Jwto.encode HS512 secret [ "username", username ] in
let token = Result.get_ok token in let token = Result.get_ok token in
@ -62,7 +67,11 @@ let login req server { secret }=
let field = "content-type" in let field = "content-type" in
let* () = Response.add ~field "text/plain; charset= utf-8" in let* () = Response.add ~field "text/plain; charset= utf-8" in
let* () = Response.with_string req "Bad credentials\n" in let* () = Response.with_string req "Bad credentials\n" in
Response.respond `Unauthorized end Response.respond `Unauthorized
let login_by_json req server cfg =
match Vif.Request.of_json req with
| Ok credential -> login req server cfg credential
| Error _ -> | Error _ ->
let field = "content-type" in let field = "content-type" in
let* () = Response.add ~field "text/plain; charset=utf-8" in let* () = Response.add ~field "text/plain; charset=utf-8" in
@ -70,6 +79,16 @@ let login req server { secret }=
Response.respond (`Code 422) 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 = let default req server _cfg =
match Request.get jwt req with match Request.get jwt req with
| None -> | None ->
@ -88,8 +107,9 @@ let default req server _cfg =
let routes = let routes =
let open Vif.U in let open Vif.U in
let open Vif.R in let open Vif.R in
let open Vif.Content_type in let open Vif.T in
[ post (json_encoding credential) (rel / "login" /?? nil) --> login [ post (m form) (rel / "login" /?? nil) --> login_by_form
; post (json_encoding credential) (rel / "login" /?? nil) --> login_by_json
; get (rel /?? nil) --> default ] ; get (rel /?? nil) --> default ]
;; ;;

9
examples/12-static/index.html
View file

@ -1 +1,8 @@
<h1>Hello from Vif!</h1> <html>
<head>
<title>Vif</title>
</head>
<body>
<h3>Hello from Vif!</h3>
</body>
</html>

15
examples/12-static/main.ml
View file

@ -2,6 +2,17 @@
open Vif ;; open Vif ;;
let () = Miou_unix.run @@ fun () -> let default req server _ =
Vif.run ~handlers:[ Handler.static ] [] () 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 ()
;; ;;

0
lib/bin.ml Normal file
View file

1
lib/vif/dune
View file

@ -15,5 +15,6 @@
decompress.zl decompress.zl
decompress.gz decompress.gz
mirage-crypto-rng-miou-unix mirage-crypto-rng-miou-unix
multipart_form-miou
httpcats httpcats
tyre)) tyre))

11
lib/vif/stream.ml
View file

@ -178,6 +178,17 @@ module Sink = struct
let stop = Buffer.contents in let stop = Buffer.contents in
Sink { init; push; full; stop } 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 json () =
let decoder = Jsonm.decoder `Manual in let decoder = Jsonm.decoder `Manual in
let rec error (`Error err) = let rec error (`Error err) =

1
lib/vif/stream.mli
View file

@ -31,6 +31,7 @@ type ('a, 'r) sink =
module Sink : sig module Sink : sig
val json : unit -> (string, (Json.t, [ `Msg of string ]) result) sink 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 val string : (string, string) sink
end end

253
lib/vif/vif.ml
View file

@ -6,7 +6,7 @@ module U = Vif_u
module R = struct module R = struct
include Vif_r include Vif_r
open Vif_content_type open Vif_t
type ('fu, 'return) t = type ('fu, 'return) t =
| Handler : ('f, 'x) Vif_r.req * ('x, 'r) Vif_u.t -> ('f, 'r) t | Handler : ('f, 'x) Vif_r.req * ('x, 'r) Vif_u.t -> ('f, 'r) t
@ -70,13 +70,51 @@ module Ms = struct
end end
end end
module Content_type = Vif_content_type module T = Vif_t
module Stream = Stream module Stream = Stream
module Method = Vif_method module Method = Vif_method
module Status = Vif_status module Status = Vif_status
module Headers = Vif_headers 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 Cookie = Vif_cookie
module Handler = Vif_handler module Handler = Vif_handler
@ -90,6 +128,11 @@ let return = Response.return
let is_application_json { Multipart_form.Content_type.ty; subty; _ } = let is_application_json { Multipart_form.Content_type.ty; subty; _ } =
match (ty, subty) with `Application, `Iana_token "json" -> true | _ -> false 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 content_type req0 =
let headers = Vif_request0.headers req0 in let headers = Vif_request0.headers req0 in
let c = Vif_headers.get headers "content-type" 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 let c = Option.to_result ~none:`Not_found c in
Result.bind c Multipart_form.Content_type.of_string Result.bind c Multipart_form.Content_type.of_string
[@@@warning "-8"]
let recognize_request ~env req0 = let recognize_request ~env req0 =
let extract : type c a. let extract : type c a.
Vif_method.t option Vif_method.t option -> (c, a) Vif_t.t -> (c, a) Vif_request.t option =
-> (c, a) Vif_content_type.t
-> (c, a) Vif_request.t option =
fun meth c -> fun meth c ->
let meth' = Vif_request0.meth req0 in let none = true in
match (meth, meth', c) with let some = ( = ) (Vif_request0.meth req0) in
| None, _, (Vif_content_type.Any as encoding) -> let meth_match = Option.fold ~none ~some meth in
Some (Vif_request.of_req0 ~encoding ~env req0) Log.debug (fun m -> m "method matches? %b" meth_match);
| Some a, b, (Vif_content_type.Any as encoding) -> match c with
if a = b then Some (Vif_request.of_req0 ~encoding ~env req0) else None | Vif_t.Any as encoding ->
| None, _, (Null as encoding) -> if meth_match then Some (Vif_request.of_req0 ~encoding ~env req0)
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)
else None 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 c = content_type req0 in
let application_json = Result.map is_application_json c in let type_match = Result.map is_application_json c in
let application_json = Result.value ~default:false application_json in let type_match = Result.value ~default:false type_match in
if application_json && a = b then if type_match && meth_match then
Some (Vif_request.of_req0 ~encoding ~env req0) Some (Vif_request.of_req0 ~encoding ~env req0)
else None else None
| None, _, (Json as encoding) -> | Multipart_form_encoding _ as encoding ->
let c = content_type req0 in let c = content_type req0 in
let application_json = Result.map is_application_json c in let type_match = Result.map is_multipart_form_data c in
let application_json = Result.value ~default:false application_json in let type_match = Result.value ~default:false type_match in
if application_json then Some (Vif_request.of_req0 ~encoding ~env req0) if type_match && meth_match then
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
Some (Vif_request.of_req0 ~encoding ~env req0) Some (Vif_request.of_req0 ~encoding ~env req0)
else None 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 in
{ Vif_r.extract } { 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 = { type 'value daemon = {
queue: 'value user's_function Queue.t queue: 'value user's_function Queue.t
; mutex: Miou.Mutex.t ; mutex: Miou.Mutex.t
@ -192,7 +307,7 @@ let rec user's_functions daemon =
in in
let fn (User's_task (req0, fn)) = let fn (User's_task (req0, fn)) =
let _prm = let _prm =
Miou.call ~orphans:daemon.orphans @@ fun () -> Miou.async ~orphans:daemon.orphans @@ fun () ->
match match
Vif_response.(run req0 empty) (fn daemon.server daemon.user's_value) Vif_response.(run req0 empty) (fn daemon.server daemon.user's_value)
with with
@ -212,6 +327,11 @@ let handler _cfg ~default ~middlewares routes daemon =
let request = recognize_request ~env req0 in let request = recognize_request ~env req0 in
let target = Vif_request0.target req0 in let target = Vif_request0.target req0 in
let fn = R.dispatch ~default routes ~request ~target 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 begin
Miou.Mutex.protect daemon.mutex @@ fun () -> Miou.Mutex.protect daemon.mutex @@ fun () ->
Queue.push (User's_task (req0, fn)) daemon.queue; 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 () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore
let config = Vif_config.config let config = Vif_config.config
let handle stop cfg fn = let process stop cfg server user's_value fn =
Logs.debug (fun m -> Logs.debug (fun m ->
m "new HTTP server on [%d]" (Stdlib.Domain.self () :> int)); 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 match (cfg.Vif_config.http, cfg.Vif_config.tls) with
| config, Some tls -> | config, Some tls ->
Httpcats.Server.with_tls ?stop ?config ~backlog:cfg.backlog tls Httpcats.Server.with_tls ~parallel ?stop ?config ~backlog:cfg.backlog tls
~handler:fn cfg.sockaddr ~handler:fn cfg.sockaddr;
Miou.cancel user's_tasks
| Some (`H2 _), None -> | Some (`H2 _), None ->
Miou.cancel user's_tasks;
failwith "Impossible to launch an h2 server without TLS." failwith "Impossible to launch an h2 server without TLS."
| Some (`Both (config, _) | `HTTP_1_1 config), None -> | 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 -> | None, None ->
Log.debug (fun m -> m "Start a non-tweaked HTTP/1.1 server"); 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 let store_pid = function
| None -> () | 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 let finally () = Mirage_crypto_rng_miou_unix.kill rng in
Fun.protect ~finally @@ fun () -> Fun.protect ~finally @@ fun () ->
let interactive = !Sys.interactive in let interactive = !Sys.interactive in
let domains = Miou.Domain.available () in let domains = cfg.domains in
store_pid cfg.pid; store_pid cfg.pid;
let stop = let stop =
match interactive with 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 let devices = Ds.run Vif_d.Hmap.empty devices user's_value in
Logs.debug (fun m -> m "devices launched"); Logs.debug (fun m -> m "devices launched");
let server = { Vif_s.devices; cookie_key= cfg.Vif_config.cookie_key } in 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 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 in
let fn0 = handler cfg ~default ~middlewares routes daemon in let prm0 = Miou.async @@ fun () -> process stop cfg server user's_value fn0 in
let prm0 = Miou.async @@ fun () -> handle stop cfg fn0 in
let tasks = let tasks =
let fn _ = handler cfg ~default ~middlewares routes daemon in let fn _ = handler cfg ~default ~middlewares routes in
List.init domains fn List.init domains fn
in in
let tasks = 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 in
Miou.await_exn prm0; Miou.await_exn prm0;
List.iter (function Ok () -> () | Error exn -> raise exn) tasks; List.iter (function Ok () -> () | Error exn -> raise exn) tasks;
Ds.finally (Vif_d.Devices devices); Ds.finally (Vif_d.Devices devices);
Miou.cancel user's_tasks;
Log.debug (fun m -> m "Vif (and devices) terminated") Log.debug (fun m -> m "Vif (and devices) terminated")
let setup_config = Vif_options.setup_config let setup_config = Vif_options.setup_config

89
lib/vif/vif.mli
View file

@ -51,14 +51,33 @@ module Method : sig
| `Other of string ] | `Other of string ]
end 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 null
type json type json
type multipart_form
type ('c, 'a) t type ('c, 'a) t
val null : (null, unit) t val null : (null, unit) t
val json : (json, Json.t) t val json : (json, Json.t) t
val json_encoding : 'a Json_encoding.encoding -> (json, 'a) 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 val any : ('c, string) t
end end
@ -73,7 +92,12 @@ module Request : sig
val meth : ('c, 'a) t -> Method.t val meth : ('c, 'a) t -> Method.t
val version : ('c, 'a) t -> int val version : ('c, 'a) t -> int
val headers : ('c, 'a) t -> Headers.t 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 stream : ('c, 'a) t -> string Stream.stream
val get : ('cfg, 'v) M.t -> ('c, 'a) t -> 'v option val get : ('cfg, 'v) M.t -> ('c, 'a) t -> 'v option
@ -87,21 +111,10 @@ end
module R : sig module R : sig
type 'r route type 'r route
type ('fu, 'return) t 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 ( --> ) : ('f, 'r) t -> 'f -> 'r route
val dispatch :
default:(('c, string) Request.t -> string -> 'r)
-> 'r route list
-> request:request
-> target:string
-> 'r
end end
module C : sig module C : sig
@ -137,11 +150,11 @@ module C : sig
let readme = let readme =
let open U in let open U in
host "raw.githubusercontent.com" host "raw.githubusercontent.com"
/% Tyre.string /% string
/% Tyre.string /% string
/ "refs" / "refs"
/ "heads" / "heads"
/% Tyre.string /% string
/ "README.md" / "README.md"
/?? nil /?? nil
@ -151,6 +164,19 @@ module C : sig
end end
module D : sig 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) arg
type ('value, 'a) device type ('value, 'a) device
@ -245,6 +271,14 @@ module Status : sig
end end
module Response : sig 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 ('p, 'q, 'a) t
type e type e
type f type f
@ -259,6 +293,13 @@ module Response : sig
val with_string : val with_string :
?compression:[< `DEFLATE ] -> ('c, 'a) Request.t -> string -> (e, f, unit) t ?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 val respond : Status.t -> (f, s, unit) t
(** Headers manipulation. *) (** Headers manipulation. *)
@ -283,17 +324,16 @@ module Cookie : sig
-> unit -> unit
-> config -> config
type error = [ `Invalid_encrypted_cookie | `Msg of string | `Not_found ]
val get : val get :
?encrypted:bool ?encrypted:bool
-> name:string -> name:string
-> S.t -> S.t
-> Request.request -> Request.request
-> ( string -> (string, [> error ]) result
, [> `Invalid_encrypted_cookie | `Msg of string | `Not_found ] )
result
val pp_error : val pp_error : error Fmt.t
[ `Invalid_encrypted_cookie | `Msg of string | `Not_found ] Fmt.t
val set : val set :
?encrypt:bool ?encrypt:bool
@ -330,7 +370,8 @@ val ( let* ) :
val return : 'a -> ('p, 'p, 'a) Response.t val return : 'a -> ('p, 'p, 'a) Response.t
val config : val config :
?cookie_key:Mirage_crypto.AES.GCM.key ?domains:int
-> ?cookie_key:Mirage_crypto.AES.GCM.key
-> ?pid:Fpath.t -> ?pid:Fpath.t
-> ?http: -> ?http:
[ `H1 of H1.Config.t [ `H1 of H1.Config.t

9
lib/vif/vif_config.ml
View file

@ -9,6 +9,7 @@ type config = {
; sockaddr: Unix.sockaddr ; sockaddr: Unix.sockaddr
; pid: Fpath.t option ; pid: Fpath.t option
; cookie_key: Mirage_crypto.AES.GCM.key ; cookie_key: Mirage_crypto.AES.GCM.key
; domains: int
} }
let really_bad_secret = let really_bad_secret =
@ -17,8 +18,10 @@ let really_bad_secret =
let hash = SHA256.to_raw_string hash in let hash = SHA256.to_raw_string hash in
Mirage_crypto.AES.GCM.of_secret hash Mirage_crypto.AES.GCM.of_secret hash
let config ?(cookie_key = really_bad_secret) ?pid ?http ?tls ?(backlog = 64) let default_domains = Int.min (Stdlib.Domain.recommended_domain_count ()) 4
sockaddr =
let config ?(domains = default_domains) ?(cookie_key = really_bad_secret) ?pid
?http ?tls ?(backlog = 64) sockaddr =
let http = let http =
match http with match http with
| Some (`H1 cfg) -> Some (`HTTP_1_1 cfg) | 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)) | Some (`Both (h1, h2)) -> Some (`Both (h1, h2))
| None -> None | None -> None
in in
{ http; tls; backlog; sockaddr; pid; cookie_key } { http; tls; backlog; sockaddr; pid; cookie_key; domains }

55
lib/vif/vif_content_type.ml
View file

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

2
lib/vif/vif_cookie.ml
View file

@ -32,6 +32,8 @@ let all_cookies hdrs =
let guard error fn = if fn () then Ok () else Error error let guard error fn = if fn () then Ok () else Error error
let err_cookie = `Invalid_encrypted_cookie let err_cookie = `Invalid_encrypted_cookie
type error = [ `Invalid_encrypted_cookie | `Msg of string | `Not_found ]
let pp_error ppf = function let pp_error ppf = function
| `Invalid_encrypted_cookie -> Fmt.string ppf "Invalid encrypted cookie" | `Invalid_encrypted_cookie -> Fmt.string ppf "Invalid encrypted cookie"
| `Not_found -> Fmt.string ppf "Cookie not found" | `Not_found -> Fmt.string ppf "Cookie not found"

143
lib/vif/vif_multipart_form.ml Normal file
View file

@ -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 "<unknown-part>"
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

23
lib/vif/vif_options.ml
View file

@ -3,16 +3,18 @@ let port = ref 8080
let inet_addr = ref Unix.inet_addr_loopback let inet_addr = ref Unix.inet_addr_loopback
let backlog = ref 64 let backlog = ref 64
let pid = ref None 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'; port := port';
inet_addr := inet_addr'; inet_addr := inet_addr';
backlog := backlog'; backlog := backlog';
pid := pid' pid := pid';
domains := domains'
let config_from_globals () = let config_from_globals () =
let sockaddr = Unix.(ADDR_INET (!inet_addr, !port)) in 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 open Cmdliner
@ -34,13 +36,17 @@ let inet_addr =
& opt inet_addr Unix.inet_addr_loopback & opt inet_addr Unix.inet_addr_loopback
& info [ "i"; "inet-addr" ] ~doc ~docv:"INET_ADDR" & 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 pid =
let doc = "Specify a file to record its process-id in." in let doc = "Specify a file to record its process-id in." in
let non_existing_file = let non_existing_file =
let parser str = let parser str =
match Fpath.of_string str with match Fpath.of_string str with
| Ok _ as v when Sys.file_exists str = false -> v | Ok _ as v when is_not_directory str -> v
| Ok v -> error_msgf "%a already exists" Fpath.pp v | Ok v -> error_msgf "%a already exists as a directory" Fpath.pp v
| Error _ as err -> err | Error _ as err -> err
in in
Arg.conv (parser, Fpath.pp) Arg.conv (parser, Fpath.pp)
@ -50,6 +56,11 @@ let pid =
& opt (some non_existing_file) None & opt (some non_existing_file) None
& info [ "pid-file" ] ~doc ~docv:"PATH" & 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 backlog =
let doc = let doc =
"The limit of outstanding connections in the socket's listen queue." "The limit of outstanding connections in the socket's listen queue."
@ -59,4 +70,4 @@ let backlog =
let setup_config = let setup_config =
let open Term in let open Term in
const setup_config $ port $ inet_addr $ backlog $ pid const setup_config $ domains $ port $ inet_addr $ backlog $ pid

24
lib/vif/vif_r.ml
View file

@ -208,7 +208,7 @@ let extract t =
type ('fu, 'return) req = type ('fu, 'return) req =
| Request : | 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 -> (('c, 'a) Vif_request.t -> 'r, 'r) req
type 'r route = Route : ('f, 'x) req * ('x, 'r) Vif_u.t * 'f -> 'r route 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 = { type request = {
extract: extract:
'c 'a. 'c 'a.
Vif_method.t option Vif_method.t option -> ('c, 'a) Vif_t.t -> ('c, 'a) Vif_request.t option
-> ('c, 'a) Vif_content_type.t
-> ('c, 'a) Vif_request.t option
} }
let rec find_and_trigger : type r. let rec find_and_trigger : type r.
original:string -> request:request -> Re.Group.t -> r re list -> r = original:string
fun ~original ~request subs -> function -> uid:int
-> request:request
-> Re.Group.t
-> r re list
-> r =
fun ~original ~uid ~request subs -> function
| [] -> raise Not_found | [] -> raise Not_found
| Re (Request (meth, c), f, id, ret) :: l -> | 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 if Re.Mark.test subs id then
match request.extract meth c with match request.extract meth c with
| Some request -> extract ~original ret subs (f request) | Some request -> extract ~original ret subs (f request)
| None -> find_and_trigger ~original ~request subs l | None -> find_and_trigger ~original ~uid:(succ uid) ~request subs l
else find_and_trigger ~original ~request subs l else find_and_trigger ~original ~uid:(succ uid) ~request subs l
let dispatch : type r c. let dispatch : type r c.
default:((c, string) Vif_request.t -> string -> r) 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 let[@warning "-8"] (Some request) = request.extract None Any in
default request target default request target
| Some subs -> begin | 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 -> with Not_found as exn ->
Log.debug (fun m -> Log.debug (fun m ->
m "Fallback to the default route (exn: %s)" m "Fallback to the default route (exn: %s)"

11
lib/vif/vif_request.ml
View file

@ -4,16 +4,13 @@ module Log = (val Logs.src_log src : Logs.LOG)
type ('c, 'a) t = { type ('c, 'a) 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 ; encoding: ('c, 'a) Vif_t.t
; env: Vif_m.Hmap.t ; env: Vif_m.Hmap.t
; request: Vif_request0.t ; request: Vif_request0.t
} }
let of_req0 : type c a. let of_req0 : type c a.
encoding:(c, a) Vif_content_type.t encoding:(c, a) Vif_t.t -> env:Vif_m.Hmap.t -> Vif_request0.t -> (c, a) t =
-> env:Vif_m.Hmap.t
-> Vif_request0.t
-> (c, a) t =
fun ~encoding ~env request -> fun ~encoding ~env request ->
let body = Vif_request0.request_body request in let body = Vif_request0.request_body request in
{ request; body; encoding; env } { 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 error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
let of_json : type a. let of_json : type a. (Vif_t.json, a) t -> (a, [> `Msg of string ]) result =
(Vif_content_type.json, a) t -> (a, [> `Msg of string ]) result = function function
| { encoding= Any; _ } as req -> Ok (to_string req) | { encoding= Any; _ } as req -> Ok (to_string req)
| { encoding= Json; _ } as req -> | { encoding= Json; _ } as req ->
let stream = stream req in let stream = stream req in

25
lib/vif/vif_response.ml
View file

@ -72,35 +72,23 @@ let compression alg req =
match alg with match alg with
| `DEFLATE when can_compress "deflate" req -> | `DEFLATE when can_compress "deflate" req ->
let* () = set ~field:"content-encoding" "deflate" in let* () = set ~field:"content-encoding" "deflate" in
let* () = rem ~field:"content-length" in
return true return true
| `DEFLATE -> return false | `DEFLATE -> return false
let with_stream ?compression:alg req stream = let with_stream ?compression:alg req stream =
match alg with let none = return false in
| Some alg -> let* _ = Option.fold ~none ~some:(fun alg -> compression alg req) alg in
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 field = "transfer-encoding" in
let v = "chunked" in let v = "chunked" in
let* _ = add_unless_exists ~field v in let* _ = add_unless_exists ~field v in
Stream stream Stream stream
let with_string ?compression:alg req str = let with_string ?compression:alg req str =
match alg with
| Some alg ->
let* _ = compression alg req in
let field = "content-length" in let field = "content-length" in
let v = string_of_int (String.length str) in let* () = add ~field (string_of_int (String.length str)) in
let* _ = add_unless_exists ~field v in let none = return false in
String str let* _ = Option.fold ~none ~some:(fun alg -> compression alg req) alg in
| None ->
let field = "content-length" in
let v = string_of_int (String.length str) in
let* _ = add_unless_exists ~field v in
String str String str
let response ?headers:(hdrs = []) status req0 = let response ?headers:(hdrs = []) status req0 =
@ -130,7 +118,6 @@ let response ?headers:(hdrs = []) status req0 =
body body
in in
let full _ = false in let full _ = false in
(* TODO(dinosaure): content-length? *)
let stop = H2.Body.Writer.close in let stop = H2.Body.Writer.close in
(Sink { init; push; full; stop } : (string, unit) Stream.sink) (Sink { init; push; full; stop } : (string, unit) Stream.sink)

18
lib/vif/vif_t.ml Normal file
View file

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