From 5b07aee78182aa6af452bf64b27b9a3c9881d7d3 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 31 Jan 2025 17:44:50 +0100 Subject: [PATCH] Be able to parse JSON --- bin/vif.ml | 4 +- lib/top/vif_top.ml | 48 +++++---------- lib/top/vif_top.mli | 2 +- lib/vif/dune | 9 ++- lib/vif/json.ml | 112 +++++++++++++++++++++++++++++++++++ lib/vif/main.ml | 102 ++++++++++++++++++++++++++++++++ lib/vif/vif.ml | 90 ++++++++++++++++++++++++++-- lib/vif/vif.mli | 114 ++++++++++++++++++++++-------------- lib/vif/vif_content_type.ml | 13 ++++ lib/vif/vif_m.ml | 0 lib/vif/vif_r.ml | 80 +++++++++++++++++-------- lib/vif/vif_request.ml | 43 ++++++++++++-- lib/vif/vif_response.ml | 95 +++++++++++++++--------------- main.ml | 71 ++++++++++++++-------- 14 files changed, 593 insertions(+), 190 deletions(-) create mode 100644 lib/vif/json.ml create mode 100644 lib/vif/main.ml create mode 100644 lib/vif/vif_content_type.ml create mode 100644 lib/vif/vif_m.ml diff --git a/bin/vif.ml b/bin/vif.ml index 60381f2..d1cf93b 100644 --- a/bin/vif.ml +++ b/bin/vif.ml @@ -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 diff --git a/lib/top/vif_top.ml b/lib/top/vif_top.ml index 9cac798..f26fc76 100644 --- a/lib/top/vif_top.ml +++ b/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 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 - (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 + capture_compiler_stuff ppf @@ fun () -> + let cmd = + match cmd with [] | [ _ ] -> cmd | x :: r -> x :: List.map (( ^ ) " ") r in - redirect ~fn + let phrases = cut_into_phrases cmd in + List.iter + (fun phrase -> + match Phrase.parse phrase with Some t -> eval t | None -> ()) + phrases; + if !errors then Error () else Ok () diff --git a/lib/top/vif_top.mli b/lib/top/vif_top.mli index 5fae63f..b9e236e 100644 --- a/lib/top/vif_top.mli +++ b/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 diff --git a/lib/vif/dune b/lib/vif/dune index 5ea6f3e..2023214 100644 --- a/lib/vif/dune +++ b/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)) diff --git a/lib/vif/json.ml b/lib/vif/json.ml new file mode 100644 index 0000000..4844712 --- /dev/null +++ b/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 diff --git a/lib/vif/main.ml b/lib/vif/main.ml new file mode 100644 index 0000000..bb237c9 --- /dev/null +++ b/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 +;; diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml index c7587b7..c2a663f 100644 --- a/lib/vif/vif.ml +++ b/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 = 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 diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli index 0044490..d234d7c 100644 --- a/lib/vif/vif.mli +++ b/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 ( --> ) : ('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 diff --git a/lib/vif/vif_content_type.ml b/lib/vif/vif_content_type.ml new file mode 100644 index 0000000..8d43fc4 --- /dev/null +++ b/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 diff --git a/lib/vif/vif_m.ml b/lib/vif/vif_m.ml new file mode 100644 index 0000000..e69de29 diff --git a/lib/vif/vif_r.ml b/lib/vif/vif_r.ml index 317f181..fc11b44 100644 --- a/lib/vif/vif_r.ml +++ b/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. - 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 diff --git a/lib/vif/vif_request.ml b/lib/vif/vif_request.ml index 3727a2f..3de4466 100644 --- a/lib/vif/vif_request.ml +++ b/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")) diff --git a/lib/vif/vif_response.ml b/lib/vif/vif_response.ml index 34cb27a..b4ed97a 100644 --- a/lib/vif/vif_response.ml +++ b/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 = - 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 () = - 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 () + 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 -> + 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 diff --git a/main.ml b/main.ml index 52ea309..67e41d5 100644 --- a/main.ml +++ b/main.ml @@ -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