From d86a49c6373e3c98acc60f4c7d5cc1e3216f029c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sat, 4 Jan 2025 18:12:43 +0100 Subject: [PATCH] . --- bin/dune | 2 +- bin/vif.ml | 83 ++++++++++++++++-- lib/meta/vif_meta.ml | 40 ++++++++- lib/top/vif_top.ml | 16 +++- lib/vif/dune | 2 + lib/vif/pct.ml | 3 + lib/vif/pct.mli | 1 + lib/vif/vif.ml | 46 ++++++++++ lib/vif/vif.mli | 22 +++++ lib/vif/vif_c.ml | 2 + lib/vif/vif_r.ml | 204 +++++++++++++++++++++++++++++++++++++++++++ lib/vif/vif_u.mli | 30 ------- main.ml | 33 +++++++ vif.opam | 2 +- 14 files changed, 439 insertions(+), 47 deletions(-) delete mode 100644 lib/vif/vif_u.mli create mode 100644 main.ml diff --git a/bin/dune b/bin/dune index 23abbb8..3e777be 100644 --- a/bin/dune +++ b/bin/dune @@ -3,4 +3,4 @@ (public_name vif) (flags (:standard -w -18 -linkall)) - (libraries logs.fmt fmt.tty vif vif.top)) + (libraries logs.fmt fmt.tty logs.cli fmt.cli vif vif.top)) diff --git a/bin/vif.ml b/bin/vif.ml index 4998b7c..60381f2 100644 --- a/bin/vif.ml +++ b/bin/vif.ml @@ -14,13 +14,7 @@ let _reporter ppf = let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt -(* -let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () -let () = Logs.set_reporter (reporter Fmt.stdout) -let () = Logs.set_level ~all:true (Some Logs.Debug) -*) - -let run roots stdlib main = +let run _quiet roots stdlib main = let roots = List.map Fpath.to_string roots in let cfg = Vif_top.config ~stdlib roots in let main = @@ -81,9 +75,82 @@ let setup_stdlib = let open Term in ret (const setup_stdlib $ const ()) +let docs_output = "OUTPUT" + +let verbosity = + let env = Cmd.Env.info "VIF_LOGS" in + Logs_cli.level ~env ~docs:docs_output () + +let renderer = + let env = Cmd.Env.info "VIF_FMT" in + Fmt_cli.style_renderer ~env ~docs:docs_output () + +let utf_8 = + let doc = "Allow us to emit UTF-8 characters." in + let env = Cmd.Env.info "VIF_UTF_8" in + let open Arg in + value + & opt bool true + & info [ "with-utf-8" ] ~doc ~docv:"BOOL" ~docs:docs_output ~env + +let app_style = `Cyan +let err_style = `Red +let warn_style = `Yellow +let info_style = `Blue +let debug_style = `Green + +let pp_header ~pp_h ppf (l, h) = + match l with + | Logs.Error -> + let h = Option.value ~default:"ERROR" h in + pp_h ppf err_style h + | Logs.Warning -> + let h = Option.value ~default:"WARN" h in + pp_h ppf warn_style h + | Logs.Info -> + let h = Option.value ~default:"INFO" h in + pp_h ppf info_style h + | Logs.Debug -> + let h = Option.value ~default:"DEBUG" h in + pp_h ppf debug_style h + | Logs.App -> + Fun.flip Option.iter h @@ fun h -> + Fmt.pf ppf "[%a] " Fmt.(styled app_style (fmt "%10s")) h + +let pp_header = + let pp_h ppf style h = Fmt.pf ppf "[%a]" Fmt.(styled style (fmt "%10s")) h in + pp_header ~pp_h + +let reporter ppf = + let report src level ~over k msgf = + let k _ = over (); k () in + let with_metadata header _tags k ppf fmt = + Fmt.kpf k ppf + ("[%02d]%a[%a]: @[" ^^ fmt ^^ "@]\n%!") + (Stdlib.Domain.self () :> int) + pp_header (level, header) + Fmt.(styled `Magenta (fmt "%20s")) + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in + { Logs.report } + +let setup_logs utf_8 style_renderer level = + let stdout = + Format.make_formatter (output_substring stdout) (fun () -> flush stdout) + in + Fmt_tty.setup_std_outputs ~utf_8 ?style_renderer (); + let reporter = reporter Fmt.stderr in + Logs.set_reporter reporter; + Logs.set_level level; + (Option.is_none level, stdout) + +let setup_logs = Term.(const setup_logs $ utf_8 $ renderer $ verbosity) + let term = let open Term in - const run $ Vif_meta.setup $ setup_stdlib $ main + const run $ setup_logs $ Vif_meta.setup $ setup_stdlib $ main let cmd = let doc = "vif" in diff --git a/lib/meta/vif_meta.ml b/lib/meta/vif_meta.ml index a17cbc7..21ebd66 100644 --- a/lib/meta/vif_meta.ml +++ b/lib/meta/vif_meta.ml @@ -59,6 +59,7 @@ module Path = struct type t = string list let of_string str = + let str = String.trim str in let pkg = String.split_on_char '.' str in let rec go = function | [] -> Ok pkg @@ -72,7 +73,7 @@ module Path = struct | Ok pkg -> pkg | Error (`Msg msg) -> invalid_arg msg - let pp ppf pkg = Format.pp_print_string ppf (String.concat "." pkg) + let pp ppf pkg = Format.fprintf ppf "%S" (String.concat "." pkg) let equal a b = try List.for_all2 String.equal a b with _ -> false end @@ -346,13 +347,38 @@ let dependencies_of (_path, descr) = exception Cycle -let equal_dep meta_path (meta_path', _, _) = Path.equal meta_path meta_path' +let get_dep (_, path, descr) graph = + let deps = dependencies_of (path, descr) in + List.map + (fun name -> + Log.debug (fun m -> m "search %a" Path.pp name); + List.find (fun (name', _, _) -> Path.equal name name') graph) + deps +type graph = (Path.t * string * Assoc.t) list + +let dfs (graph : graph) visited start_node = + let rec explore path visited node = + if List.mem node path then raise Cycle + else if List.mem node visited then visited + else + let new_path = node :: path in + let edges = get_dep node graph in + let visited = List.fold_left (explore new_path) visited edges in + node :: visited + in + explore [] visited start_node + +let sort graph = + List.fold_left (fun visited node -> dfs graph visited node) [] graph + +(* let sort libs = let rec go acc later todo progress = match (todo, later) with | [], [] -> List.rev acc - | [], _ -> if progress then go acc [] later false else raise Cycle + | [], _ -> + if progress then go acc [] later false else raise Cycle | ((_, path, descr) as x) :: r, _ -> let deps = dependencies_of (path, descr) in let deps_already_added = @@ -368,6 +394,7 @@ let sort libs = libs in go starts [] todo false +*) let ancestors ~roots ?(predicates = [ "native"; "byte" ]) meta_path = let rec go acc visited = function @@ -388,7 +415,12 @@ let ancestors ~roots ?(predicates = [ "native"; "byte" ]) meta_path = | Error _ as err -> err) in let open Rresult in - go [] [] [ meta_path ] >>| sort + go [] [] [ meta_path ] >>| fun lst -> + Log.debug (fun m -> + m "%a requires: %a" Path.pp meta_path + Fmt.(Dump.list Path.pp) + (List.map (fun (x, _, _) -> x) lst)); + sort lst |> List.rev let to_artifacts pkgs = let ( let* ) = Result.bind in diff --git a/lib/top/vif_top.ml b/lib/top/vif_top.ml index 564ee62..9cac798 100644 --- a/lib/top/vif_top.ml +++ b/lib/top/vif_top.ml @@ -142,13 +142,23 @@ let load cfg str = Log.debug (fun m -> m "load: @[%a@]" Fmt.(Dump.list string) artifacts); Ok artifacts +let null = + Format.formatter_of_out_functions + { + Format.out_string= (fun _ _ _ -> ()) + ; out_flush= ignore + ; out_newline= ignore + ; out_spaces= ignore + ; out_indent= ignore + } + let load cfg str = match load cfg str with | Ok artifacts -> let fn artifact = let dir = Filename.dirname artifact in Topdirs.dir_directory dir; - Topdirs.dir_load Fmt.stderr artifact + try Topdirs.dir_load null artifact with _ -> () in List.iter fn artifacts | Error (`Msg msg) -> Log.err (fun m -> m "Impossible to load %S: %s" str msg) @@ -234,8 +244,8 @@ let redirect : fn:(capture:(Buffer.t -> unit) -> 'a) -> 'a = Unix.dup2 ~cloexec:false stdout' Unix.stdout; Unix.dup2 ~cloexec:false stderr' Unix.stderr; Unix.close stdout'; - Unix.close stderr'; - Sys.remove filename + Unix.close stderr' + (* Sys.remove filename *) in Fun.protect ~finally @@ fun () -> fn ~capture diff --git a/lib/vif/dune b/lib/vif/dune index c043a2c..36d4c1a 100644 --- a/lib/vif/dune +++ b/lib/vif/dune @@ -1,4 +1,6 @@ (library (name vif) (public_name vif) + (flags + (:standard -linkall)) (libraries httpcats tyre)) diff --git a/lib/vif/pct.ml b/lib/vif/pct.ml index 5590227..521ce65 100644 --- a/lib/vif/pct.ml +++ b/lib/vif/pct.ml @@ -9,6 +9,8 @@ let pchar = arr.(Char.code '@') <- true; arr +let safe_host = pchar + let safe_path = let v = "!$&'()*+,;=" in let arr = Array.copy pchar in @@ -52,6 +54,7 @@ let encode safe_chars str = scan 0 0; Buffer.contents buf let encode_path str = encode safe_path str +let encode_host str = encode safe_host str let encode_query lst = let enc = diff --git a/lib/vif/pct.mli b/lib/vif/pct.mli index 3b268a3..b10849f 100644 --- a/lib/vif/pct.mli +++ b/lib/vif/pct.mli @@ -1,2 +1,3 @@ +val encode_host : string -> string val encode_path : string -> string val encode_query : (string * string list) list -> string diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml index be90cf7..71a79dd 100644 --- a/lib/vif/vif.ml +++ b/lib/vif/vif.ml @@ -1,2 +1,48 @@ module U = Vif_u +module R = Vif_r module C = Vif_c + +module Request = struct + type t = H1 of H1.Request.t | H2 of H2.Request.t + + let of_reqd = function + | `V1 reqd -> H1 (H1.Reqd.request reqd) + | `V2 reqd -> H2 (H2.Reqd.request reqd) + + let target = function + | H1 request -> request.H1.Request.target + | H2 request -> request.H2.Request.target +end + +type config = + [ `HTTP_1_1 of H1.Config.t + | `H2 of H2.Config.t + | `Both of H1.Config.t * H2.Config.t ] + +let default _reqd _target = () + +let handler routes _socket reqd = + let request = Request.of_reqd reqd in + let target = Request.target request in + R.dispatch ~default routes ~target reqd + +let run ?stop ?config ?backlog ?tls_config routes sockaddr = + let domains = Miou.Domain.available () in + let handler = handler routes in + let fn = + match (config, tls_config) with + | _, Some tls_config -> + fun () -> + Httpcats.Server.with_tls ?stop ?config ?backlog tls_config ~handler + sockaddr + | Some (`H2 _), None -> + failwith "Impossible to launch an h2 server without TLS." + | Some (`Both (config, _) | `HTTP_1_1 config), None -> + fun () -> Httpcats.Server.clear ?stop ~config ~handler sockaddr + | None, None -> fun () -> Httpcats.Server.clear ?stop ~handler sockaddr + in + let prm = Miou.async fn in + if domains > 0 then + Miou.parallel fn (List.init domains (Fun.const ())) + |> List.iter (function Ok () -> () | Error exn -> raise exn); + Miou.await_exn prm diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli index 317a3bc..85c4766 100644 --- a/lib/vif/vif.mli +++ b/lib/vif/vif.mli @@ -22,6 +22,14 @@ module U : sig val eval : ('f, string) t -> 'f end +module R : sig + type 'r route + + 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 +end + module C : sig (** Module [C] implements the {b c}lient part of the HTTP protocol. *) @@ -66,3 +74,17 @@ module C : sig C.request ~meth:`GET readme org repository branch ]} *) end + +type config = + [ `HTTP_1_1 of H1.Config.t + | `H2 of H2.Config.t + | `Both of H1.Config.t * H2.Config.t ] + +val run : + ?stop:Httpcats.Server.stop + -> ?config:config + -> ?backlog:int + -> ?tls_config:Tls.Config.server + -> (Httpcats.Server.reqd -> unit) R.route list + -> Unix.sockaddr + -> unit diff --git a/lib/vif/vif_c.ml b/lib/vif/vif_c.ml index 39467f5..b97742e 100644 --- a/lib/vif/vif_c.ml +++ b/lib/vif/vif_c.ml @@ -10,6 +10,8 @@ let request ?config ?tls_config ?authenticator ?meth ?headers ?body:_ ?max_redirect ?follow_redirect ?resolver t = let f _meta _response a _chunk = a in let fn uri = + let uri = "https://" ^ uri in + (* TODO *) let res = Httpcats.request ?config ?tls_config ?authenticator ?meth ?headers ?max_redirect ?follow_redirect ?resolver ~f ~uri () diff --git a/lib/vif/vif_r.ml b/lib/vif/vif_r.ml index 5b8d139..4f7d3aa 100644 --- a/lib/vif/vif_r.ml +++ b/lib/vif/vif_r.ml @@ -3,6 +3,7 @@ type 'a atom = 'a Tyre.Internal.wit let atom re = Tyre.Internal.build re let slash = Re.char '/' let comma = Re.char ',' +let amper = Re.char '&' let list ?m ~component n re = let open Re in @@ -27,3 +28,206 @@ let atom_path : type a. int -> a Tyre.Internal.raw -> int * a atom * Re.t = | e -> let i', w, re = atom i e in (i', w, seq [ slash; re ]) + +let atom_query : type a. int -> a Tyre.Internal.raw -> int * a atom * Re.t = + let open Re in + fun i -> function + | Rep e -> + let _, w, re = atom 1 e in + ( i + 1 + , Rep (i, w, Re.compile re) + , group (list ~component:`Query_value 0 (no_group re)) ) + | e -> atom i e + +type ('fu, 'return) path = + | Start : ('r, 'r) path + | Path_atom : ('f, 'a -> 'r) path * 'a atom -> ('f, 'r) path + +let rec path : type r f. + int -> (f, r) Vif_u.path -> int * (f, r) path * Re.t list = + fun i -> function + | Vif_u.Host str -> + let re = Re.str (Pct.encode_host str) in + (i, Start, [ re ]) + | Rel -> (i, Start, []) + | Path_const (p, str) -> + let i', p, re = path i p in + (i', p, Re.str str :: slash :: re) + | Path_atom (p, a) -> + let i', wp, rp = path i p in + let i'', wa, ra = atom_path i' (Tyre.Internal.from_t a) in + (i'', Path_atom (wp, wa), ra :: rp) + +type ('fu, 'return) query = + | Nil : ('r, 'r) query + | Any : ('r, 'r) query + | Cons : 'a atom * ('f, 'r) query -> ('a -> 'f, 'r) query + +let rec collect_query : type r f. + (f, r) Vif_u.query -> (f, r) query * bool * (string * (Re.t * int)) list = + function + | Nil -> (Nil, false, []) + | Any -> (Any, true, []) + | Query_atom (s, a, q) -> + let grps, wa, ra = atom_query 0 (Tyre.Internal.from_t a) in + let wq, b_any, rq = collect_query q in + (Cons (wa, wq), b_any, (s, (ra, grps)) :: rq) + +let rec shift_literals : type a. int -> a atom -> a atom = + fun shift -> function + | Tyre.Internal.Lit i -> Lit (i + shift) + | Conv (x, f) -> Conv (shift_literals shift x, f) + | Opt (m, x) -> Opt (m, shift_literals shift x) + | Alt (m, x1, x2) -> Alt (m, shift_literals shift x1, shift_literals shift x2) + | Seq (x1, x2) -> Seq (shift_literals shift x1, shift_literals shift x2) + | Rep (i, x, r) -> Rep (shift + i, x, r) + +let rec permut_query : type r f. + int -> int array -> (r, f) query -> (r, f) query = + fun n permutation -> function + | Nil -> Nil + | Any -> Any + | Cons (wa, wq) -> + let shift = permutation.(n) in + let wa = shift_literals shift wa in + Cons (wa, permut_query (n + 1) permutation wq) + +let find_idx count el l = + let rec go el i = function + | [] -> raise Not_found + | x :: r -> if x == el then i else go el (i + count el) r + in + go el 0 l + +let build_permutation offset count l_before l_after = + let t = Array.make (List.length l_before) 0 in + let fn i x = + let j = find_idx count x l_after in + t.(i) <- offset + j + in + List.iteri fn l_before; t + +let sort_query = List.sort (fun (x, _) (y, _) -> String.compare x y) + +let query current_idx q = + let wq, b, rql = collect_query q in + let rel = sort_query rql in + let p = build_permutation current_idx (fun (_, (_, i)) -> i) rql rel in + let wq = permut_query 0 p wq in + (wq, b, rel) + +type ('fu, 'return) t = Url : ('f, 'x) path * ('x, 'r) query -> ('f, 'r) t + +let query_sep ~any = + if not any then amper + else Re.(seq [ amper; rep (seq [ rep1 (compl [ amper ]); amper ]) ]) + +let rec intersperse sep = function + | [] -> [] + | [ x ] -> [ x ] + | x :: r -> x :: sep :: intersperse sep r + +let url : type f r. (f, r) Vif_u.t -> (f, r) t * Re.t = + fun (Vif_u.Url (slash, p, q)) -> + let end_path = + match slash with + | Vif_u.No_slash -> Re.epsilon + | Slash -> Re.char '/' + | Maybe_slash -> Re.(opt (Re.char '/')) + in + let idx, wp, rp = path 1 p in + match q with + | Nil -> (Url (wp, Nil), Re.seq (List.rev (end_path :: rp))) + | Any -> + let end_re = Re.(opt (seq [ Re.char '?'; rep any ])) in + (Url (wp, Nil), Re.seq (List.rev_append rp [ end_path; end_re ])) + | _ -> + let wq, any_query, rel = query idx q in + let query_sep = query_sep ~any:any_query in + let add_around_query = + if not any_query then fun x -> x else fun l -> Re.(rep any) :: l + in + let re = + let rel = + let fn l (s, (re, _)) = Re.seq [ Re.str (s ^ "="); re ] :: l in + List.fold_left fn [] rel + in + intersperse query_sep rel + |> add_around_query + |> List.rev + |> add_around_query + in + let re = Re.seq (List.rev_append rp (end_path :: Re.char '?' :: re)) in + (Url (wp, wq), re) + +let re t = snd (url t) +let extract = Tyre.Internal.extract + +let rec extract_path : type f x r. + original:string -> (f, x) path -> Re.Group.t -> (x -> r) -> f -> r = + fun ~original wp subs k -> + match wp with + | Start -> k + | Path_atom (rep, rea) -> + let v = extract ~original rea subs in + 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 -> + match wq with + | Nil -> f + | Any -> f + | Cons (rea, req) -> + let v = extract ~original rea subs in + extract_query ~original req subs (f v) + +let extract : type r f. original:string -> (f, r) t -> Re.Group.t -> f -> r = + fun ~original (Url (wp, wq)) subs f -> + let k = extract_query ~original wq subs in + let k = extract_path ~original wp subs k in + k f + +(* +let extract t = + let url, re = url t in + let re = Re.(compile (whole_string re)) in + fun ~f target -> + let subs = Re.exec re target in + extract ~original:target url subs f +*) + +type 'r route = Route : ('f, 'r) Vif_u.t * 'f -> 'r route + +let route t f = Route (t, f) +let ( --> ) = route + +type 'r re = Re : 'f * Re.Mark.t * ('f, 'r) t -> 'r re + +let rec build_info_list = function + | [] -> ([], []) + | Route (t, f) :: l -> + let rel, wl = build_info_list l in + let ret, re = url t in + let id, re = Re.mark re in + (re :: rel, Re (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 + +let dispatch : type r. + default:(string -> r) -> r route list -> target:string -> r = + fun ~default l -> + let rel, wl = build_info_list l in + let re = Re.(compile (whole_string (alt rel))) in + fun ~target -> + try + let subs = Re.exec re target in + find_and_trigger ~original:target subs wl + with Not_found -> default target diff --git a/lib/vif/vif_u.mli b/lib/vif/vif_u.mli deleted file mode 100644 index 1c8aba3..0000000 --- a/lib/vif/vif_u.mli +++ /dev/null @@ -1,30 +0,0 @@ -type 'a atom = 'a Tyre.t -type ('f, 'r) path - -val rel : ('r, 'r) path -val host : string -> ('r, 'r) path -val ( / ) : ('f, 'r) path -> string -> ('f, 'r) path -val ( /% ) : ('f, 'a -> 'r) path -> 'a atom -> ('f, 'r) path - -type ('f, 'r) query - -val nil : ('r, 'r) query -val any : ('r, 'r) query -val ( ** ) : string * 'a atom -> ('f, 'r) query -> ('a -> 'f, 'r) query - -type ('f, 'r) t - -val ( /? ) : ('f, 'x) path -> ('x, 'r) query -> ('f, 'r) t -val ( //? ) : ('f, 'x) path -> ('x, 'r) query -> ('f, 'r) t -val ( /?? ) : ('f, 'x) path -> ('x, 'r) query -> ('f, 'r) t - -(**/**) - -val keval : ('f, 'r) t -> (string -> 'r) -> 'f -val eval : ('f, string) t -> 'f - -type 'a handler = 'a Httpcats.handler -type response = Httpcats.response -type error = Httpcats.error - -val request : f:'a handler -> 'a -> ('f, (response * 'a, error) result) t -> 'f diff --git a/main.ml b/main.ml new file mode 100644 index 0000000..be58921 --- /dev/null +++ b/main.ml @@ -0,0 +1,33 @@ +#require "miou.unix" ;; +#require "mirage-crypto-rng-miou-unix" ;; +#require "vif" ;; + +open Vif + +let[@warning "-8"] index (`V1 reqd : Httpcats.Server.reqd) = + let open H1 in + let text = "Hello from an OCaml script!" in + let headers = + Headers.of_list + [ + ("content-type", "text/plain; charset=utf-8") + ; ("content-length", string_of_int (String.length text)) + ] + in + let resp = Response.create ~headers `OK in + Reqd.respond_with_string reqd resp text +;; + +let routes = + let open U in + let open R in + [ (rel /?? nil) --> index ] +;; + +let () = + Miou_unix.run @@ fun () -> + let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in + let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in + Vif.run routes sockaddr; + Mirage_crypto_rng_miou_unix.kill rng +;; diff --git a/vif.opam b/vif.opam index 0969d6a..de2bd10 100644 --- a/vif.opam +++ b/vif.opam @@ -12,9 +12,9 @@ depends: [ "fmt" "bos" "logs" - "unix" "fpath" "cmdliner" + "httpcats" ] conflicts: [ "result" {< "1.5"} ] build: [