diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore new file mode 100644 index 0000000..d357328 --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1 @@ +examples/**/* diff --git a/TODO.md b/TODO.md index d2697c4..dbaf6dc 100644 --- a/TODO.md +++ b/TODO.md @@ -1,6 +1,24 @@ - [x] be able to load *.cmx{,a} when we use "#require" `findlib`/`topfind` only loads directories, `ocamlnat` wants to load files. Let's use our work about `uniq` to solve dependencies and load artifacts + + [ ] lint the way we load dependencies + + [ ] compare to what `omod` can do (may be a better approach) - [x] do some tests with Miou and see if we can execute small applications -- [ ] start to eval a file (and show the result?) -- [ ] start to make a nice intf for a HTTP server via `httpcats` +- [x] start to eval a file (and show the result?) + + [ ] do we need to show the result? +- [x] start to make a nice intf for a HTTP server via `httpcats` + + [x] provide Request + + [x] provide Response + + [x] provide Method + + [x] provide Status +- [ ] dispatch on method and content-type + + [x] recognize application/json + + [ ] recognize multipart/form + * [ ] provide an API to describe, by types, a multipart/form +- [x] be able to extract the body of a request as a JSON value + + [x] cast a JSON value to an OCaml value via Json_encoding (or repr?) + + [ ] lint this function and errors +- [ ] template engine with jingoo or eml? + + [ ] with jingoo, do something "à la printf" and provide a tool which generates + from a string something like `(_, _, _, _) format4` + + [ ] jingoo to GADT? diff --git a/bin/vif.ml b/bin/vif.ml index 66a65ef..cd7c227 100644 --- a/bin/vif.ml +++ b/bin/vif.ml @@ -150,7 +150,12 @@ let setup_logs = Term.(const setup_logs $ utf_8 $ renderer $ verbosity) let term = let open Term in - const run $ setup_logs $ Vif.setup_config $ Vif_meta.setup $ setup_stdlib $ main + const run + $ setup_logs + $ Vif.setup_config + $ Vif_meta.setup + $ setup_stdlib + $ main let cmd = let doc = "vif" in diff --git a/examples/01-hello/main.ml b/examples/01-hello/main.ml index 88bdd8f..b77aa65 100644 --- a/examples/01-hello/main.ml +++ b/examples/01-hello/main.ml @@ -4,7 +4,4 @@ let default req target server () = Vif.Response.with_string server `OK "Hello World!\n" ;; -let () = - Miou_unix.run @@ fun () -> - Vif.run ~default [] () -;; +let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;; diff --git a/examples/02-counter/main.ml b/examples/02-counter/main.ml index 7f954e5..bde8fa6 100644 --- a/examples/02-counter/main.ml +++ b/examples/02-counter/main.ml @@ -8,7 +8,4 @@ let default req target server () = Vif.Response.with_string server `OK (Fmt.str "%d request(s)\n" (succ v)) ;; -let () = - Miou_unix.run @@ fun () -> - Vif.run ~default [] () -;; +let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;; diff --git a/examples/03-fail/main.ml b/examples/03-fail/main.ml index a57445e..1635069 100644 --- a/examples/03-fail/main.ml +++ b/examples/03-fail/main.ml @@ -1,15 +1,7 @@ #require "vif" ;; -exception Foo - -let () = Printexc.register_printer @@ function - | Foo -> Some "Foo" - | _ -> None -;; +exception Foo ;; +let () = Printexc.register_printer @@ function Foo -> Some "Foo" | _ -> None ;; let default req target server () = raise Foo ;; - -let () = - Miou_unix.run @@ fun () -> - Vif.run ~default [] () -;; +let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;; diff --git a/examples/04-device/main.ml b/examples/04-device/main.ml index e007ee4..2df8194 100644 --- a/examples/04-device/main.ml +++ b/examples/04-device/main.ml @@ -4,16 +4,14 @@ let rng = let open Mirage_crypto_rng_miou_unix in let finally = kill in - Vif.D.device ~name:"rng" ~finally [] @@ fun () -> - initialize (module Pfortuna) + Vif.D.device ~name:"rng" ~finally [] @@ fun () -> initialize (module Pfortuna) ;; type foo = Foo ;; let foo = let finally Foo = () in - Vif.D.device ~name:"foo" ~finally [] @@ fun () -> - Foo + Vif.D.device ~name:"foo" ~finally [] @@ fun () -> Foo ;; let default req target server () = @@ -23,6 +21,5 @@ let default req target server () = ;; let () = - Miou_unix.run @@ fun () -> - Vif.run ~default ~devices:Vif.Ds.[ rng; foo ] [] () + Miou_unix.run @@ fun () -> Vif.run ~default ~devices:Vif.Ds.[ rng; foo ] [] () ;; diff --git a/examples/05-json/main.ml b/examples/05-json/main.ml index 0ac2029..2bb0125 100644 --- a/examples/05-json/main.ml +++ b/examples/05-json/main.ml @@ -1,10 +1,10 @@ #require "vif" ;; type foo = - { username : string - ; password : string - ; age : int option - ; address : string option } + { username: string + ; password: string + ; age: int option + ; address: string option } ;; let foo = @@ -14,20 +14,29 @@ let foo = let age = opt "age" int in let address = opt "address" string in let foo = obj4 username password age address in - let prj { username; password; age; address } = (username, password, age, address) in - let inj (username, password, age, address) = { username; password; age; address } in + let prj { username; password; age; address } = + (username, password, age, address) + in + let inj (username, password, age, address) = + { username; password; age; address } + in conv prj inj foo ;; let deserialize req server () = match Vif.Request.to_json req with | Ok (foo : foo) -> - let str = Fmt.str "username: %s, password: %s, age: %a, address: %a\n" - foo.username foo.password Fmt.(Dump.option int) foo.age - Fmt.(Dump.option string) foo.address in + let str = + Fmt.str "username: %s, password: %s, age: %a, address: %a\n" + foo.username foo.password + Fmt.(Dump.option int) + foo.age + 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 + | Error (`Msg msg) -> Vif.Response.with_string server (`Code 422) msg +;; let routes = let open Vif.U in @@ -41,7 +50,4 @@ let default req target server () = Vif.Response.with_string server `Not_found str ;; -let () = - Miou_unix.run @@ fun () -> - Vif.run ~default routes () -;; +let () = Miou_unix.run @@ fun () -> Vif.run ~default routes () ;; diff --git a/examples/06-caqti/foo.sqlite b/examples/06-caqti/foo.sqlite new file mode 100644 index 0000000..846d366 Binary files /dev/null and b/examples/06-caqti/foo.sqlite differ diff --git a/examples/06-caqti/main.ml b/examples/06-caqti/main.ml new file mode 100644 index 0000000..8f28c37 --- /dev/null +++ b/examples/06-caqti/main.ml @@ -0,0 +1,64 @@ +#require "caqti-miou" ;; +#require "caqti-miou.unix" ;; +#require "caqti-driver-sqlite3" ;; +#require "vif" ;; + +type cfg = + { sw : Caqti_miou.Switch.t + ; uri : Uri.t } +;; + +let caqti = + let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in + Vif.D.device ~name:"caqti" ~finally [] @@ fun { sw; uri } -> + match Caqti_miou_unix.connect ~sw uri with + | Ok conn -> conn + | Error err -> + Logs.err (fun m -> m "%a" Caqti_error.pp err); + Fmt.failwith "%a" Caqti_error.pp err +;; + +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 + | Ok () -> + Vif.Response.with_string server `OK (Fmt.str "%d Added\n" n) + | Error err -> + let str = Fmt.str "SQL error: %a" Caqti_error.pp err in + Vif.Response.with_string server `Internal_server_error str +;; + +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 + | Ok lst -> + let str = Fmt.str "%a" Fmt.(Dump.list int) lst in + Vif.Response.with_string server `OK str + | Error err -> + let str = Fmt.str "SQL error: %a" Caqti_error.pp err in + Vif.Response.with_string server `Internal_server_error str +;; + +let default req target server _ = + let str = Fmt.str "%s not found\n" target in + Vif.Response.with_string server `Not_found str +;; + +let routes = + let open Vif.U in + let open Vif.R in + let open Vif.Content_type in + [ post any (rel / "add" /% Tyre.int /?? nil) --> add + ; get (rel /?? nil) --> list ] + +let () = + Miou_unix.run @@ fun () -> + Caqti_miou.Switch.run @@ fun sw -> + let uri = Uri.of_string "sqlite3:foo.sqlite?create=false" in + let cfg = { sw; uri } in + Vif.run ~default ~devices:Vif.Ds.[ caqti ] routes cfg +;; diff --git a/lib/meta/objinfo.ml b/lib/meta/objinfo.ml index b1b535c..d68e231 100644 --- a/lib/meta/objinfo.ml +++ b/lib/meta/objinfo.ml @@ -1,4 +1,4 @@ -let src = Logs.Src.create "uniq.info" +let src = Logs.Src.create "vif.top.info" module Log = (val Logs.src_log src : Logs.LOG) diff --git a/lib/meta/vif_meta.ml b/lib/meta/vif_meta.ml index c4c537b..63161a3 100644 --- a/lib/meta/vif_meta.ml +++ b/lib/meta/vif_meta.ml @@ -85,10 +85,28 @@ let compile ~predicates t ks = in List.exists one ps in - let rec go acc t = function + let find_directory contents = + let rec go result = function + | [] -> result + | Add { name= "directory"; predicates= []; value } :: rest -> + if Option.is_none result then go (Some value) rest else go result rest + | Add { name= "directory"; predicates; value } :: rest -> + if incl predicates && Option.is_none result then go (Some value) rest + else go result rest + | Set { name= "directory"; predicates= []; value } :: rest -> + go (Some value) rest + | Set { name= "directory"; predicates; value } :: rest -> + if incl predicates then go (Some value) rest else go result rest + | _ :: rest -> go result rest + in + go None contents + in + let rec go ~directory acc t = function | [] -> let rec go acc = function - | [] -> acc + | [] -> + let acc = List.remove_assoc "directory" acc in + ("directory", [ directory ]) :: acc | Node _ :: rest -> go acc rest | Add { name; predicates= []; value } :: rest -> go (Assoc.add name value acc) rest @@ -102,14 +120,21 @@ let compile ~predicates t ks = else go acc rest in go acc t - | k :: ks -> ( + | k :: ks -> begin match t with | [] -> acc | Node { name= "package"; value; contents } :: rest -> - if k = value then go acc contents ks else go acc rest (k :: ks) - | _ :: rest -> go acc rest (k :: ks)) + let directory' = + match find_directory contents with + | Some v -> Filename.concat directory v + | None -> directory + in + if k = value then go ~directory:directory' acc contents ks + else go ~directory acc rest (k :: ks) + | _ :: rest -> go ~directory acc rest (k :: ks) + end in - go [] t ks + go ~directory:"" [] t ks exception Parser_error of string @@ -328,7 +353,11 @@ let search ~roots ?(predicates = [ "native"; "byte" ]) meta_path = diff meta_path meta_path' >>= fun ks -> parser path >>| fun meta -> compile ~predicates meta ks with - | Ok descr -> Map.add (root / Filename.dirname rel) descr acc + | Ok descr -> + Log.debug (fun m -> m "add %s" (root / Filename.dirname rel)); + Log.debug (fun m -> + m "%a" Fmt.(Dump.list (Dump.pair string (Dump.list string))) descr); + Map.add (root / Filename.dirname rel) descr acc | Error (`Msg msg) -> Log.warn (fun m -> m "Impossible to extract the META file of %s: %s" path msg); diff --git a/lib/top/vif_top.ml b/lib/top/vif_top.ml index 990756b..9f7b8f9 100644 --- a/lib/top/vif_top.ml +++ b/lib/top/vif_top.ml @@ -157,7 +157,8 @@ let load cfg str = let fn artifact = let dir = Filename.dirname artifact in Topdirs.dir_directory dir; - try Topdirs.dir_load null artifact with _ -> () + try Topdirs.dir_load null artifact + with exn -> Log.err (fun m -> m "exn: %s" (Printexc.to_string exn)) in List.iter fn artifacts | Error (`Msg msg) -> Log.err (fun m -> m "Impossible to load %S: %s" str msg) diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml index 83f930e..f7be52c 100644 --- a/lib/vif/vif.ml +++ b/lib/vif/vif.ml @@ -9,11 +9,11 @@ module R = struct open Vif_content_type type ('fu, 'return) t = - | Handler : ('f, 'x) body * ('x, 'r) Vif_u.t -> ('f, 'r) t + | Handler : ('f, 'x) Vif_r.req * ('x, 'r) Vif_u.t -> ('f, 'r) t - let get t = Handler (Body Null, t) - let post body t = Handler (Body body, t) - let route (Handler (body, t)) f = Route (body, t, f) + let get t = Handler (Request (Some `GET, Null), t) + let post c t = Handler (Request (Some `POST, c), t) + let route (Handler (req, t)) f = Route (req, t, f) let ( --> ) = route end @@ -55,72 +55,88 @@ module Response = Vif_response 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 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 server = let extract : type c a. - (c, a) Vif_content_type.t -> (c, a) Vif_request.t option = function - | Vif_content_type.Any as encoding -> + 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 + match (meth, meth', c) with + | None, _, (Vif_content_type.Any as encoding) -> Some (Vif_request.of_reqd ~encoding server.S.reqd) - | Null as encoding -> Some (Vif_request.of_reqd ~encoding server.S.reqd) - | Json_encoding _ as encoding -> - 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 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 - let c = Result.bind c Multipart_form.Content_type.of_string in - begin - match c with - | Ok c when is_application_json c -> - Some (Vif_request.of_reqd ~encoding server.S.reqd) - | _ -> None - end - | Json as encoding -> - 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 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 - let c = Result.bind c Multipart_form.Content_type.of_string in - Log.debug (fun m -> - m "content-type: %a" - Fmt.( - Dump.result ~ok:Multipart_form.Content_type.pp - ~error:(any "#errored")) - c); - begin - match c with - | Ok c when is_application_json c -> - Some (Vif_request.of_reqd ~encoding server.S.reqd) - | _ -> None - end + | Some a, b, (Vif_content_type.Any as encoding) -> + if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd) + else None + | None, _, (Null as encoding) -> + Some (Vif_request.of_reqd ~encoding server.S.reqd) + | Some a, b, (Null as encoding) -> + if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd) + else None + | None, _, (Json_encoding _ as encoding) -> + let c = content_type server 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 server.S.reqd) + else None + | Some a, b, (Json_encoding _ as encoding) -> + let c = content_type server 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 server.S.reqd) + else None + | None, _, (Json as encoding) -> + let c = content_type server 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 server.S.reqd) + else None + | Some a, b, (Json as encoding) -> + let c = content_type server 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 server.S.reqd) + else None in { Vif_r.extract } -let handler ~default 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 request = request server in - Log.debug (fun m -> m "Handle a new request to %s" target); - let fn = R.dispatch ~default routes ~request ~target in - match fn server user's_value with Vif_response.Response -> () +let handler ~default 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 request = request server in + Log.debug (fun m -> m "Handle a new request to %s" target); + let fn = R.dispatch ~default routes ~request ~target in + match fn server user's_value with Vif_response.Response -> () type config = Vif_config.config @@ -132,8 +148,8 @@ let handle stop cfg fn = m "new HTTP server on [%d]" (Stdlib.Domain.self () :> int)); 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 ?stop ?config ~backlog:cfg.backlog tls + ~handler:fn cfg.sockaddr | Some (`H2 _), None -> failwith "Impossible to launch an h2 server without TLS." | Some (`Both (config, _) | `HTTP_1_1 config), None -> @@ -142,7 +158,8 @@ let handle stop cfg fn = Log.debug (fun m -> m "Start a non-tweaked HTTP/1.1 server"); Httpcats.Server.clear ?stop ~handler:fn cfg.sockaddr -let run ?(cfg= Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default routes user's_value = +let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default + routes user's_value = let interactive = !Sys.interactive in let domains = Miou.Domain.available () in let stop = @@ -162,8 +179,12 @@ let run ?(cfg= Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default r Logs.debug (fun m -> m "devices launched"); let fn0 = handler ~default routes devices user's_value in let prm = Miou.async @@ fun () -> handle stop cfg fn0 in - let tasks = List.init domains (fun _ -> handler ~default routes devices user's_value) in - let tasks = if domains > 0 then Miou.parallel (handle stop cfg) tasks else [] in + let tasks = + List.init domains (fun _ -> handler ~default routes devices user's_value) + in + let tasks = + if domains > 0 then Miou.parallel (handle stop cfg) tasks else [] + in Miou.await_exn prm; List.iter (function Ok () -> () | Error exn -> raise exn) tasks; Ds.finally (Vif_d.Devices devices); diff --git a/lib/vif/vif_options.ml b/lib/vif/vif_options.ml index 3952768..c9415a3 100644 --- a/lib/vif/vif_options.ml +++ b/lib/vif/vif_options.ml @@ -1,5 +1,4 @@ let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt - let port = ref 8080 let inet_addr = ref Unix.inet_addr_loopback let backlog = ref 64 @@ -24,14 +23,19 @@ let inet_addr = let doc = "The address to bind the HTTP server." in let parser str = try Ok (Unix.inet_addr_of_string str) - with _ -> error_msgf "Invalid inet-addr: %S" str in + with _ -> error_msgf "Invalid inet-addr: %S" str + in let pp ppf inet_addr = Fmt.string ppf (Unix.string_of_inet_addr inet_addr) in let inet_addr = Arg.conv (parser, pp) in let open Arg in - value & opt inet_addr Unix.inet_addr_loopback & info [ "i"; "inet-addr" ] ~doc ~docv:"INET_ADDR" + value + & opt inet_addr Unix.inet_addr_loopback + & info [ "i"; "inet-addr" ] ~doc ~docv:"INET_ADDR" let backlog = - let doc = "The limit of outstanding connections in the socket's listen queue." in + let doc = + "The limit of outstanding connections in the socket's listen queue." + in let open Arg in value & opt int 64 & info [ "backlog" ] ~doc ~docv:"NUMBER" diff --git a/lib/vif/vif_r.ml b/lib/vif/vif_r.ml index c715269..8c4a775 100644 --- a/lib/vif/vif_r.ml +++ b/lib/vif/vif_r.ml @@ -206,36 +206,40 @@ let extract t = extract ~original:target url subs f *) -type ('fu, 'return) body = - | Body : - ('c, 'a) Vif_content_type.t - -> (('c, 'a) Vif_request.t -> 'r, 'r) body +type ('fu, 'return) req = + | Request : + Vif_method.t option * ('c, 'a) Vif_content_type.t + -> (('c, 'a) Vif_request.t -> 'r, 'r) req -type 'r route = Route : ('f, 'x) body * ('x, 'r) Vif_u.t * 'f -> 'r route +type 'r route = Route : ('f, 'x) req * ('x, 'r) Vif_u.t * 'f -> 'r route -let route body t f = Route (body, t, f) +let route req t f = Route (req, t, f) -type 'r re = Re : ('f, 'x) body * 'f * Re.Mark.t * ('x, 'r) t -> 'r re +type 'r re = Re : ('f, 'x) req * 'f * Re.Mark.t * ('x, 'r) t -> 'r re let rec build_info_list idx = function | [] -> ([], []) - | Route (b, t, f) :: l -> + | Route (req, t, f) :: l -> let idx, ret, re = url idx t in let rel, wl = build_info_list idx l in let id, re = Re.mark re in - (re :: rel, Re (b, f, id, ret) :: wl) + (re :: rel, Re (req, f, id, ret) :: wl) type request = { - extract: 'c 'a. ('c, 'a) Vif_content_type.t -> ('c, 'a) Vif_request.t option + extract: + 'c 'a. + Vif_method.t option + -> ('c, 'a) Vif_content_type.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 | [] -> raise Not_found - | Re (Body body, f, id, ret) :: l -> + | Re (Request (meth, c), f, id, ret) :: l -> if Re.Mark.test subs id then - match request.extract body with + 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 @@ -253,7 +257,7 @@ let dispatch : type r c. match Re.exec_opt re target with | None -> Log.debug (fun m -> m "Fallback to the default route"); - let[@warning "-8"] (Some request) = request.extract Any in + 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 @@ -261,6 +265,6 @@ let dispatch : type r c. Log.debug (fun m -> m "Fallback to the default route (exn: %s)" (Printexc.to_string exn)); - let[@warning "-8"] (Some request) = request.extract Any in + let[@warning "-8"] (Some request) = request.extract None Any in default request target end diff --git a/lib/vif/vif_response.ml b/lib/vif/vif_response.ml index 3a71ca8..33a4c50 100644 --- a/lib/vif/vif_response.ml +++ b/lib/vif/vif_response.ml @@ -25,8 +25,8 @@ let with_string server ?headers:(hdrs = []) status str = match status with | #H1.Status.t as status -> status | status -> - Log.err (fun m -> m "Invalid status: %a" H2.Status.pp_hum status); - invalid_arg "Response.with_string: invalid status" + Log.err (fun m -> m "Invalid status: %a" H2.Status.pp_hum status); + invalid_arg "Response.with_string: invalid status" in let resp = H1.Response.create ~headers:hdrs status in H1.Reqd.respond_with_string reqd resp str;