Be able to parse JSON

bin/vif.ml

@@ -28,9 +28,7 @@ let run _quiet roots stdlib main =
     in
     go []
   in
-  match Vif_top.eval cfg main with
+  match Vif_top.eval cfg main with Ok () -> () | Error () -> exit 1
-  | Ok sstr -> List.iter print_endline sstr
-  | Error sstr -> List.iter prerr_endline sstr
 
 open Cmdliner
 

lib/top/vif_top.ml

@@ -217,7 +217,7 @@ let eval _cfg ppf ph =
         false
     end
 
-let redirect : fn:(capture:(Buffer.t -> unit) -> 'a) -> 'a =
+let _redirect : fn:(capture:(Buffer.t -> unit) -> 'a) -> 'a =
  fun ~fn ->
   let filename = Filename.temp_file "vif-" ".stdout" in
   Log.debug (fun m -> m "redirect stdout/stderr into %s" filename);
@@ -273,7 +273,7 @@ let trim str =
 
 let rec ltrim = function "" :: r -> ltrim r | lst -> lst
 let rtrim lst = List.rev (ltrim (List.rev lst))
-let trim lst = ltrim (rtrim (List.map trim lst))
+let _trim lst = ltrim (rtrim (List.map trim lst))
 
 let rec ends_by_semi_semi = function
   | [] -> false
@@ -293,23 +293,13 @@ let cut_into_phrases lst =
   go [] [] lst
 
 let eval cfg cmd =
-  let buf = Buffer.create 0x7ff in
   let ppf = Format.formatter_of_out_channel stderr in
   errors := false;
-  let eval ~capture phrase =
+  let eval phrase =
-    let lines = ref [] in
-    let capture () =
-      capture buf;
-      match Buffer.contents buf with
-      | "" -> ()
-      | str ->
-          Buffer.clear buf;
-          lines := str :: !lines
-    in
     let out_phrase = !Oprint.out_phrase in
     let fn_out_phrase ppf = function
       | Outcometree.Ophr_exception _ as phr -> out_phrase ppf phr
-      | phr -> capture (); out_phrase ppf phr; capture ()
+      | phr -> out_phrase ppf phr
     in
     Oprint.out_phrase := fn_out_phrase;
     let restore () = Oprint.out_phrase := out_phrase in
@@ -323,25 +313,15 @@ let eval cfg cmd =
           restore ();
           Location.report_exception ppf exn
     end;
-    Format.pp_print_flush ppf ();
+    Format.pp_print_flush ppf ()
-    capture ();
-    trim (List.rev !lines)
   in
-  let fn ~capture =
   capture_compiler_stuff ppf @@ fun () ->
   let cmd =
     match cmd with [] | [ _ ] -> cmd | x :: r -> x :: List.map (( ^ ) " ") r
   in
   let phrases = cut_into_phrases cmd in
-    let phrases =
+  List.iter
-      List.map
     (fun phrase ->
-          match Phrase.parse phrase with
+      match Phrase.parse phrase with Some t -> eval t | None -> ())
-          | Some t -> eval ~capture t
+    phrases;
-          | None -> [])
+  if !errors then Error () else Ok ()
-        phrases
-    in
-    let phrases = List.concat phrases in
-    if !errors then Error phrases else Ok phrases
-  in
-  redirect ~fn

lib/top/vif_top.mli

@@ -1,4 +1,4 @@
 type cfg
 
 val config : stdlib:Fpath.t -> string list -> cfg
-val eval : cfg -> string list -> (string list, string list) result
+val eval : cfg -> string list -> (unit, unit) result

lib/vif/dune

@@ -3,4 +3,11 @@
  (public_name vif)
  (flags
   (:standard -linkall))
- (libraries hmap mirage-crypto-rng-miou-unix httpcats tyre))
+ (libraries
+  json-data-encoding
+  multipart_form
+  jsonm
+  hmap
+  mirage-crypto-rng-miou-unix
+  httpcats
+  tyre))

lib/vif/json.ml

