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

Be able to parse JSON

Browse source
This commit is contained in:
Calascibetta Romain 2025-01-31 17:44:50 +01:00
parent a0a0b22f1e
commit 5b07aee781
14 changed files with 593 additions and 190 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
bin/vif.ml
View file

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

38
lib/top/vif_top.ml
View file

@ -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 lines = ref [] in
let capture () =
capture buf;
match Buffer.contents buf with
| "" -> ()
| str ->
Buffer.clear buf;
lines := str :: !lines
in
let eval phrase =
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 ();
capture ();
trim (List.rev !lines)
Format.pp_print_flush ppf ()
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.map
List.iter
(fun phrase ->
match Phrase.parse phrase with
| Some t -> eval ~capture t
| None -> [])
phrases
in
let phrases = List.concat phrases in
if !errors then Error phrases else Ok phrases
in
redirect ~fn
match Phrase.parse phrase with Some t -> eval t | None -> ())
phrases;
if !errors then Error () else Ok ()

2
lib/top/vif_top.mli
View file

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

9
lib/vif/dune
View file

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

112
lib/vif/json.ml Normal file
View file

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

102
lib/vif/main.ml Normal file
View file

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

90
lib/vif/vif.ml
View file

@ -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 = Request.target request in
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
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

114
lib/vif/vif.mli
View file

@ -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 ( --> ) : ('f, 'r) U.t -> 'f -> 'r route
val dispatch : default:(string -> 'r) -> 'r route list -> target:string -> 'r
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 ( --> ) : ('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)
-> (S.t -> Request.t -> 'value -> unit) R.route list
-> default:(('c, string) Request.t -> string -> S.t -> 'value -> Response.t)
-> (S.t -> 'value -> Response.t) R.route list
-> 'value
-> unit

13
lib/vif/vif_content_type.ml Normal file
View file

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

0
lib/vif/vif_m.ml Normal file
View file

80
lib/vif/vif_r.ml
View file

@ -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.
original:string -> (x, r) query -> Re.Group.t -> x -> r =
fun ~original wq subs f ->
let rec extract_query : type f x r.
original:string -> (f, r) query -> Re.Group.t -> f -> r =
fun ~original wq subs k ->
match wq with
| Nil -> f
| Any -> f
| Nil -> k
| 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)
let ( --> ) = route
type 'r route = Route : ('f, 'x) body * ('x, 'r) Vif_u.t * 'f -> 'r 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.
original:string -> Re.Group.t -> r re list -> r =
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
type request = {
extract: 'c 'a. ('c, 'a) Vif_content_type.t -> ('c, 'a) Vif_request.t option
}
let dispatch : type r.
default:(string -> r) -> r route list -> target:string -> r =
let rec find_and_trigger : type f r a.
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
| Some subs -> (
try find_and_trigger ~original:target subs wl
with Not_found -> assert false)
| None ->
Log.debug (fun m -> m "Fallback to the default route");
let[@warning "-8"] (Some request) = request.extract Any in
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

43
lib/vif/vif_request.ml
View file

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

91
lib/vif/vif_response.ml
View file

@ -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 =
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
module Hdrs = Vif_headers
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 =
Vif_headers.add_unless_exists headers "transfer-encoding" "chunked"
in
let headers = H1.Headers.of_list headers in
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 = 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 finally = H1.Body.Writer.close in
Miou.Ownership.create ~finally body
in
let res1 =
let finally = Stream.close in
Miou.Ownership.create ~finally stream
in
let prm0 =
Miou.async ~give:[ res0 ] @@ fun () ->
let rec go () =
let res0 = Miou.Ownership.create ~finally:H1.Body.Writer.close body in
let res1 = Miou.Ownership.create ~finally:Stream.close stream in
let rec send stream body res =
match Stream.get stream with
| Some str ->
let () = H1.Body.Writer.write_string body str in
go ()
| None -> H1.Body.Writer.close body; Miou.Ownership.disown res0
in
go ()
H1.Body.Writer.write_string body str;
send stream body res
| None -> H1.Body.Writer.close body; Miou.Ownership.disown res
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

71
main.ml
View file

@ -1,18 +1,22 @@
#require "miou.unix" ;;
#require "mirage-crypto-rng-miou-unix" ;;
#require "vif" ;;
#require "digestif.c" ;;
#require "base64" ;;
#require "miou.unix"
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
; (rel / "random" /% Tyre.int /?? nil) --> random
; (rel / "test" /% Tyre.int /?? nil) --> test
; (rel / "digest" /?? nil) --> digest
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 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