Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 175 lines (160 sloc) 6.272 kB
fccc685 Initial open-source release
MLstate authored
1 (*
3098bdc @Aqua-Ye [enhance] http_client,web_client: more_headers argument is now a stri…
Aqua-Ye authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
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 @author Laurent Le Brun
20 @author Cédric Soulas
21 @author Frederic Ye
22 @author David Rajchenbach-Teller
23 **)
24
3098bdc @Aqua-Ye [enhance] http_client,web_client: more_headers argument is now a stri…
Aqua-Ye authored
25 #<Debugvar:HTTP_CLIENT_DEBUG>
fccc685 Initial open-source release
MLstate authored
26
27 open Http_common
28
29 let http : NetAddr.protocol = HttpTools.http
30 let http_version = "HTTP/1.0"
31
32 let client_name = Printf.sprintf "Opa-webclient/%s" version
33
34 let parse_response str =
35 try
36 let pos, res = Request.parse_request_full_response str in
37 `Success (res, String.sub str pos (String.length str - pos))
38 with Trx_runtime.SyntaxError (pos, str) -> `Failure (Printf.sprintf "Http_client: parse response error: %s (pos:%d)" str pos)
39
40 exception Timeout
41
42 let place_request (sched: Scheduler.t) ~hostname ~port ~path
43 ?client_certificate ?verify_params
44 ?(secure=false) ~request_kind ?(auth="")
3098bdc @Aqua-Ye [enhance] http_client,web_client: more_headers argument is now a stri…
Aqua-Ye authored
45 ?(more_headers=[]) ?(data="")
fccc685 Initial open-source release
MLstate authored
46 ?(client_name=client_name)
47 ?(timeout=Time.seconds 36)
48 ?err_cont ~success ~failure () =
49 let err_cont =
50 match err_cont with
51 | Some err_cont -> err_cont
52 | None -> (fun _ -> failure `Timeout)
53 in
54 try
55 (* check *)
56 let has_port =
57 String.contains hostname ':'
58 in
59 let path =
60 if path = "" then (
61 Logger.warning "[Http_client.get] the Request_URI canNOT be null.";
62 "/"
63 (* Quote from http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html :
64 (...)
65 Note that the absolute path cannot be empty; if none is present in the original URI, it MUST be given as "/"
66 (...)
67 *)
68 ) else path
69 in
70 match
71 try `Success (Network.inet_addr_of_name hostname) with Network.Unknown_machine s -> `Unknown_machine s
72 with
73 | (`Unknown_machine _s) as e -> failure e
74 | `Success machine ->
75 let secure_mode =
76 if secure then Network.Secured (client_certificate, verify_params)
77 else Network.Unsecured
78 in
79 let port_spec = Network.make_port_spec ~protocol:http machine port in
3098bdc @Aqua-Ye [enhance] http_client,web_client: more_headers argument is now a stri…
Aqua-Ye authored
80 let command = Printf.sprintf "%s %s %s%s%sHost: %s%sUser-Agent: %s%s%s%s%s"
fccc685 Initial open-source release
MLstate authored
81 request_kind
82 path
83 http_version
84 Base.crlf
85 (if auth = "" then "" else (Printf.sprintf "Authorization: %s%s" auth Base.crlf))
86 (if port = 80 then hostname else Printf.sprintf "%s:%d" hostname port)
87 Base.crlf
88 client_name
21375f3 [fix] web_client: broken behaviour with custom headers fixed
Nicolas Glondu authored
89 Base.crlf
3098bdc @Aqua-Ye [enhance] http_client,web_client: more_headers argument is now a stri…
Aqua-Ye authored
90 (List.fold_left (
91 fun acc h -> Printf.sprintf "%s%s%s" acc h Base.crlf
92 ) "" more_headers)
93 Base.crlf
fccc685 Initial open-source release
MLstate authored
94 data
95 in
96 let start conn =
97 Scheduler.write ~timeout ~err_cont sched conn command (
98 fun _ -> Scheduler.read_all ~timeout ~err_cont sched conn (
99 fun (_, buf) ->
100 #<If:TESTING $minlevel 0>
101 Logger.info "[http_client] received\n %s" command;
102 #<End>;
103 match parse_response (FBuffer.contents buf) with
104 | `Success (((_, status), header), body) ->
105 begin
106 match Requestdef.ResponseHeader.get_string `Content_Length header with
107 | Some s ->
108 begin
42e49a9 [fix] libnet: Http_client failed to handle HEAD requests.
Thomas Refis authored
109 let len = String.length body in
110 match try Some (int_of_string s == len) with Failure _ -> None
fccc685 Initial open-source release
MLstate authored
111 with
112 | Some true -> success (status, header, body)
42e49a9 [fix] libnet: Http_client failed to handle HEAD requests.
Thomas Refis authored
113 | Some false ->
114 if (len = 0) && ("HEAD" = request_kind) then
115 success (status, header, body)
116 else
117 failure (`Cannot_parse_response (Printf.sprintf "(incorrect size %s, expected %d)" s (String.length body)))
fccc685 Initial open-source release
MLstate authored
118 | None -> failure (`Cannot_parse_response (Printf.sprintf "(invalid size %S, expected an integer)" s))
119 end
120 | _ -> success (status, header, body)
121 end
122 | `Failure s -> failure (`Cannot_parse_response s)
123 )
124 )
125 in
126 #<If:TESTING $minlevel 0>
127 Printf.printf "%s\n" command;
128 #<End>;
129 Logger.info "[http_client] %s" command;
130 if has_port then
131 Logger.warning "[Http_client] hostname contains ':' but it shouldn't, please check";
132 Network.connect sched port_spec secure_mode ~err_cont start
133 with
134 | exn -> err_cont exn
135
136 let default_failure = function
137 | `Unknown_machine m -> Logger.error "Unknown machine %s" m
138 | `Cannot_parse_response s -> Logger.error "Cannot parse response %s" s
139 | `Timeout -> Logger.error "Timeout exceeded"
140
141 let get (sched: Scheduler.t) hostname port path
142 ?client_certificate ?verify_params
143 ?(secure=false) ?(auth="")
3098bdc @Aqua-Ye [enhance] http_client,web_client: more_headers argument is now a stri…
Aqua-Ye authored
144 ?(more_headers=[]) ?err_cont ?(failure=default_failure) cont =
fccc685 Initial open-source release
MLstate authored
145 place_request sched ~hostname ~port ~path
146 ~request_kind:"GET"
147 ?client_certificate ?verify_params
148 ~secure ~auth
149 ~more_headers
150 ~client_name:client_name
151 ?err_cont
152 ~success:(fun (_, x, y) -> cont (x, y))
153 ?failure
154 ()
155
156 let post (sched: Scheduler.t) hostname port path
157 ?client_certificate ?verify_params
158 ?(secure=false) ?(auth="") mime_type
159 ?(length=(-1)) ?err_cont ?(failure=default_failure) data cont =
160 let length = if length = (-1) then String.length data else length in
3098bdc @Aqua-Ye [enhance] http_client,web_client: more_headers argument is now a stri…
Aqua-Ye authored
161 let more_headers = [
162 Printf.sprintf "Content-Length: %d" length;
163 Printf.sprintf "Content-Type: %s" mime_type;
164 ] in
fccc685 Initial open-source release
MLstate authored
165 place_request sched ~hostname ~port ~path
166 ~request_kind:"POST"
167 ?client_certificate ?verify_params
168 ~secure ~auth
169 ~more_headers ~data
170 ~client_name:client_name
171 ?err_cont
172 ~success:(fun (_, x, y) -> cont (x, y))
173 ?failure
174 ()
Something went wrong with that request. Please try again.