Source file resto_json.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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
module Encoding = struct
include Json_encoding
type 'a t = 'a encoding
type schema = Json_schema.schema
let untyped = obj1 (req "untyped" string)
let conv f g t = conv ~schema:(schema t) f g t
module StringMap = Map.Make (String)
let arg_encoding =
let open Json_encoding in
conv
(fun {Resto.Arg.name; descr} -> (name, descr))
(fun (name, descr) -> {name; descr})
(obj2 (req "name" string) (opt "descr" string))
open Resto.Description
let meth_encoding =
Json_encoding.string_enum
[ ("GET", `GET);
("POST", `POST);
("DELETE", `DELETE);
("PUT", `PUT);
("PATCH", `PATCH) ]
let path_item_encoding =
let open Json_encoding in
union
[ case
string
(function PStatic s -> Some s | _ -> None)
(fun s -> PStatic s);
case
arg_encoding
(function PDynamic s -> Some s | _ -> None)
(fun s -> PDynamic s) ]
let query_kind_encoding =
let open Json_encoding in
union
[ case
(obj1 (req "single" arg_encoding))
(function Single s -> Some s | _ -> None)
(fun s -> Single s);
case
(obj1 (req "optional" arg_encoding))
(function Optional s -> Some s | _ -> None)
(fun s -> Optional s);
case
(obj1 (req "flag" empty))
(function Flag -> Some () | _ -> None)
(fun () -> Flag);
case
(obj1 (req "multi" arg_encoding))
(function Multi s -> Some s | _ -> None)
(fun s -> Multi s) ]
let query_item_encoding =
let open Json_encoding in
conv
(fun {name; description; kind} -> (name, description, kind))
(fun (name, description, kind) -> {name; description; kind})
(obj3
(req "name" string)
(opt "description" string)
(req "kind" query_kind_encoding))
let service_descr_encoding =
let open Json_encoding in
conv
(fun {meth; path; description; query; input; output; error} ->
( meth,
path,
description,
query,
( match input with
| None ->
None
| Some input ->
Some (Lazy.force input) ),
Lazy.force output,
Lazy.force error ))
(fun (meth, path, description, query, input, output, error) ->
{
meth;
path;
description;
query;
input =
( match input with
| None ->
None
| Some input ->
Some (Lazy.from_val input) );
output = Lazy.from_val output;
error = Lazy.from_val error;
})
(obj7
(req "meth" meth_encoding)
(req "path" (list path_item_encoding))
(opt "description" string)
(req "query" (list query_item_encoding))
(opt "input" any_schema)
(req "output" any_schema)
(req "erro" any_schema))
let directory_descr_encoding =
let open Json_encoding in
mu "service_tree"
@@ fun directory_descr_encoding ->
let static_subdirectories_descr_encoding =
union
[ case
(obj1
(req
"suffixes"
(list
(obj2
(req "name" string)
(req "tree" directory_descr_encoding)))))
(function
| Suffixes map -> Some (Resto.StringMap.bindings map) | _ -> None)
(fun m ->
let add acc (n, t) = Resto.StringMap.add n t acc in
Suffixes (List.fold_left add Resto.StringMap.empty m));
case
(obj1
(req
"dynamic_dispatch"
(obj2
(req "arg" arg_encoding)
(req "tree" directory_descr_encoding))))
(function Arg (ty, tree) -> Some (ty, tree) | _ -> None)
(fun (ty, tree) -> Arg (ty, tree)) ]
in
let static_directory_descr_encoding =
conv
(fun {services; subdirs} ->
let find s =
try Some (Resto.MethMap.find s services) with Not_found -> None
in
(find `GET, find `POST, find `DELETE, find `PUT, find `PATCH, subdirs))
(fun (get, post, delete, put, patch, subdirs) ->
let add meth s services =
match s with
| None ->
services
| Some s ->
Resto.MethMap.add meth s services
in
let services =
Resto.MethMap.empty
|> add `GET get
|> add `POST post
|> add `DELETE delete
|> add `PUT put
|> add `PATCH patch
in
{services; subdirs})
(obj6
(opt "get_service" service_descr_encoding)
(opt "post_service" service_descr_encoding)
(opt "delete_service" service_descr_encoding)
(opt "put_service" service_descr_encoding)
(opt "patch_service" service_descr_encoding)
(opt "subdirs" static_subdirectories_descr_encoding))
in
union
[ case
(obj1 (req "static" static_directory_descr_encoding))
(function Static descr -> Some descr | _ -> None)
(fun descr -> Static descr);
case
(obj1 (req "dynamic" (option string)))
(function Dynamic descr -> Some descr | _ -> None)
(fun descr -> Dynamic descr) ]
let description_request_encoding =
conv
(fun {recurse} -> recurse)
(function recurse -> {recurse})
(obj1 (dft "recursive" bool false))
let description_answer_encoding = directory_descr_encoding
end
module type VALUE = sig
type t
type 'a encoding
val construct : 'a encoding -> 'a -> t
val destruct : 'a encoding -> t -> 'a
end
module Ezjsonm = struct
type t = Json_repr.Ezjsonm.value
let construct enc v = Json_encoding.construct enc v
let destruct = Json_encoding.destruct
end
module Bson = struct
open Json_repr_bson
type t = Repr.value
let construct enc v = Json_encoding.construct enc v
let destruct = Json_encoding.destruct
end