Add some HTTP client code

Signed-off-by: David Scott <dave.scott@eu.citrix.com>

diff --git a/http-svr/Makefile b/http-svr/Makefile
index 6d7411b9152a13b87b6c3bb338a7220b0f337151..1e6b2f77a5b5828acfc26f92cfa37ad78135dc89 100644 (file)
--- a/http-svr/Makefile
+++ b/http-svr/Makefile
@@ -14,7 +14,7 @@ OCAMLABI := $(shell ocamlc -version)
 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 @@ uninstall:
 .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 --git a/http-svr/http.ml b/http-svr/http.ml
index 16a1753731160bf456e8932bf33a6f23e7cda107..d698482ae23cc95a4c9bba93324db88a8c156a92 100644 (file)
--- a/http-svr/http.ml
+++ b/http-svr/http.ml
@@ -118,6 +118,13 @@ and request = { m: method_t;
                 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 @@ let authorization_of_string x =
     | _ -> 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 @@ let parse_keyvalpairs xs =
            | 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 @@ let request_of_string x =
        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 @@ let pretty_string_of_request x =
     (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:[ '<', "&lt;"; '>', "&gt;"; '\'', "&apos;"; '"', "&quot;"; '&', "&amp;" ] uri
 
+
 (* For transfer-encoding: chunked *)
 
 type 'a ll = End | Item of 'a * (unit -> 'a ll)

diff --git a/http-svr/http.mli b/http-svr/http.mli
index 12b264297145ea5c13ca09b240ef34b455fa2787..0666596e0b3d79fe81ee25f10d9e8e2a55c9bb3e 100644 (file)
--- a/http-svr/http.mli
+++ b/http-svr/http.mli
@@ -42,14 +42,28 @@ type request = {
     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 --git a/xapi-libs.spec b/xapi-libs.spec
index 4079405a7e26f1d4ac92ddbc005d3792a4e3c05b..73e91370b4d09a2dbe411b0e50fd8830a913d771 100644 (file)
--- a/xapi-libs.spec
+++ b/xapi-libs.spec
@@ -107,6 +107,8 @@ rm -rf $RPM_BUILD_ROOT
    /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