From: David Scott Date: Mon, 23 Aug 2010 12:56:23 +0000 (+0100) Subject: Add some HTTP client code X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=58bcf2933edebc5f30c4308ea833b5682a6ec598;p=xcp%2Fxen-api-libs.git Add some HTTP client code Signed-off-by: David Scott --- diff --git a/http-svr/Makefile b/http-svr/Makefile index 6d7411b..1e6b2f7 100644 --- 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 16a1753..d698482 100644 --- 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:[ '<', "<"; '>', ">"; '\'', "'"; '"', """; '&', "&" ] 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 12b2642..0666596 100644 --- 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 4079405..73e9137 100644 --- 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