# HG changeset patch
# User David Scott <dave.scott@xxxxxxxxxxxxx>
# Date 1282568183 -3600
# Node ID fb54e065e83269c2784802516c75a5ecfe9ba941
# Parent 815d0a9b3661be23e76be25b95e9b0d7fd9641c9
Add some HTTP client code
Signed-off-by: David Scott <dave.scott@xxxxxxxxxxxxx>
diff -r 815d0a9b3661 -r fb54e065e832 http-svr/Makefile
--- a/http-svr/Makefile Fri Jul 23 17:46:18 2010 +0100
+++ b/http-svr/Makefile Mon Aug 23 13:56:23 2010 +0100
@@ -14,7 +14,7 @@
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
@@ -60,6 +60,6 @@
.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)
diff -r 815d0a9b3661 -r fb54e065e832 http-svr/http.ml
--- a/http-svr/http.ml Fri Jul 23 17:46:18 2010 +0100
+++ b/http-svr/http.ml Mon Aug 23 13:56:23 2010 +0100
@@ -118,6 +118,13 @@
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
@@ -149,21 +156,15 @@
| _ -> 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
@@ -209,11 +210,12 @@
| 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 *)
@@ -223,6 +225,7 @@
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 }"
@@ -237,9 +240,35 @@
(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)
diff -r 815d0a9b3661 -r fb54e065e832 http-svr/http.mli
--- a/http-svr/http.mli Fri Jul 23 17:46:18 2010 +0100
+++ b/http-svr/http.mli Mon Aug 23 13:56:23 2010 +0100
@@ -42,14 +42,28 @@
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
diff -r 815d0a9b3661 -r fb54e065e832 http-svr/http_client.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/http-svr/http_client.ml Mon Aug 23 13:56:23 2010 +0100
@@ -0,0 +1,121 @@
+(*
+ * 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
+
diff -r 815d0a9b3661 -r fb54e065e832 http-svr/http_client.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/http-svr/http_client.mli Mon Aug 23 13:56:23 2010 +0100
@@ -0,0 +1,25 @@
+(*
+ * 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
diff -r 815d0a9b3661 -r fb54e065e832 xapi-libs.spec
--- a/xapi-libs.spec Fri Jul 23 17:46:18 2010 +0100
+++ b/xapi-libs.spec Mon Aug 23 13:56:23 2010 +0100
@@ -107,6 +107,8 @@
/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
http-svr/Makefile | 4 +-
http-svr/http.ml | 57 ++++++++++++++++-----
http-svr/http.mli | 14 +++++
http-svr/http_client.ml | 121 +++++++++++++++++++++++++++++++++++++++++++++++
http-svr/http_client.mli | 25 +++++++++
xapi-libs.spec | 2 +
6 files changed, 207 insertions(+), 16 deletions(-)
xen-api-libs.hg.patch
Description: Text Data
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home