OCAMLLIBDIR := $(shell ocamlc -where)
OCAMLDESTDIR ?= $(OCAMLLIBDIR)
-OBJS = server_io buf_io http http_svr
+OBJS = server_io buf_io http http_svr http_client
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = http_svr.cma http_svr.cmxa
.PHONY: doc
doc: $(INTF)
python ../doc/doc.py $(DOCDIR) "http-svr" "package" "$(OBJS)" "." "log,stdext" ""
-
+
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
mutable close: bool;
headers: string list} with rpc
+module Response = struct
+ type t = {
+ content_length: int64 option;
+ task: string option;
+ }
+end
+
let string_of_method_t = function
| Get -> "GET" | Post -> "POST" | Put -> "PUT" | Connect -> "CONNECT" | Unknown x -> "Unknown " ^ x
let method_t_of_string = function
| _ -> UnknownAuth x
else UnknownAuth x
+let string_of_authorization = function
+| UnknownAuth x -> x
+| Basic(username, password) -> "Basic " ^ (Base64.encode (username ^ ":" ^ password))
+
exception Malformed_url of string
let print_keyvalpairs xs =
String.concat "&" (List.map (fun (k, v) -> k ^ "=" ^ v) xs)
-let http_request ?(version="1.0") ?(keep_alive=false) ?cookie ?length ~user_agent meth host path =
- let cookie = default [] (may (fun x -> [ "Cookie: " ^ (print_keyvalpairs x) ]) cookie) in
- let content_length = default [] (may (fun l -> [ "Content-Length: "^(Int64.to_string l)]) length) in
- [ Printf.sprintf "%s %s HTTP/%s" (string_of_method_t meth) path version;
- Printf.sprintf "Host: %s" host;
- Printf.sprintf "Connection: %s" (if keep_alive then "keep-alive" else "close");
- Printf.sprintf "%s :%s" user_agent_hdr user_agent;
- ] @ cookie @ content_length
-
-
let urldecode url =
let chars = String.explode url in
let rec fn ac = function
| k :: vs -> ((urldecode k), urldecode (String.concat "=" vs))
| [] -> raise Http_parse_failure) kvpairs
+let parse_uri x = match String.split '?' x with
+| [ uri ] -> uri, []
+| [ uri; params ] -> uri, parse_keyvalpairs params
+| _ -> raise Http_parse_failure
+
let request_of_string x =
- let parse_uri x = match String.split '?' x with
- | [ uri ] -> uri, []
- | [ uri; params ] -> uri, parse_keyvalpairs params
- | _ -> raise Http_parse_failure in
match String.split_f String.isspace x with
| [ m; uri; version ] ->
(* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *)
version = version; cookie = []; auth = None; task = None; subtask_of = None; content_type = None; user_agent = None; close=false; headers=[] }
| _ -> raise Http_parse_failure
+
let pretty_string_of_request x =
let kvpairs x = String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) x) in
Printf.sprintf "{ method = %s; uri = %s; query = [ %s ]; content_length = [ %s ]; transfer encoding = %s; version = %s; cookie = [ %s ]; task = %s; subtask_of = %s; content-type = %s; user_agent = %s }"
(default "" x.content_type)
(default "" x.user_agent)
+let http_request ?(version="1.0") ?(keep_alive=false) ?cookie ?length ~user_agent meth host path =
+ let cookie = default [] (may (fun x -> [ "Cookie: " ^ (print_keyvalpairs x) ]) cookie) in
+ let content_length = default [] (may (fun l -> [ "Content-Length: "^(Int64.to_string l)]) length) in
+ [ Printf.sprintf "%s %s HTTP/%s" (string_of_method_t meth) path version;
+ Printf.sprintf "Host: %s" host;
+ Printf.sprintf "Connection: %s" (if keep_alive then "keep-alive" else "close");
+ Printf.sprintf "%s :%s" user_agent_hdr user_agent;
+ ] @ cookie @ content_length
+
+let string_list_of_request x =
+ let kvpairs x = String.concat "&" (List.map (fun (k, v) -> urlencode k ^ "=" ^ (urlencode v)) x) in
+ let query = if x.query = [] then "" else "?" ^ (kvpairs x.query) in
+ let cookie = if x.cookie = [] then [] else [ "Cookie: " ^ (kvpairs x.cookie) ] in
+ let transfer_encoding = Opt.default [] (Opt.map (fun x -> [ "transfer-encoding: " ^ x ]) x.transfer_encoding) in
+ let content_length = Opt.default [] (Opt.map (fun x -> [ Printf.sprintf "content-length: %Ld" x ]) x.content_length) in
+ let auth = Opt.default [] (Opt.map (fun x -> [ "authorization: " ^ (string_of_authorization x) ]) x.auth) in
+ let task = Opt.default [] (Opt.map (fun x -> [ task_id_hdr ^ ": " ^ x ]) x.task) in
+ let subtask_of = Opt.default [] (Opt.map (fun x -> [ subtask_of_hdr ^ ": " ^ x ]) x.subtask_of) in
+ let content_type = Opt.default [] (Opt.map (fun x -> [ "content-type: " ^ x ]) x.content_type) in
+ let user_agent = Opt.default [] (Opt.map (fun x -> [ "user-agent: " ^ x ]) x.user_agent) in
+ let close = [ "Connection: " ^ (if x.close then "close" else "keep-alive") ] in
+ [ Printf.sprintf "%s %s%s HTTP/%s" (string_of_method_t x.m) x.uri query x.version ]
+ @ cookie @ transfer_encoding @ content_length @ auth @ task @ subtask_of @ content_type @ user_agent @ close
+ @ x.headers
+
let escape uri =
String.escaped ~rules:[ '<', "<"; '>', ">"; '\'', "'"; '"', """; '&', "&" ] uri
+
(* For transfer-encoding: chunked *)
type 'a ll = End | Item of 'a * (unit -> 'a ll)
headers: string list;
}
+(** Parsed form of the HTTP response *)
+module Response : sig
+ type t = {
+ content_length: int64 option;
+ task: string option;
+ }
+end
+
val rpc_of_request : request -> Rpc.t
val request_of_rpc : Rpc.t -> request
val nullreq : request
val authorization_of_string : string -> authorization
+
+val parse_uri : string -> string * ((string * string) list)
+
val request_of_string : string -> request
val pretty_string_of_request : request -> string
+(** Marshal a request back into wire-format *)
+val string_list_of_request : request -> string list
+
val http_request : ?version:string -> ?keep_alive:bool -> ?cookie:((string*string) list) -> ?length:(int64) -> user_agent:(string) -> method_t -> string -> string -> string list
val http_403_forbidden : string list
--- /dev/null
+(*
+ * Copyright (C) 2006-2010 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+(* A very simple HTTP client *)
+
+open Stringext
+
+exception Connection_reset
+
+(** Thrown when no data is received from the remote HTTP server. This could happen if
+ (eg) an stunnel accepted the connection but xapi refused the forward causing stunnel
+ to immediately close. *)
+exception Empty_response_from_server
+
+(** Thrown when we get a non-HTTP response *)
+exception Http_request_rejected
+
+(** Thrown when we get a specific HTTP failure *)
+exception Http_error of string
+
+let http_rpc_send_query fd request body =
+ try
+ let writeln x =
+ Unixext.really_write fd x 0 (String.length x);
+ let end_of_line = "\r\n" in
+ Unixext.really_write fd end_of_line 0 (String.length end_of_line) in
+ List.iter writeln (Http.string_list_of_request request);
+ writeln "";
+ if body <> "" then Unixext.really_write fd body 0 (String.length body)
+ with
+ | Unix.Unix_error(Unix.ECONNRESET, _, _) -> raise Connection_reset
+
+(* Internal exception thrown when reading a newline-terminated HTTP header when the
+ connection is closed *)
+exception Http_header_truncated of string
+
+(* Tediously read an HTTP header byte-by-byte. At some point we need to add buffering
+ but we'll need to encapsulate our file descriptor into more of a channel-like object
+ to make that work. *)
+let input_line_fd (fd: Unix.file_descr) =
+ let buf = Buffer.create 20 in
+ let finished = ref false in
+ try
+ while not(!finished) do
+ let buffer = " " in
+ let read = Unix.read fd buffer 0 1 in
+ if read < 1 then raise (Http_header_truncated (Buffer.contents buf));
+ if buffer = "\n" then finished := true else Buffer.add_char buf buffer.[0]
+ done;
+ Buffer.contents buf
+ with
+ | Unix.Unix_error(Unix.ECONNRESET, _, _) -> raise Connection_reset
+
+(* Read the HTTP response and if a 200 OK, return (content_length, task_id option). Otherwise
+ throw an exception. *)
+let http_rpc_recv_response fd =
+ let ok = ref false in
+ let task_id = ref None in
+ let content_length = ref None in
+ (try
+ (* Initial line has the response code on it *)
+ let line =
+ try input_line_fd fd
+ with
+ | Http_header_truncated "" ->
+ (* Special case the error when no data is received at all *)
+ raise Empty_response_from_server
+ in
+ match String.split_f String.isspace line with
+ | _ :: "200" :: _ ->
+ ok := true;
+ (* Skip the rest of the headers *)
+ while true do
+ let line = input_line_fd fd in
+
+ (* NB input_line removes the final '\n'.
+ RFC1945 says to expect a '\r\n' (- '\n' = '\r') *)
+ match line with
+ | "" | "\r" -> raise Not_found
+ | x ->
+ begin
+ let (k,t) = match String.split ':' x with
+ | k :: rst -> (k, String.concat ":" rst)
+ | _ -> ("","") in
+ let k' = String.lowercase k in
+ if k' = String.lowercase Http.task_id_hdr then begin
+ let t = String.strip String.isspace t in
+ task_id := Some t
+ end else if k' = "content-length" then begin
+ let t = String.strip String.isspace t in
+ content_length := Some (Int64.of_string t)
+ end
+ end
+ done
+ | _ :: (("401"|"403"|"500") as http_code) :: _ ->
+ raise (Http_error http_code)
+ | _ -> raise Not_found
+ with Not_found -> ());
+ if not(!ok)
+ then raise Http_request_rejected
+ else { Http.Response.content_length = !content_length;
+ task = !task_id }
+
+
+(** [rpc request body f] marshals the HTTP request represented by [request] and [body]
+ and then parses the response. On success, [f] is called with an HTTP response record.
+ On failure an exception is thrown. *)
+let rpc (fd: Unix.file_descr) request body f =
+ http_rpc_send_query fd request body;
+ f (http_rpc_recv_response fd) fd
+
--- /dev/null
+(*
+ * Copyright (C) 2006-2010 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+(* A very simple HTTP client *)
+
+(** Thrown when we get a non-HTTP response *)
+exception Http_request_rejected
+
+(** Thrown when we get a specific HTTP failure *)
+exception Http_error of string
+
+(** [rpc fd request body f] marshals the HTTP request represented by [request] and [body]
+ through file descriptor [fd] and then applies the response to [f]. On failure an
+ exception is thrown. *)
+val rpc : Unix.file_descr -> Http.request -> string -> (Http.Response.t -> Unix.file_descr -> 'a) -> 'a
\ No newline at end of file
/usr/lib/ocaml/http-svr/http_svr.cmxa
/usr/lib/ocaml/http-svr/server_io.cmi
/usr/lib/ocaml/http-svr/server_io.cmx
+ /usr/lib/ocaml/http-svr/http_client.cmi
+ /usr/lib/ocaml/http-svr/http_client.cmx
/usr/lib/ocaml/log/META
/usr/lib/ocaml/log/debug.cmi
/usr/lib/ocaml/log/debug.cmx
projects / xcp / xen-api-libs.git / commitdiff