Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
182 lines (164 sloc) 6.26 KB
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 <>.
@author Laurent Le Brun
@author Cédric Soulas
@author Frederic Ye
@author David Rajchenbach-Teller
(* open Base *)
(* open Protocol *)
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 =
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="")
?(timeout=Time.seconds 36)
?err_cont ~success ~failure () =
let err_cont =
match err_cont with
| Some err_cont -> err_cont
| None -> (fun _ -> failure `Timeout)
(* check *)
let has_port =
String.contains hostname ':'
let path =
if path = "" then (
Logger.warning "[Http_client.get] the Request_URI canNOT be null.";
(* Quote from :
Note that the absolute path cannot be empty; if none is present in the original URI, it MUST be given as "/"
) else path
try `Success (Network.inet_addr_of_name hostname) with Network.Unknown_machine s -> `Unknown_machine s
| (`Unknown_machine _s) as e -> failure e
| `Success machine ->
let secure_mode =
if secure then Network.Secured (client_certificate, verify_params)
else Network.Unsecured
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"
(if auth = "" then "" else (Printf.sprintf "Authorization: %s%s" auth Base.crlf))
(if port = 80 then hostname else Printf.sprintf "%s:%d" hostname port)
(Printf.sprintf "%s%s" Base.crlf more_headers)
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> "[http_client] received\n %s" command;
match parse_response (FBuffer.contents buf) with
| `Success (((_, status), header), body) ->
match Requestdef.ResponseHeader.get_string `Content_Length header with
| Some s ->
match try Some (int_of_string s == String.length body) with Failure _ -> None
| 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))
| _ -> success (status, header, body)
| `Failure s -> failure (`Cannot_parse_response s)
#<If:TESTING $minlevel 0>
Printf.printf "%s\n" command;
#<End>; "[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
| 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
?client_certificate ?verify_params
~secure ~auth
~success:(fun (_, x, y) -> cont (x, y))
(* 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
?client_certificate ?verify_params
~secure ~auth
~more_headers ~data
~success:(fun (_, x, y) -> cont (x, y))
Something went wrong with that request. Please try again.