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