From ebad5b20d6846cf0ded4d0c6caf69a009e0e6dbf Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 21 Jan 2025 14:46:27 +0100 Subject: [PATCH] fix vif --- lib/vif/vif_r.ml | 72 +++++++++++++++++++++++------------------------- main.ml | 1 - 2 files changed, 34 insertions(+), 39 deletions(-) diff --git a/lib/vif/vif_r.ml b/lib/vif/vif_r.ml index 8c34a7a..317f181 100644 --- a/lib/vif/vif_r.ml +++ b/lib/vif/vif_r.ml @@ -1,7 +1,3 @@ -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 @@ -17,21 +13,21 @@ let list ?m ~component n re = if n = 0 then alt [ epsilon; seq [ re; repn (seq [ comma; re ]) 0 m ] ] else seq [ re; repn (seq [ comma; re ]) (n - 1) m ] -let atom_path : type a. int -> a Tyre.Internal.raw -> int * a atom * Re.t = +let atom_path : type a. int -> a Tyre.Internal.raw -> int * a atom * Re.t list = 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:`Path 0 (no_group re)) ) + , [ group (list ~component:`Path 0 (no_group re)) ] ) | Opt e -> let i', w, re = atom i e in let id, re = mark re in - (i', Opt (id, w), seq [ alt [ epsilon; seq [ slash; re ] ] ]) + (i', Opt (id, w), [ alt [ epsilon; seq [ slash; re ] ] ]) | e -> let i', w, re = atom i e in - (i', w, seq [ slash; re ]) + (i', w, [ slash; re ]) let atom_query : type a. int -> a Tyre.Internal.raw -> int * a atom * Re.t = let open Re in @@ -60,7 +56,7 @@ let rec path : type r f. | 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) + (i'', Path_atom (wp, wa), List.rev_append ra rp) type ('fu, 'return) query = | Nil : ('r, 'r) query @@ -68,14 +64,15 @@ type ('fu, 'return) 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, []) + (f, r) Vif_u.query + -> int * (f, r) query * bool * (string * (Re.t * int)) list = function + | Nil -> (0, Nil, false, []) + | Any -> (0, 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 total_grps, wq, b_any, rq = collect_query q in + let total_grps = total_grps + grps in + (total_grps, Cons (wa, wq), b_any, (s, (ra, grps)) :: rq) let rec shift_literals : type a. int -> a atom -> a atom = fun shift -> function @@ -114,11 +111,11 @@ let build_permutation offset count l_before l_after = 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 grps, 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) + (grps, wq, b, rel) type ('fu, 'return) t = Url : ('f, 'x) path * ('x, 'r) query -> ('f, 'r) t @@ -131,22 +128,22 @@ 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 url : type f r. int -> (f, r) Vif_u.t -> int * (f, r) t * Re.t = + fun i (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 + let idx, wp, rp = path i p in match q with - | Nil -> (Url (wp, Nil), Re.seq (List.rev (end_path :: rp))) + | Nil -> (idx, 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 ])) + (idx, Url (wp, Nil), Re.seq (List.rev_append rp [ end_path; end_re ])) | _ -> - let wq, any_query, rel = query idx q in + let grps, 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 @@ -162,9 +159,12 @@ let url : type f r. (f, r) Vif_u.t -> (f, r) t * Re.t = |> add_around_query in let re = Re.seq (List.rev_append rp (end_path :: Re.char '?' :: re)) in - (Url (wp, wq), re) + (idx + grps, Url (wp, wq), re) + +let re t = + let _, _, re = url 1 t in + re -let re t = snd (url t) let extract = Tyre.Internal.extract let rec extract_path : type f x r. @@ -209,11 +209,11 @@ let ( --> ) = route type 'r re = Re : 'f * Re.Mark.t * ('f, 'r) t -> 'r re -let rec build_info_list = function +let rec build_info_list idx = function | [] -> ([], []) | Route (t, f) :: l -> - let rel, wl = build_info_list l in - let ret, re = url t in + 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) @@ -222,21 +222,17 @@ let rec find_and_trigger : type r. fun ~original subs -> function | [] -> assert false | Re (f, id, ret) :: l -> - Log.debug (fun m -> m "original:%S subs:%a\n%!" original Re.Group.pp subs); - Log.debug (fun m -> m "recognized:%b" (Re.Mark.test subs id)); 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 rel, wl = build_info_list 1 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 -> - let bt = Printexc.get_raw_backtrace () in - Log.warn (fun m -> m "%s" (Printexc.raw_backtrace_to_string bt)); - default 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) diff --git a/main.ml b/main.ml index cbcb39d..bc33bc5 100644 --- a/main.ml +++ b/main.ml @@ -28,7 +28,6 @@ let random len server req () = let buf = Bytes.create 0x7ff in Vif.Response.with_stream server `OK @@ fun oc -> let rec go rem = - Format.printf ">>> %d\n%!" rem; if rem > 0 then begin let len = Int.min rem (Bytes.length buf) in Mirage_crypto_rng.generate_into buf len;