Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 511 lines (477 sloc) 14.094 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 (**)
20
21 exception Parsing of string
22
23 type request_header =
24 [ `Cache_Control
25 | `Connection
26 | `Date
27 | `Pragma
28 | `Trailer
29 | `Transfer_Encoding
30 | `Upgrade
31 | `Via
32 | `Warning
33 | `Allow
34 | `Content_Encoding
35 | `Content_Language
36 | `Content_Length
37 | `Content_Location
38 | `Content_MD5
39 | `Content_Range
40 | `Content_Type
41 | `Content_Disposition
42 | `Expires
43 | `Last_Modified
44 | `Accept
45 | `Accept_Charset
46 | `Accept_Encoding
47 | `Accept_Language
48 | `Authorization
49 | `Expect
50 | `From
51 | `Host
52 | `If_Match
53 | `If_Modified_Since
54 | `If_None_Match
55 | `If_Range
56 | `If_Unmodified_Since
57 | `Max_Forwards
58 | `Proxy_Authorization
59 | `ReqRange
60 | `Referer
61 | `TE
62 | `User_Agent
63 | `Cookie
64 | `NewCookie (* inserted by read (only on first connection) *)
65 ]
66
67
68 let string_of_request_header = function
69 | `Cache_Control -> "Cache-Control"
70 | `Connection -> "Connection"
71 | `Date -> "Date"
72 | `Pragma -> "Pragma"
73 | `Trailer -> "Trailer"
74 | `Transfer_Encoding -> "Transfer-Encoding"
75 | `Upgrade -> "Upgrade"
76 | `Via -> "Via"
77 | `Warning -> "Warning"
78 | `Allow -> "Allow"
79 | `Content_Encoding -> "Content-Encoding"
80 | `Content_Language -> "Content-Language"
81 | `Content_Length -> "Content-Length"
82 | `Content_Location -> "Content-Location"
83 | `Content_MD5 -> "Content-MD5"
84 | `Content_Range -> "Content-Range"
85 | `Content_Type -> "Content-Type"
86 | `Content_Disposition -> "Content-Disposition"
87 | `Expires -> "Expires"
88 | `Last_Modified -> "Last-Modified"
89 | `Accept -> "Accept"
90 | `Accept_Charset -> "Accept-Charset"
91 | `Accept_Encoding -> "Accept-Encoding"
92 | `Accept_Language -> "Accept-Language"
93 | `Authorization -> "Authorization"
94 | `Expect -> "Expect"
95 | `From -> "From"
96 | `Host -> "Host"
97 | `If_Match -> "If-Match"
98 | `If_Modified_Since -> "If-Modified-Since"
99 | `If_None_Match -> "If-None-Match"
100 | `If_Range -> "If-Range"
101 | `If_Unmodified_Since -> "If-Unmodified-Since"
102 | `Max_Forwards -> "Max-Forwards"
103 | `Proxy_Authorization -> "Proxy-Authorization"
104 | `ReqRange -> "ReqRange"
105 | `Referer -> "Referer"
106 | `TE -> "TE"
107 | `User_Agent -> "User-Agent"
108 | `Cookie -> "Cookie"
109 | `NewCookie -> "NewCookie"
110
111 let request_header_of_string = function
112 | "Cache-Control" -> `Cache_Control
113 | "Connection" -> `Connection
114 | "Date" -> `Date
115 | "Pragma" -> `Pragma
116 | "Trailer" -> `Trailer
117 | "Transfer-Encoding" -> `Transfer_Encoding
118 | "Upgrade" -> `Upgrade
119 | "Via" -> `Via
120 | "Warning" -> `Warning
121 | "Allow" -> `Allow
122 | "Content-Encoding" -> `Content_Encoding
123 | "Content-Language" -> `Content_Language
124 | "Content-Length" -> `Content_Length
125 | "Content-Location" -> `Content_Location
126 | "Content-MD5" -> `Content_MD5
127 | "Content-Range" -> `Content_Range
128 | "Content-Type" -> `Content_Type
129 | "Content-Disposition" -> `Content_Disposition
130 | "Expires" -> `Expires
131 | "Last-Modified" -> `Last_Modified
132 | "Accept" -> `Accept
133 | "Accept-Charset" -> `Accept_Charset
134 | "Accept-Encoding" -> `Accept_Encoding
135 | "Accept-Language" -> `Accept_Language
136 | "Authorization" -> `Authorization
137 | "Expect" -> `Expect
138 | "From" -> `From
139 | "Host" -> `Host
140 | "If-Match" -> `If_Match
141 | "If-Modified-Since" -> `If_Modified_Since
142 | "If-None-Match" -> `If_None_Match
143 | "If-Range" -> `If_Range
144 | "If-Unmodified-Since" -> `If_Unmodified_Since
145 | "Max-Forwards" -> `Max_Forwards
146 | "Proxy-Authorization" -> `Proxy_Authorization
147 | "ReqRange" -> `ReqRange
148 | "Referer" -> `Referer
149 | "TE" -> `TE
150 | "User-Agent" -> `User_Agent
151 | "Cookie" -> `Cookie
152 | "NewCookie" -> `NewCookie
153 | _ -> raise (Parsing "request_header")
154
155 let request_header_of_string_safe s =
156 try Some (request_header_of_string s) with
157 | Parsing _ -> None
158
159 type response_header =
160 [ `Cache_Control
161 | `Connection
162 | `Date
163 | `Pragma
164 | `Trailer
165 | `Transfer_Encoding
166 | `Upgrade
167 | `Via
168 | `Warning
169 | `Allow
170 | `Content_Encoding
171 | `Content_Language
172 | `Content_Length
173 | `Content_Location
174 | `Content_MD5
175 | `Content_Range
176 | `Content_Type
177 | `Content_Disposition
178 | `Expires
179 | `Last_Modified
180 | `Accept_Ranges
181 | `Age
182 | `ETag
183 | `Location
184 | `Proxy_Authenticate
185 | `Retry_After
186 | `Server
187 | `Vary
188 | `WWW_Authenticate
189 | `Set_Cookie
190 | `Set_Cookie_External
191 | `Set_Cookie_Internal
192 ]
193
194 let string_of_response_header = function
195 | `Cache_Control -> "Cache-Control"
196 | `Connection -> "Connection"
197 | `Date -> "Date"
198 | `Pragma -> "Pragma"
199 | `Trailer -> "Trailer"
200 | `Transfer_Encoding -> "Transfer-Encoding"
201 | `Upgrade -> "Upgrade"
202 | `Via -> "Via"
203 | `Warning -> "Warning"
204 | `Allow -> "Allow"
205 | `Content_Encoding -> "Content-Encoding"
206 | `Content_Language -> "Content-Language"
207 | `Content_Length -> "Content-Length"
208 | `Content_Location -> "Content-Location"
209 | `Content_MD5 -> "Content-MD5"
210 | `Content_Range -> "Content-Range"
211 | `Content_Type -> "Content-Type"
212 | `Content_Disposition -> "Content-Disposition"
213 | `Expires -> "Expires"
214 | `Last_Modified -> "Last-Modified"
215 | `Accept_Ranges -> "Accept-Ranges"
216 | `Age -> "Age"
217 | `ETag -> "ETag"
218 | `Location -> "Location"
219 | `Proxy_Authenticate -> "Proxy-Authenticate"
220 | `Retry_After -> "Retry-After"
221 | `Server -> "Server"
222 | `Vary -> "Vary"
223 | `WWW_Authenticate -> "WWW-Authenticate"
224 | `Set_Cookie -> "Set-Cookie"
225 | `Set_Cookie_External -> "Set-Cookie"
226 | `Set_Cookie_Internal -> "Set-Cookie"
227
228 let response_header_of_string = function
229 | "Cache-Control" -> `Cache_Control
230 | "Connection" -> `Connection
231 | "Date" -> `Date
232 | "Pragma" -> `Pragma
233 | "Trailer" -> `Trailer
234 | "Transfer-Encoding" -> `Transfer_Encoding
235 | "Upgrade" -> `Upgrade
236 | "Via" -> `Via
237 | "Warning" -> `Warning
238 | "Allow" -> `Allow
239 | "Content-Encoding" -> `Content_Encoding
240 | "Content-Language" -> `Content_Language
241 | "Content-Length" -> `Content_Length
242 | "Content-Location" -> `Content_Location
243 | "Content-MD5" -> `Content_MD5
244 | "Content-Range" -> `Content_Range
245 | "Content-Type" -> `Content_Type
246 | "Content-Disposition" -> `Content_Disposition
247 | "Expires" -> `Expires
248 | "Last-Modified" -> `Last_Modified
249 | "Accept-Ranges" -> `Accept_Ranges
250 | "Age" -> `Age
251 | "ETag" -> `ETag
252 | "Location" -> `Location
253 | "Proxy-Authenticate" -> `Proxy_Authenticate
254 | "Retry-After" -> `Retry_After
255 | "Server" -> `Server
256 | "Vary" -> `Vary
257 | "WWW-Authenticate" -> `WWW_Authenticate
258 | "Set-Cookie" -> `Set_Cookie
259 | _ -> raise (Parsing "response_header")
260
261 let response_header_of_string_safe s =
262 try Some (response_header_of_string s) with
263 | Parsing _ -> None
264
265 type _method =
266 | Options
267 | Get
268 | Head
269 | Post
270 | Put
271 | Delete
272 | Trace
273 | Connect
274 let string_of_method = function
275 | Options -> "OPTIONS"
276 | Get -> "GET"
277 | Head -> "HEAD"
278 | Post -> "POST"
279 | Put -> "PUT"
280 | Delete -> "DELETE"
281 | Trace -> "TRACE"
282 | Connect -> "CONNECT"
283 let method_of_string s = match String.uppercase s with
284 | "OPTIONS" -> Options
285 | "GET" -> Get
286 | "HEAD" -> Head
287 | "POST" -> Post
288 | "PUT" -> Put
289 | "DELETE" -> Delete
290 | "TRACE" -> Trace
291 | "CONNECT" -> Connect
292 | _ -> failwith "method_of_string"
293
294
295 (* FIXME: générer automatiquement... type classes ;) *)
296 module Order_request_header : (Map.OrderedType with type t = request_header) =
297 struct type t = request_header let compare (a:request_header) b = Pervasives.compare a b end
298 module Order_response_header : (Map.OrderedType with type t = response_header) =
299 struct type t = response_header let compare (a:response_header) b = Pervasives.compare a b end
300
301 module Value =
302 struct
303 (* FIXME: type 'a parsed = Unparsed of string | Parse of 'a *)
304 type value =
305 [ `string of string
306 | `value of (string * string option) list
307 ]
308 let sprint_value (a, b) = Printf.sprintf "%s%s" a (match b with Some s -> Printf.sprintf ";%s" s | _ -> "")
309 let to_string = function
310 | `string s -> s
311 | `value [] -> ""
312 | `value (hd::tl) ->
313 List.fold_left (
314 fun acc ab -> Printf.sprintf "%s,%s" acc (sprint_value ab)
315 ) (sprint_value hd) tl
316
317 (* let first_value = function
318 | `string s -> s
319 | `value v -> fst (List.hd v) *)
320 end
321
322 module MakeHeader (Order : Map.OrderedType) =
323 struct
324 module HMap = Map.Make (Order)
325 include HMap
326 type header = Value.value t
327 let add_string k v = add k (`string v)
328 let get k t = if mem k t then Some (find k t) else None
329 let get_string k t = if mem k t then Some (Value.to_string (find k t)) else None
330 let remove k t = remove k t
331 let to_string f t = (* FIXME: Tune 128... de manière globale sur l'ensemble de l'application... *)
332 FBuffer.contents (
333 fold (fun k v b -> FBuffer.add b (Printf.sprintf "%s: %s%s" (f k) (Value.to_string v) Base.crlf))
334 t (FBuffer.create ~name:"MakeHeader.to_string" 128)
335 )
336 let keys t =
337 HMap.fold (fun k _ acc -> k::acc) t []
338
339 (** parse une ligne de request header *)
340 let parse f header l =
341 let rec aux header remainder = function
342 | [] -> header, remainder
343 | ((x, y) as hd)::tl ->
344 begin try (* ajoute le champ reconnu par f au header *)
345 aux (add (f x) y header) remainder tl
346 with (Parsing _) -> (* champ non reconnu par f *)
347 aux header (hd::remainder) tl end
348 in
349 aux header [] l
350 end
351
352 module RequestHeader = MakeHeader (Order_request_header)
353 module ResponseHeader = MakeHeader (Order_response_header)
354
355 (* --------------------- types de webserve ---------------------- *)
356
357 type request_line =
358 { _method : _method
359 ; request_uri : string
360 ; http_version : string }
361
362 type server_info =
363 { server_url : string
364 ; server_id : int }
365
366 type request =
367 { request_line : request_line
368 ; request_header : RequestHeader.header
369 ; request_message_body : string (* use FBuffer ? *)
370 ; server_info : server_info option }
371
372 type status =
373 | SC_Continue
374 | SC_SwitchingProtocols
375 | SC_OK
376 | SC_Created
377 | SC_Accepted
378 | SC_Non_AuthoritativeInformation
379 | SC_NoContent
380 | SC_ResetContent
381 | SC_PartialContent
382 | SC_MultipleChoices
383 | SC_MovedPermanently
384 | SC_Found
385 | SC_SeeOther
386 | SC_NotModified
387 | SC_UseProxy
388 | SC_TemporaryRedirect
389 | SC_BadRequest
390 | SC_Unauthorized
391 | SC_PaymentRequired
392 | SC_Forbidden of string option
393 | SC_NotFound
394 | SC_MethodNotAllowed
395 | SC_NotAcceptable
396 | SC_ProxyAuthenticationRequired
397 | SC_RequestTime_out
398 | SC_Conflict
399 | SC_Gone
400 | SC_LengthRequired
401 | SC_PreconditionFailed
402 | SC_RequestEntityTooLarge
403 | SC_Request_URITooLarge
404 | SC_UnsupportedMediaType
405 | SC_RequestedRangeNotSatisfiable
406 | SC_ExpectationFailed
407 | SC_InternalServerError
408 | SC_NotImplemented
409 | SC_BadGateway
410 | SC_ServiceUnavailable
411 | SC_GatewayTime_out
412 | SC_HTTPVersionNotSupported
413 (* | extension-code, extension-code = 3DIGIT *)
414
415 let status_code = function
416 | SC_Continue -> 100
417 | SC_SwitchingProtocols -> 101
418 | SC_OK -> 200
419 | SC_Created -> 201
420 | SC_Accepted -> 202
421 | SC_Non_AuthoritativeInformation -> 203
422 | SC_NoContent -> 204
423 | SC_ResetContent -> 205
424 | SC_PartialContent -> 206
425 | SC_MultipleChoices -> 300
426 | SC_MovedPermanently -> 301
427 | SC_Found -> 302
428 | SC_SeeOther -> 303
429 | SC_NotModified -> 304
430 | SC_UseProxy -> 305
431 | SC_TemporaryRedirect -> 307
432 | SC_BadRequest -> 400
433 | SC_Unauthorized -> 401
434 | SC_PaymentRequired -> 402
435 | SC_Forbidden _ -> 403
436 | SC_NotFound -> 404
437 | SC_MethodNotAllowed -> 405
438 | SC_NotAcceptable -> 406
439 | SC_ProxyAuthenticationRequired -> 407
440 | SC_RequestTime_out -> 408
441 | SC_Conflict -> 409
442 | SC_Gone -> 410
443 | SC_LengthRequired -> 411
444 | SC_PreconditionFailed -> 412
445 | SC_RequestEntityTooLarge -> 413
446 | SC_Request_URITooLarge -> 414
447 | SC_UnsupportedMediaType -> 415
448 | SC_RequestedRangeNotSatisfiable -> 416
449 | SC_ExpectationFailed -> 417
450 | SC_InternalServerError -> 500
451 | SC_NotImplemented -> 501
452 | SC_BadGateway -> 502
453 | SC_ServiceUnavailable -> 503
454 | SC_GatewayTime_out -> 504
455 | SC_HTTPVersionNotSupported -> 505
456
457 let reason_phrase = function (* *<TEXT, excluding CR, LF> *)
458 | 100 -> "Continue"
459 | 101 -> "Switching Protocols"
460 | 200 -> "OK"
461 | 201 -> "Created"
462 | 202 -> "Accepted"
463 | 203 -> "Non-Authoritative Information"
464 | 204 -> "No Content"
465 | 205 -> "Reset Content"
466 | 206 -> "Partial Content"
467 | 300 -> "Multiple Choices"
468 | 301 -> "Moved Permanently"
469 | 302 -> "Found"
470 | 303 -> "See Other"
471 | 304 -> "Not Modified"
472 | 305 -> "Use Proxy"
473 | 307 -> "Temporary Redirect"
474 | 400 -> "Bad Request"
475 | 401 -> "Unauthorized"
476 | 402 -> "Payment Required"
477 | 403 -> "Forbidden"
478 | 404 -> "Not Found"
479 | 405 -> "Method Not Allowed"
480 | 406 -> "Not Acceptable "
481 | 407 -> "Proxy Authentication Required"
482 | 408 -> "Request Time-out"
483 | 409 -> "Conflict"
484 | 410 -> "Gone"
485 | 411 -> "Length Required"
486 | 412 -> "Precondition Failed"
487 | 413 -> "Request Entity Too Large"
488 | 414 -> "Request-URI Too Large"
489 | 415 -> "Unsupported Media Type"
490 | 416 -> "Requested range not satisfiable"
491 | 417 -> "Expectation Failed"
492 | 500 -> "Internal Server Error"
493 | 501 -> "Not Implemented"
494 | 502 -> "Bad Gateway"
495 | 503 -> "Service Unavailable"
496 | 504 -> "Gateway Time-out"
497 | 505 -> "HTTP Version not supported"
498 | _ -> failwith "reason_phrase"
499
500 (** V2: WIP *)
501
502 type req_body =
503 | Buffer of string
504 | TmpFile of string
505
506 type request2 =
507 { request_line2 : request_line
508 ; request_header2 : RequestHeader.header
509 ; request_message_body2 : req_body
510 ; server_info2 : server_info option }
Something went wrong with that request. Please try again.