Skip to content
Browse files

Merge pull request #62 from djs55/http-url

[http-client]: add a URL parser (Http.Url.of_string) and make it easy to...
  • Loading branch information...
2 parents f7d2cda + 4d0bfda commit 014516c555b94b54edf2ff64f42857682eb67438 @djs55 djs55 committed
Showing with 132 additions and 6 deletions.
  1. +56 −1 http-svr/http.ml
  2. +23 −1 http-svr/http.mli
  3. +0 −1 http-svr/http_client.ml
  4. +36 −0 http-svr/http_test.ml
  5. +13 −2 http-svr/xmlrpc_client.ml
  6. +4 −1 http-svr/xmlrpc_client.mli
View
57 http-svr/http.ml
@@ -373,7 +373,7 @@ module Request = struct
body = None;
}
- let make ?(frame=false) ?(version="1.0") ?(keep_alive=false) ?accept ?cookie ?length ?subtask_of ?body ?(headers=[]) ?content_type ~user_agent meth path =
+ let make ?(frame=false) ?(version="1.0") ?(keep_alive=false) ?accept ?cookie ?length ?auth ?subtask_of ?body ?(headers=[]) ?content_type ~user_agent meth path =
{ empty with
version = version;
frame = frame;
@@ -381,6 +381,7 @@ module Request = struct
cookie = Opt.default [] cookie;
subtask_of = subtask_of;
content_length = length;
+ auth = auth;
content_type = content_type;
user_agent = Some user_agent;
m = meth;
@@ -541,3 +542,57 @@ type 'a ll = End | Item of 'a * (unit -> 'a ll)
let rec ll_iter f = function
| End -> ()
| Item (x, xs) -> f x; ll_iter f (xs ())
+
+
+module Url = struct
+ type http = {
+ host: string;
+ auth: authorization option;
+ port: int option;
+ ssl: bool;
+ }
+ type file = {
+ path: string;
+ }
+
+ type t =
+ | Http of http * string
+ | File of file * string
+
+ let of_string url =
+ let host x = match String.split ':' x with
+ | host :: _ -> host
+ | _ -> failwith (Printf.sprintf "Failed to parse host: %s" x) in
+ let port x = match String.split ':' x with
+ | _ :: port :: _ -> Some (int_of_string port)
+ | _ -> None in
+ let uname_password_host_port x = match String.split '@' x with
+ | [ _ ] -> None, host x, port x
+ | [ uname_password; host_port ] ->
+ begin match String.split ':' uname_password with
+ | [ uname; password ] -> Some (Basic (uname, password)), host host_port, port host_port
+ | _ -> failwith (Printf.sprintf "Failed to parse authentication substring: %s" uname_password)
+ end
+ | _ -> failwith (Printf.sprintf "Failed to parse username password host and port: %s" x) in
+ let reconstruct_uri uri = "/" ^ (String.concat "/" uri) in
+ let http_or_https ssl x uri =
+ let uname_password, host, port = uname_password_host_port x in
+ Http ({
+ host = host; port = port; auth = uname_password; ssl = ssl;
+ }, reconstruct_uri uri) in
+ match String.split '/' url with
+ | "http:" :: "" :: x :: uri -> http_or_https false x uri
+ | "https:" :: "" :: x :: uri -> http_or_https true x uri
+ | "file:" :: uri ->
+ File ({ path = reconstruct_uri uri }, "/")
+ | x :: _ -> failwith (Printf.sprintf "Unknown scheme %s" x)
+ | _ -> failwith (Printf.sprintf "Failed to parse URL: %s" url)
+
+ let uri_of = function
+ | File (_, x) -> x
+ | Http (_, x) -> x
+
+ let auth_of = function
+ | File (_, _) -> None
+ | Http ({ auth = auth }, _) -> auth
+end
View
24 http-svr/http.mli
@@ -76,7 +76,7 @@ module Request : sig
val empty: t
(** [make] is the standard constructor for [t] *)
- val make: ?frame:bool -> ?version:string -> ?keep_alive:bool -> ?accept:string -> ?cookie:(string*string) list -> ?length:int64 -> ?subtask_of:string -> ?body:string -> ?headers:(string*string) list -> ?content_type:string -> user_agent:string -> method_t -> string -> t
+ val make: ?frame:bool -> ?version:string -> ?keep_alive:bool -> ?accept:string -> ?cookie:(string*string) list -> ?length:int64 -> ?auth:authorization -> ?subtask_of:string -> ?body:string -> ?headers:(string*string) list -> ?content_type:string -> user_agent:string -> method_t -> string -> t
(** [get_version t] returns the HTTP protocol version *)
val get_version: t -> string
@@ -166,3 +166,25 @@ val urlencode : string -> string
type 'a ll = End | Item of 'a * (unit -> 'a ll)
val ll_iter : ('a -> unit) -> 'a ll -> unit
+
+module Url : sig
+ type http = {
+ host: string;
+ auth: authorization option;
+ port: int option;
+ ssl: bool;
+ }
+ type file = {
+ path: string;
+ }
+
+ type t =
+ | Http of http * string
+ | File of file * string
+
+ val of_string: string -> t
+
+ val uri_of: t -> string
+
+ val auth_of: t -> authorization option
+end
View
1 http-svr/http_client.ml
@@ -179,4 +179,3 @@ let rpc ?(use_fastpath=false) (fd: Unix.file_descr) request f =
(* Printf.printf "request = [%s]" (Http.Request.to_wire_string request);*)
http_rpc_send_query fd request;
f (http_rpc_recv_response use_fastpath (Http.Request.to_string request) fd) fd
-
View
36 http-svr/http_test.ml
@@ -94,6 +94,41 @@ let test_radix_tree2 _ =
if List.length all <> (List.length test_strings)
then failwith "fold"
+let test_url _ =
+ let open Http in
+ let open Http.Url in
+ begin match of_string "file:/var/xapi/storage" with
+ | File ({ path = "/var/xapi/storage" }, "/") -> ()
+ | _ -> assert false
+ end;
+ begin match of_string "http://root:foo@localhost" with
+ | Http (t, "/") ->
+ assert (t.auth = Some(Basic("root", "foo")));
+ assert (t.ssl = false);
+ assert (t.host = "localhost");
+ | _ -> assert false
+ end;
+ begin match of_string "https://google.com/gmail" with
+ | Http (t, "/gmail") ->
+ assert (t.ssl = true);
+ assert (t.host = "google.com");
+ | _ -> assert false
+ end;
+ begin match of_string "https://xapi.xen.org/services/SM" with
+ | Http (t, "/services/SM") ->
+ assert (t.ssl = true);
+ assert (t.host = "xapi.xen.org");
+ | _ -> assert false
+ end;
+ begin match of_string "https://root:foo@xapi.xen.org:1234/services/SM" with
+ | Http (t, "/services/SM") ->
+ assert (t.auth = Some(Basic("root", "foo")));
+ assert (t.port = Some 1234);
+ assert (t.ssl = true);
+ assert (t.host = "xapi.xen.org");
+ | _ -> assert false
+ end
+
let _ =
let verbose = ref false in
Arg.parse [
@@ -107,5 +142,6 @@ let _ =
"accept_complex" >:: test_accept_complex;
"radix1" >:: test_radix_tree1;
"radix2" >:: test_radix_tree2;
+ "test_url" >:: test_url
] in
run_test_tt ~verbose:!verbose suite
View
15 http-svr/xmlrpc_client.ml
@@ -31,9 +31,9 @@ let connect ?session_id ?task_id ?subtask_of path =
Http.Request.make ~user_agent ~version:"1.0" ~keep_alive:true ~cookie ?subtask_of
Http.Connect path
-let xmlrpc ?frame ?version ?keep_alive ?task_id ?cookie ?length ?subtask_of ?body path =
+let xmlrpc ?frame ?version ?keep_alive ?task_id ?cookie ?length ?auth ?subtask_of ?body path =
let headers = Opt.map (fun x -> [ Http.Hdr.task_id, x ]) task_id in
- Http.Request.make ~user_agent ?frame ?version ?keep_alive ?cookie ?headers ?length ?subtask_of ?body
+ Http.Request.make ~user_agent ?frame ?version ?keep_alive ?cookie ?headers ?length ?auth ?subtask_of ?body
Http.Post path
(** Thrown when ECONNRESET is caught which suggests the remote crashed or restarted *)
@@ -164,6 +164,17 @@ let string_of_transport = function
| TCP (host, port) -> Printf.sprintf "TCP %s:%d" host port
| SSL (ssl, host, port) -> Printf.sprintf "SSL %s:%d %s" host port (SSL.to_string ssl)
+let transport_of_url =
+ let open Http.Url in
+ function
+ | File ({ path = path }, _) -> Unix path
+ | Http ({ ssl = false } as h, _) ->
+ let port = Opt.default 80 h.port in
+ TCP(h.host, port)
+ | Http ({ ssl = true } as h, _) ->
+ let port = Opt.default 443 h.port in
+ SSL(SSL.make (), h.host, port)
+
let with_transport transport f = match transport with
| Unix path ->
debug "Attempting to open %s" path;
View
5 http-svr/xmlrpc_client.mli
@@ -37,6 +37,9 @@ type transport =
| TCP of string * int (** Plain TCP/IP with a host, port *)
| SSL of SSL.t * string * int (** SSL over TCP/IP with a host, port *)
+(** [transport_of_url url] returns the transport associated with [url] *)
+val transport_of_url : Http.Url.t -> transport
+
(** [string_of_transport t] returns a debug-friendly version of [t] *)
val string_of_transport : transport -> string
@@ -50,7 +53,7 @@ val with_transport : transport -> (Unix.file_descr -> 'a) -> 'a
val with_http : Http.Request.t -> (Http.Response.t * Unix.file_descr -> 'a) -> Unix.file_descr -> 'a
(** Returns an HTTP.Request.t representing an XMLRPC request *)
-val xmlrpc: ?frame:bool -> ?version:string -> ?keep_alive:bool -> ?task_id:string -> ?cookie:(string*string) list -> ?length:int64 -> ?subtask_of:string -> ?body:string -> string -> Http.Request.t
+val xmlrpc: ?frame:bool -> ?version:string -> ?keep_alive:bool -> ?task_id:string -> ?cookie:(string*string) list -> ?length:int64 -> ?auth:Http.authorization -> ?subtask_of:string -> ?body:string -> string -> Http.Request.t
(** Returns an HTTP.Request.t representing an HTTP CONNECT *)
val connect: ?session_id:string -> ?task_id:string -> ?subtask_of:string -> string -> Http.Request.t

0 comments on commit 014516c

Please sign in to comment.
Something went wrong with that request. Please try again.