Source file vif_uri.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
(* Part of this code is based on the furl project and
   Copyright (c) 2015 Gabriel Radanne <drupyo@zoho.com>
   SPDX-License-Identifier: MIT
   Copyright (c) 2025 Romain Calascibetta <romain.calascibetta@gmail.com>
*)

type ('e, 'a) atom = ('e, 'a) Tyre.t

type ('e, 'fu, 'return) path =
  | Host : string -> ('e, 'r, 'r) path
  | Rel : ('e, 'r, 'r) path
  | Path_const : ('e, 'f, 'r) path * string -> ('e, 'f, 'r) path
  | Path_atom : ('e, 'f, 'a -> 'r) path * ('e, 'a) atom -> ('e, 'f, 'r) path

type ('e, 'fu, 'return) query =
  | Nil : ('e, 'r, 'r) query
  | Any : ('e, 'r, 'r) query
  | Query_atom :
      string * ('e, 'a) atom * ('e, 'f, 'r) query
      -> ('e, 'a -> 'f, 'r) query

type slash = Slash | No_slash | Maybe_slash

type ('e, 'f, 'r) t =
  | Url : slash * ('e, 'f, 'x) path * ('e, 'x, 'r) query -> ('e, 'f, 'r) t

module Path = struct
  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 e f r x.
      (e, f, x) path -> (e, x, r) path -> (e, f, r) path =
   fun p1 p2 ->
    match p2 with
    | Host _ -> p1
    | Rel -> p1
    | Path_const (p, str) -> Path_const (_concat p1 p, str)
    | Path_atom (p, a) -> Path_atom (_concat p1 p, a)
end

module Query = struct
  let nil : _ query = Nil
  let any = Any
  let add n x query = Query_atom (n, x, query)

  let rec make_any : type e f r. (e, f, r) query -> (e, f, r) query = function
    | Nil -> Any
    | Any -> Any
    | Query_atom (n, x, q) -> Query_atom (n, x, make_any q)

  let rec _concat : type e f r x.
      (e, f, x) query -> (e, x, r) query -> (e, f, r) query =
   fun q1 q2 ->
    match q1 with
    | Nil -> q2
    | Any -> make_any q2
    | Query_atom (n, x, q) -> Query_atom (n, x, _concat q q2)
end

module Url = struct
  let make ?(slash = No_slash) path query : _ t = Url (slash, path, query)
end

let nil = Query.nil
let any = Query.any
let ( ** ) (n, x) q = Query.add n x q
let host = Path.host
let rel = Path.relative
let ( / ) = Path.add
let ( /% ) = Path.add_atom
let ( /? ) path query = Url.make ~slash:No_slash path query
let ( //? ) path query = Url.make ~slash:Slash path query
let ( /?? ) path query = Url.make ~slash:Maybe_slash path query
let eval_atom p x = Tyre.(eval (Internal.to_t p) x)

let eval_top_atom : type a.
    (Tyre.evaluable, a) Tyre.Internal.raw -> a -> string list = function
  | Opt p -> ( function None -> [] | Some x -> [ eval_atom p x ])
  | Rep p -> fun l -> List.of_seq (Seq.map (eval_atom p) l)
  | e -> fun x -> [ eval_atom e x ]

let rec eval_path : type r f.
    (Tyre.evaluable, f, r) path -> (string option -> string list -> r) -> f =
 fun p k ->
  match p with
  | Host str -> k (Some str) []
  | Rel -> k None []
  | Path_const (p, str) -> eval_path p (fun h r -> k h (str :: r))
  | Path_atom (p, a) ->
      let fn h r x = k h (eval_top_atom (Tyre.Internal.from_t a) x @ r) in
      eval_path p fn

let rec eval_query : type r f.
    (Tyre.evaluable, f, r) query -> ((string * string list) list -> r) -> f =
 fun q k ->
  match q with
  | Nil -> k []
  | Any -> k []
  | Query_atom (n, a, q) ->
      fun x ->
        let fn r = k ((n, eval_top_atom (Tyre.Internal.from_t a) x) :: r) in
        eval_query q fn

let keval : ?slash:bool -> (Tyre.evaluable, 'a, 'b) t -> (string -> 'b) -> 'a =
 fun ?slash:(force = false) (Url (slash, p, q)) k ->
  eval_path p @@ fun host path ->
  eval_query q @@ fun query ->
  let path =
    match slash with Slash -> "" :: path | No_slash | Maybe_slash -> path
  in
  let host = Option.value ~default:"" host in
  let path =
    match path with
    | [] when force -> [ ""; "" ]
    | [] -> []
    | path -> "" :: List.rev path
  in
  let path = String.concat "/" path in
  let path = Pct.encode_path path in
  let query = Pct.encode_query query in
  k (host ^ path ^ query)

let eval ?slash t = keval ?slash t Fun.id

type 'a handler = 'a Httpcats_core.handler
type response = Httpcats_core.response
type error = Httpcats_core.error

(* TODO *)
(* let request ~fn a t = keval t @@ fun uri -> Httpcats.request ~fn ~uri a *)