Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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