(* $Id: http_client.ml 1999 2014-08-24 21:34:18Z gerd $
* ----------------------------------------------------------------------
*
*)
(* TODO:
- Also support automatic compression of uploads. Be prepared to get
a 415 response, and fall back to [identity] (or whatever is available)
Plan:
* message: set_content_encoding
* message, private-api: allow automatic compression in open_value_rd
* Uq_io: implement filter_in_buffer
* postprocess: intercept 415 responses, and choose a different
encoding
*)
(* Reference documents:
* RFC 2068, 2616: HTTP 1.1
* RFC 2069, 2617: Digest Authentication
*)
module Debug = struct
let enable = ref false
end
let dlog = Netlog.Debug.mk_dlog "Http_client" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Http_client" Debug.enable
let () =
Netlog.Debug.register_module "Http_client" Debug.enable
open Http_client_conncache
open Printf
open Uq_engines.Operators
exception Bad_message of string;;
exception Http_error of (int * string);;
exception Http_protocol of exn;;
exception Proxy_error of int
exception No_reply;;
exception Too_many_redirections;;
exception Name_resolution_error = Uq_resolver.Host_not_found
exception URL_syntax_error of string
exception Timeout of string
exception Response_too_large
let () =
Netexn.register_printer
(Http_protocol Not_found)
(fun e ->
match e with
| Http_protocol e' ->
"Http_client.Http_protocol(" ^ Netexn.to_string e' ^ ")"
| _ ->
assert false
)
let() =
Netsys_signal.init()
type status =
[ `Unserved
| `Http_protocol_error of exn
| `Successful
| `Redirection
| `Client_error
| `Server_error
]
type response_body_storage =
[ `Memory
| `File of unit -> string
| `Body of unit -> Netmime.mime_body
| `Device of unit -> Uq_io.out_device
]
type 'message_class how_to_reconnect =
Send_again
| Request_fails
| Inquire of ('message_class -> bool)
| Send_again_if_idem
;;
type 'message_class how_to_redirect =
Redirect
| Do_not_redirect
| Redirect_inquire of ('message_class -> bool)
| Redirect_if_idem
;;
type resolver =
Unixqueue.unix_event_system ->
string ->
(Unix.inet_addr option -> unit) ->
unit
;;
type counters =
{ mutable new_connections : int;
mutable timed_out_connections : int;
mutable crashed_connections: int;
mutable server_eof_connections : int;
mutable successful_connections : int;
mutable failed_connections : int;
}
let better_unix_error f arg =
try
f arg
with
Unix.Unix_error (e,syscall,param) ->
let error = Unix.error_message e in
if param = "" then
failwith error
else
failwith (param ^ ": " ^ error)
let rec syscall f =
(* Invoke system call, and handle EINTR *)
try
f()
with
Unix.Unix_error(Unix.EINTR,_,_) ->
(* "interrupted system call": A signal happened while the system
* blocked.
* Simply restart the call.
*)
syscall f
;;
let hex_digits = [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7';
'8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f' |];;
let encode_hex s =
(* encode with lowercase hex digits *)
let l = String.length s in
let t = String.make (2*l) ' ' in
for n = 0 to l - 1 do
let x = Char.code s.[n] in
t.[2*n] <- hex_digits.( x lsr 4 );
t.[2*n+1] <- hex_digits.( x land 15 );
done;
t
;;
type synchronization =
| Sync
| Pipeline of int
;;
let max_pipeline = 8 ;;
let pipeline_blacklist =
(* Stolen from Mozilla *)
[ Netstring_str.regexp "Microsoft-IIS/";
Netstring_str.regexp "Netscape-Enterprise/3.";
]
;;
type channel_binding_id = int
type http_options =
{ synchronization : synchronization;
maximum_connection_failures : int;
maximum_message_errors : int;
inhibit_persistency : bool;
connection_timeout : float;
number_of_parallel_connections : int;
maximum_redirections : int;
handshake_timeout : float;
resolver : resolver;
configure_socket : Unix.file_descr -> unit;
schemes : (string * Neturl.url_syntax * int option * channel_binding_id)
list;
verbose_status : bool;
verbose_request_header : bool;
verbose_response_header : bool;
verbose_request_contents : bool;
verbose_response_contents : bool;
verbose_connection : bool;
verbose_events : bool;
}
;;
type header_kind = [ `Base | `Effective ]
(*
let http_re =
Netstring_str.regexp
"^https?://\
\\(\
\\([^/:@]+\\)\
\\(:\\([^/:@]+\\)\\)?@\
\\)?\
\\([^/:@]+\\)\
\\(:\\([0-9]+\\)\\)?\
\\([/?].*\\)?$"
*)
let parse_url_0 ?base_url schemes url =
try
let sch =
try Neturl.extract_url_scheme url
with err ->
( match base_url with
| None -> raise err
| Some b -> Neturl.url_scheme b
) in
let (_,syn,p_opt,cb) =
List.find (fun (sch',_,_,_) -> sch=sch') schemes in
let ht = Hashtbl.create 1 in
Hashtbl.add ht sch syn;
let url' = Neturl.fixup_url_string ~escape_hash:true url in
let nu1 =
Neturl.parse_url
?base_syntax:(match base_url with
| None -> None
| Some b -> Some(Neturl.url_syntax_of_url b)
)
~schemes:ht ~accept_8bits:true url' in
let nu2 =
Neturl.ensure_absolute_url ?base:base_url nu1 in
(Neturl.default_url ?port:p_opt nu2, cb)
with
| Neturl.Malformed_URL -> raise Not_found
let parse_url ?base_url options url =
parse_url_0 ?base_url !options.schemes url
(*
match Netstring_str.string_match http_re url 0 with
| None ->
raise Not_found
| Some m ->
let is_https =
String.sub url 0 5 = "https" in
let user =
try Some(Netstring_str.matched_group m 2 url)
with Not_found -> None in
let password =
try Some(Netstring_str.matched_group m 4 url)
with Not_found -> None in
let host =
Netstring_str.matched_group m 5 url in
let port =
try int_of_string(Netstring_str.matched_group m 7 url)
with Not_found -> (if is_https then 443 else 80) in
let path =
try Netstring_str.matched_group m 8 url with Not_found -> "" in
(is_https,user,password,host,port,path)
*)
let new_cb_id () =
Oo.id (object end)
let http_cb_id = new_cb_id()
let https_cb_id = new_cb_id()
let proxy_only_cb_id = new_cb_id()
let default_schemes =
let http_syn =
{ (Hashtbl.find Neturl.common_url_syntax "http") with
Neturl.url_enable_query = Neturl.Url_part_not_recognized
} in
let https_syn =
{ (Hashtbl.find Neturl.common_url_syntax "https") with
Neturl.url_enable_query = Neturl.Url_part_not_recognized
} in
let ipp_syn =
{ (Hashtbl.find Neturl.common_url_syntax "ipp") with
Neturl.url_enable_query = Neturl.Url_part_not_recognized
} in
[ "http", http_syn, Some 80, http_cb_id;
"https", https_syn, Some 443, https_cb_id;
"ipp", ipp_syn, Some 631, http_cb_id;
]
let comma_re = Netstring_str.regexp "[ \t\n\r]*,[ \t\n\r]*" ;;
let split_words_by_commas s =
Netstring_str.split comma_re s ;;
let space_re = Netstring_str.regexp "[ \t\n\r]+" ;;
let split_words s =
Netstring_str.split space_re s ;;
let sync_resolver esys name reply =
(* FIXME: Use Uq_resolver also in the async case! *)
let addr =
try
let h = Uq_resolver.get_host_by_name name in
Some h.Unix.h_addr_list.(0)
with Uq_resolver.Host_not_found _ -> None in
reply addr
;;
(**********************************************************************)
(*** BUFFERS ***)
(**********************************************************************)
(* Similar to Buffer, but may be accessed in a more efficient way. *)
module B = Netbuffer;;
type buffer_type = B.t;;
module Q =
struct
(* This queue allows one to insert elements. *)
type 'a t = 'a Queue.t
exception Empty = Queue.Empty
let create = Queue.create
let add = Queue.add
let push = add
let add_at n x q =
(* Add x behind the n-the last element of q, i.e.
* add_at 0 x q = Add behind the last element = add x q
* add_at 1 x q = Add before the last element
* ...
* This algorithm is usually called for n ~ length, and is quite
* efficient in this case.
*)
let l = Queue.length q in
let q' = Queue.create() in
for k = 1 to l-n do
Queue.add (Queue.take q) q'
done;
Queue.add x q';
Queue.transfer q q';
Queue.transfer q' q
let take = Queue.take
let pop = take
let peek = Queue.peek
let top = peek
let clear = Queue.clear
let copy = Queue.copy
let is_empty = Queue.is_empty
let length = Queue.length
let iter = Queue.iter
let transfer = Queue.transfer
(* fold: omitted *)
end
(**********************************************************************)
(*** THE HTTP CALL CONTAINER ***)
(**********************************************************************)
let dump_header prefix h =
List.iter
(fun (n,v) ->
dlog (prefix ^ n ^ ": " ^ v))
h
type 'session auth_state = (* 'session = auth_session, defined below *)
[ `None
(* Authentication has not yet been tried *)
| `In_advance of 'session
(* This session had been tried before a 401 response was seen *)
| `In_reply of 'session
(* This session was tried after a 401 response was seen *)
]
class type http_call =
object
method is_served : bool
method status : status
method request_method : string
method request_uri : string
method set_request_uri : string -> unit
(* method is_https : bool *)
method request_header : header_kind -> Netmime.mime_header
method set_request_header : Netmime.mime_header -> unit
method set_expect_handshake : unit -> unit
method set_chunked_request : unit -> unit
method effective_request_uri : string
method request_body : Netmime.mime_body
method set_request_body : Netmime.mime_body -> unit
method set_request_device : (unit -> Uq_io.in_device) -> unit
method set_accept_encoding : unit -> unit
method response_status_code : int
method response_status_text : string
method response_status : Nethttp.http_status
method response_protocol : string
method response_header : Netmime.mime_header
method response_body : Netmime.mime_body
method response_body_storage : response_body_storage
method set_response_body_storage : response_body_storage -> unit
method max_response_body_length : int64
method set_max_response_body_length : int64 -> unit
method get_reconnect_mode : http_call how_to_reconnect
method set_reconnect_mode : http_call how_to_reconnect -> unit
method get_redirect_mode : http_call how_to_redirect
method set_redirect_mode : http_call how_to_redirect -> unit
method proxy_enabled : bool
method set_proxy_enabled : bool -> unit
method no_proxy : unit -> unit
method is_proxy_allowed : unit -> bool
method proxy_use_connect : bool
method empty_path_replacement : string
method is_idempotent : bool
method has_req_body : bool
method has_resp_body : bool
method set_channel_binding : channel_binding_id -> unit
method same_call : unit -> http_call
method get_req_method : unit -> string
method get_host : unit -> string
method get_port : unit -> int
method get_path : unit -> string
method get_uri : unit -> string
method get_req_body : unit -> string
method get_req_header : unit -> (string * string) list
method assoc_req_header : string -> string
method assoc_multi_req_header : string -> string list
method set_req_header : string -> string -> unit
method get_resp_header : unit -> (string * string) list
method assoc_resp_header : string -> string
method assoc_multi_resp_header : string -> string list
method get_resp_body : unit -> string
method dest_status : unit -> (string * int * string)
method private_api : private_api
end
and private_api =
object
method parse_request_uri : http_options ref -> unit
method request_uri_with : ?path:string option -> ?remove_particles:bool ->
unit -> Neturl.url
method channel_binding : http_options ref -> channel_binding_id
method get_error_counter : int
method set_error_counter : int -> unit
method set_error_exception : exn -> unit
method error_exception : exn option
method error_if_unserved : bool -> exn -> unit
method get_redir_counter : int
method set_redir_counter : int -> unit
method continue : bool
(* The value of the continue flag *)
method set_continue : bool -> unit
(* Set the continue flag to [true]. The argument says whether a
"100" code was received or not. (In the latter case the reaction is
different.)
*)
method wait_continue_e : float -> Unixqueue.event_system ->
bool Uq_engines.engine
(* Waits until [set_continue] is called, or until the time is over.
The bool result says whether a "100" code was received or not.
*)
method auth_state : auth_session auth_state
method set_auth_state : auth_session auth_state -> unit
method retry_anyway : bool
method set_retry_anyway : bool -> unit
(* This flag is set when we retry the request after an authentication
error. It overrides the reconnect mode - even if we do not want to
retry the request normally, we do it now exceptionally.
This is especially important for non-idempotent requests.
The flag remains active until we get to the point that we can
write the request line.
*)
method set_effective_request_uri : string -> unit
method prepare_transmission : unit -> unit
(* Initializes the `Effective request header, and creates the response
* objects. Sets the status to [`Unserved]. The error and redirection
* counters are not changed.
*)
method set_response_status : int -> string -> string -> unit
(* code, text, proto *)
method set_response_header : Netmime.mime_header -> unit
(* Sets the response header *)
method response_body_open_wr : Unixqueue.event_system -> Uq_io.out_device
(* Opens the response body for writing *)
method request_body_open_rd : Unixqueue.event_system -> Uq_io.in_device
(* Opens the request body for reading *)
method finish_request_e : Unixqueue.event_system -> unit Uq_engines.engine
(* Finish the request part of the call *)
method finish_response_e : Unixqueue.event_system -> unit Uq_engines.engine
(* The call is finished. The [status] is set to [`Successful],
* [`Redirection], [`Client_error], or [`Server_error] depending on
* the response.
*)
method cleanup : unit -> unit
(* Release resources *)
method response_code : int
method response_proto : string
method response_header : Netmime.mime_header
method decompression_enabled : bool
method dump_status : unit -> unit
method dump_response_header : unit -> unit
method dump_response_body : unit -> unit
end
and auth_session =
object
method auth_scheme : string
method auth_domain : Neturl.url list
method auth_realm : string
method auth_user : string
method auth_in_advance : bool
method authenticate : http_call -> (string * string) list
method invalidate : http_call -> bool
end
class type virtual gen_call =
object
inherit http_call
method private virtual fixup_request : unit -> unit
method private virtual def_request_method : string
method private virtual def_empty_path_replacement : string
method private virtual def_is_idempotent : bool
method private virtual def_has_req_body : bool
method private virtual def_has_resp_body : bool
end
class virtual generic_call : gen_call =
object(self)
val mutable status = (`Unserved : status)
val mutable finished = false
val mutable req_uri = None
(* The req_uri must always include the port number *)
val mutable req_uri_raw = ""
val mutable req_cb = http_cb_id
val mutable req_cb_set = false
val mutable req_secure = false
val mutable req_host = "" (* derived from req_uri *)
val mutable req_port = 80 (* derived from req_uri *)
val mutable req_path = "" (* derived from req_uri *)
val mutable req_base_header = new Netmime.basic_mime_header []
val mutable req_work_header = new Netmime.basic_mime_header []
val mutable req_body = new Netmime.memory_mime_body ""
val mutable req_dev = None
val mutable eff_req_uri = ""
val mutable resp_code = 0
val mutable resp_text = ""
val mutable resp_proto = ""
val mutable resp_header = new Netmime.basic_mime_header []
val mutable resp_header_set = false
val mutable resp_body = None
val mutable resp_body_max = Int64.max_int
val mutable resp_decompress = false
val mutable resp_body_storage = (`Memory : response_body_storage)
val mutable reconn_mode = Send_again_if_idem
val mutable redir_mode = Redirect_if_idem
val mutable proxy_enabled = true
val mutable retry_anyway = false
val mutable private_api = None
val mutable resp_handle = None
val mutable req_handle = None
val mutable continue = false (* Whether 100-Continue has been seen *)
val mutable continue_e = None
val mutable continue_aborted = false
val mutable continue_100 = false
val mutable error_counter = 0
val mutable redir_counter = 0
val mutable auth_state = `None
method private resp_body =
match resp_body with
| None ->
let rbody =
match resp_body_storage with
| `Memory ->
new Netmime.memory_mime_body ""
| `File f ->
let name = f() in
new Netmime.file_mime_body name
| `Body f ->
f ()
| `Device _ ->
failwith "Http_client: response is forwarded to device - \
no accessible response_body" in
resp_body <- Some rbody;
rbody
| Some rbody -> rbody
method private def_private_api fixup_request =
( object(pself)
method private release_resources() =
(* eprintf "release_resources call=%d\n%!" (Oo.id self); *)
( match req_handle with
| None -> ()
| Some d ->
Uq_io.inactivate d; req_handle <- None
);
( match resp_handle with
| None -> ()
| Some d ->
Uq_io.inactivate d; resp_handle <- None
);
( match continue_e with
| None -> ()
| Some e ->
continue_e <- None;
continue_aborted <- true;
e#abort()
)
method get_error_counter = error_counter
method set_error_counter n = error_counter <- n
method get_redir_counter = redir_counter
method set_redir_counter n = redir_counter <- n
method continue = continue
method set_continue code_100 =
continue <- true;
continue_100 <- code_100;
match continue_e with
| None -> ()
| Some e ->
continue_e <- None;
e#abort()
method wait_continue_e tmo esys =
if continue then
eps_e (`Done true) esys
else (
assert(continue_e = None); (* cannot be called multiple times *)
let e =
Uq_engines.delay_engine tmo
(fun () -> eps_e (`Done ()) esys)
esys in
continue_e <- Some e;
( e
>> (fun _ ->
continue_e <- None;
if continue_aborted then `Aborted else `Done continue_100
)
)
)
method auth_state = auth_state
method set_auth_state s = auth_state <- s
method retry_anyway = retry_anyway
method set_retry_anyway flag = retry_anyway <- flag;
method set_effective_request_uri s = eff_req_uri <- s
method parse_request_uri options =
if req_uri = None then (
try
let (nu, cb) = parse_url options req_uri_raw in
if (Neturl.url_provides ~user:true nu ||
Neturl.url_provides ~password:true nu)
then
failwith "Http_client: URL must not contain user or password";
req_uri <- Some nu;
req_host <- Neturl.url_host nu;
req_port <- Neturl.url_port nu;
(* req_path must also contain the parts after the path, i.e.
param and query
*)
req_path <-
Neturl.join_path(Neturl.url_path ~encoded:true nu) ^
( try String.concat ""
(List.map
(fun s -> ";" ^ s)
(Neturl.url_param ~encoded:true nu))
with Not_found -> "") ^
( try "?" ^ Neturl.url_query ~encoded:true nu
with Not_found -> "");
if not req_cb_set then
req_cb <- cb;
with
Not_found ->
failwith "Http_client: bad URL"
)
method channel_binding options =
pself # parse_request_uri options;
req_cb
method request_uri_with ?path ?(remove_particles=false) () =
match req_uri with
| None ->
assert false
| Some ru ->
let nu =
Neturl.modify_url
?path:(match path with
| None | Some None -> None
| Some (Some p) -> Some(Neturl.split_path p)
)
(Neturl.remove_from_url
~path:(path = Some None)
~query:remove_particles
~param:remove_particles
~fragment:remove_particles
ru) in
nu
method decompression_enabled = resp_decompress
method prepare_transmission () =
pself # release_resources();
status <- `Unserved;
req_work_header <- new Netmime.basic_mime_header
req_base_header#fields;
resp_code <- 0;
resp_text <- "";
resp_proto <- "";
resp_header <- new Netmime.basic_mime_header [];
resp_header_set <- false;
resp_body <- None;
fixup_request();
( try ignore(req_work_header # field "Date")
with Not_found ->
Nethttp.Header.set_date req_work_header (Unix.time())
);
( try ignore(req_work_header # field "User-agent")
with Not_found ->
req_work_header # update_field "User-agent" "Netclient"
);
continue <- false;
continue_e <- None;
continue_aborted <- false;
continue_100 <- false;
method request_body_open_rd esys =
match req_dev with
| Some f ->
let d = f() in
req_handle <- Some d;
d
| _ ->
let ch = req_body # open_value_rd() in
let d =
`Async_in(new Uq_engines.pseudo_async_in_channel ch,esys) in
req_handle <- Some d;
d
method set_response_status code text proto =
resp_code <- code;
resp_text <- text;
resp_proto <- proto
method set_response_header h =
resp_header <- h;
resp_header_set <- true;
assert(resp_code <> 0);
method response_body_open_wr esys =
let d0 =
match resp_body_storage with
| `Device f ->
f()
| _ ->
let rbody = self#resp_body in
let ch = rbody # open_value_wr() in
`Async_out(new Uq_engines.pseudo_async_out_channel ch,esys) in
(* Check for maximum response length: *)
let c = ref 0L in
let c_max = self # max_response_body_length in
let out_count n =
c := Int64.add !c (Int64.of_int n);
if !c > c_max then raise Response_too_large in
let d1 = `Count_out(out_count, d0) in
(* Check for decompression: *)
let d2 =
if pself#decompression_enabled then
let algos =
try Nethttp.Header.get_content_encoding resp_header
with Not_found -> [] in
match algos with
| [ algo ] ->
( try
let decoder =
Netcompression.lookup_decoder ~iana_name:algo () in
resp_header # delete_field "Content-Encoding";
let b =
Uq_io.filter_out_buffer
~max:(Some 4096) decoder d1 in
`Buffer_out b
with
| Not_found -> d1
)
| _ ->
d1
else
d1 in
resp_handle <- Some d2;
d2
method response_code = resp_code
method response_proto = resp_proto
method response_header = resp_header
method finish_request_e esys =
(* eprintf "finish_request call=%d\n%!" (Oo.id self); *)
match req_handle with
| None ->
eps_e (`Done ()) esys
| Some d ->
req_handle <- None;
Uq_io.shutdown_e d
>> (fun st -> Uq_io.inactivate d; st)
method finish_response_e esys =
(* eprintf "finish_response call=%d\n%!" (Oo.id self); *)
assert(resp_code <> 0);
finished <- true;
status <- (if resp_code >= 200 && resp_code <= 299 then
`Successful
else if resp_code >= 300 && resp_code <= 399 then
`Redirection
else if resp_code >= 400 && resp_code <= 499 then
`Client_error
else
`Server_error);
(* do this last - it can trigger user callback functions: *)
match resp_handle with
| None ->
eps_e (`Done ()) esys
| Some d ->
(* prerr_endline "Http_cllent SHUTDOWN"; *)
resp_handle <- None;
Uq_io.shutdown_e d
>> (fun st -> Uq_io.inactivate d; st)
method error_if_unserved verbose error =
match status with
| `Unserved ->
if verbose then
dlogr (fun () ->
sprintf "Call %d - error %s"
(Oo.id self)
(Netexn.to_string error));
pself # set_error_exception error;
| _ ->
()
method set_error_exception x =
finished <- true;
( match x with
Http_error(_,_) -> assert false (* not allowed *)
| _ ->
status <- (`Http_protocol_error x);
);
(* do this last - it can trigger user callback functions: *)
pself # release_resources();
method error_exception =
match status with
| `Http_protocol_error x -> Some x
| _ -> None
method cleanup () =
pself # release_resources()
method dump_status () =
dlog (sprintf
"Call %d - HTTP response code: %d (%s)"
(Oo.id self) resp_code resp_text);
dlog (sprintf
"Call %d - HTTP response protocol: %s"
(Oo.id self) resp_proto);
method dump_response_header () =
dump_header
(sprintf
"Call %d - HTTP response "
(Oo.id self))
(resp_header # fields)
method dump_response_body () =
dlog (sprintf "Call %d - HTTP response body:\n%s\n"
(Oo.id self)
(match resp_body with
| Some rbody -> rbody#value
| None -> ""
))
end
)
(* Call state *)
method is_served = finished
method status = status
(* Accessing the request message (new style) *)
method request_method = self # def_request_method
method request_uri = req_uri_raw
method set_request_uri uri = req_uri_raw <- uri; req_uri <- None
method set_channel_binding cb =
req_cb <- cb;
req_cb_set <- true
method request_header (k:header_kind) =
match k with
| `Base -> req_base_header
| `Effective -> req_work_header
method set_request_header h =
req_base_header <- h
method set_expect_handshake() =
req_base_header # update_field "Expect" "100-continue"
method set_chunked_request() =
req_base_header # update_field "Transfer-encoding" "chunked"
method request_body =
if req_dev <> None then
failwith "Http_client: No request_body - using a device instead";
req_body
method set_request_body b = req_body <- b; req_dev <- None
method set_request_device f = req_dev <- Some f
method effective_request_uri = eff_req_uri
method set_accept_encoding() =
let all_algos =
Netcompression.all_decoders() in
Nethttp.Header.set_accept_encoding
req_base_header
(if all_algos = [] then ["identity",[]] else
(List.map (fun token -> (token,[])) all_algos));
resp_decompress <- true
(* Accessing the response message (new style) *)
method private check_response() =
match status with
| `Unserved ->
if not resp_header_set then
failwith "Http_client: HTTP call is unserved, no response yet"
| `Http_protocol_error e ->
raise (Http_protocol e)
| _ -> ()
method response_status_code = self#check_response(); resp_code
method response_status_text = self#check_response(); resp_text
method response_status =
self#check_response();
try Nethttp.http_status_of_int resp_code
with Not_found ->
Nethttp.http_status_of_int (Nethttp.base_code resp_code)
method response_protocol = self#check_response(); resp_proto
method response_header = self#check_response(); resp_header
method response_body =
(* [status] is already set after the header is available. The presence
of the body is indicated by [finished].
*)
self#check_response();
if not finished then
failwith "Http_client: HTTP call is unserved, response not yet complete";
self#resp_body
(* Options *)
method response_body_storage = resp_body_storage
method set_response_body_storage s = resp_body_storage <- s
method max_response_body_length = resp_body_max
method set_max_response_body_length n = resp_body_max <- n
method get_reconnect_mode = reconn_mode
method set_reconnect_mode m = reconn_mode <- m
method get_redirect_mode = redir_mode
method set_redirect_mode m = redir_mode <- m
method proxy_enabled = proxy_enabled
method set_proxy_enabled e = proxy_enabled <- e
method no_proxy() = proxy_enabled <- false
method is_proxy_allowed() = proxy_enabled
method proxy_use_connect = (req_cb = https_cb_id)
(* Method characteristics *)
method empty_path_replacement = self # def_empty_path_replacement
method is_idempotent = self # def_is_idempotent
method has_req_body = self # def_has_req_body
method has_resp_body = self # def_has_resp_body
(* Repeating calls *)
method same_call() =
let same =
{< status = `Unserved;
finished = false;
resp_header = new Netmime.basic_mime_header [];
resp_header_set = false;
resp_body = None;
eff_req_uri = "";
private_api = None;
error_counter = 0;
redir_counter = 0;
continue = false;
continue_aborted = false;
continue_100 = false;
continue_e = None;
resp_handle = None;
req_handle = None;
auth_state = `None;
retry_anyway = false
>} in
(same : #http_call :> http_call)
(* Old style access methods *)
method get_req_method() = self # def_request_method
method get_host() = req_host
method get_port() = req_port
method get_path() = req_path
method get_uri() = req_uri_raw
method get_req_body() = req_body # value
method get_req_header () =
List.map (fun (n,v) -> (String.lowercase n, v)) req_base_header#fields
method assoc_req_header n =
req_base_header # field n
method assoc_multi_req_header n =
req_base_header # multiple_field n
method set_req_header n v =
req_base_header # update_field n v
method get_resp_header() =
self#check_response();
List.map (fun (n,v) -> (String.lowercase n, v)) resp_header#fields
method assoc_resp_header n =
self#check_response();
resp_header # field n
method assoc_multi_resp_header n =
self#check_response();
resp_header # multiple_field n
method get_resp_body() =
self#check_response();
if resp_code >= 200 && resp_code <= 299 then
self # resp_body # value
else
raise(Http_error(resp_code, self#resp_body#value))
method dest_status() =
self#check_response();
(resp_proto, resp_code, resp_text)
(* Private *)
method private_api =
match private_api with
| None ->
let api = self # def_private_api self#fixup_request in
private_api <- Some api;
api
| Some api ->
api
(* Virtual methods *)
method virtual private fixup_request : unit -> unit
method virtual private def_request_method : string
method virtual private def_empty_path_replacement : string
method virtual private def_is_idempotent : bool
method virtual private def_has_req_body : bool
method virtual private def_has_resp_body : bool
end
(******** SUBCLASSES IMPLEMENTING HTTP METHODS ************************)
class get_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "GET"
method private def_is_idempotent = true
method private def_has_req_body = false
method private def_has_resp_body = true
method private def_empty_path_replacement = "/"
end
class head_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "HEAD"
method private def_is_idempotent = true
method private def_has_req_body = false
method private def_has_resp_body = false
method private def_empty_path_replacement = "/"
end
class trace_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "TRACE"
method private def_is_idempotent = false
method private def_has_req_body = false
method private def_has_resp_body = true
method private def_empty_path_replacement = "/"
end
class options_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "OPTIONS"
method private def_is_idempotent = false
method private def_has_req_body = true
method private def_has_resp_body = true
method private def_empty_path_replacement = "*"
end
class post_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "POST"
method private def_is_idempotent = false
method private def_has_req_body = true
method private def_has_resp_body = true
method private def_empty_path_replacement = "/"
end
class put_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "PUT"
method private def_is_idempotent = true (* sic! *)
method private def_has_req_body = true
method private def_has_resp_body = true
method private def_empty_path_replacement = "/"
end
class delete_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "DELETE"
method private def_is_idempotent = true
method private def_has_req_body = false
method private def_has_resp_body = true
method private def_empty_path_replacement = "/"
end
class connect_call =
object(self)
inherit generic_call
method private fixup_request() = ()
method private def_request_method = "CONNECT"
method private def_is_idempotent = false
method private def_has_req_body = false
method private def_has_resp_body = true
(* This is broken to some degree. See the comment below on when
CONNECT has a response body
*)
method private def_empty_path_replacement = "/"
end
class get the_query =
object (self)
inherit get_call
initializer
self # set_request_uri the_query
end
class trace the_query max_hops =
object (self)
inherit trace_call
initializer
self # set_request_uri the_query
method private fixup_request() =
(self # request_header `Effective) # update_field
"max-forwards" (string_of_int max_hops)
end
class options the_query =
object (self)
inherit options_call
initializer
self # set_request_uri the_query
end
class head the_query =
object (self)
inherit head_call
initializer
self # set_request_uri the_query
end
class post query params =
object (self)
inherit post_call
initializer
self # set_request_uri query
method private fixup_request() =
let rh = self # request_header `Effective in
let is_chunked =
try rh # field "Transfer-encoding" <> "identity"
with Not_found -> false in
rh # update_field "Content-type" "application/x-www-form-urlencoded";
let l = List.map (fun (n,v) -> n ^ "=" ^ Netencoding.Url.encode v) params in
let s = String.concat "&" l in
if not is_chunked then
rh # update_field "Content-length" (string_of_int (String.length s));
self # request_body # set_value s
end
;;
class post_raw the_query s =
object (self)
inherit post_call
initializer
self # set_request_uri the_query
method private fixup_request() =
let rh = self # request_header `Effective in
let is_chunked =
try rh # field "Transfer-encoding" <> "identity"
with Not_found -> false in
self # request_body # set_value s;
if not is_chunked then
rh # update_field "Content-length" (string_of_int (String.length s));
end
;;
class put the_query s =
object (self)
inherit put_call
initializer
self # set_request_uri the_query
method private fixup_request() =
let rh = self # request_header `Effective in
let is_chunked =
try rh # field "Transfer-encoding" <> "identity"
with Not_found -> false in
self # request_body # set_value s;
if not is_chunked then
rh # update_field "Content-length" (string_of_int (String.length s));
end
;;
class delete the_query =
object (self)
inherit delete_call
initializer
self # set_request_uri the_query
end
;;
class connect the_query (* host:port only *) =
object (self)
inherit connect_call
initializer
self # set_request_uri ("http://" ^ the_query)
method effective_request_uri =
the_query
end
;;
(**********************************************************************)
(*** AUTHENTICATION METHODS ***)
(**********************************************************************)
class type key =
object
method user : string
method password : string
method realm : string
method domain : string list
end
let key ~user ~password ~realm ~domain =
( object
method user = user
method password = password
method realm = realm
method domain = domain
end
)
class type key_handler =
object
method inquire_key :
domain:string list -> realms:string list -> auth:string -> key
method invalidate_key : key -> unit
end
class key_ring ?uplink () =
object(self)
val mutable keys = (Hashtbl.create 10 :
(string list * string, key * bool) Hashtbl.t)
(* Maps (domain, realm) to (key, from_uplink) *)
method inquire_key ~domain ~realms ~(auth:string) =
let l =
List.flatten
(List.map
(fun realm ->
try
[ Hashtbl.find keys (domain, realm) ]
with
Not_found ->
try
[ Hashtbl.find keys (["*"], realm) ]
with Not_found -> []
)
realms) in
match l with
| (key,_) :: _ ->
key
| [] ->
( match uplink with
| None -> raise Not_found
| Some h ->
let key = h # inquire_key ~domain ~realms ~auth in
(* or Not_found *)
Hashtbl.replace keys (key#domain, key#realm) (key,true);
key
)
method invalidate_key (key : key) =
let domain = key # domain in
let realm = key # realm in
try
let (_, from_uplink) = Hashtbl.find keys (domain, realm) in
Hashtbl.remove keys (domain, realm);
if from_uplink then
( match uplink with
| None -> assert false
| Some h -> h # invalidate_key key
)
with
Not_found -> ()
method clear () =
Hashtbl.clear keys
method add_key key =
let domain = key # domain in
let realm = key # realm in
(* The domain must be the full URL with no parts omitted. For developers
who cannot read do some cleanups here:
*)
let domain_fixedup =
List.map
(fun dom ->
try
let (u1, _) = parse_url_0 default_schemes dom in
let u2 = Neturl.default_url ~path:[ "" ] u1 in
let u3 =
Neturl.remove_from_url
~user:true ~user_param:true ~password:true u2 in
Neturl.string_of_url u3
with
| Not_found ->
dom
)
domain in
let key_fixedup =
if domain = domain_fixedup then
key
else
( object
method user = key#user
method password = key#password
method realm = key#realm
method domain = domain_fixedup
end
) in
Hashtbl.replace keys (domain_fixedup, realm) (key_fixedup, false)
method keys =
Hashtbl.fold
(fun _ (key,_) acc -> key :: acc)
keys
[]
end
class proxy_key_handler user password : key_handler =
object
method inquire_key ~domain ~realms ~auth =
try
let realm = List.hd realms in
key ~domain ~realm ~user ~password
with _ -> raise Not_found
method invalidate_key _ = ()
end
class type auth_handler =
object
method create_session : http_call -> http_options ref -> auth_session option
method create_proxy_session : http_call -> http_options ref -> auth_session option
method skip_challenge : string option
method skip_challenge_session : http_call -> http_options ref -> auth_session option
end
exception Not_applicable
let get_domain_uri (call : http_call) =
call # private_api # request_uri_with
~path:(Some "/") ~remove_particles:true ()
let no_port url = (* or Not_found *)
match Neturl.url_scheme url with
| "http" ->
Neturl.undefault_url ~port:80 url
| "https" ->
Neturl.undefault_url ~port:443 url
| _ -> raise Not_found
class core_basic_auth_session
enable_auth_in_advance key_handler for_proxy
domain_uri realms
: auth_session =
let domain =
List.map Neturl.string_of_url domain_uri in
let alt_domain =
List.map (fun u -> Neturl.string_of_url (no_port u)) domain_uri in
let key =
(* Return the selected key, or raise Not_applicable *)
try
key_handler # inquire_key ~domain ~realms ~auth:"basic"
with
Not_found ->
try
key_handler # inquire_key ~domain:alt_domain ~realms ~auth:"basic"
with
Not_found ->
raise Not_applicable
in
(* Check the key: *)
let () =
if not (List.mem key#realm realms) then raise Not_applicable;
let d = key#domain in
if d <> domain && d <> alt_domain && d <> ["*"] then
raise Not_applicable;
in
object(self)
method auth_scheme = "basic"
method auth_domain = domain_uri
method auth_realm = key # realm
method auth_user = key # user
method auth_in_advance = enable_auth_in_advance
method authenticate call =
let basic_cookie =
Netencoding.Base64.encode
(key#user ^ ":" ^ key#password) in
let cred = "Basic " ^ basic_cookie in
let field_name =
if for_proxy then "Proxy-Authorization" else "Authorization" in
[ field_name, cred ]
method invalidate call =
key_handler # invalidate_key key;
false
end
class basic_auth_session enable_auth_in_advance
key_handler init_call for_proxy
: auth_session =
let domain_uri = if for_proxy then [] else [ get_domain_uri init_call ] in
let basic_realms =
(* Return all "Basic" realms in www-authenticate, or raise Not_applicable *)
let auth_list =
try
if for_proxy then
Nethttp.Header.get_proxy_authenticate init_call#response_header
else
Nethttp.Header.get_www_authenticate init_call#response_header
with
| Not_found -> raise Not_applicable
| Nethttp.Bad_header_field _ -> raise Not_applicable in
let basic_auth_list =
List.filter
(fun (scheme,_) -> String.lowercase scheme = "basic") auth_list in
let basic_auth_realm_list =
List.flatten
(List.map
(fun (_,params) ->
try
let (_,realm) =
List.find (fun (pname,_) ->
String.lowercase pname = "realm") params in
[realm]
with
Not_found -> [])
basic_auth_list) in
if basic_auth_realm_list = [] then
raise Not_applicable
else
basic_auth_realm_list
in
core_basic_auth_session
enable_auth_in_advance key_handler for_proxy domain_uri basic_realms
class basic_auth_handler ?(enable_auth_in_advance=false)
?(skip_challenge=None)
(key_handler : #key_handler)
: auth_handler =
object(self)
method create_session call options =
try
Some(new basic_auth_session enable_auth_in_advance key_handler call false)
with
Not_applicable ->
None
method create_proxy_session call options =
try
Some(new basic_auth_session enable_auth_in_advance key_handler call true)
with
Not_applicable ->
None
method skip_challenge = skip_challenge
method skip_challenge_session call options =
try
let domain_uri = [ get_domain_uri call ] in
Some(new core_basic_auth_session
false key_handler false domain_uri ["anywhere"])
with
Not_applicable ->
None
end
let contains_auth v =
List.mem "auth" (split_words v)
class digest_auth_session enable_auth_in_advance options
key_handler (init_call : http_call) for_proxy
: auth_session =
let normalize_domain s =
try
let (nu1,_) =
parse_url
~base_url:(init_call#private_api#request_uri_with())
options s in
Neturl.remove_from_url
~user:true ~user_param:true ~password:true ~fragment:true nu1
with
| Neturl.Malformed_URL -> raise Not_found
(*
if s <> "" && s.[0] = '/' then
init_call#private_api#request_uri_with
~path:None ~remove_particles:true ()
^ s
else
( try
let (is_https,_,_,host,port,path) = parse_http_url s in
let scheme = if is_https then "https" else "http" in
scheme ^ "://" ^ host ^ ":" ^ string_of_int port ^ path
with
| Not_found -> s
)
*)
in
let digest_request =
(* Return the "Digest" params in www-authenticate, or raise Not_applicable *)
let auth_list =
try
if for_proxy then
Nethttp.Header.get_proxy_authenticate init_call#response_header
else
Nethttp.Header.get_www_authenticate init_call#response_header
with
| Not_found -> raise Not_applicable
| Nethttp.Bad_header_field _ -> raise Not_applicable in
let digest_auth_list =
List.filter
(fun (scheme,params) ->
String.lowercase scheme = "digest"
&& List.mem_assoc "realm" params
&& (try List.mem (List.assoc "algorithm" params) ["MD5";"MD5-sess"]
with Not_found -> true)
&& (try contains_auth (List.assoc "qop" params)
with Not_found -> true)
&& List.mem_assoc "nonce" params
)
auth_list in
match digest_auth_list with
| [] ->
raise Not_applicable
| (_,params) :: _ ->
(* Restriction: only the first request can be processed *)
params
in
let domain_url =
if for_proxy then [] else
try
List.map
normalize_domain
(split_words (List.assoc "domain" digest_request))
with
Not_found -> [ get_domain_uri init_call ] in
let domain =
List.map Neturl.string_of_url domain_url in
let alt_domain =
List.map (fun u -> Neturl.string_of_url (no_port u)) domain_url in
let realm =
try List.assoc "realm" digest_request
with Not_found -> assert false in
let key =
(* Return the selected key, or raise Not_applicable *)
try
key_handler # inquire_key ~domain ~realms:[realm] ~auth:"digest"
with
Not_found ->
try
key_handler # inquire_key ~domain:alt_domain ~realms:[realm]
~auth:"digest"
with
Not_found -> raise Not_applicable
in
(* Check the key: *)
let () =
if key#realm <> realm then raise Not_applicable;
let d = key#domain in
if d <> domain && d <> alt_domain && d <> ["*"] then
raise Not_applicable;
in
let algorithm =
try List.assoc "algorithm" digest_request
with Not_found -> "MD5" in
let qop =
if List.mem_assoc "qop" digest_request then "auth" else "" in
(* "" = RFC 2069 mode *)
let nonce =
try List.assoc "nonce" digest_request
with Not_found -> assert false in
let cnonce_init0 =
try
let s = String.make 8 'X' in
let () = Netsys_rng.fill_random s in
s
with _ -> string_of_float (Unix.gettimeofday()) in
object(self)
val mutable cnonce_init = cnonce_init0
val mutable cnonce_incr = 0
val mutable nc = 0
val mutable opaque = None
val mutable a1 = None
method private first_cnonce =
Digest.to_hex
(Digest.string (cnonce_init ^ ":0"))
method private next_cnonce() =
let cnonce =
Digest.to_hex
(Digest.string (cnonce_init ^ ":" ^ string_of_int cnonce_incr)) in
cnonce_incr <- cnonce_incr + 1;
cnonce
method private next_nc() =
let r = nc in
nc <- nc + 1;
r
method private fn_h data =
encode_hex (Digest.string data)
method private fn_kd secret data =
encode_hex (Digest.string (secret ^ ":" ^ data))
method private a1 =
match a1 with
| Some v -> v
| None ->
let v =
match algorithm with
| "MD5" ->
key#user ^ ":" ^ realm ^ ":" ^ key#password
| "MD5-sess" ->
(self # fn_h
(key#user ^ ":" ^ realm ^ ":" ^ key#password)) ^
":" ^ nonce ^ ":" ^ self#first_cnonce
| _ ->
assert false
in
a1 <- Some v;
v
method private a2 call =
let meth = call # request_method in
let uri = call # effective_request_uri in
meth ^ ":" ^ uri
method authenticate call =
let cnonce = self#next_cnonce() in
let nc = self # next_nc() in
let digest =
match qop with
| "auth" ->
self#fn_kd
(self#fn_h self#a1)
(nonce ^ ":" ^ (Printf.sprintf "%08x" nc) ^ ":" ^ cnonce ^ ":" ^
"auth:" ^ (self#fn_h (self#a2 call)))
| "" ->
self#fn_kd
(self#fn_h self#a1)
(nonce ^ ":" ^ (self#fn_h (self#a2 call)))
| _ ->
assert false (* such digests are not accepted *)
in
let creds =
Printf.sprintf
"Digest username=\"%s\",realm=\"%s\",nonce=\"%s\",uri=\"%s\",response=\"%s\",algorithm=%s,cnonce=\"%s\",%s%snc=%08d"
key#user
realm
nonce
call#effective_request_uri
digest
algorithm
cnonce
(match opaque with
| None -> ""
| Some s -> "opaque=\"" ^ s ^ "\",")
(match qop with
| "" -> ""
| "auth" -> "qop=auth,"
| _ -> assert false)
nc in
let field_name =
if for_proxy then "Proxy-Authorization" else "Authorization" in
[ field_name, creds ]
method auth_scheme = "digest"
method auth_domain = domain_url
method auth_realm = key # realm
method auth_user = key # user
method auth_in_advance = enable_auth_in_advance
method invalidate call =
(* Check if the [stale] flag is set for our nonce: *)
let is_stale =
try
let auth_list =
Nethttp.Header.get_www_authenticate call#response_header in
List.exists
(fun (scheme,params) ->
String.lowercase scheme = "digest"
&& (try List.assoc "realm" params = realm
with Not_found -> false)
&& (try List.assoc "nonce" params = nonce
with Not_found -> false)
&& (try String.lowercase (List.assoc "stale" params) = "true"
with Not_found -> false)
)
auth_list
with
| Not_found -> false (* No www-authenticate header *)
| Nethttp.Bad_header_field _ -> false in
is_stale || (
key_handler # invalidate_key key;
false
)
end
class digest_auth_handler ?(enable_auth_in_advance=false)
(key_handler : #key_handler)
: auth_handler =
object(self)
method create_session call options =
try
Some(new digest_auth_session
enable_auth_in_advance options key_handler call false)
with
Not_applicable ->
None
method create_proxy_session call options =
try
Some(new digest_auth_session
enable_auth_in_advance options key_handler call true)
with
Not_applicable ->
None
method skip_challenge = None
method skip_challenge_session _ _ = assert false
end
class unified_auth_handler (key_handler : #key_handler) : auth_handler =
object(self)
method create_session call options =
try Some(new digest_auth_session false options key_handler call false)
with Not_applicable ->
try Some(new basic_auth_session false key_handler call false)
with Not_applicable ->
None
method create_proxy_session call options =
try Some(new digest_auth_session false options key_handler call true)
with Not_applicable ->
try Some(new basic_auth_session false key_handler call true)
with Not_applicable ->
None
method skip_challenge = None
method skip_challenge_session _ _ = assert false
end
let norm_neturl neturl =
(* Returns the neturl as normalized string (esp. normalized % sequences) *)
assert(Neturl.url_provides ~port:true neturl);
let neturl' =
Neturl.make_url
~encoded:false
~scheme:(Neturl.url_scheme neturl)
~host:(Neturl.url_host neturl)
~path:(try Neturl.url_path neturl with Not_found -> [])
?query:(try Some(Neturl.url_query neturl) with Not_found -> None)
?fragment:(try Some(Neturl.url_fragment neturl) with Not_found -> None)
(Neturl.url_syntax_of_url neturl) in
Neturl.string_of_url neturl'
let prefixes_of_neturl s_url =
(* Returns a list of all legal prefixes of the absolute URI s.
* The prefixes are in Neturl format.
*)
let rec rev_path_prefixes rev_path =
match rev_path with
| [] -> []
| [ "" ] -> [ rev_path; [] ]
| [ ""; "" ] -> assert false
| [ _; "" ] -> rev_path :: rev_path_prefixes [ "" ]
| "" :: rev_path' ->
if rev_path' = [ ""; "" ] then
rev_path :: rev_path_prefixes [ "" ]
else
rev_path :: rev_path_prefixes rev_path'
| _ :: rev_path' ->
rev_path :: (rev_path_prefixes ("" :: rev_path'))
in
let path_prefixes path =
List.map List.rev (rev_path_prefixes (List.rev path)) in
let s_nofrag_url = Neturl.remove_from_url ~fragment:true s_url in
let s_noquery_url = Neturl.remove_from_url ~query:true s_nofrag_url in
let path = Neturl.url_path s_noquery_url in
s_url :: s_nofrag_url ::
(List.map
(fun prefix -> Neturl.modify_url ~path:prefix s_noquery_url
)
(path_prefixes path))
class auth_cache =
object(self)
val mutable auth_handlers = []
val sessions = Hashtbl.create 10
(* Only sessions that can be used for authentication in advance.
* The hash table maps domain URIs to sessions.
*)
method add_auth_handler (h : auth_handler) =
auth_handlers <- auth_handlers @ [h]
method create_session (call : http_call) options =
(* Create a new session after a 401 reply *)
let rec find l =
match l with
| [] -> None
| h :: l' ->
( match h # create_session call options with
| None ->
find l'
| Some s ->
Some s
)
in
find auth_handlers
method tell_successful_session (sess : auth_session) =
(* Called by [postprocess_complete_message] when authentication was
* successful. If enabled, [sess] can be used for authentication
* in advance.
*)
if sess # auth_in_advance then (
List.iter
(fun dom_uri ->
try
let dom_uri' = norm_neturl dom_uri in
Hashtbl.replace sessions dom_uri' sess
with
| Neturl.Malformed_URL -> ()
)
sess#auth_domain
)
method tell_failed_session (sess : auth_session) =
(* Called by [postprocess_complete_message] when authentication
* failed
*)
List.iter
(fun dom_uri ->
try
let dom_uri' = norm_neturl dom_uri in
Hashtbl.remove sessions dom_uri'
with
| Neturl.Malformed_URL -> ()
)
sess#auth_domain;
method find_session_in_advance (call : http_call) options =
(* Find a session suitable for authentication in advance *)
let uri = call # private_api # request_uri_with() in
(* We are not only looking for [uri], but also for all prefixes of [uri] *)
try
let prefixes = prefixes_of_neturl uri in
let string_prefixes =
List.flatten
(List.map
(fun p -> try [norm_neturl p] with _ -> [])
prefixes
) in
try
let string_prefix =
List.find (* or Not_found *)
(fun string_prefix ->
Hashtbl.mem sessions string_prefix
)
string_prefixes in
Hashtbl.find sessions string_prefix
with
| Not_found ->
(* Also try skip_challenge authentication *)
let h =
List.find (* or Not_found *)
(fun handler ->
match handler#skip_challenge with
| None -> false
| Some skip_space ->
skip_space="*" || List.mem skip_space string_prefixes
)
auth_handlers in
( match
h # skip_challenge_session call options
with
| Some sess -> sess
| None -> raise Not_found
)
with
| Neturl.Malformed_URL ->
raise Not_found
end
(* Backwards compatibility: *)
class key_backing_store =
object(self)
val db = (Hashtbl.create 10 : (string, (string*string)) Hashtbl.t)
method set_realm realm user password =
Hashtbl.replace db realm (user,password)
method inquire_key ~domain ~realms ~(auth:string) =
let realm = List.find (fun realm -> Hashtbl.mem db realm) realms in
let (user, password) = Hashtbl.find db realm in
( object
method user = user
method password = password
method realm = realm
method domain = (domain : string list)
end
)
method invalidate_key (_ : key) = ()
end
class auth_method name (mk_auth_handler : key_ring -> auth_handler) =
let key_bs =
new key_backing_store in
let key_ring =
new key_ring ~uplink:key_bs () in
let auth_handler =
mk_auth_handler key_ring in
object(self)
method name = (name : string)
method set_realm realm user password =
key_bs # set_realm realm user password
method as_auth_handler =
auth_handler
end
class basic_auth_method =
auth_method
"basic"
(fun kr ->
new basic_auth_handler ~enable_auth_in_advance:true kr)
class digest_auth_method =
auth_method
"digest"
(fun kr ->
new digest_auth_handler ~enable_auth_in_advance:true kr)
(**********************************************************************)
(*** THE CONNECTION CACHE ***)
(**********************************************************************)
type connection_cache = Http_client_conncache.connection_cache
let close_connection_cache conn_cache =
conn_cache # close_all()
let create_restrictive_cache() = new restrictive_cache()
let create_aggressive_cache() = new aggressive_cache()
(**********************************************************************)
(*** THE I/O BUFFER ***)
(**********************************************************************)
(* io_buffer performs the socket I/O.
*
* TODO: COMMENT OUT OF DATE
* The input side is a queue of octets which can be filled by
* a Unix.read call at its end, and from which octets can be removed
* at its beginning ("consuming octets").
* There is also functionality to remove 1XX responses at the beginning
* of the buffer, and to interpret the beginning of the buffer as HTTP
* status line.
* The idea of the buffer is that octets can be added at the end of the
* buffer while the beginning of the buffer is interpreted as the beginning
* of the next message. Once enough octets have been added that the message
* is complete, it is removed (consumed) from the buffer, and the possibly
* remaining octets are the beginning of the following message.
*)
exception Garbage_received of string
(* This exception is raised by [parse_response] when a protocol error
* occurred before the response status line has been completely received.
* Such errors are not transferred to the http_call.
*)
let status_re =
Netstring_str.regexp "^\\([^ \t]+\\)\
[ \t]+\
\\([0-9][0-9][0-9]\\)\
\\([ \t]+\\([^\r\n]*\\)\\)?\
\r?$" ;;
let chunk_re =
Netstring_str.regexp "[ \t]*\
\\([0-9a-fA-F]+\\)\
[ \t]*\
\\(;[^\r\n\000]*\\)?\
\r?" ;;
type sockstate =
Down
| Up_rw
| Up_r
;;
type send_token =
| Send_header of int * string * string * Netmime.mime_header_ro
(* call_id, method, url, header *)
| Send_body of Uq_io.in_device * int64 option
(* data, length_opt *)
| Send_body_chunked of Uq_io.in_device
| Send_eof
let max_line_len = 65536
let input_line_opt_e ?max_len dev =
Uq_io.input_line_e ?max_len dev >> Uq_io.eof_as_none >>
(fun st ->
match st with
| `Error Uq_io.Line_too_long ->
raise(Garbage_received "Line too long")
| _ -> st
)
let input_opt_e dev s p n =
Uq_io.input_e dev s p n >> Uq_io.eof_as_none
class type io_buffer =
object
method socket_state : sockstate
method socket : Unix.file_descr
method socket_str : string
method close : followup:(unit->unit) -> unit -> unit
method down : unit -> unit
method status_seen : bool
method configure_read : fetch_call:(unit -> http_call) -> unit -> unit
method read_e : Unixqueue.event_system -> http_call option Uq_engines.engine
method write_activity : bool
method add : send_token -> unit
method write_e : Unixqueue.event_system -> unit Uq_engines.engine
end
let io_buffer options fd mplex fd_state : io_buffer =
let dev = `Multiplex mplex in
let buf_in_dev = `Buffer_in(Uq_io.create_in_buffer dev) in
( object (self)
(****************************** SOCKET ********************************)
val mutable socket_state = fd_state
val mutable status_seen = false
method socket_state = socket_state
method socket =
match socket_state with
| Down -> failwith "Socket is down"
| _ -> fd
method socket_str =
try
Int64.to_string (Netsys.int64_of_file_descr self # socket)
with _ -> "n/a"
method close ~followup () =
match socket_state with
| Down -> followup ()
| _ ->
let fd_str = self # socket_str in
if !options.verbose_connection then
dlogr (fun () ->
sprintf "FD %s - HTTP connection: Closing socket!"
fd_str);
mplex # cancel_reading();
mplex # cancel_writing();
mplex # start_shutting_down
~when_done:(fun x_opt ->
Netlog.Debug.release_fd fd;
mplex # inactivate();
match x_opt with
| None ->
followup ()
| Some err ->
if !options.verbose_connection then
dlog(sprintf
"FD %s - Shutdown error: %s"
fd_str (Netexn.to_string err));
followup()
)
();
socket_state <- Down
method down() =
socket_state <- Down (* our view *)
(****************************** INPUT ********************************)
val mutable cfg_fetch_call = (fun () -> raise Not_found)
method status_seen =
(* Whether at least one status line (incl. status 1XX) has been seen *)
status_seen
method configure_read ~fetch_call () =
(* fetch_call: This is called when the status line is read to get
the corresponding call. This function may raise [Not_found] in
which case the status line is an error
*)
cfg_fetch_call <- fetch_call
method read_e esys =
(* This engine returns the next call read from the input, or
returns None for EOF.
*)
assert (socket_state = Up_r || socket_state = Up_rw);
let cur_call = ref None in
(* remember the call - only for postprocessing on error *)
let rec read_status_line_e call_opt =
input_line_opt_e ~max_len:max_line_len buf_in_dev
++ (fun line_opt ->
match line_opt with
| None ->
eps_e (`Done None) esys
| Some line ->
if !options.verbose_status then
dlogr
(fun () ->
sprintf "FD %Ld - Status: %S"
(Netsys.int64_of_file_descr fd)
line
);
( match Netstring_str.string_match status_re line 0 with
| None ->
raise (Garbage_received "Bad status line")
| Some m ->
let proto = Netstring_str.matched_group m 1 line in
let code_str = Netstring_str.matched_group m 2 line in
let code = int_of_string code_str in
let text =
try Netstring_str.matched_group m 4 line
with Not_found -> "" in
if code < 100 || code > 599 then
raise (Garbage_received "Bad status code");
status_seen <- true (* code >= 200 *);
let call_opt =
if call_opt = None then (
let call_opt' =
try Some(cfg_fetch_call())
with Not_found -> None in
cur_call := call_opt';
call_opt'
)
else
call_opt in
( match call_opt with
| None ->
raise(Garbage_received "Spontaneous data")
| Some call ->
(* eprintf "code=%d text=%s proto=%s\n%!" code text proto; *)
if code >= 200 then
call # private_api # set_response_status
code text proto;
let hdr_buf = Buffer.create 500 in
read_header_e code call hdr_buf
)
)
)
and read_header_e code call hdr_buf =
input_line_opt_e ~max_len:max_line_len buf_in_dev
++ (fun line_opt ->
match line_opt with
| None ->
let msg = "EOF where response header expected" in
raise (Garbage_received msg)
| Some line ->
Buffer.add_string hdr_buf line;
Buffer.add_string hdr_buf "\n";
if line = "" || line = "\r" then (
parse_header_e code call (Buffer.contents hdr_buf)
)
else (
if Buffer.length hdr_buf > 100000 then (
let msg ="Response header too long" in
raise (Garbage_received msg)
);
read_header_e code call hdr_buf
)
)
and parse_header_e code call hdr_str =
let header_l, real_end_pos =
try
Mimestring.scan_header
~downcase:false ~unfold:true ~strip:true hdr_str
~start_pos:0 ~end_pos:(String.length hdr_str)
with
| Failure _ ->
let msg = "Bad response header" in
raise (Garbage_received msg)
in
assert(real_end_pos = String.length hdr_str);
let header = new Netmime.basic_mime_header header_l in
if !options.verbose_response_header then
dump_header "HTTP response " header#fields;
call # private_api # set_continue (code < 200);
(* Calling set_continue may trigger that the send loop
in [transmitter] resumes its send task. We need to do it
whatever code we see here - not only for code=100.
*)
if code < 200 then (
if !options.verbose_events then
dlogr (fun () ->
sprintf "FD %s - HTTP events: Got 100 Continue line"
self#socket_str
);
read_status_line_e None
)
else (
call # private_api # set_response_header header;
read_body_e code header call
)
and read_body_e code header call =
(* First determine whether a body is expected:
- Normally, the call has either always a body (like GET), or
it does not (like HEAD). Exceptions are only the codes 204
and 304
- The CONNECT method is broken in this respect. If a 200
response is emitted, the response body is missing. Any
error response includes a body, though.
*)
let have_body =
call # has_resp_body && code <> 204 && code <> 304 &&
(call # request_method <> "CONNECT" || code >= 300) in
if have_body then (
let out_dev = call # private_api # response_body_open_wr esys in
(* Check if we have chunked encoding: *)
let is_chunked =
try header # field "Transfer-encoding" <> "identity"
with Not_found -> false in
if is_chunked then
read_chunked_body_e code header out_dev call
else (
let length_opt =
try
let l = Int64.of_string (header # field "Content-Length") in
if l < 0L then raise (Bad_message "Bad Content-Length field");
Some l
with
| Failure _ -> raise (Bad_message "Bad Content-Length field")
| Not_found -> None in
read_plain_body_e code header out_dev length_opt call
)
) else
read_end_e call
and read_plain_body_e code header out_dev length_opt call =
(* Parses a non-chunked HTTP body. If length_opt=None, the message
* is terminated by EOF. If length_opt=Some len, the message has
* this length.
*)
( Uq_io.copy_e
?len64:length_opt
buf_in_dev
out_dev
>> (function
| `Done n ->
( match length_opt with
| None -> ()
| Some l ->
if n <> l then
raise(Bad_message "EOF in response message")
);
if !options.verbose_response_contents then
dlogr
(fun () ->
sprintf "FD %Ld - HTTP response body %s"
(Netsys.int64_of_file_descr fd)
(match length_opt with
| None -> "(unknown length)"
| Some n -> sprintf "(%Ld bytes)" n
)
);
`Done n
| st -> st
) (* out_dev is closed in read_end_e *)
)
++ (fun n -> read_end_e call)
and read_chunked_body_e code header out_dev call =
(* Parses a chunked HTTP body *)
input_line_opt_e ~max_len:max_line_len buf_in_dev
++ (function
| Some line ->
if !options.verbose_response_contents then
dlogr
(fun () ->
sprintf "FD %Ld - HTTP response chunk size: %S"
(Netsys.int64_of_file_descr fd)
line
);
( match Netstring_str.string_match chunk_re line 0 with
| None ->
raise
(Bad_message "Cannot parse chunk of response body");
| Some m ->
let hex_len = Netstring_str.matched_group m 1 line in
let len =
try Int64.of_string ("0x" ^ hex_len)
with Failure _ ->
raise (Bad_message "Chunk too large") in
if len = 0L then
let trl_buf = Buffer.create 100 in
read_trailer_e code header out_dev call trl_buf
else
read_chunk_data_e code header out_dev len call
)
| None ->
raise (Bad_message "EOF where next response chunk expected")
)
and read_chunk_data_e code header out_dev len call =
(* Parses the chunk data following the chunk size field *)
Uq_io.copy_e
?len64:(Some len)
buf_in_dev
out_dev
++ (fun n ->
if n <> len then
raise(Bad_message "EOF in response message");
read_chunk_end_e code header out_dev call
)
and read_chunk_end_e code header out_dev call =
input_line_opt_e ~max_len:max_line_len buf_in_dev
++ (function
| Some line ->
if !options.verbose_response_contents then
dlogr
(fun () ->
sprintf "FD %Ld - HTTP response chunk end: %S"
(Netsys.int64_of_file_descr fd)
line
);
if line = "" || line = "\r" then
read_chunked_body_e code header out_dev call
else
raise (Bad_message "CR/LF after response chunk is missing")
| None ->
raise (Bad_message "EOF where next response chunk expected")
)
and read_trailer_e code header out_dev call trl_buf =
input_line_opt_e ~max_len:max_line_len buf_in_dev
++ (fun line_opt ->
match line_opt with
| None ->
let msg = "EOF where response trailer expected" in
raise (Bad_message msg)
| Some line ->
if !options.verbose_response_contents then
dlogr
(fun () ->
sprintf "FD %Ld - HTTP response trailer: %S"
(Netsys.int64_of_file_descr fd)
line
);
Buffer.add_string trl_buf line;
Buffer.add_string trl_buf "\n";
if line = "" || line = "\r" then (
parse_trailer_e
code header out_dev call (Buffer.contents trl_buf)
)
else (
if Buffer.length trl_buf > 10000 then (
let msg ="Response trailer too long" in
raise (Bad_message msg)
);
read_trailer_e code header out_dev call trl_buf
)
)
and parse_trailer_e code header out_dev call trl_str =
let trailer_l, real_end_pos =
try
Mimestring.scan_header
~downcase:false ~unfold:true ~strip:true trl_str
~start_pos:0 ~end_pos:(String.length trl_str)
with
| Failure _ ->
let msg = "Bad response trailer" in
raise (Bad_message msg)
in
assert(real_end_pos = String.length trl_str);
let new_header =
new Netmime.basic_mime_header (header#fields @ trailer_l) in
call # private_api # set_response_header new_header;
if !options.verbose_response_header then
dump_header "HTTP response+trailer " new_header#fields;
(* out_dev is closed in read_end_e *)
read_end_e call
and read_end_e call =
call # private_api # finish_response_e esys (* will close out_dev *)
++ (fun () ->
eps_e (`Done (Some call)) esys
)
in
read_status_line_e None
>> (fun st ->
let propagate_garbage = !cur_call <> None in
let maybe_cleanup() =
match !cur_call with
| None -> ()
| Some call ->
call # private_api # cleanup();
cur_call := None in
match st with
| `Error (Garbage_received msg) when propagate_garbage ->
maybe_cleanup();
`Error (Bad_message msg)
(* If we can associate a Garbage_received error with
a certain call change the exception to Bad_message.
The background is that Garbage_received is not
attributed to a specific message by the higher layers.
*)
| `Error e ->
maybe_cleanup();
`Error e
| _ ->
st
)
(****************************** OUTPUT ********************************)
val send_queue = Q.create()
val send_buf = String.create 4096
val mutable sending = false
method write_activity =
sending || not(Q.is_empty send_queue)
method add x =
Q.add x send_queue
method write_e esys =
(* Writes all contents of send_queue *)
(* It is the task of the caller to close the request body, by
calling finish_request_e at the right moment
*)
let rec write_next_e() =
if Q.is_empty send_queue then
eps_e (`Done()) esys
else (
let token = Q.take send_queue in
( match token with
| Send_header (call_id, meth, url, hdr) ->
write_header_e call_id meth url hdr
| Send_body (dev,length_opt) ->
write_body_e dev length_opt
| Send_body_chunked dev ->
write_body_chunked_e dev
| Send_eof ->
write_eof_e ()
)
++ write_next_e
)
and write_header_e call_id meth url hdr =
let buf = B.create 1000 in
B.add_string buf meth;
B.add_string buf " ";
B.add_string buf url;
B.add_string buf " HTTP/1.1";
if !options.verbose_status then
dlogr
(fun () ->
sprintf "FD %s - Call %d - HTTP request: %s"
self#socket_str call_id (B.contents buf));
B.add_string buf "\r\n";
let ch = new Netchannels.output_netbuffer buf in
Mimestring.write_header ch hdr#fields;
ch # close_out();
if !options.verbose_request_header then
dump_header "HTTP request " hdr#fields;
Uq_io.output_netbuffer_e dev buf
and write_body_e d expected_length_opt =
if !options.verbose_request_contents then
dlogr
(fun () ->
sprintf "FD %Ld - HTTP request body fragment %s"
(Netsys.int64_of_file_descr fd)
(match expected_length_opt with
| None -> "(unknown length)"
| Some n -> sprintf "(%Ld bytes)" n
)
);
(* N.B. We do not close [d] here - task of caller *)
Uq_io.copy_e ?len64:expected_length_opt d dev
>> (function
| `Done n ->
( match expected_length_opt with
| None -> ()
| Some exp_n ->
if n <> exp_n then
failwith "Http_client: announced length of \
request body does not match actual length"
);
`Done ()
| `Error e -> `Error e
| `Aborted -> `Aborted
)
and write_body_chunked_e d =
write_body_next_chunk_e d ()
and write_body_next_chunk_e d () =
input_opt_e d (`String send_buf) 0 (String.length send_buf)
++ (function
| Some n ->
if !options.verbose_request_contents then
dlogr
(fun () ->
sprintf "FD %Ld - HTTP request body chunk (%d bytes)"
(Netsys.int64_of_file_descr fd) n
);
let s = sprintf "%x\r\n" n in
Uq_io.output_string_e dev s
++ (fun () ->
Uq_io.really_output_e dev (`String send_buf) 0 n)
++ (fun () -> Uq_io.output_string_e dev "\r\n")
++ write_body_next_chunk_e d
| None ->
if !options.verbose_request_contents then
dlogr
(fun () ->
sprintf "FD %Ld - HTTP request body chunk (last)"
(Netsys.int64_of_file_descr fd)
);
let s = "0\r\n\r\n" in
Uq_io.output_string_e dev s
(* N.B. We do not close [d] here - task of caller *)
)
and write_eof_e () =
if !options.verbose_request_contents then
dlogr (fun () ->
sprintf "FD %Ld - HTTP request EOF"
(Netsys.int64_of_file_descr fd)
);
Uq_io.write_eof_e dev
++ (fun flag ->
if not flag then
failwith "Http_client: \
no support for closing the write side only";
(* It is better to set the new state after a successful
write_eof operation than before. It is possible that the whole
chain of write operations is aborted. In this case
an EOF also needs to be written. If we abort between write_eof
and the following assignment, the EOF will just be
written twice (which is unproblematic). Otherwise, the EOF
could be forgotten, and the client would hang.
*)
if socket_state = Up_rw then
socket_state <- Up_r;
eps_e (`Done()) esys
)
in
(* If the socket is already closed for writing, do nothing. This
can happen if the read side decides to close the socket.
*)
if socket_state = Up_rw then (
sending <- true;
write_next_e()
>> (fun st -> sending <- false; st)
)
else
eps_e (`Done ()) esys
end
)
;;
(**********************************************************************)
(*** PROTOCOL STATE OF A SINGLE MESSAGE ***)
(**********************************************************************)
(* The class 'transmitter' is a container for the message and the
* associated protocol state, and defines the methods to send
* the request, and to receive the reply.
* The protocol state stored here mainly controls the send and receive
* buffers (e.g. how many octets have already been sent? Are the octets
* received so far already a complete message or not?)
*)
type message_state =
Unprocessed (* Not even a byte sent or received *)
| Sending_hdr (* Sending currently the header *)
| Handshake (* The header has been sent, now waiting for status 100 *)
| Sending_body (* The header has been sent, now sending the body *)
| Finishing (* The body is almost sent - about to finish *)
| Sent_request (* The body has been sent; the reply is being received *)
| Complete (* The whole reply has been received *)
;;
(* The states Unprocessed...Sent_request are only set by the request
sender. We enter Complete only if we can receive the corresponding
response.
In the case that the response arrives while we are still sending,
the processing of the response needs to be delayed until the sending
is done. What can happen then:
- We get the status while waiting for "100". This is handled in send_e,
and the status is set to Finishing.
- We get the status line later while still sending. This is detected
by the reader, and send_interrupt is called.
- If we get the status line when already in state Finishing, the
request is not aborted, and the remaining bytes are sent.
Errors are not reflected in the state.
*)
let string_of_state =
function
| Unprocessed -> "Unprocessed"
| Sending_hdr -> "Sending_hdr"
| Handshake -> "Handshake"
| Sending_body -> "Sending_body"
| Finishing -> "Finishing"
| Sent_request -> "Sent_request"
| Complete -> "Complete"
let test_conn_close hdr =
let conn_list =
try Nethttp.Header.get_connection hdr
with _ (* incl. syntax error *) -> [] in
List.mem "close" (List.map String.lowercase conn_list)
let test_conn_keep_alive hdr =
let conn_list =
try Nethttp.Header.get_connection hdr
with _ (* incl. syntax error *) -> [] in
List.mem "keep-alive" (List.map String.lowercase conn_list)
let test_proxy_conn_close hdr =
let conn_list =
try
List.map String.lowercase
(hdr # multiple_field "proxy-connection")
with _ (* incl. syntax error *) -> [] in
List.mem "close" (List.map String.lowercase conn_list)
let test_proxy_conn_keep_alive hdr =
let conn_list =
try
List.map String.lowercase
(hdr # multiple_field "proxy-connection")
with _ (* incl. syntax error *) -> [] in
List.mem "keep-alive" (List.map String.lowercase conn_list)
let test_http_1_1 proto_str =
try
let proto = Nethttp.protocol_of_string proto_str in
match proto with
| `Http((1,n),_) when n >= 1 ->
(* HTTP/1.1 <= proto < HTTP/2.0 *)
true
| _ ->
false
with _ -> false
let transmitter
peer_is_proxy
proxy_auth_state
(m : http_call)
(f_done : http_call -> unit)
options
=
( object (self)
val mutable state = Unprocessed
val indicate_done = f_done
val msg = m
(*
val mutable auth_headers = []
(* Additional header for _proxy_ authentication *)
*)
val mutable send_e_opt = None
val mutable send_finish_e_opt = None
val mutable send_interrupted = false
method state = state
method f_done = indicate_done
method send_interrupted = send_interrupted
method init() =
(* Prepare for (re)transmission:
* - Set the `Effective request header
* - Reset the status info of the http_call
* - Initialize transmission state
*)
if !options.verbose_status then
dlogr (fun () -> sprintf "Call %d: initialize transmitter"
(Oo.id msg));
msg # private_api # prepare_transmission();
(* Set the effective URI. This must happen before authentication. *)
let eff_uri =
if peer_is_proxy then
msg # request_uri
else
let path = msg # get_path() in
if path = "" then (
msg # empty_path_replacement
)
else path
in
msg # private_api # set_effective_request_uri eff_uri;
let cah =
match msg # private_api # auth_state with
| `None -> []
| `In_advance session
| `In_reply session ->
session # authenticate msg in
let pah =
match !proxy_auth_state with
| `None -> []
| `In_advance session
| `In_reply session ->
session # authenticate msg in
let rh = msg # request_header `Effective in
List.iter
(fun (n,v) ->
rh # update_field n v
)
(cah @ pah);
if peer_is_proxy then
rh # update_field "Proxy-Connection" "keep-alive";
state <- Unprocessed;
if not (msg # has_req_body) then (
(* Remove certain headers *)
rh # delete_field "Expect";
);
send_finish_e_opt <- None
method cleanup() =
(* release resources *)
msg # private_api # cleanup()
(*
method add_auth_header n v =
auth_headers <- (n,v) :: auth_headers
*)
method error_if_unserved error =
msg # private_api # error_if_unserved !options.verbose_status error
method send_e (io : io_buffer)
(handshake_cfg : float option)
(close_flag : bool)
esys =
(* handshake_cfg: if [Some t], it is waited after the header for the
"100 Continue" handshake. [t] is the timeout. The [Expect]
header is already set (by the user).
close_flag: if true, the "connection:close" header is set
*)
assert (state = Unprocessed);
assert (not(io # write_activity));
assert (send_finish_e_opt = None);
let rec send_header_e() =
let rh = msg # request_header `Effective in
let host = msg # get_host() in
let port = msg # get_port() in
let host_str = host ^ (if port = 80 then ""
else ":" ^ string_of_int port) in
rh # update_field "Host" host_str;
if close_flag then
rh # update_field "Connection" "close";
io # add (Send_header(self#call_id,
msg#request_method,
msg#effective_request_uri,
(rh :> Netmime.mime_header_ro)));
state <- (if handshake_cfg <> None then Handshake else Sending_hdr);
io # write_e esys
++ (match handshake_cfg with
| Some t when not msg # private_api # continue ->
send_handshake_e t
| _ ->
send_body_e
)
and send_handshake_e tmo () =
if !options.verbose_events then
dlogr (fun () ->
sprintf "Call %d - HTTP events: Waiting for 100 Continue"
(Oo.id msg)
);
msg # private_api # wait_continue_e tmo esys
++ (fun code_100 ->
if code_100 then
send_body_e()
else
(* We got a non-100 response after waiting for 100.
We suppress the request body, and instead close the
connection on the sender side.
*)
send_no_body_e()
)
and send_body_e () : unit Uq_engines.engine =
if msg # has_req_body then (
state <- Sending_body;
let rh = msg # request_header `Effective in
let is_chunked =
try rh # field "Transfer-encoding" <> "identity"
with Not_found -> false in
let d = msg # private_api # request_body_open_rd esys in
let tok, need_eof =
if is_chunked then
Send_body_chunked d, false
else (
let length_opt =
try
let l =
try Int64.of_string (rh # field "Content-Length")
with
| Failure _ ->
failwith "Http_client: Bad Content-Length field \
in request" in
if l < 0L then
failwith "Http_client: Bad Content-Length field in request";
Some l
with Not_found -> None in
Send_body(d, length_opt), length_opt = None
) in
io # add tok;
if need_eof then
io # add Send_eof;
io # write_e esys
++ (fun () ->
state <- Sent_request;
msg # private_api # finish_request_e esys
)
)
else (
state <- Sent_request;
msg # private_api # finish_request_e esys
)
and send_no_body_e () =
(* This is only used if we announced a body in the header, but
finally do not send it (because we got an error from the server).
We need to close the connection in this case. Unconditionally,
because we got out of sync (the server cannot know whether we've
seen the error before we start sending the request body, so the
server cannot know what to do).
*)
state <- Finishing;
io # add Send_eof;
io # write_e esys
++ (fun () ->
state <- Sent_request;
eps_e (`Done ()) esys
)
in
let (fin_e, signal) = Uq_engines.signal_engine esys in
send_finish_e_opt <- Some fin_e;
let e = send_header_e() in
send_e_opt <- Some e;
let e' =
(* This engine handles send interrupts, and returns [true] if an
EOF needs to be written
*)
e >> (fun st ->
send_e_opt <- None;
match st with
| `Aborted when send_interrupted ->
if !options.verbose_events then
dlogr
(fun () ->
sprintf "Call %d - HTTP event: Send interrupted"
(Oo.id msg));
`Done true
| `Aborted -> `Aborted
| `Error err -> `Error err
| `Done () -> `Done false
) in
let e'' =
(* This engine writes the EOF if needed *)
e'
++ (fun flag ->
if flag then (
io # add Send_eof;
io # write_e esys
)
else eps_e (`Done ()) esys
) in
(* Finally catch errors and signal termination: *)
e''
>> (fun st ->
( match st with
| `Error err ->
if !options.verbose_events then
dlogr
(fun () ->
sprintf "Call %d - HTTP event: Send exception: %s"
(Oo.id msg) (Netexn.to_string err)
);
| _ -> ()
);
signal st; st
)
method send_interrupt() =
(* Stop sending immediately. This method is called by the reader
when an error status is received while we are still writing
the request. The reaction is to close the write side of the
connection.
For chunked encoding, we could also finish the current chunk,
and send an empty chunk. However, this is complicated to
get done here, so we always use the close method.
*)
match send_e_opt with
| None -> ()
| Some e ->
send_interrupted <- true;
e # abort()
method send_finish_e esys =
(* Wait here until the request is completely sent (synchronization with
the sender)
*)
match send_finish_e_opt with
| None ->
eps_e (`Done ()) esys
| Some e ->
e
method receive_complete () =
assert(state = Handshake || state = Sending_body || state = Finishing ||
state = Sent_request);
(* Handshake: this is possible when we were waiting for a 100 response,
but got a non-100 instead. In this case, the request is not sent,
hence the state remains at Handshake.
Sending_body: this is possible when we get a server status while
sending the reqest, and stopping the request because of this.
*)
state <- Complete
method indicate_pipelining =
(* Return 'true' iff the reply is HTTP/1.1 compliant and does not
* contain the 'connection: close' header.
*)
let req_hdr = msg # request_header `Effective in
let b0 =
if peer_is_proxy then
not(test_proxy_conn_close req_hdr) &&
not(test_conn_close req_hdr)
else
not(test_conn_close req_hdr) in
b0 && (
let resp_header = msg # private_api # response_header in
let proto_str = msg # private_api # response_proto in
let b1 =
if peer_is_proxy then
test_http_1_1 proto_str && not(test_proxy_conn_close resp_header)
&& not(test_conn_close resp_header)
else
test_http_1_1 proto_str && not(test_conn_close resp_header) in
b1 && (
try
let server = resp_header # field "Server" in
not (List.exists
(fun re ->
Netstring_str.string_match re server 0 <> None
)
pipeline_blacklist)
with
| Not_found -> true (* Nothing known ... Assume the best! *)
)
)
method indicate_sequential_persistency =
(* Returns 'true' if persistency without pipelining
* is possible.
*)
let b0 =
not(test_conn_close (msg # request_header `Effective)) in
b0 && (
let resp_header = msg # private_api # response_header in
let proto_str = msg # private_api # response_proto in
let is_http_11 = test_http_1_1 proto_str in
let normal_persistency =
not peer_is_proxy &&
(not (test_conn_close resp_header)) &&
(is_http_11 || test_conn_keep_alive resp_header) in
let proxy_persistency =
peer_is_proxy &&
(not (test_conn_close resp_header)) &&
(not (test_proxy_conn_close resp_header)) &&
(is_http_11 || test_proxy_conn_keep_alive resp_header) in
normal_persistency || proxy_persistency
)
method message = msg
method call_id = Oo.id msg
end
)
;;
let drive_postprocessing_e esys options m f_done =
Uq_engines.delay_engine 0.0
(fun () ->
( try
if !options.verbose_status then
dlogr (fun () ->
sprintf "Call %d - postprocessing" (Oo.id m));
let () = f_done m in ()
with
| any ->
if !options.verbose_status then
dlogr (fun () ->
sprintf "Call %d - Exception in postprocessing: %s"
(Oo.id m) (Netexn.to_string any));
let g = Unixqueue.new_group esys in
Unixqueue.once esys g 0.0 (fun () -> raise any);
);
eps_e (`Done ()) esys
)
esys
let drive_postprocessing_msg esys options m f_done =
ignore(drive_postprocessing_e esys options m f_done)
(**********************************************************************)
(**********************************************************************)
(**********************************************************************)
(*** ***)
(*** THE PROTOCOL STATE OF THE CONNECTION ***)
(*** ***)
(**********************************************************************)
(**********************************************************************)
(**********************************************************************)
type peer =
[ `Direct of string * int
| `Http_proxy of string * int
| `Http_proxy_connect of (string * int) * (string * int)
| `Socks5 of (string * int) * (string * int)
]
let first_hop =
function
| `Direct (host,port) -> (host,port)
| `Http_proxy (host,port) -> (host,port)
| `Http_proxy_connect ((host,port),_) -> (host,port)
| `Socks5 ((host,port),_) -> (host,port)
let content_hop =
function
| `Direct (host,port) -> (host,port)
| `Http_proxy (host,port) -> (host,port) (* This case does not work *)
| `Http_proxy_connect (_,(host,port)) -> (host,port)
| `Socks5 (_,(host,port)) -> (host,port)
let rewrite_first_hop s =
function
| `Direct (host,port) -> `Direct(s,port)
| `Http_proxy (host,port) -> `Http_proxy(s,port)
| `Http_proxy_connect ((host1,port1),(host2,port2)) ->
`Http_proxy_connect ((s,port1),(host2,port2))
| `Socks5 ((host1,port1),(host2,port2)) ->
`Socks5 ((s,port1),(host2,port2))
let string_of_peer peer =
match peer with
| `Direct (host,port) ->
sprintf "direct connection to %s:%d" host port
| `Http_proxy (host,port) ->
sprintf "proxy connection via %s:%d" host port
| `Http_proxy_connect ((host1,port1),(host2,port2)) ->
sprintf "proxy connection via %s:%d to %s:%d" host1 port1 host2 port2
| `Socks5 ((host1,port1),(host2,port2)) ->
sprintf "SOCKS connection via %s:%d to %s:%d" host1 port1 host2 port2
let proxy_connect_e esys fd fd_open host port options proxy_auth_handler_opt
cur_proxy_session tcp_real_connect_e setup_e =
(* Send the CONNECT line plus header, and wait for 200.
The continuation of this engine is either setup_e() if successful,
or tcp_real_connect_e() if another connection to the proxy needs to
be opened.
*)
let mplex =
Uq_engines.create_multiplex_controller_for_connected_socket
~supports_half_open_connection:true
fd esys in
(* N.B. No timeout here required because this activity is covered by the
connect timeout
*)
let io = io_buffer options fd mplex Up_rw in
let host_url = sprintf "%s:%d" host port in
let msg = new connect host_url in
let hdr = msg # request_header `Effective in
hdr # update_field "Host" host_url;
hdr # update_field "Proxy-Connection" "keep-alive";
let rec request_e () =
( match !cur_proxy_session with (* authentication *)
| None -> ()
| Some sess ->
let pah = sess # authenticate msg in
List.iter
(fun (n,v) ->
hdr # update_field n v
)
pah
);
io#add (Send_header(0, msg#request_method, msg#effective_request_uri,
( hdr :> Netmime.mime_header_ro )
));
io#configure_read ~fetch_call:(fun () -> msg) ();
io#write_e esys
++ (fun () ->
io#read_e esys
++ (function
| None ->
failwith "EOF from proxy server"
| Some m ->
assert(m = msg);
( try
if m#response_status_code = 407 &&
!cur_proxy_session = None &&
proxy_auth_handler_opt <> None
then (
let ah =
match proxy_auth_handler_opt with
| None -> assert false
| Some ah -> ah in
let sess =
match ah # create_proxy_session msg options with
| None -> raise Not_found
| Some sess -> sess in
cur_proxy_session := Some sess;
(* It is now possible that the proxy closes the
connection. If so, we do this too, and reopen
another one. Otherwise, just go on.
*)
let rh = m#response_header in
let ps = m#response_protocol in
let close_flag =
test_conn_close rh || test_proxy_conn_close rh ||
(not (test_http_1_1 ps) &&
not (test_conn_keep_alive rh) &&
not (test_proxy_conn_keep_alive rh)) in
if close_flag then (
Unix.close fd;
fd_open := false;
tcp_real_connect_e()
(* The value of !cur_proxy_session is kept,
so we will use the authentication knowlege
we already gathered
*)
)
else
request_e ()
)
else
raise Not_found
with Not_found ->
match m#status with
| `Unserved ->
assert false
| `Http_protocol_error err ->
failwith ("Exception from proxy connection: " ^
Netexn.to_string err)
| `Redirection
| `Client_error
| `Server_error ->
raise(Proxy_error m#response_status_code)
| `Successful ->
setup_e()
)
)
)
in
request_e ()
>> (function
| `Error (Garbage_received msg) ->
`Error (Bad_message msg)
| st -> st
)
let tcp_connect_e esys tp cb (peer:peer) conn_cache conn_owner options
proxy_auth_handler_opt =
(* An engine connecting to peer_host:peer_port. If a connection is still
available in conn_cache, use this instead.
Output is:
- `Done(fd, conn_time): fd is the new connection (established in conn_time
seconds)
*)
let timeout_value = !options.connection_timeout in
let resolve_e, signal_res =
Uq_engines.signal_engine esys in
let t0 = Unix.gettimeofday() in
let (hop1_host,hop1_port) = first_hop peer in
!options.resolver
esys
hop1_host
(function
| None ->
if !options.verbose_events then
dlog "HTTP events: reset after DNS failure";
let err = Name_resolution_error hop1_host in
signal_res (`Error err)
| Some addr ->
signal_res (`Done addr)
);
let descr = string_of_peer peer in
let tmo_x =
Timeout descr in
let real_host, real_port = content_hop peer in
resolve_e
++ (fun hop1_ip ->
let hop1_host_ip =
Unix.string_of_inet_addr hop1_ip in
let cache_peer =
rewrite_first_hop hop1_host_ip peer in
try
let fd, priv_data =
conn_cache # find_inactive_connection cache_peer cb in
(* Case: reuse old connection *)
conn_cache # set_connection_state fd cache_peer (`Active conn_owner);
if !options.verbose_events then
dlog (sprintf
"FD %Ld - HTTP events: config input (reused fd) - target %s"
(Netsys.int64_of_file_descr fd) descr);
let mplex =
tp # continue
fd cb !options.connection_timeout tmo_x
real_host real_port esys priv_data in
eps_e (`Done(fd, mplex, priv_data, cache_peer, 0.0)) esys
with
| Not_found ->
if !options.verbose_connection then
dlog ("HTTP connection: creating " ^
descr);
let proxy_opt = (* SOCKS5 *)
match peer with
| `Socks5 _ ->
Some(new Uq_socks5.proxy_client
(`Socket(`Sock_inet(Unix.SOCK_STREAM,
hop1_ip,
hop1_port),
Uq_engines.default_connect_options)))
| _ -> None in
let sockspec =
match peer with
| `Direct _
| `Http_proxy _
| `Http_proxy_connect _ ->
`Sock_inet(Unix.SOCK_STREAM, hop1_ip, hop1_port)
| `Socks5 (_,(host2,port2)) ->
`Sock_inet_byname(Unix.SOCK_STREAM, host2, port2) in
let cur_proxy_session = ref None in
let rec tcp_real_connect_e () =
Uq_engines.connector
?proxy:proxy_opt
(`Socket(sockspec, Uq_engines.default_connect_options))
esys
++ (function
| `Socket(fd,_) ->
let fd_open = ref true in
!options.configure_socket fd;
let setup_e() =
tp # setup_e
fd cb !options.connection_timeout tmo_x
real_host real_port esys
>> (function
| `Done(mplex,priv_data) ->
`Done(fd,mplex,priv_data)
| `Error err -> `Error err
| `Aborted -> `Aborted
) in
( match peer with
| `Http_proxy_connect(_,(host2,port2)) ->
proxy_connect_e
esys fd fd_open host2 port2 options
proxy_auth_handler_opt
cur_proxy_session
tcp_real_connect_e
setup_e
| _ ->
setup_e()
)
>> (fun st ->
match st with
| `Error _ | `Aborted ->
if !fd_open then Unix.close fd;
fd_open := false;
st
| _ -> st
)
| _ -> assert false
) in
let eng = tcp_real_connect_e() in
Uq_engines.timeout_engine
timeout_value
(Timeout (sprintf
"creating %s" descr))
eng
++ (fun (fd,mplex,priv_data) ->
let t1 = Unix.gettimeofday() in
let d = t1 -. t0 in
if !options.verbose_connection then
dlog (sprintf
"FD %Ld - HTTP %s: Connected!"
(Netsys.int64_of_file_descr fd) descr);
Netlog.Debug.track_fd
~owner:"Http_client"
~descr:(sprintf
"HTTP %s" descr)
fd;
(* The release_fd is in Http_client_conncache! *)
conn_cache # set_connection_state
fd cache_peer (`Active conn_owner);
eps_e (`Done(fd, mplex, priv_data, cache_peer, d)) esys
)
>> (function
| `Error err ->
if !options.verbose_connection then (
dlog(sprintf
"HTTP connection: Cannot create %s: \
Exception %s"
descr (Netexn.to_string err))
);
`Error err
| st -> st
)
)
(**********************************************************************)
class type transport_channel_type =
object
method setup_e : Unix.file_descr -> channel_binding_id -> float -> exn ->
string -> int -> Unixqueue.event_system ->
(Uq_engines.multiplex_controller *
Http_client_conncache.private_data
)Uq_engines.engine
method continue : Unix.file_descr -> channel_binding_id -> float -> exn ->
string -> int -> Unixqueue.event_system ->
Http_client_conncache.private_data ->
Uq_engines.multiplex_controller
end
let http_transport_channel_type : transport_channel_type =
( object(self)
method continue fd cb tmo tmo_x host port esys priv_data =
if priv_data <> None then raise Not_found;
Uq_engines.create_multiplex_controller_for_connected_socket
~close_inactive_descr:true
~supports_half_open_connection:true
~timeout:( tmo, tmo_x )
fd esys
method setup_e fd cb tmo tmo_x host port esys =
let mplex = self # continue fd cb tmo tmo_x host port esys None in
eps_e (`Done(mplex,None)) esys
end
)
(**********************************************************************)
let fragile_pipeline
esys cb
cache_peer
proxy_auth_state proxy_auth_handler_opt
fd mplex priv_data connect_time no_pipelining conn_cache
auth_cache
counters options =
(* Implements a pipeline for an existing connection [fd]. This object
does not implement any way of recovering after errors.
*)
(* NB. cache_peer contains IP addresses for the next hop *)
let connection_e, signal_connection = Uq_engines.signal_engine esys in
(* Indicates that the connection is closed *)
let queue_e, signal_queue = Uq_engines.signal_engine esys in
(* Indicates that all processing of queued messages is done *)
let finished_e =
Uq_engines.sync_engine connection_e queue_e
>> (function
| `Done _ -> `Done()
| `Error e -> `Error e
| `Aborted -> `Aborted
) in
let fd_str =
Int64.to_string (Netsys.int64_of_file_descr fd) in
let peer_is_proxy = (* whether we have a normal HTTP proxy *)
match cache_peer with
| `Http_proxy _ -> true
| _ -> false in
( object(self)
val mutable io = io_buffer options fd mplex Up_rw
val mutable write_queue = Q.create()
val mutable read_queue = Q.create()
(* Invariant: write_queue is a suffix of read_queue *)
(* The following two variables control whether pipelining is enabled or
* not. The problem is that it is unclear how old servers react if we
* send to them several requests at once. The solution is that the first
* "round" of requests and replies is done in a compatibility mode: After
* the first request has been sent sending stops, and the client waits
* until the reply is received. If the reply indicates HTTP/1.1 and does
* not contain a "connection: close" header, all further requests and
* replies will be performed in pipelining mode, i.e. the requests are
* sent independent of whether the replies of the previous requests have
* been received or not.
*
* sending_first_message: 'true' means that the first request has not yet
* been completely sent to the server.
* done_first_message: 'true' means that the reply of the first request
* has been arrived.
*)
val mutable sending_first_message = true
val mutable done_first_message = false
(* 'inhibit_pipelining_byserver': becomes true if the server is able
* to keep persistent connections but is not able to use pipelining.
* (HTTP/1.0 "keep alive" connections)
*)
val mutable inhibit_pipelining_byserver = no_pipelining
(*
(* Proxy authorization: If 'proxy_user' is non-empty, the variables
* 'proxy_user' and 'proxy_password' are interpreted as user and
* password for proxy authentication. More precisely, once the proxy
* responds with status code 407, 'proxy_credentials_required' becomes
* true, and all following requests will include the credentials identifying
* the user (with the "basic" authentication method).
* If the proxy responds again with code 407, this reaction will not
* be handled again but will be visible to the outside.
*)
val mutable proxy_credentials_required = false
val mutable proxy_cookie = ""
*)
(* Whether this connection never proves to exchange a message: *)
val mutable total_failure = false
(* 'close_connection' indicates that a HTTP/1.0 response was received or
* that a response contained a 'connection: close' header.
*)
val mutable close_connection = false
(* whether the [after_eof] cleanup has already been done (must only happen
once
*)
val mutable after_eof = false
(* The vars govern whether there is an engine writing/reading *)
val mutable drive_output_active = None
val mutable drive_input_active = None
method length =
(* Returns the number of open requests (requests without response) *)
Q.length read_queue
method active =
(* Whether something is to be done *)
self # length > 0
method iter_unserved_messages f =
(* Call f with all unserved messages *)
Queue.iter (fun trans -> f trans) read_queue
method is_total_failure = total_failure
method no_pipelining = inhibit_pipelining_byserver
method finished_e = finished_e
(* This engine transitions to [`Done()] when the
connection is finished, and all messages are processed.
At this point, the file descriptor is closed or given back
to the cache. The read and write queues are unmodified, and
can be used to recover.
Errors are reported via the messages.
*)
method add urgent m f_done =
(* add: adds to the read_queue/write_queue. This must be possible
at any time - even after shutting down the socket and stopping
any event processing.
*)
(* urgent: whether to insert the message m into the front-most place
(to be used after autorization)
*)
if !options.verbose_connection then
dlogr (fun () ->
sprintf "HTTP Connection: adding call %d"
(Oo.id m));
(* Create the transport container for the message and add it to the
* queues:
*)
let trans =
transmitter peer_is_proxy proxy_auth_state m f_done options in
(* (* would not work, so leave disabled *)
if !proxy_auth_state = `None then (
match proxy_auth_handler_opt with
| None -> ()
| Some ah ->
(* enable in-advance authentication *)
( match ah # create_proxy_session m with
| None -> ()
| Some sess ->
proxy_auth_state := `In_advance sess
)
);
*)
(* Initialize [trans] for transmission: *)
trans # init();
let n = Queue.length write_queue in
if urgent && n > 0 then (
(* Insert [trans] at the ealierst possible place *)
Q.add_at (n-1) trans write_queue;
Q.add_at (n-1) trans read_queue;
)
else (
Q.add trans write_queue;
Q.add trans read_queue;
)
method attach() =
(* Enables event processing. To be called after [add] *)
sending_first_message <- true;
done_first_message <- false;
close_connection <- false;
(* FIXME: reset other vars? *)
io # configure_read
~fetch_call:self#drive_input_fetch ();
self # drive_input();
if !options.verbose_events then
dlog (sprintf
"FD %Ld - HTTP events: config input"
(Netsys.int64_of_file_descr fd));
self # maintain_polling();
method reset() =
(* Compare also with after_eof! *)
self # abort ~reusable:false ~count:`Crashed;
Q.iter
(fun trans ->
trans # cleanup(); (* release resources *)
trans # error_if_unserved No_reply;
self # drive_postprocessing trans
)
read_queue;
signal_queue `Aborted
(**********************************************************************)
(* End of interface. *)
(**********************************************************************)
method private maintain_polling() =
(* If one of the following conditions is true, we need not to poll
* the write side of the socket:
* - The write_queue is empty but the read_queue not
* - The difference between the read and the write queue is too big
* - We wait for the reply of the first request send to a server
* - The write side of the socket is closed
*)
if !options.verbose_events then
dlogr
(fun () ->
sprintf "FD %s - HTTP events: maintain_polling"
fd_str
);
if io # socket_state <> Down then (
let actual_max_drift =
if inhibit_pipelining_byserver then 0 else
match !options.synchronization with
| Pipeline drift -> min drift max_pipeline
| _ -> 0
(* 0: Allow no drift if pipelining is not allowed *)
in
let have_requests =
Q.length read_queue - Q.length write_queue <= actual_max_drift
&& Q.length write_queue > 0
&& (Q.peek write_queue) # state = Unprocessed
&& (done_first_message || sending_first_message) in
(* Note: sending_first_message is true while the first request is sent.
* done_first_message becomes true when the response arrived. In the
* meantime both variables are false, and nothing is sent.
*)
let do_release =
(io # socket_state = Up_rw &&
Q.length read_queue = 0 && Q.length write_queue = 0) in
(* If the socket is still up, we must send EOF. Normally, this
* should have happened already, just to be sure we check this here.
*)
let do_close_output = close_connection in
(* close_connection: this is set in update_characteristics after
* receiving the first response
*)
if !options.verbose_events then
dlogr
(fun () ->
sprintf "FD %s - HTTP events: maintain_polling \
n_read=%d n_write=%d \
actual_max_drift=%d have_requests=%B \
do_close_output=%B do_release=%B"
fd_str
(Q.length read_queue) (Q.length write_queue)
actual_max_drift have_requests do_close_output do_release
);
if drive_output_active = None && io#socket_state = Up_rw then (
if !options.verbose_events then
dlogr
(fun () ->
sprintf "FD %s - HTTP events: config output=%s"
fd_str
(if do_close_output then "close" else
if do_release then "release" else
if have_requests then "enabled" else
"none"
)
);
if do_close_output then
self # close_output()
else
if do_release then
self # release_io ()
else
if have_requests then
self # drive_output()
)
)
method private abort ~reusable ~count =
(* This method is called when the connection is in a final (maybe
* errorneous) state, and the protocol handler decides to stop
* processing.
*
* reusable: whether it is possible to reuse this connection later
*)
if io # socket_state <> Down then (
if !options.verbose_connection then
dlog (sprintf
"FD %s - HTTP connection: Shutdown reusable=%B"
fd_str reusable);
let followup() =
signal_connection(`Done());
if !options.verbose_events then
dlogr
(fun () ->
sprintf "FD %s - HTTP event: Connection processing done"
fd_str) in
begin match io#socket_state with
Down ->
assert false
| Up_r ->
io # close
~followup ()
| Up_rw ->
if reusable then (
( try
dlog (sprintf
"FD %s - HTTP connection: caching as inactive"
fd_str);
conn_cache # set_connection_state
fd cache_peer (`Inactive(cb,priv_data));
io # down();
with
| Not_found ->
(* We can do an orderly shutdown: *)
io # close ~followup:(fun () -> ()) ()
);
followup()
)
else
io # close
~followup ()
end;
( match count with
| `Timed_out ->
counters.timed_out_connections <-
counters.timed_out_connections + 1;
| `Crashed ->
counters.crashed_connections <-
counters.crashed_connections + 1;
| `Server_eof ->
counters.server_eof_connections <-
counters.server_eof_connections + 1;
| `Successful ->
counters.successful_connections <-
counters.successful_connections + 1
| `Failed ->
(* By definition of the counter, an abort cannot be failed *)
assert false;
);
if !options.verbose_events then
dlog (sprintf "FD %s - HTTP events: reset after shutdown"
fd_str);
self # cancel_output(); (* FIXME: check whether sufficient *)
self # cancel_input();
)
(**********************************************************************)
(*** THE OUTPUT HANDLER ***)
(**********************************************************************)
method private drive_output() =
if !options.verbose_events then
dlogr (fun() ->
sprintf "FD %s - HTTP events: drive_output" fd_str);
let can_output =
drive_output_active = None &&
io#socket_state = Up_rw &&
not(Q.is_empty write_queue) in
assert(can_output);
if can_output then (
let trans = Q.peek write_queue in
assert(trans#state = Unprocessed);
(* Clear this flag now because we are about to really send a new
request
*)
trans # message # private_api # set_retry_anyway false;
let close_flag =
!options.inhibit_persistency in
let handshake_cfg =
try
(* Proper parsing not required, because [Expect] is
* set by the user.
* [continue]: Already seen status 100
*)
let rh = trans # message # request_header `Effective in
if (not (trans # message # private_api # continue) &&
String.lowercase(rh # field "expect") = "100-continue")
then Some !options.handshake_timeout
else None
with
| Not_found -> None
in
let e =
trans # send_e io handshake_cfg close_flag esys
>> (fun st ->
drive_output_active <- None;
if !options.verbose_events then
dlogr (fun() ->
sprintf "FD %s - HTTP events: done with output \
state=%s"
fd_str (string_of_state trans#state));
match st with
| `Done () ->
assert
(trans#state = Sent_request || trans#state = Complete
|| trans#state = Handshake
|| trans#send_interrupted
);
sending_first_message <- false;
ignore (Q.take write_queue);
self # maintain_polling();
st
| `Error err ->
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: Exception %s"
fd_str (Netexn.to_string err));
self # abort ~reusable:false ~count:`Crashed;
self # after_eof (Some err);
st
| `Aborted ->
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: Aborting"
fd_str
);
st
) in
drive_output_active <- Some e;
)
method private close_output() =
if !options.verbose_events then
dlogr (fun() ->
sprintf "FD %s - HTTP events: close_output" fd_str);
let can_close =
drive_output_active = None &&
io#socket_state = Up_rw in
assert(can_close);
if can_close then (
assert (not(io # write_activity));
io # add Send_eof;
let e =
io # write_e esys
>> (fun st ->
drive_output_active <- None;
if !options.verbose_events then
dlogr (fun() ->
sprintf "FD %s - HTTP events: close_output done"
fd_str);
match st with
| `Done () ->
(* The connection closure can be driven by several
reasons, so there can still be messages on the
queues!
*)
self # abort ~reusable:false ~count:`Successful;
self # after_eof None;
st
| `Error err ->
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: Exception %s"
fd_str (Netexn.to_string err));
self # abort ~reusable:false ~count:`Crashed;
self # after_eof (Some err);
st
| `Aborted ->
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: Aborting"
fd_str
);
st
)
in
drive_output_active <- Some e;
)
method private cancel_output() =
match drive_output_active with
| None -> ()
| Some e ->
drive_output_active <- None; e # abort()
method private release_io() =
(* Give fd/mplex back to the connection cache *)
assert(io # socket_state = Up_rw);
self # abort ~reusable:true ~count:`Successful;
self # after_eof None
(* FIXME: check whether sufficient *)
(**********************************************************************)
(*** THE INPUT HANDLER ***)
(**********************************************************************)
method private drive_input() =
let rec read_loop_e() =
io # read_e esys
++ (fun call_opt ->
match call_opt with
| None ->
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: Got EOF!" fd_str);
(* The sender may be still writing, so try to stop it *)
if Q.length write_queue > 0 then
(Queue.peek write_queue) # send_interrupt();
self # abort ~reusable:false ~count:`Server_eof;
self # after_eof None;
eps_e (`Done()) esys
| Some call ->
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: Got Call %d!"
fd_str (Oo.id call));
let trans =
try Q.peek read_queue
with Q.Empty -> assert false in
assert(trans#message = call);
(* It is possible that the write is still ongoing.
By calling send_interrupt we try to stop this,
but nevertheless we have to wait until the
writer is done! The special state Finishing
indicates that it is not worth-while to stop
sending because it will end soon anyway.
Note that send_finish_e may also report errors
of the sending side.
*)
if trans#state <> Finishing then
trans # send_interrupt();
trans # send_finish_e esys
++ (fun () ->
trans # receive_complete();
self # update_characteristics trans;
ignore(Q.take read_queue);
(* Note that postprocessing may imply a
re-initialization of [trans]! So don't access
[trans] later than this point.
*)
self # postprocess_complete_message_e trans
++ (fun () ->
self # maintain_polling();
if io#socket_state <> Down then
read_loop_e()
else
eps_e (`Done()) esys
)
)
)
in
if !options.verbose_events then
dlogr
(fun () ->
sprintf "FD %s - HTTP event: Starting read loop"
fd_str);
let e =
read_loop_e() in
drive_input_active <- Some e;
ignore(e >>
(fun st ->
drive_input_active <- None;
if !options.verbose_events then
dlogr
(fun () ->
sprintf "FD %s - HTTP event: Leaving read loop: %s"
fd_str
( match st with
| `Done _ -> "regular"
| `Error e -> "exception " ^ Netexn.to_string e
| `Aborted -> "aborted"
)
);
( match st with
| `Error err ->
self # abort ~reusable:false ~count:`Crashed;
self # after_eof (Some err)
| _ -> ()
);
st
)
)
method cancel_input() =
match drive_input_active with
| None -> ()
| Some e ->
drive_input_active <- None; e # abort()
method drive_input_fetch() =
(* This is called by io when the next status line has been received *)
if Q.is_empty read_queue then (
if !options.verbose_connection then (
dlogr
(fun () ->
sprintf
"FD %s - HTTP connection: \
Got data of spontaneous response" fd_str);
);
raise Not_found
);
let trans = Q.peek read_queue in
match trans # state with
| Unprocessed ->
(* We get response data before we even tried to send
* the request. We allow this, although this is weird.
*)
if !options.verbose_connection then (
dlogr
(fun () ->
sprintf
"FD %s - HTTP connection: \
Got response before sending request" fd_str);
);
trans#message
| Sending_hdr ->
(* We get response data before we finished
* the request. We allow this for pragmatic reasons.
*)
if !options.verbose_connection then (
dlogr
(fun () ->
sprintf
"FD %s - HTTP connection: \
Got response before finishing request" fd_str)
);
trans#message
| Handshake
| Sending_body ->
(* This is perfectly legal - we get the response after
we sent at least the header
*)
trans#message
| Sent_request ->
(* The normal case *)
trans#message
| _ ->
(* Should not happen *)
assert false
method private update_characteristics trans =
(* After getting a response, check the type, and adapt the
transmission style
*)
let old_close_connection = close_connection in
let able_to_pipeline =
trans # indicate_pipelining in
(* able_to_pipeline: is true if we assume that the server
* is HTTP/1.1-compliant and thus is able to manage pipelined
* connections.
* Update first 'close_connection': This variable becomes
* true if the connection is not assumed to be pipelined
* which forces that the CLIENT closes the connection
* immediately (this is tested in maintain_polling).
*)
let only_sequential_persistency =
not able_to_pipeline &&
trans # indicate_sequential_persistency in
(* only_sequential_persistency: is true if the connection is
* HTTP/1.0, and the server indicated a persistent connection.
* In this case, pipelining is disabled.
*)
if only_sequential_persistency then begin
(* 'close_connection': not set.
*)
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: \
using HTTP/1.0 style persistent connection"
fd_str);
inhibit_pipelining_byserver <- true;
end
else
close_connection <- close_connection || not able_to_pipeline;
if !options.verbose_connection then
dlogr
(fun () ->
sprintf "FD %s - HTTP connection: pipelining=%B persistency=%B close_connection=%B->%B"
fd_str able_to_pipeline only_sequential_persistency
old_close_connection close_connection
);
(* Remember that the first request/reply round is over: *)
done_first_message <- true
method private after_eof err_opt =
(* Postprocess error information *)
if not after_eof then (
(* THINK: We could here process Garbage_received exceptions differently.
It is questionable to attribute such exceptions to specific
calls.
*)
(* First check if the connection was a total failure, i.e. if not
* even a status line was received. This is just reported to the
* robust_pipeline, where the counter for totally failed connections
* can be increased.
*)
total_failure <- not io#status_seen;
(* Assertions about queues: write queue is a suffix of read queue *)
let n_read = Q.length read_queue in
let n_write = Q.length write_queue in
assert (n_read >= n_write);
(* Clean up the transmitters: *)
Q.iter
(fun trans ->
trans # cleanup(); (* release resources *)
match err_opt with
| None ->
if total_failure then
trans # error_if_unserved (Bad_message "Protocol error")
| Some err ->
let err' =
match err with
| Garbage_received _ ->
Bad_message "Protocol error"
| No_reply ->
Bad_message "Protocol error"
| err -> err in
trans # error_if_unserved err'
)
read_queue;
(* Increase the error counter of the head of read_queue: *)
if n_read > 0 && err_opt <> None then (
let trans = Q.peek read_queue in
let m = trans # message in
let e = m # private_api # get_error_counter in
m # private_api # set_error_counter (e+1);
);
(* We have reached the logical end: *)
signal_queue (`Done());
if !options.verbose_events then
dlogr
(fun () ->
sprintf "FD %s - HTTP event: Queue processing done"
fd_str);
after_eof <- true
)
(**********************************************************************)
(*** AUTHENTICATION ***)
(**********************************************************************)
method private postprocess_complete_message_e trans =
(* This method is invoked for every complete reply. The following
* cases are handled at this stage of processing:
*
* - Status code 407: The proxy demands authorization. If the request
* already contains credentials for the proxy, this status code
* isn't handled here. Otherwise, the request is added again onto
* the queue, and a flag ('proxy_credentials_required') is set which
* forces that the proxy credentials must be added for every new
* request.
* Note: The necessary authentication header fields are added in
* the 'add' method.
*
* - Status code 401: XXX
*
* All other status codes are not handled here. Note that it is not
* possible to react on the redirection codes because this object
* represents the connection to exactly one server.
* As default behaviour, the method 'postprocess' of the
* transmitter object is invoked; this method incorporates
* all the intelligence not coded here.
*)
let default_action_e() =
trans#cleanup();
drive_postprocessing_e esys options trans#message trans#f_done in
let msg = trans # message in
let code = msg # private_api # response_code in
let _req_hdr = msg # request_header `Effective in
let _resp_hdr = msg # private_api # response_header in
match code with
| 407 when peer_is_proxy ->
(* --------- Proxy authorization required: ---------- *)
let try_again =
match !proxy_auth_state with
| `None
| `In_advance _ ->
true
| `In_reply sess ->
(* A previous attempt failed. *)
let continue = sess # invalidate msg in
if not continue then proxy_auth_state := `None;
continue
in
if try_again then (
match proxy_auth_handler_opt with
| None ->
default_action_e()
| Some ah ->
(match ah # create_proxy_session msg options with
| None ->
(* Authentication failed immediately *)
proxy_auth_state := `None;
default_action_e()
| Some sess ->
(* Remember the new session: *)
proxy_auth_state := `In_reply sess;
(* Force that even a new connection will be
established independently of reconnect_mode:
*)
msg # private_api # set_retry_anyway true;
ignore (self # add true trans#message trans#f_done);
eps_e (`Done()) esys
)
)
else
default_action_e()
| 401 ->
(* -------- Content server authorization required: ---------- *)
(* Unless a previous authentication attempt failed, just create
* a new session, and repeat the request.
*)
let try_again =
match msg # private_api # auth_state with
| `None
| `In_advance _ ->
true
| `In_reply sess ->
(* A previous attempt failed. *)
let continue = sess # invalidate msg in
if not continue then auth_cache # tell_failed_session sess;
continue
in
if try_again then (
match auth_cache # create_session msg options with
| None ->
(* Authentication failed immediately *)
default_action_e()
| Some sess ->
(* Remember the new session: *)
msg # private_api # set_auth_state (`In_reply sess);
(* Force that even a new connection will be
established independently of reconnect_mode:
*)
msg # private_api # set_retry_anyway true;
ignore (self # add true trans#message trans#f_done);
eps_e (`Done()) esys
)
else
default_action_e()
| n when n >= 200 && n < 400 ->
(* Check whether authentication was successful *)
( match msg # private_api # auth_state with
| `None -> ()
| `In_advance _ -> ()
| `In_reply session ->
auth_cache # tell_successful_session session
);
default_action_e()
| _ ->
default_action_e()
(**********************************************************************)
(*** POSTPROCESS = INVOKE USER CALLBACK FUNCTION ***)
(**********************************************************************)
method private drive_postprocessing trans =
trans#cleanup();
drive_postprocessing_msg esys options trans#message trans#f_done
end
)
(**********************************************************************)
let robust_pipeline
esys tp cb
peer
proxy_auth_handler_opt
conn_cache conn_owner
auth_cache
counters options =
(* Implements a pipeline that connects to the peer after the first
message is added, and that is able to reconnect as often as
necessary
*)
let proxy_auth_state = ref `None in
( object(self)
val mutable fp_opt = None
(* The fragile_pipeline, if any *)
val queue = Q.create()
(* Queued requests before being connected *)
(* 'connecting' may be set to [Some e] where [e] is the connecting engine.
*)
val mutable connecting = None
(* 'connect_pause': seconds to wait until the next connection is tried.
* There seems to be a problem with some operating systems (namely
* Linux 2.2) which do not like immediate reconnects if the previous
* connection did not end in a sane state.
* A value of 0.5 seems to be sufficient for reconnects (see below).
*)
val mutable connect_pause = 0.0
(* no_pipelining: true if the server has somehow indicated that it
is better not to rely on pipelining
*)
val mutable no_pipelining = false
(* 'connect_time': how many seconds the last 'connect' took
*)
val mutable connect_time = 0.0
(* If a connection does not lead to any type of response, the client
* simply re-opens a new connection and tries again. The following
* variables limit the number of attempts until the client gives up.
*
* 'totally_failed_connections': counts the number of failed connections
* without any response from the server.
*)
val mutable totally_failed_connections = 0
method length =
match fp_opt with
| None -> 0
| Some fp -> fp#length
method active =
match fp_opt with
| None -> false
| Some fp -> fp#active
method add urgent (m : http_call) f_done =
(* Check whether we can authenticate in advance: *)
if m # private_api # auth_state = `None then (
try
let sess = auth_cache # find_session_in_advance m options in
m # private_api # set_auth_state (`In_advance sess)
with
Not_found -> ()
);
match fp_opt with
| None ->
Q.add (urgent,m,f_done) queue;
if connecting = None then
self # reconnect()
| Some fp ->
(* Even if fp is already shut down! This only means that fp#finish_e
has not yet signalled that we are actually finished. This will
happen soon, though, and the added message will be picked up
then
*)
fp # add urgent m f_done
method reset () =
if !options.verbose_connection then
dlog "HTTP connection: reset";
( match connecting with
| None -> ()
| Some e ->
e#abort();
connecting <- None
);
( match fp_opt with
| None -> ()
| Some fp ->
fp # reset();
fp_opt <- None
(* note that [fp#reset] causes that finished_e transitions
to `Aborted. Hence, conn_is_done is not called
The remaining messages in fp are already postprocessed.
*)
);
Q.iter
(fun (_,m,f_done) ->
m # private_api # error_if_unserved
!options.verbose_connection No_reply;
self # drive_postprocessing_msg m f_done
)
queue;
Q.clear queue;
totally_failed_connections <- 0
method private reconnect() =
assert(connecting = None);
assert(fp_opt = None);
let e =
Uq_engines.delay_engine
connect_pause
(fun () ->
tcp_connect_e
esys tp cb peer conn_cache conn_owner options
proxy_auth_handler_opt
)
esys in
connecting <- Some e;
Uq_engines.when_state
~is_error:(fun err ->
connecting <- None;
self#conn_is_error err
)
~is_done:(fun (fd,mplex,priv_data,cache_peer,t) ->
connect_time <- t;
connect_pause <- 0.0;
connecting <- None;
let fp =
fragile_pipeline
esys cb cache_peer
proxy_auth_state proxy_auth_handler_opt
fd mplex priv_data t no_pipelining conn_cache
auth_cache
counters options in
fp_opt <- Some fp;
Q.iter
(fun (urgent,m,f_done) ->
fp # add urgent m f_done
)
queue;
Q.clear queue;
fp # attach();
Uq_engines.when_state
~is_done:(self#conn_is_done fp)
fp#finished_e
)
e
method private conn_is_error error =
(* It was not possible to reach the peer *)
counters.crashed_connections <-
counters.crashed_connections + 1;
let q = Q.create() in
Q.transfer queue q;
self # conn_retry true error q;
method private conn_is_done fp () =
(* Check the result of fp, and move the requests back to [queue] that
can be tried again
*)
fp_opt <- None;
no_pipelining <- fp#no_pipelining; (* remember that *)
let q = Q.create() in
fp # iter_unserved_messages
(fun trans ->
trans # cleanup();
Q.add (false, trans#message, trans#f_done) q
);
self # conn_retry fp#is_total_failure No_reply q
method private conn_retry is_total_failure subst_error q =
(* Maybe we have a "total failure" - got no response from server *)
let too_many_total_failures =
if is_total_failure then (
totally_failed_connections <- totally_failed_connections + 1;
if !options.verbose_connection then
dlog "HTTP connection: total failure";
totally_failed_connections >= !options.maximum_connection_failures
)
else (
totally_failed_connections <- 0;
false
) in
if !options.verbose_connection then
dlog "HTTP connection: checking remaining pipeline requests";
if too_many_total_failures then
counters.failed_connections <-
counters.failed_connections + 1;
(* Check all requests individually *)
Q.iter
(fun (urgent,m,f_done) ->
let e = m # private_api # get_error_counter in
(*dlog (sprintf "e=%d idem=%B" e m#is_idempotent);*)
let try_again =
not too_many_total_failures &&
e <= !options.maximum_message_errors &&
(m # private_api # error_exception <> Some Response_too_large) &&
(m # private_api # retry_anyway ||
( match m # get_reconnect_mode with
| Send_again -> true
| Request_fails -> false
| Send_again_if_idem -> m # is_idempotent
| Inquire f ->
(* Ask the function 'f' whether to reconnect or not: *)
( try f m (* returns true or false *)
with
(* The invocation of 'f' may raise an exception.
* It is printed to stderr (there is no other
* way to report it).
*)
x ->
dlog ("Exception caught in Http_client: "
^ (Netexn.to_string x));
false
)
)
) in
if try_again then (
(* Ok, this request is tried again. *)
if !options.verbose_status then
dlogr (fun () ->
sprintf "Call %d - rescheduling" (Oo.id m));
Q.add (urgent,m,f_done) queue;
)
else (
m # private_api # error_if_unserved
!options.verbose_connection subst_error;
self # drive_postprocessing_msg m f_done
)
)
q;
(* Try again: *)
if Q.length queue > 0 then (
if !options.verbose_connection then
dlog "HTTP connection: retrying after failure";
connect_pause <- 1.0;
self#reconnect()
)
(**********************************************************************)
(*** POSTPROCESS = INVOKE USER CALLBACK FUNCTION ***)
(**********************************************************************)
(* Same as for fragile_pipeline *)
method private drive_postprocessing_msg m f_done =
drive_postprocessing_msg esys options m f_done
end
)
(**********************************************************************)
(**********************************************************************)
(**********************************************************************)
(**********************************************************************)
(*** ***)
(*** THE PIPELINE INTERFACE ***)
(*** ***)
(**********************************************************************)
(**********************************************************************)
(**********************************************************************)
(* The following class, 'pipeline' defines the interface for the outside
* world.
*)
type proxy_type = [`Http_proxy | `Socks5 ]
let parse_proxy_setting url =
let syn = Neturl.ip_url_syntax in
let (nu,cb) =
try parse_url_0 [ "http", syn, Some 80, http_cb_id ] url
with Not_found -> failwith ("Invalid proxy URL: " ^ url) in
let auth =
try
let u = Neturl.url_user nu in (* may raise Not_found *)
let p = Neturl.url_password nu in (* may raise Not_found *)
Some(u,p)
with Not_found -> None in
(Neturl.url_host nu, Neturl.url_port nu, auth)
let parse_no_proxy =
split_words_by_commas
class pipeline =
object (self)
val mutable esys = Unixqueue.create_unix_event_system()
val mutable proxy = ""
val mutable proxy_port = 80
val mutable proxy_auth = false
val mutable proxy_user = ""
val mutable proxy_password = ""
val mutable proxy_type = `Http_proxy
val tproxy = Hashtbl.create 5 (* transport-specific proxy *)
val mutable no_proxy_for = []
val mutable connections = Hashtbl.create 10
val mutable open_messages = 0
val mutable open_connections = 0
val options =
ref
{ (* Default values: *)
synchronization = Pipeline 5;
maximum_connection_failures = 2;
maximum_message_errors = 2;
inhibit_persistency = false;
connection_timeout = 300.0;
number_of_parallel_connections = 2;
maximum_redirections = 10;
handshake_timeout = 1.0;
resolver = sync_resolver;
configure_socket = (fun _ -> ());
schemes = default_schemes;
verbose_status = true;
verbose_request_header = false;
verbose_response_header = false;
verbose_request_contents = false;
verbose_response_contents = false;
verbose_connection = true;
verbose_events = false;
}
val auth_cache = new auth_cache
val mutable conn_cache = create_restrictive_cache()
val counters =
{ new_connections = 0;
timed_out_connections = 0;
crashed_connections = 0;
server_eof_connections = 0;
successful_connections = 0;
failed_connections = 0;
}
val transports = Hashtbl.create 5
initializer (
Hashtbl.add transports http_cb_id http_transport_channel_type;
Hashtbl.add transports proxy_only_cb_id http_transport_channel_type;
)
method event_system = esys
method set_event_system new_esys =
esys <- new_esys;
Hashtbl.clear connections;
method connection_cache = conn_cache
method set_connection_cache cc = conn_cache <- cc
method add_authentication_method ( m : auth_method ) =
self # add_auth_handler (m # as_auth_handler)
method add_auth_handler (h : auth_handler) =
auth_cache # add_auth_handler h
method set_proxy the_proxy the_port =
(* proxy="": disables proxy *)
proxy <- the_proxy;
proxy_port <- the_port;
proxy_type <- `Http_proxy;
()
method set_proxy_auth user passwd =
(* sets 'user' and 'password' if demanded by a proxy *)
proxy_auth <- user <> "";
proxy_user <- user;
proxy_password <- passwd
method avoid_proxy_for l =
(* l: List of hosts or domains *)
no_proxy_for <- l
method set_proxy_from_environment() =
(* Is the environment variable "http_proxy" set? *)
let http_proxy =
try Sys.getenv "http_proxy" with Not_found -> "" in
if http_proxy <> "" then (
let (host,port,auth) = parse_proxy_setting http_proxy in
self # set_proxy host port;
match auth with
| None -> ()
| Some(u,p) ->
self # set_proxy_auth u p
);
(* Is the environment variable "no_proxy" set? *)
let no_proxy =
try Sys.getenv "no_proxy" with Not_found -> "" in
let no_proxy_list =
parse_no_proxy no_proxy in
self # avoid_proxy_for no_proxy_list;
method set_transport_proxy_from_environment l =
List.iter
(fun (var_name, cb_id) ->
let var =
try Sys.getenv var_name with Not_found -> "" in
if var <> "" then (
let (host,port,auth) = parse_proxy_setting var in
self # set_transport_proxy cb_id host port auth `Http_proxy
);
)
l;
(* Is the environment variable "no_proxy" set? *)
let no_proxy =
try Sys.getenv "no_proxy" with Not_found -> "" in
let no_proxy_list =
parse_no_proxy no_proxy in
self # avoid_proxy_for no_proxy_list
method set_socks5_proxy host port =
proxy <- host;
proxy_port <- port;
proxy_type <- `Socks5
method configure_transport (cb:int) (tp:transport_channel_type) =
Hashtbl.replace transports cb tp
method set_transport_proxy cb host port auth (pt:proxy_type) =
Hashtbl.replace tproxy cb (host,port,auth,pt)
method reset () =
(* deletes all pending requests; closes connection *)
(* Reset all connections: *)
Hashtbl.iter
(fun _ cl ->
List.iter
(fun c ->
c # reset())
!cl)
connections;
(*
- well, this _should_ do nothing
List.iter
(fun fd ->
conn_cache # forget_connection fd;
Unix.close fd;
)
(conn_cache # find_my_connections (self :> < >));
*)
self # reset_counters()
method private peer_of_call request =
request # private_api # parse_request_uri options;
let host = request # get_host() in
let port = request # get_port() in
let cb = request # private_api # channel_binding options in
let peer_of_proxy h p pt =
match pt with
| `Http_proxy ->
if request # proxy_use_connect then
`Http_proxy_connect((h,p),(host,port))
else
`Http_proxy(h,p)
| `Socks5 ->
`Socks5((h,p),(host,port)) in
let proxy_possible =
request # proxy_enabled &&
(not
(List.exists
(fun dom ->
if dom <> "" &&
dom.[0] = '.' &&
String.length host > String.length dom
then
let ld = String.length dom in
String.lowercase(String.sub
host
(String.length host - ld)
ld)
= String.lowercase dom
else
dom = host)
no_proxy_for
)) in
try
if proxy_possible then (
try
let (h,p,a,pt) = Hashtbl.find tproxy cb in
(peer_of_proxy h p pt, a)
with
| Not_found ->
if proxy = "" then raise Not_found;
(peer_of_proxy proxy proxy_port proxy_type,
if proxy_auth then
Some(proxy_user, proxy_password)
else
None
)
)
else raise Not_found
with Not_found ->
(`Direct(host,port), None)
method proxy_type_of_call request =
let peer, auth = self # peer_of_call request in
match peer with
| `Http_proxy _ -> Some `Http_proxy
| `Http_proxy_connect _ -> Some `Http_proxy
| `Socks5 _ -> Some `Socks5
| `Direct _ -> None
method proxy_type url : proxy_type option =
let request = new get url in (* pseudo request *)
self # proxy_type_of_call request
method channel_binding (req : http_call) =
req # private_api # channel_binding options
method private add_with_callback_no_redirection (request : http_call) f_done =
let cb = request # private_api # channel_binding options in
(* find out the effective peer: *)
let peer, auth = self # peer_of_call request in
let use_proxy =
match peer with
| `Direct _ -> false
| _ -> true in
(* Find out if there is already a connection to this peer: *)
let conn =
let connlist =
try
Hashtbl.find connections (peer, cb)
with
Not_found ->
let new_connlist = ref [] in
Hashtbl.add
connections (peer, cb) new_connlist;
new_connlist
in
if List.length !connlist < !options.number_of_parallel_connections
then begin
let tp =
try
if cb = proxy_only_cb_id && not use_proxy then raise Not_found;
Hashtbl.find transports cb
with Not_found ->
failwith "Http_client: No transport for this channel binding" in
let proxy_auth_handler_opt =
match auth with
| Some(u,p) ->
let kh = new proxy_key_handler u p in
Some(new unified_auth_handler kh)
| None ->
None in
let new_conn = robust_pipeline
esys tp cb
peer
proxy_auth_handler_opt
conn_cache
(self :> < >)
auth_cache
counters
options in
open_connections <- open_connections + 1;
counters.new_connections <- counters.new_connections + 1;
connlist := new_conn :: !connlist;
new_conn
end
else begin
(* Find the connection with the lowest number of queue entries: *)
List.fold_left
(fun best_conn a_conn ->
if a_conn # length < best_conn # length then
a_conn
else
best_conn)
(List.hd !connlist)
(List.tl !connlist)
end
in
(* Add the request to the queue of this connection: *)
conn # add false request
(fun m ->
(* Update 'open_connections', 'connections', and 'open_messages' *)
if not conn#active then begin
(* Check whether the connection is still in the [connections]
* hash. It is possible that it is already deleted here.
*)
let connlist =
try
Hashtbl.find connections (peer, cb);
with
Not_found -> ref []
in
if List.exists (fun c -> c == conn) !connlist then (
open_connections <- open_connections - 1;
connlist := List.filter (fun c -> c != conn) !connlist;
if !connlist = [] then
Hashtbl.remove connections (peer, cb);
)
end;
self # update_open_messages;
(* Do user action: *)
f_done m;
);
open_messages <- open_messages + 1;
method private update_open_messages =
open_messages <- 0;
Hashtbl.iter
(fun _ cl ->
List.iter
(fun c ->
if c # active then
open_messages <- open_messages + (c # length))
!cl)
connections;
method add_with_callback (request : http_call) f_done =
request # private_api # parse_request_uri options;
self # add_with_callback_no_redirection
request
(fun m ->
try
let (_,code,_) = m # dest_status() in
match code with
(301|302) ->
(* Simply repeat the request with a different URI *)
let do_redirection =
match m # get_redirect_mode with
Redirect -> true
| Do_not_redirect -> false
| Redirect_if_idem -> m # is_idempotent
| Redirect_inquire f ->
(* Ask the function 'f' whether to redirect: *)
begin
try f m (* returns true or false *)
with
(* The invocation of 'f' may raise an exception.
* It is printed to stderr (there is no other
* way to report it).
*)
x ->
dlog (sprintf
"Call %d - \
Exception caught in Http_client %s"
(Oo.id m)
(Netexn.to_string x));
false
end
in
if do_redirection then begin
(* Maybe the redirection limit is exceeded: *)
let rc = m # private_api # get_redir_counter in
if rc >= !options.maximum_redirections
then (
m # private_api # set_error_exception Too_many_redirections;
f_done m
)
else (
let location = m # assoc_resp_header "location" in
(* or raise Not_found *)
let location' =
if location <> "" && location.[0] = '/' then
(* Problem: "Location" header must be absolute due
* to RFC specs. Now it is relative (with full path).
* Workaround: Interpret relative to old server
*)
( try
let (nu,_) =
parse_url
~base_url:(m # private_api # request_uri_with
())
options
location in
Neturl.string_of_url nu
with _ -> location
)
else
location in
let ok =
try
m # set_request_uri location';
true
with
| _ ->
(* Bad URL! *)
let e = URL_syntax_error location' in
m # private_api # set_error_exception e;
false
in
if ok then (
m # private_api # set_redir_counter (rc+1);
m # private_api # set_error_counter 0;
self # add_with_callback m f_done
)
else f_done m
)
end
else f_done m
| _ ->
f_done m
with
(Http_protocol _ | Not_found) ->
f_done m
)
method add request =
self # add_with_callback request (fun _ -> ())
method add_e request =
let (e, signal) = Uq_engines.signal_engine esys in
self # add_with_callback request (fun c -> signal (`Done c));
e
method run () =
Unixqueue.run esys
method get_options = !options
method set_options p =
options := p
method number_of_open_messages = open_messages
method number_of_open_connections = open_connections
method connections =
let l = ref [] in
Hashtbl.iter
(fun (peer, _) conns ->
List.iter
(fun conn ->
let host, port = first_hop peer in
l := (host, port, conn#length) :: !l
)
!conns
)
connections;
!l
method cnt_new_connections = counters.new_connections
method cnt_timed_out_connections = counters.timed_out_connections
method cnt_crashed_connections = counters.crashed_connections
method cnt_server_eof_connections = counters.server_eof_connections
method cnt_successful_connections = counters.successful_connections
method cnt_failed_connections = counters.failed_connections
method reset_counters() =
counters.new_connections <- 0;
counters.timed_out_connections <- 0;
counters.crashed_connections <- 0;
counters.server_eof_connections <- 0;
counters.successful_connections <- 0;
counters.failed_connections <- 0;
end
;;
(**********************************************************************)
(**********************************************************************)
(**********************************************************************)
(*** ***)
(*** THE CONVENIENCE MODULE ***)
(*** ***)
(**********************************************************************)
(**********************************************************************)
(**********************************************************************)
(* This module is intended for beginners and for simple applications
* of this HTTP implementation.
*)
let omtp = !Netsys_oothr.provider
let mutex = omtp # create_mutex()
let serialize f arg =
mutex # lock();
try
let r = f arg in
mutex # unlock();
r
with
err -> mutex # unlock(); raise err
;;
module Convenience =
struct
let http_trials = ref 3
let http_user = ref ""
let http_password = ref ""
let this_user = ref ""
let this_password = ref ""
let conv_verbose = ref false
class simple_key_handler : key_handler =
object
method inquire_key ~domain ~realms ~auth =
if !this_user <> "" then
( object
method user = !this_user
method password = !this_password
method realm = List.hd realms
method domain = domain
end )
else
if !http_user <> "" then
( object
method user = !http_user
method password = !http_password
method realm = List.hd realms
method domain = domain
end )
else
raise Not_found
method invalidate_key (_ : key) = ()
end
let auth_basic =
new basic_auth_handler
~enable_auth_in_advance:true (new simple_key_handler)
let auth_digest =
new digest_auth_handler
~enable_auth_in_advance:true (new simple_key_handler)
let get_default_pipe() =
let p = new pipeline in
p # set_proxy_from_environment();
(* Add authentication methods: *)
p # add_auth_handler auth_basic;
p # add_auth_handler auth_digest;
(* That's it: *)
p
let pipe = lazy (get_default_pipe())
let pipe_empty = ref true
let configure_pipeline f =
let p = Lazy.force pipe in
f p
let request m =
serialize
(fun trials ->
let p = Lazy.force pipe in
m # set_accept_encoding();
p # add m;
try
p # run()
with
| error -> p # reset(); raise error
)
let prepare_url =
serialize
(fun url ->
let p = Lazy.force pipe in
try
this_user := "";
let (nu, _) = parse_url (ref p#get_options) url in
if Neturl.url_provides ~user:true nu then (
this_user := Neturl.url_user nu;
this_password := "";
if Neturl.url_provides ~password:true nu then
this_password := Neturl.url_password nu;
);
Neturl.string_of_url
(Neturl.remove_from_url
~user:true ~user_param:true ~password:true
nu)
with
| Not_found | Neturl.Malformed_URL ->
url
)
let http_get_message url =
let m = new get (prepare_url url) in
request m !http_trials;
m
let http_get url = (http_get_message url) # get_resp_body()
let http_head_message url =
let m = new head (prepare_url url) in
request m !http_trials;
m
let http_post_message url params =
let m = new post (prepare_url url) params in
request m 1;
m
let http_post url params = (http_post_message url params) # get_resp_body()
let http_put_message url content =
let m = new put (prepare_url url) content in
request m !http_trials;
m
let http_put url content = (http_put_message url content) # get_resp_body()
let http_delete_message url =
let m = new delete (prepare_url url) in
request m 1;
m
let http_delete url = (http_delete_message url) # get_resp_body()
let http_verbose
?(verbose_status=true)
?(verbose_request_header=true)
?(verbose_response_header=true)
?(verbose_request_contents=true)
?(verbose_response_contents=true)
?(verbose_connection=true)
?(verbose_events=true) =
serialize
(fun () ->
let p = Lazy.force pipe in
let opt = p # get_options in
p # set_options
{ opt with verbose_status = verbose_status;
verbose_request_header = verbose_request_header;
verbose_response_header = verbose_response_header;
verbose_request_contents = verbose_request_contents;
verbose_response_contents = verbose_response_contents;
verbose_connection = verbose_connection;
verbose_events = verbose_events
};
conv_verbose := true;
Debug.enable := true;
)
end
