-
-
Notifications
You must be signed in to change notification settings - Fork 124
/
dream.ml
436 lines (303 loc) · 9.1 KB
/
dream.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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
(* This file is part of Dream, released under the MIT license. See LICENSE.md
for details, or visit https://github.com/aantron/dream.
Copyright 2021 Anton Bachin *)
module Catch = Dream__server.Catch
module Cipher = Dream__cipher.Cipher
module Cookie = Dream__server.Cookie
module Content_length = Dream__server.Content_length
module Csrf = Dream__server.Csrf
module Echo = Dream__server.Echo
module Error_handler = Dream__http.Error_handler
module Flash = Dream__server.Flash
module Form = Dream__server.Form
module Formats = Dream_pure.Formats
module Graphql = Dream__graphql.Graphql
module Helpers = Dream__server.Helpers
module Http = Dream__http.Http
module Lowercase_headers = Dream__server.Lowercase_headers
module Message = Dream_pure.Message
module Method = Dream_pure.Method
module Origin_referrer_check = Dream__server.Origin_referrer_check
module Query = Dream__server.Query
module Random = Dream__cipher.Random
module Router = Dream__server.Router
module Site_prefix = Dream__server.Site_prefix
module Sql = Dream__sql.Sql
module Sql_session = Dream__sql.Session
module Static = Dream__unix.Static
module Status = Dream_pure.Status
module Stream = Dream_pure.Stream
module Tag = Dream__server.Tag
module Upload = Dream__server.Upload
(* Initialize clock handling and random number generator. These are
platform-specific, differing between Unix and Mirage. This is the Unix
initialization. *)
module Log =
struct
include Dream__server.Log
include Dream__server.Log.Make (Ptime_clock)
end
let default_log =
Log.sub_log (Logs.Src.name Logs.default)
let () =
Log.initialize ~setup_outputs:Fmt_tty.setup_std_outputs
let now () =
Ptime.to_float_s (Ptime.v (Ptime_clock.now_d_ps ()))
let () =
Random.initialize Mirage_crypto_rng_lwt.initialize
module Session =
struct
include Dream__server.Session
include Dream__server.Session.Make (Ptime_clock)
end
(* Types *)
type request = Message.request
type response = Message.response
type handler = Message.handler
type middleware = Message.middleware
type route = Router.route
type 'a message = 'a Message.message
type client = Message.client
type server = Message.server
type 'a promise = 'a Message.promise
(* Methods *)
include Method
(* Status codes *)
include Status
(* Requests *)
let client = Helpers.client
let https = Helpers.https
let method_ = Message.method_
let target = Message.target
let prefix = Router.prefix
let path = Router.path
let version = Message.version
let set_client = Helpers.set_client
let set_method_ = Message.set_method_
let query = Query.query
let queries = Query.queries
let all_queries = Query.all_queries
(* Responses *)
let response = Helpers.response_with_body
let respond = Helpers.respond
let html = Helpers.html
let json = Helpers.json
let redirect = Helpers.redirect
let empty = Helpers.empty
let stream = Helpers.stream
let websocket = Helpers.websocket
let status = Message.status
(* Headers *)
let header = Message.header
let headers = Message.headers
let all_headers = Message.all_headers
let has_header = Message.has_header
let add_header = Message.add_header
let drop_header = Message.drop_header
let set_header = Message.set_header
(* Cookies *)
let set_cookie = Cookie.set_cookie
let drop_cookie = Cookie.drop_cookie
let cookie = Cookie.cookie
let all_cookies = Cookie.all_cookies
(* Bodies *)
let body = Message.body
let set_body = Message.set_body
let read = Message.read
let write = Message.write
let flush = Message.flush
let close = Message.close
type buffer = Stream.buffer
type stream = Stream.stream
let client_stream = Message.client_stream
let server_stream = Message.server_stream
let set_client_stream = Message.set_client_stream
let set_server_stream = Message.set_server_stream
let read_stream = Stream.read
let ready_stream = Stream.ready
let write_stream = Stream.write
let flush_stream = Stream.flush
let ping_stream = Stream.ping
let pong_stream = Stream.pong
let close_stream = Stream.close
let abort_stream = Stream.abort
(* JSON *)
let origin_referrer_check = Origin_referrer_check.origin_referrer_check
(* Forms *)
type 'a form_result = 'a Form.form_result
let form = Form.form ~now
type multipart_form = Upload.multipart_form
let multipart = Upload.multipart ~now
type part = Upload.part
let upload = Upload.upload
let upload_part = Upload.upload_part
type csrf_result = Csrf.csrf_result
let csrf_token = Csrf.csrf_token ~now
let verify_csrf_token = Csrf.verify_csrf_token ~now
(* Templates *)
let form_tag ?method_ ?target ?enctype ?csrf_token ~action request =
Tag.form_tag ~now ?method_ ?target ?enctype ?csrf_token ~action request
(* Middleware *)
let no_middleware = Message.no_middleware
let pipeline = Message.pipeline
(* Routing *)
let router = Router.router
let get = Router.get
let post = Router.post
let put = Router.put
let delete = Router.delete
let head = Router.head
let connect = Router.connect
let options = Router.options
let trace = Router.trace
let patch = Router.patch
let any = Router.any
let not_found = Helpers.not_found
let param = Router.param
let scope = Router.scope
let no_route = Router.no_route
(* Static files *)
let static = Static.static
let from_filesystem = Static.from_filesystem
let mime_lookup = Static.mime_lookup
(* Sessions *)
let session = Session.session
let put_session = Session.put_session
let all_session_values = Session.all_session_values
let invalidate_session = Session.invalidate_session
let memory_sessions = Session.memory_sessions
let cookie_sessions = Session.cookie_sessions
let sql_sessions = Sql_session.sql_sessions
let session_id = Session.session_id
let session_label = Session.session_label
let session_expires_at = Session.session_expires_at
(* Flash messages *)
let flash_messages = Flash.flash_messages
let flash = Flash.flash
let put_flash = Flash.put_flash
(* GraphQL *)
let graphql = Graphql.graphql
let graphiql = Graphql.graphiql
(* SQL *)
let sql_pool = Sql.sql_pool
let sql = Sql.sql
(* Logging *)
let logger = Log.logger
let log = Log.convenience_log
type ('a, 'b) conditional_log = ('a, 'b) Log.conditional_log
type log_level = Log.log_level
let error = default_log.error
let warning = default_log.warning
let info = default_log.info
let debug = default_log.debug
type sub_log = Log.sub_log = {
error : 'a. ('a, unit) conditional_log;
warning : 'a. ('a, unit) conditional_log;
info : 'a. ('a, unit) conditional_log;
debug : 'a. ('a, unit) conditional_log;
}
let sub_log = Log.sub_log
let initialize_log = Log.initialize_log
let set_log_level = Log.set_log_level
(* Errors *)
type error = Catch.error = {
condition : [
| `Response of Message.response
| `String of string
| `Exn of exn
];
layer : [
| `App
| `HTTP
| `HTTP2
| `TLS
| `WebSocket
];
caused_by : [
| `Server
| `Client
];
request : Message.request option;
response : Message.response option;
client : string option;
severity : Log.log_level;
will_send_response : bool;
}
type error_handler = Catch.error_handler
let error_template = Error_handler.customize
let debug_error_handler = Error_handler.debug_error_handler
let catch = Catch.catch
(* Servers *)
let run = Http.run
let serve = Http.serve
let lowercase_headers = Lowercase_headers.lowercase_headers
let content_length = Content_length.content_length
let with_site_prefix = Site_prefix.with_site_prefix
(* Web formats *)
include Formats
(* Cryptography *)
let set_secret = Cipher.set_secret
let random = Random.random
let encrypt = Cipher.encrypt
let decrypt = Cipher.decrypt
(* Custom fields *)
type 'a field = 'a Message.field
let new_field = Message.new_field
let field = Message.field
let set_field = Message.set_field
(* Testing. *)
let request = Helpers.request_with_body
(* TODO Restore the ability to test with a prefix and re-enable the
corresponding tests. *)
let test ?(prefix = "") handler request =
let app =
Content_length.content_length
@@ Site_prefix.with_site_prefix prefix
@@ handler
in
Lwt_main.run (app request)
let sort_headers = Message.sort_headers
let echo = Echo.echo
(* Deprecated helpers. *)
let with_client client message =
Helpers.set_client message client;
message
let with_method_ method_ message =
Message.set_method_ message method_;
message
let with_version version message =
Message.set_version message version;
message
let with_path path message =
Router.set_path message path;
message
let with_header name value message =
Message.set_header message name value;
message
let with_body body message =
Message.set_body message body;
message
let with_stream message =
message
let write_buffer ?(offset = 0) ?length message chunk =
let length =
match length with
| Some length -> length
| None -> Bigstringaf.length chunk - offset
in
let string = Bigstringaf.substring chunk ~off:offset ~len:length in
write ~kind:`Binary message string
type websocket = Message.response
let send = write
let receive = read
let close_websocket = close
type 'a local = 'a Message.field
let new_local = Message.new_field
let local = Message.field
let with_local key value message =
Message.set_field message key value;
message
let first message =
message
let last message =
message