/
http_client.ml
178 lines (162 loc) · 6.22 KB
/
http_client.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
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA 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 Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(*
@author Laurent Le Brun
@author Cédric Soulas
@author Frederic Ye
@author David Rajchenbach-Teller
**)
#<Debugvar:TESTING>
open Http_common
let http : NetAddr.protocol = HttpTools.http
let http_version = "HTTP/1.0"
let client_name = Printf.sprintf "Opa-webclient/%s" version
let parse_response str =
try
let pos, res = Request.parse_request_full_response str in
`Success (res, String.sub str pos (String.length str - pos))
with Trx_runtime.SyntaxError (pos, str) -> `Failure (Printf.sprintf "Http_client: parse response error: %s (pos:%d)" str pos)
(* let get_dialog command = *)
(* pLet (write command) (fun _ -> *)
(* pLet read_all (fun (_, buf) -> *)
(* pDo close *)
(* (return buf))) *)
exception Timeout
let place_request (sched: Scheduler.t) ~hostname ~port ~path
?client_certificate ?verify_params
?(secure=false) ~request_kind ?(auth="")
?(more_headers="") ?(data="")
?(client_name=client_name)
?(timeout=Time.seconds 36)
?err_cont ~success ~failure () =
let err_cont =
match err_cont with
| Some err_cont -> err_cont
| None -> (fun _ -> failure `Timeout)
in
try
(* check *)
let has_port =
String.contains hostname ':'
in
let path =
if path = "" then (
Logger.warning "[Http_client.get] the Request_URI canNOT be null.";
"/"
(* Quote from http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html :
(...)
Note that the absolute path cannot be empty; if none is present in the original URI, it MUST be given as "/"
(...)
*)
) else path
in
match
try `Success (Network.inet_addr_of_name hostname) with Network.Unknown_machine s -> `Unknown_machine s
with
| (`Unknown_machine _s) as e -> failure e
| `Success machine ->
let secure_mode =
if secure then Network.Secured (client_certificate, verify_params)
else Network.Unsecured
in
let port_spec = Network.make_port_spec ~protocol:http machine port in
let command = Printf.sprintf "%s %s %s%s%sHost: %s%sUser-Agent: %s%s%s%s"
request_kind
path
http_version
Base.crlf
(if auth = "" then "" else (Printf.sprintf "Authorization: %s%s" auth Base.crlf))
(if port = 80 then hostname else Printf.sprintf "%s:%d" hostname port)
Base.crlf
client_name
(Printf.sprintf "%s%s" Base.crlf more_headers)
Base.crlf
data
in
let start conn =
Scheduler.write ~timeout ~err_cont sched conn command (
fun _ -> Scheduler.read_all ~timeout ~err_cont sched conn (
fun (_, buf) ->
#<If:TESTING $minlevel 0>
Logger.info "[http_client] received\n %s" command;
#<End>;
match parse_response (FBuffer.contents buf) with
| `Success (((_, status), header), body) ->
begin
match Requestdef.ResponseHeader.get_string `Content_Length header with
| Some s ->
begin
match try Some (int_of_string s == String.length body) with Failure _ -> None
with
| Some true -> success (status, header, body)
| Some false -> failure (`Cannot_parse_response (Printf.sprintf "(incorrect size %s, expected %d)" s (String.length body)))
| None -> failure (`Cannot_parse_response (Printf.sprintf "(invalid size %S, expected an integer)" s))
end
| _ -> success (status, header, body)
end
| `Failure s -> failure (`Cannot_parse_response s)
)
)
in
#<If:TESTING $minlevel 0>
Printf.printf "%s\n" command;
#<End>;
Logger.info "[http_client] %s" command;
if has_port then
Logger.warning "[Http_client] hostname contains ':' but it shouldn't, please check";
Network.connect sched port_spec secure_mode ~err_cont start
with
| exn -> err_cont exn
let default_failure = function
| `Unknown_machine m -> Logger.error "Unknown machine %s" m
| `Cannot_parse_response s -> Logger.error "Cannot parse response %s" s
| `Timeout -> Logger.error "Timeout exceeded"
let get (sched: Scheduler.t) hostname port path
?client_certificate ?verify_params
?(secure=false) ?(auth="")
?(more_headers="") ?err_cont ?(failure=default_failure) cont =
place_request sched ~hostname ~port ~path
~request_kind:"GET"
?client_certificate ?verify_params
~secure ~auth
~more_headers
~client_name:client_name
?err_cont
~success:(fun (_, x, y) -> cont (x, y))
?failure
()
(* let rec retry n = *)
(* if n <= 0 then failwith "Http_client: too much failures"; *)
(* Protocol.apply conn (get_dialog command) (fun res -> *)
(* match check res with *)
(* | None -> retry (n - 1) *)
(* | Some x -> cont x) *)
(* in retry 2 *)
let post (sched: Scheduler.t) hostname port path
?client_certificate ?verify_params
?(secure=false) ?(auth="") mime_type
?(length=(-1)) ?err_cont ?(failure=default_failure) data cont =
let length = if length = (-1) then String.length data else length in
let more_headers =
Printf.sprintf "Content-Length: %d%sContent-Type: %s%s" length Base.crlf mime_type Base.crlf in
place_request sched ~hostname ~port ~path
~request_kind:"POST"
?client_certificate ?verify_params
~secure ~auth
~more_headers ~data
~client_name:client_name
?err_cont
~success:(fun (_, x, y) -> cont (x, y))
?failure
()