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
|
(*
OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
Copyright (C) <2002-2007> Stefano Zacchiroli <zack@cs.unibo.it>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as
published by the Free Software Foundation, version 2.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)
open Printf;;
open Http_common;;
open Http_types;;
let debug_dump_request path params =
debug_print ("request path = " ^ path);
debug_print (
sprintf"request params = %s"
(String.concat ";"
(List.map (fun (h,v) -> String.concat "=" [h;v]) params)))
let auth_sep_RE = Pcre.regexp ":"
let basic_auth_RE = Pcre.regexp "^Basic\\s+"
exception Fallback;; (* used internally by request class *)
class request ic =
let (meth, uri, version) = Http_parser.parse_request_fst_line ic in
let uri_str = Neturl.string_of_url uri in
let path = Http_parser.parse_path uri in
let query_get_params = Http_parser.parse_query_get_params uri in
let (headers, body) =
(match version with
| None -> [], "" (* No version given, use request's 1st line only *)
| Some version -> (* Version specified, parse also headers and body *)
let headers =
List.map (* lowercase header names to ease lookups before having a
request object *)
(fun (h,v) -> (String.lowercase_ascii h, v))
(Http_parser.parse_headers ic) (* trailing \r\n consumed! *)
in
let body =
(* TODO fallback on size defined in Transfer-Encoding if
Content-Length isn't defined *)
match meth with
| `POST | `PUT | `TRACE ->
Buffer.contents
(try (* read only Content-Length bytes *)
let limit_raw =
(try
List.assoc "content-length" headers
with Not_found -> raise Fallback)
in
let limit =
(try (* TODO supports only a maximum content-length of 1Gb *)
int_of_string limit_raw
with Failure "int_of_string" ->
raise (Invalid_header ("content-length: " ^ limit_raw)))
in
Http_misc.buf_of_inchan ~limit ic
with Fallback -> Http_misc.buf_of_inchan ic) (* read until EOF *)
| _ ->
""
in
(headers, body))
in
let cookies =
try
let _hdr, raw_cookies =
List.find
(fun (hdr, _cookie) -> String.lowercase_ascii hdr = "cookie")
headers
in
Some (Http_parser.parse_cookies raw_cookies)
with
| Not_found -> None
| Malformed_cookies _ -> None
in
let query_post_params =
match meth with
| `POST ->
let ct = try List.assoc "content-type" headers with Not_found -> "" in
if ct = "application/x-www-form-urlencoded" then
Http_parser.split_query_params body
else []
| _ -> []
in
let params = query_post_params @ query_get_params in (* prefers POST params *)
let _ = debug_dump_request path params in
let (clisockaddr, srvsockaddr) =
(Http_misc.peername_of_in_channel ic, Http_misc.sockname_of_in_channel ic)
in
object (self)
inherit
Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
val params_tbl =
let tbl = Hashtbl.create (List.length params) in
List.iter (fun (n,v) -> Hashtbl.add tbl n v) params;
tbl
method meth = meth
method uri = uri_str
method path = path
method param ?(meth: meth option) ?(default: string option) name =
try
(match meth with
| None -> Hashtbl.find params_tbl name
| Some `GET -> List.assoc name query_get_params
| Some `HEAD -> List.assoc name query_get_params
| Some `PUT -> List.assoc name query_get_params
| Some `DELETE -> List.assoc name query_get_params
| Some `OPTIONS -> List.assoc name query_get_params
| Some `TRACE -> List.assoc name query_get_params
| Some `POST -> List.assoc name query_post_params)
with Not_found ->
(match default with
| None -> raise (Param_not_found name)
| Some value -> value)
method paramAll ?meth name =
(match (meth: meth option) with
| None -> List.rev (Hashtbl.find_all params_tbl name)
| Some `GET -> Http_misc.list_assoc_all name query_get_params
| Some `HEAD -> Http_misc.list_assoc_all name query_get_params
| Some `PUT -> Http_misc.list_assoc_all name query_get_params
| Some `DELETE -> Http_misc.list_assoc_all name query_get_params
| Some `OPTIONS -> Http_misc.list_assoc_all name query_get_params
| Some `TRACE -> Http_misc.list_assoc_all name query_get_params
| Some `POST -> Http_misc.list_assoc_all name query_post_params)
method params = params
method params_GET = query_get_params
method params_POST = query_post_params
method cookies = cookies
method private fstLineToString =
let method_string = string_of_method self#meth in
match self#version with
| Some version ->
sprintf "%s %s %s" method_string self#uri (string_of_version version)
| None -> sprintf "%s %s" method_string self#uri
method authorization: auth_info option =
try
let credentials =
Netencoding.Base64.decode
(Pcre.replace ~rex:basic_auth_RE (self#header "authorization"))
in
debug_print ("HTTP Basic auth credentials: " ^ credentials);
(match Pcre.split ~rex:auth_sep_RE credentials with
| [username; password] -> Some (`Basic (username, password))
| l -> raise Exit)
with Header_not_found _ | Invalid_argument _ | Exit -> None
end
|
