From 7df281ec6e34da6795e6a25c741625c97f5f61f1 Mon Sep 17 00:00:00 2001
From: Romain Calascibetta <romain.calascibetta@gmail.com>
Date: Sat, 4 Jan 2025 11:19:33 +0100
Subject: [PATCH] .

---
 lib/vif/vif.ml   |  1 +
 lib/vif/vif.mli  | 69 +++++++++++++++++++++++++++++++++++++++++++++++-
 lib/vif/vif_c.ml | 21 +++++++++++++++
 lib/vif/vif_r.ml | 29 ++++++++++++++++++++
 lib/vif/vif_u.ml | 54 ++++++++++++-------------------------
 5 files changed, 136 insertions(+), 38 deletions(-)
 create mode 100644 lib/vif/vif_c.ml
 create mode 100644 lib/vif/vif_r.ml

diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml
index 45c6bbf..be90cf7 100644
--- a/lib/vif/vif.ml
+++ b/lib/vif/vif.ml
@@ -1 +1,2 @@
 module U = Vif_u
+module C = Vif_c
diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli
index 45c6bbf..317a3bc 100644
--- a/lib/vif/vif.mli
+++ b/lib/vif/vif.mli
@@ -1 +1,68 @@
-module U = Vif_u
+module U : sig
+  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
+end
+
+module C : sig
+  (** Module [C] implements the {b c}lient part of the HTTP protocol. *)
+
+  type body
+  type response
+
+  type resolver =
+    [ `Happy of Happy_eyeballs_miou_unix.t
+    | `User of Httpcats.resolver
+    | `System ]
+
+  val request :
+       ?config:[ `HTTP_1_1 of H1.Config.t | `H2 of H2.Config.t ]
+    -> ?tls_config:Tls.Config.client
+    -> ?authenticator:X509.Authenticator.t
+    -> ?meth:H1.Method.t
+    -> ?headers:(string * string) list
+    -> ?body:body
+    -> ?max_redirect:int
+    -> ?follow_redirect:bool
+    -> ?resolver:resolver
+    -> ('a, response) U.t
+    -> 'a
+
+  (** {3:example-client Examples.}
+
+      {[
+        open Vif
+
+        (* https://raw.githubusercontent.com/<org>/<repository>/refs/heads/<branch>/README.md *)
+        let readme =
+          let open U in
+          host "raw.githubusercontent.com"
+          /% Tyre.string
+          /% Tyre.string
+          / "refs"
+          / "heads"
+          /% Tyre.string
+          / "README.md"
+
+        let get_readme ?(branch = "main") ~org ~repository () =
+          C.request ~meth:`GET readme org repository branch
+      ]} *)
+end
diff --git a/lib/vif/vif_c.ml b/lib/vif/vif_c.ml
new file mode 100644
index 0000000..39467f5
--- /dev/null
+++ b/lib/vif/vif_c.ml
@@ -0,0 +1,21 @@
+type body = |
+type response = unit
+
+exception Client_error of Httpcats.error
+
+type resolver =
+  [ `Happy of Happy_eyeballs_miou_unix.t | `User of Httpcats.resolver | `System ]
+
+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 res =
+      Httpcats.request ?config ?tls_config ?authenticator ?meth ?headers
+        ?max_redirect ?follow_redirect ?resolver ~f ~uri ()
+    in
+    match res with
+    | Ok (_response, ()) -> ()
+    | Error (#Httpcats.error as err) -> raise (Client_error err)
+  in
+  Vif_u.keval t fn
diff --git a/lib/vif/vif_r.ml b/lib/vif/vif_r.ml
new file mode 100644
index 0000000..5b8d139
--- /dev/null
+++ b/lib/vif/vif_r.ml
@@ -0,0 +1,29 @@
+type 'a atom = 'a Tyre.Internal.wit
+
+let atom re = Tyre.Internal.build re
+let slash = Re.char '/'
+let comma = Re.char ','
+
+let list ?m ~component n re =
+  let open Re in
+  match component with
+  | `Path -> repn (seq [ slash; re ]) n m
+  | `Query_value ->
+      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 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)) )
+    | 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 ] ] ])
+    | e ->
+        let i', w, re = atom i e in
+        (i', w, seq [ slash; re ])
diff --git a/lib/vif/vif_u.ml b/lib/vif/vif_u.ml
index fd9db65..3676ca9 100644
--- a/lib/vif/vif_u.ml
+++ b/lib/vif/vif_u.ml
@@ -1,34 +1,26 @@
 type 'a atom = 'a Tyre.t
 
-module Types = struct
-  type ('fu, 'return) path =
-    | Host : string -> ('r, 'r) path
-    | Rel : ('r, 'r) path
-    | Path_const : ('f, 'r) path * string -> ('f, 'r) path
-    | Path_atom : ('f, 'a -> 'r) path * 'a atom -> ('f, 'r) path
+type ('fu, 'return) path =
+  | Host : string -> ('r, 'r) path
+  | Rel : ('r, 'r) path
+  | Path_const : ('f, 'r) path * string -> ('f, 'r) path
+  | Path_atom : ('f, 'a -> 'r) path * 'a atom -> ('f, 'r) path
 
-  type ('fu, 'return) query =
-    | Nil : ('r, 'r) query
-    | Any : ('r, 'r) query
-    | Query_atom : string * 'a atom * ('f, 'r) query -> ('a -> 'f, 'r) query
+type ('fu, 'return) query =
+  | Nil : ('r, 'r) query
+  | Any : ('r, 'r) query
+  | Query_atom : string * 'a atom * ('f, 'r) query -> ('a -> 'f, 'r) query
 
-  type slash = Slash | No_slash | Maybe_slash
-
-  type ('f, 'r) url =
-    | Url : slash * ('f, 'x) path * ('x, 'r) query -> ('f, 'r) url
-end
+type slash = Slash | No_slash | Maybe_slash
+type ('f, 'r) t = Url : slash * ('f, 'x) path * ('x, 'r) query -> ('f, 'r) t
 
 module Path = struct
-  type ('f, 'r) t = ('f, 'r) Types.path
-
-  open Types
-
   let host str = Host str
   let relative = Rel
   let add path str = Path_const (path, str)
   let add_atom path atom = Path_atom (path, atom)
 
-  let rec _concat : type f r x. (f, x) t -> (x, r) t -> (f, r) t =
+  let rec _concat : type f r x. (f, x) path -> (x, r) path -> (f, r) path =
    fun p1 p2 ->
     match p2 with
     | Host _ -> p1
@@ -38,20 +30,16 @@ module Path = struct
 end
 
 module Query = struct
-  type ('f, 'r) t = ('f, 'r) Types.query
-
-  open Types
-
-  let nil : _ t = Nil
+  let nil : _ query = Nil
   let any = Any
   let add n x query = Query_atom (n, x, query)
 
-  let rec make_any : type f r. (f, r) t -> (f, r) t = function
+  let rec make_any : type f r. (f, r) query -> (f, r) query = function
     | Nil -> Any
     | Any -> Any
     | Query_atom (n, x, q) -> Query_atom (n, x, make_any q)
 
-  let rec _concat : type f r x. (f, x) t -> (x, r) t -> (f, r) t =
+  let rec _concat : type f r x. (f, x) query -> (x, r) query -> (f, r) query =
    fun q1 q2 ->
     match q1 with
     | Nil -> q2
@@ -60,17 +48,9 @@ module Query = struct
 end
 
 module Url = struct
-  type ('f, 'r) t = ('f, 'r) Types.url
-
-  open Types
-
   let make ?(slash = No_slash) path query : _ t = Url (slash, path, query)
 end
 
-type ('f, 'r) path = ('f, 'r) Path.t
-type ('f, 'r) query = ('f, 'r) Query.t
-type ('f, 'r) t = ('f, 'r) Url.t
-
 let nil = Query.nil
 let any = Query.any
 let ( ** ) (n, x) q = Query.add n x q
@@ -89,7 +69,7 @@ let eval_top_atom : type a. a Tyre.Internal.raw -> a -> string list = function
   | e -> fun x -> [ eval_atom e x ]
 
 let rec eval_path : type r f.
-    (f, r) Path.t -> (string option -> string list -> r) -> f =
+    (f, r) path -> (string option -> string list -> r) -> f =
  fun p k ->
   match p with
   | Host str -> k (Some str) []
@@ -100,7 +80,7 @@ let rec eval_path : type r f.
       eval_path p fn
 
 let rec eval_query : type r f.
-    (f, r) Query.t -> ((string * string list) list -> r) -> f =
+    (f, r) query -> ((string * string list) list -> r) -> f =
  fun q k ->
   match q with
   | Nil -> k []