@@ -0,0 +1,112 @@
+type value = [ `Null | `Bool of bool | `String of string | `Float of float ]
+type t = [ value | `A of t list | `O of (string * t) list ]
+type 'a or_error = ('a, [ `Msg of string ]) result
+type await = [ `Await ]
+type error = [ `Error of Jsonm.error ]
+type eoi = [ `End ]
+
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+let _max_young_size = Sys.word_size / 8 * 256
+
+let rec pp ppf = function
+  | `Null -> Fmt.const Fmt.string "()" ppf ()
+  | `Bool v -> Fmt.bool ppf v
+  | `Float v -> Fmt.float ppf v
+  | `Name v -> Fmt.string ppf v
+  | `String v -> Fmt.string ppf v
+  | `O lst -> Fmt.Dump.list (Fmt.Dump.pair Fmt.string pp) ppf lst
+  | `A lst -> Fmt.Dump.list pp ppf lst
+
+let decode ~input k =
+  let decoder = Jsonm.decoder `Manual in
+  let rec await k `Await =
+    match input () with
+    | Some str ->
+        let buf = Bytes.unsafe_of_string str in
+        Jsonm.Manual.src decoder buf 0 (Bytes.length buf);
+        k ()
+    | None ->
+        Jsonm.Manual.src decoder Bytes.empty 0 0;
+        k ()
+  and error (`Error err) =
+    error_msgf "Invalid JSON input: %a" Jsonm.pp_error err
+  and end_of_input `End = error_msgf "Unexpected end of input"
+  and arr acc k =
+    match Jsonm.decode decoder with
+    | #await as v -> await (fun () -> arr acc k) v
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme `Ae -> k (`A (List.rev acc))
+    | `Lexeme v -> core (fun v -> arr (v :: acc) k) v
+  and name n k =
+    match Jsonm.decode decoder with
+    | #await as v -> await (fun () -> name n k) v
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme v -> core (fun v -> k (n, v)) v
+  and obj acc k =
+    match Jsonm.decode decoder with
+    | #await as v -> await (fun () -> obj acc k) v
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme `Oe -> k (`O (List.rev acc))
+    | `Lexeme (`Name n) -> name n (fun v -> obj (v :: acc) k)
+    | `Lexeme v ->
+        error_msgf "Unexpected lexeme: %a (expected key)" Jsonm.pp_lexeme v
+  and core k = function
+    | #value as v -> k v
+    | `Os -> obj [] k
+    | `As -> arr [] k
+    | `Ae | `Oe -> error_msgf "Retrieve invalid end of JSON array/object"
+    | `Name _ -> error_msgf "Retrieve invalid JSON key value"
+  and top () =
+    match Jsonm.decode decoder with
+    | #await as v -> await top v
+    | #error as v -> error v
+    | #eoi -> k `Null
+    | `Lexeme (#Jsonm.lexeme as lexeme) -> core k lexeme
+  in
+  top ()
+
+module Stack = struct
+  type stack =
+    | In_array of t list * stack
+    | In_object of (string * t) list * stack
+    | Empty
+end
+
+let encode ?minify ?(size_chunk = _max_young_size) ~output t =
+  let encoder = Jsonm.encoder ?minify `Manual in
+  let buf = Bytes.create size_chunk in
+  let rec encode k stack value =
+    match Jsonm.encode encoder value with
+    | `Ok -> k stack
+    | `Partial ->
+        let len = Bytes.length buf - Jsonm.Manual.dst_rem encoder in
+        output (Bytes.sub_string buf 0 len);
+        Jsonm.Manual.dst encoder buf 0 (Bytes.length buf);
+        encode k stack `Await
+  and value k v stack =
+    match v with
+    | #value as v -> encode (continue k) stack (`Lexeme v)
+    | `O ms -> encode (obj k ms) stack (`Lexeme `Os)
+    | `A vs -> encode (arr k vs) stack (`Lexeme `As)
+  and obj k ms stack =
+    match ms with
+    | (n, v) :: ms ->
+        let stack = Stack.In_object (ms, stack) in
+        encode (value k v) stack (`Lexeme (`Name n))
+    | [] -> encode (continue k) stack (`Lexeme `Oe)
+  and arr k vs stack =
+    match vs with
+    | v :: vs ->
+        let stack = Stack.In_array (vs, stack) in
+        value k v stack
+    | [] -> encode (continue k) stack (`Lexeme `Ae)
+  and continue k = function
+    | Stack.In_array (vs, stack) -> arr k vs stack
+    | Stack.In_object (ms, stack) -> obj k ms stack
+    | Stack.Empty as stack -> encode k stack `End
+  in
+  Jsonm.Manual.dst encoder buf 0 (Bytes.length buf);
+  value (Fun.const ()) t Stack.Empty

lib/vif/main.ml

@@ -0,0 +1,102 @@
+#require "miou.unix" ;;
+#require "mirage-crypto-rng-miou-unix" ;;
+#require "vif" ;;
+#require "digestif.c" ;;
+#require "base64" ;;
+
+type cfg = Config
+
+let index _req server Config =
+  Vif.Response.with_string server `OK "Hello from an OCaml script!"
+;;
+
+let hex _req arg server Config =
+  Vif.Response.with_string server `OK (Fmt.str "%02x\n%!" arg)
+;;
+
+let digest req server Config =
+  let ic = Vif.Request.to_stream req in
+  let rec go ctx =
+    match Vif.Stream.get ic with
+    | Some str -> go (Digestif.SHA1.feed_string ctx str)
+    | None -> Digestif.SHA1.get ctx
+  in
+  let hash = go Digestif.SHA1.empty in
+  let hash = Digestif.SHA1.to_hex hash in
+  Vif.Response.with_string server `OK hash
+;;
+
+let random req len server Config =
+  let buf = Bytes.create 0x7ff in
+  Vif.Response.with_stream server `OK @@ fun oc ->
+  let rec go rem =
+    if rem > 0 then begin
+      let len = Int.min rem (Bytes.length buf) in
+      Mirage_crypto_rng.generate_into buf len;
+      let str = Bytes.sub_string buf 0 len in
+      let str = Base64.encode_exn str in
+      Vif.Stream.put oc str;
+      go (rem - len)
+    end
+  in
+  go len
+;;
+
+type foo =
+  { username : string
+  ; password : string
+  ; age : int option }
+;;
+
+let foo =
+  let open Json_encoding in
+  let username = req "username" string in
+  let password = req "password" string in
+  let age = opt "age" int in
+  let foo = obj3 username password age in
+  let inj (username, password, age) = { username; password; age } in
+  let prj { username; password; age } = (username, password, age) in
+  conv prj inj foo
+;;
+
+let login req server Config =
+  match Vif.Request.to_json req with
+  | Ok (foo : foo) ->
+      Logs.debug (fun m -> m "username: %s" foo.username);
+      Logs.debug (fun m -> m "password: %s" foo.password);
+      Vif.Response.with_string server `OK "Foo"
+  | Error (`Msg err) ->
+      Logs.err (fun m -> m "Invalid JSON: %s" err);
+      Vif.Response.with_string server `Not_acceptable err
+
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [
+    get (rel /?? nil) --> index
+  ; get (rel / "random" /% Tyre.int /?? nil) --> random
+  ; get (rel / "hex" /% Tyre.int /?? nil) --> hex
+  ; post any (rel / "digest" /?? nil) --> digest
+  ; post (json_encoding foo) (rel / "json" /?? nil) --> login
+  ]
+;;
+
+let default req target server Config =
+  Logs.debug (fun m -> m "We are into the default case");
+  Vif.Response.with_string server `Not_found (Fmt.str "%S not found\n%!" target)
+;;
+
+let rng =
+  let open Mirage_crypto_rng_miou_unix in
+  let finally = kill in
+  Vif.D.device ~name:"rng" ~finally [] @@ fun Config ->
+  initialize (module Pfortuna)
+;;
+
+let () =
+  Miou_unix.run @@ fun () ->
+  let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
+  let cfg = Vif.config sockaddr in
+  Vif.run ~cfg ~default ~devices:Vif.Ds.[ rng ] routes Config
+;;

lib/vif/vif.ml

@@ -1,5 +1,22 @@
+let src = Logs.Src.create "vif"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+module Json = Json
 module U = Vif_u
-module R = Vif_r
+
+module R = struct
+  include Vif_r
+  open Vif_content_type
+
+  type ('fu, 'return) t =
+    | Handler : ('f, 'x) body * ('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 ( --> ) = route
+end
+
 module C = Vif_c
 module D = Vif_d
 module S = Vif_s
@@ -27,6 +44,7 @@ module Ds = struct
     Vif_d.Hmap.iter fn m
 end
 
+module Content_type = Vif_content_type
 module Stream = Stream
 module Method = Vif_method
 module Status = Vif_status
@@ -60,11 +78,75 @@ let config ?http ?tls ?(backlog = 64) ?stop sockaddr =
 
 let stop = Httpcats.Server.stop
 
+let is_application_json { Multipart_form.Content_type.ty; subty; _ } =
+  match (ty, subty) with `Application, `Iana_token "json" -> true | _ -> false
+
+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 ->
+        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
+  in
+  { Vif_r.extract }
+
 let handler ~default routes devices user's_value socket reqd =
-  let request = Request.of_reqd reqd in
+  let target =
-  let target = Request.target request in
+    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
-  R.dispatch ~default routes ~target server request user's_value
+  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 run ~cfg ~devices ~default routes user's_value =
   let domains = Miou.Domain.available () in

lib/vif/vif.mli

@@ -22,12 +22,75 @@ module U : sig
   val eval : ('f, string) t -> 'f
 end
 
+module Stream : sig
+  type 'a t
+
+  val create : int -> 'a t
+  val put : 'a t -> 'a -> unit
+  val get : 'a t -> 'a option
+  val close : 'a t -> unit
+end
+
+module Headers : sig
+  type t = (string * string) list
+end
+
+module Method : sig
+  type t =
+    [ `CONNECT
+    | `DELETE
+    | `GET
+    | `HEAD
+    | `OPTIONS
+    | `POST
+    | `PUT
+    | `TRACE
+    | `Other of string ]
+end
+
+module Json = Json
+
+module Content_type : sig
+  type null
+  type json
+  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 any : ('c, string) t
+end
+
+module Request : sig
+  type ('c, 'a) t
+
+  val target : ('c, 'a) t -> string
+  val meth : ('c, 'a) t -> Method.t
+  val version : ('c, 'a) t -> int
+  val headers : ('c, 'a) t -> Headers.t
+  val to_string : ('c, 'a) t -> string
+  val to_stream : ('c, 'a) t -> string Stream.t
+  val to_json : (Content_type.json, 'a) t -> ('a, [> `Msg of string ]) result
+end
+
 module R : sig
   type 'r route
+  type ('fu, 'return) t
+  type request
 
-  val route : ('f, 'r) U.t -> 'f -> 'r route
+  val get : ('x, 'r) U.t -> ((Content_type.null, unit) Request.t -> 'x, 'r) t
-  val ( --> ) : ('f, 'r) U.t -> 'f -> 'r route
+
-  val dispatch : default:(string -> 'r) -> 'r route list -> target:string -> 'r
+  val post :
+    ('c, 'a) Content_type.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
@@ -112,28 +175,6 @@ module S : sig
   val device : ('value, 'a) D.device -> t -> 'a
 end
 
-module Stream : sig
-  type 'a t
-
-  val create : int -> 'a t
-  val put : 'a t -> 'a -> unit
-  val get : 'a t -> 'a option
-  val close : 'a t -> unit
-end
-
-module Method : sig
-  type t =
-    [ `CONNECT
-    | `DELETE
-    | `GET
-    | `HEAD
-    | `OPTIONS
-    | `POST
-    | `PUT
-    | `TRACE
-    | `Other of string ]
-end
-
 module Status : sig
   type t =
     [ `Accepted
@@ -187,28 +228,13 @@ module Status : sig
     | `Use_proxy ]
 end
 
-module Headers : sig
-  type t = (string * string) list
-end
-
-module Request : sig
-  type t
-
-  val target : t -> string
-  val meth : t -> Method.t
-  val version : t -> int
-  val headers : t -> Headers.t
-  val to_string : t -> string
-  val to_stream : t -> string Stream.t
-end
-
 module Response : sig
   type t
 
   val with_stream :
-    S.t -> ?headers:Headers.t -> Status.t -> (string Stream.t -> unit) -> unit
+    S.t -> ?headers:Headers.t -> Status.t -> (string Stream.t -> unit) -> t
 
-  val with_string : S.t -> ?headers:Headers.t -> Status.t -> string -> unit
+  val with_string : S.t -> ?headers:Headers.t -> Status.t -> string -> t
 end
 
 type config
@@ -230,7 +256,7 @@ val stop : unit -> stop
 val run :
      cfg:config
   -> devices:'value Ds.t
-  -> default:(string -> S.t -> Request.t -> 'value -> unit)
+  -> default:(('c, string) Request.t -> string -> S.t -> 'value -> Response.t)
-  -> (S.t -> Request.t -> 'value -> unit) R.route list
+  -> (S.t -> 'value -> Response.t) R.route list
   -> 'value
   -> unit

lib/vif/vif_content_type.ml

@@ -0,0 +1,13 @@
+type null = Null
+and json = Json
+
+type ('c, 'a) t =
+  | Null : (null, unit) t
+  | Json_encoding : 'a Json_encoding.encoding -> (json, 'a) 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

lib/vif/vif_r.ml

@@ -1,3 +1,7 @@
+let src = Logs.Src.create "vif.r"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
 type 'a atom = 'a Tyre.Internal.wit
 
 let atom re = Tyre.Internal.build re
@@ -177,15 +181,15 @@ let rec extract_path : type f x r.
       let k f = k (f v) in
       extract_path ~original rep subs k
 
-let rec extract_query : type x r.
+let rec extract_query : type f x r.
-    original:string -> (x, r) query -> Re.Group.t -> x -> r =
+    original:string -> (f, r) query -> Re.Group.t -> f -> r =
- fun ~original wq subs f ->
+ fun ~original wq subs k ->
   match wq with
-  | Nil -> f
+  | Nil -> k
-  | Any -> f
+  | Any -> k
   | Cons (rea, req) ->
       let v = extract ~original rea subs in
-      extract_query ~original req subs (f v)
+      extract_query ~original req subs (k v)
 
 let extract : type r f. original:string -> (f, r) t -> Re.Group.t -> f -> r =
  fun ~original (Url (wp, wq)) subs f ->
@@ -202,37 +206,61 @@ let extract t =
     extract ~original:target url subs f
 *)
 
-type 'r route = Route : ('f, 'r) Vif_u.t * 'f -> 'r route
+type ('fu, 'return) body =
+  | Body :
+      ('c, 'a) Vif_content_type.t
+      -> (('c, 'a) Vif_request.t -> 'r, 'r) body
 
-let route t f = Route (t, f)
+type 'r route = Route : ('f, 'x) body * ('x, 'r) Vif_u.t * 'f -> 'r route
-let ( --> ) = route
 
-type 'r re = Re : 'f * Re.Mark.t * ('f, 'r) t -> 'r re
+let route body t f = Route (body, t, f)
+
+type 'r re = Re : ('f, 'x) body * 'f * Re.Mark.t * ('x, 'r) t -> 'r re
 
 let rec build_info_list idx = function
   | [] -> ([], [])
-  | Route (t, f) :: l ->
+  | Route (b, 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 (f, id, ret) :: wl)
+      (re :: rel, Re (b, f, id, ret) :: wl)
 
-let rec find_and_trigger : type r.
+type request = {
-    original:string -> Re.Group.t -> r re list -> r =
+    extract: 'c 'a. ('c, 'a) Vif_content_type.t -> ('c, 'a) Vif_request.t option
- fun ~original subs -> function
+}
-  | [] -> assert false
-  | Re (f, id, ret) :: l ->
-      if Re.Mark.test subs id then extract ~original ret subs f
-      else find_and_trigger ~original subs l
 
-let dispatch : type r.
+let rec find_and_trigger : type f r a.
-    default:(string -> r) -> r route list -> target:string -> 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 ->
+      if Re.Mark.test subs id then
+        match request.extract body 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
+
+let dispatch : type f r c a.
+       default:((c, string) Vif_request.t -> string -> r)
+    -> r route list
+    -> request:request
+    -> target:string
+    -> r =
  fun ~default l ->
   let rel, wl = build_info_list 1 l in
   let re = Re.(compile (whole_string (alt rel))) in
-  fun ~target ->
+  fun ~request ~target ->
     match Re.exec_opt re target with
-    | None -> default target
+    | None ->
-    | Some subs -> (
+        Log.debug (fun m -> m "Fallback to the default route");
-        try find_and_trigger ~original:target subs wl
+        let[@warning "-8"] (Some request) = request.extract Any in
-        with Not_found -> assert false)
+        default request target
+    | Some subs -> begin
+        try find_and_trigger ~original:target ~request subs wl
+        with exn ->
+          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
+          default request target
+      end

lib/vif/vif_request.ml

@@ -1,17 +1,24 @@
-type t = {
+let src = Logs.Src.create "vif.request"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type ('c, 'a) t = {
     request: [ `V1 of H1.Request.t | `V2 of H2.Request.t ]
   ; body: [ `V1 of H1.Body.Reader.t | `V2 of H2.Body.Reader.t ]
+  ; encoding: ('c, 'a) Vif_content_type.t
 }
 
-let of_reqd = function
+let of_reqd : type c a.
+    encoding:(c, a) Vif_content_type.t -> Httpcats.Server.reqd -> (c, a) t =
+ fun ~encoding -> function
   | `V1 reqd ->
       let request = `V1 (H1.Reqd.request reqd) in
       let body = `V1 (H1.Reqd.request_body reqd) in
-      { request; body }
+      { request; body; encoding }
   | `V2 reqd ->
       let request = `V2 (H2.Reqd.request reqd) in
       let body = `V2 (H2.Reqd.request_body reqd) in
-      { request; body }
+      { request; body; encoding }
 
 let target { request; _ } =
   match request with
@@ -70,3 +77,31 @@ let to_stream { body; _ } =
   | `V2 body ->
       to_stream ~schedule:H2.Body.Reader.schedule_read
         ~close:H2.Body.Reader.close body
+
+let destruct : type a. a Json_encoding.encoding -> Json.t -> a =
+  Json_encoding.destruct
+
+let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
+
+let to_json : type a.
+    (Vif_content_type.json, a) t -> (a, [> `Msg of string ]) result = function
+  | { encoding= Any; _ } as req -> Ok (to_string req)
+  | { encoding= Json; _ } as req ->
+      Log.debug (fun m -> m "Parse the body as a JSON data");
+      let stream = to_stream req in
+      Log.debug (fun m -> m "Get the stream");
+      let input () =
+        let str = Stream.get stream in
+        Log.debug (fun m -> m "json(%a)" Fmt.(option (fmt "%S")) str);
+        str
+      in
+      Json.decode ~input Result.ok
+  | { encoding= Json_encoding encoding; _ } as req -> (
+      let stream = to_stream req in
+      let input () = Stream.get stream in
+      match Json.decode ~input Result.ok with
+      | Error (`Msg _) as err -> err
+      | Ok (json : Json.t) -> (
+          try Ok (destruct encoding json)
+          with Json_encoding.Cannot_destruct (_, _) ->
+            error_msgf "Invalid JSON value"))

lib/vif/vif_response.ml

@@ -1,70 +1,67 @@
-type t = { response: Httpcats.response; compress: [ `GZip | `DEFLATE ] option }
+type t = Response
 
 let strf fmt = Format.asprintf fmt
 
-let with_string server ?(headers = []) status str =
+module Hdrs = Vif_headers
-  match Vif_s.reqd server with
-  | `V1 reqd ->
-      let headers =
-        Vif_headers.add_unless_exists headers "content-length"
-          (strf "%d" (String.length str))
-      in
-      let headers = H1.Headers.of_list headers in
-      let status =
-        match status with
-        | #H1.Status.t as status -> status
-        | _ -> invalid_arg "Response.with_string: invalid status"
-      in
-      let resp = H1.Response.create ~headers status in
-      H1.Reqd.respond_with_string reqd resp str
-  | `V2 reqd ->
-      let headers =
-        Vif_headers.add_unless_exists headers "content-length"
-          (strf "%d" (String.length str))
-      in
-      let headers = H2.Headers.of_list headers in
-      let resp = H2.Response.create ~headers status in
-      H2.Reqd.respond_with_string reqd resp str
 
-let with_stream server ?(headers = []) status fn =
+let compress_string ~headers str =
+  match List.assoc_opt "content-encoding" headers with
+  | Some "gzip" -> assert false
+  | _ -> str
+
+let with_string server ?headers:(hdrs = []) status str =
   match Vif_s.reqd server with
   | `V1 reqd ->
-      let headers =
+      let length = strf "%d" (String.length str) in
-        Vif_headers.add_unless_exists headers "transfer-encoding" "chunked"
+      let hdrs = Hdrs.add_unless_exists hdrs "content-length" length in
-      in
+      let str = compress_string ~headers:hdrs str in
-      let headers = H1.Headers.of_list headers in
+      let hdrs = H1.Headers.of_list hdrs in
       let status =
         match status with
         | #H1.Status.t as status -> status
         | _ -> invalid_arg "Response.with_string: invalid status"
       in
-      let resp = H1.Response.create ~headers status in
+      let resp = H1.Response.create ~headers:hdrs status in
+      H1.Reqd.respond_with_string reqd resp str;
+      Response
+  | `V2 reqd ->
+      let length = strf "%d" (String.length str) in
+      let hdrs = Hdrs.add_unless_exists hdrs "content-length" length in
+      let str = compress_string ~headers:hdrs str in
+      let hdrs = H2.Headers.of_list hdrs in
+      let resp = H2.Response.create ~headers:hdrs status in
+      H2.Reqd.respond_with_string reqd resp str;
+      Response
+
+let with_stream server ?headers:(hdrs = []) status fn =
+  match Vif_s.reqd server with
+  | `V1 reqd ->
+      let hdrs = Hdrs.add_unless_exists hdrs "transfer-encoding" "chunked" in
+      let hdrs = H1.Headers.of_list hdrs in
+      let status =
+        match status with
+        | #H1.Status.t as status -> status
+        | _ -> invalid_arg "Response.with_string: invalid status"
+      in
+      let resp = H1.Response.create ~headers:hdrs status in
       let stream = Stream.create 0x7ff in
       let body = H1.Reqd.respond_with_streaming reqd resp in
-      let res0 =
+      let res0 = Miou.Ownership.create ~finally:H1.Body.Writer.close body in
-        let finally = H1.Body.Writer.close in
+      let res1 = Miou.Ownership.create ~finally:Stream.close stream in
-        Miou.Ownership.create ~finally body
+      let rec send stream body res =
-      in
-      let res1 =
-        let finally = Stream.close in
-        Miou.Ownership.create ~finally stream
-      in
-      let prm0 =
-        Miou.async ~give:[ res0 ] @@ fun () ->
-        let rec go () =
         match Stream.get stream with
         | Some str ->
-              let () = H1.Body.Writer.write_string body str in
+            H1.Body.Writer.write_string body str;
-              go ()
+            send stream body res
-          | None -> H1.Body.Writer.close body; Miou.Ownership.disown res0
+        | None -> H1.Body.Writer.close body; Miou.Ownership.disown res
-        in
-        go ()
       in
+      let prm0 = Miou.async ~give:[ res0 ] @@ fun () -> send stream body res0 in
       let prm1 =
         Miou.async ~give:[ res1 ] @@ fun () ->
         let () = fn stream in
         Stream.close stream; Miou.Ownership.disown res1
       in
       Miou.await_all [ prm0; prm1 ]
-      |> List.iter (function Ok () -> () | Error exn -> raise exn)
+      |> List.iter (function Ok () -> () | Error exn -> raise exn);
+      Response
   | `V2 _ -> assert false

main.ml

@@ -1,18 +1,22 @@
-#require "miou.unix" ;;
+#require "miou.unix"
-#require "mirage-crypto-rng-miou-unix" ;;
-#require "vif" ;;
-#require "digestif.c" ;;
-#require "base64" ;;
 
-let index server _req () =
+#require "mirage-crypto-rng-miou-unix"
+
+#require "vif"
+
+#require "digestif.c"
+
+#require "base64"
+
+type cfg = Config
+
+let index _req server Config =
   Vif.Response.with_string server `OK "Hello from an OCaml script!"
-;;
 
-let test arg server _req () =
+let hex _req arg server Config =
   Vif.Response.with_string server `OK (Fmt.str "%02x\n%!" arg)
-;;
 
-let digest server req () =
+let digest req server Config =
   let ic = Vif.Request.to_stream req in
   let rec go ctx =
     match Vif.Stream.get ic with
@@ -22,9 +26,8 @@ let digest server req () =
   let hash = go Digestif.SHA1.empty in
   let hash = Digestif.SHA1.to_hex hash in
   Vif.Response.with_string server `OK hash
-;;
 
-let random len server req () =
+let random req len server Config =
   let buf = Bytes.create 0x7ff in
   Vif.Response.with_stream server `OK @@ fun oc ->
   let rec go rem =
@@ -38,33 +41,53 @@ let random len server req () =
     end
   in
   go len
-;;
+
+type foo = { username: string; password: string; age: int option }
+
+let foo =
+  let open Json_encoding in
+  let username = req "username" string in
+  let password = req "password" string in
+  let age = opt "age" int in
+  let foo = obj3 username password age in
+  let inj (username, password, age) = { username; password; age } in
+  let prj { username; password; age } = (username, password, age) in
+  conv prj inj foo
+
+let login req server Config =
+  match Vif.Request.to_json req with
+  | Ok (foo : foo) ->
+      Logs.debug (fun m -> m "username: %s" foo.username);
+      Logs.debug (fun m -> m "password: %s" foo.password);
+      Vif.Response.with_string server `OK "Foo"
+  | Error (`Msg err) ->
+      Logs.err (fun m -> m "Invalid JSON: %s" err);
+      Vif.Response.with_string server `Not_acceptable err
 
 let routes =
   let open Vif.U in
   let open Vif.R in
+  let open Vif.Content_type in
   [
-    (rel /?? nil) --> index
+    get (rel /?? nil) --> index
-  ; (rel / "random" /% Tyre.int /?? nil) --> random
+  ; get (rel / "random" /% Tyre.int /?? nil) --> random
-  ; (rel / "test" /% Tyre.int /?? nil) --> test
+  ; get (rel / "hex" /% Tyre.int /?? nil) --> hex
-  ; (rel / "digest" /?? nil) --> digest
+  ; post any (rel / "digest" /?? nil) --> digest
+  ; post (json_encoding foo) (rel / "json" /?? nil) --> login
   ]
-;;
 
-let default target server req () =
+let default req target server Config =
+  Logs.debug (fun m -> m "We are into the default case");
   Vif.Response.with_string server `Not_found (Fmt.str "%S not found\n%!" target)
-;;
 
 let rng =
   let open Mirage_crypto_rng_miou_unix in
   let finally = kill in
-  Vif.D.device ~name:"rng" ~finally [] @@ fun _cfg ->
+  Vif.D.device ~name:"rng" ~finally [] @@ fun Config ->
   initialize (module Pfortuna)
-;;
 
 let () =
   Miou_unix.run @@ fun () ->
   let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
   let cfg = Vif.config sockaddr in
-  Vif.run ~cfg ~default ~devices:Vif.Ds.[ rng; ] routes ()
+  Vif.run ~cfg ~default ~devices:Vif.Ds.[ rng ] routes Config
-;;