.

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

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]: @[<hov>" ^^ 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

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

lib/top/vif_top.ml

@@ -142,13 +142,23 @@ let load cfg str =
   Log.debug (fun m -> m "load: @[<hov>%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
 

lib/vif/dune

@@ -1,4 +1,6 @@
 (library
  (name vif)
  (public_name vif)
+ (flags
+  (:standard -linkall))
  (libraries httpcats tyre))

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 =

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

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

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

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

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

lib/vif/vif_u.mli

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

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

vif.opam

@@ -12,9 +12,9 @@ depends: [
   "fmt"
   "bos"
   "logs"
-  "unix"
   "fpath"
   "cmdliner"
+  "httpcats"
 ]
 conflicts: [ "result" {< "1.5"} ]
 build: [