# HG changeset patch # User David Scott <[email protected]> # Date 1282568183 -3600 # Node ID fb54e065e83269c2784802516c75a5ecfe9ba941 # Parent 815d0a9b3661be23e76be25b95e9b0d7fd9641c9 Add some HTTP client code
Signed-off-by: David Scott <[email protected]> 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(-)
# HG changeset patch # User David Scott <[email protected]> # Date 1282568183 -3600 # Node ID fb54e065e83269c2784802516c75a5ecfe9ba941 # Parent 815d0a9b3661be23e76be25b95e9b0d7fd9641c9 Add some HTTP client code Signed-off-by: David Scott <[email protected]> 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
_______________________________________________ xen-api mailing list [email protected] http://lists.xensource.com/mailman/listinfo/xen-api
