LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
-PP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma
-
OCAMLABI := $(shell ocamlc -version)
OCAMLLIBDIR := $(shell ocamlc -where)
OCAMLDESTDIR ?= $(OCAMLLIBDIR)
-OBJS = server_io buf_io http http_svr http_client
+OBJS = server_io buf_io http http_svr
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = http_svr.cma http_svr.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS)
bins: $(PROGRAMS)
$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
%.cmo: %.ml %.cmi
- $(OCAMLC) -c -pp '${PP}' -thread -I ../rpc-light -I ../stdext -I ../log -o $@ $<
+ $(OCAMLC) -c -thread -I ../stdext -I ../log -o $@ $<
%.cmi: %.mli
- $(OCAMLC) -c -I ../rpc-light -thread -o $@ $<
+ $(OCAMLC) -c -thread -o $@ $<
%.cmx: %.ml %.cmi
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -pp '${PP}' -c -thread -I ../rpc-light -I ../stdext -I ../log -o $@ $<
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -thread -I ../stdext -I ../log -o $@ $<
%.o: %.c
$(CC) $(CFLAGS) -c -o $@ $<
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore http-svr META $(INTF) $(LIBS) *.a *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore http-svr META $(INTF) $(LIBS) *.a *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove http-svr
-.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)
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
\ No newline at end of file
let subtask_of_hdr = "Subtask-of"
-let content_type_hdr = "Content-Type"
-
let user_agent_hdr = "User-Agent"
let myprint fmt = debug fmt
String.sub r 0 ((String.length r)-1)
type method_t = Get | Post | Put | Connect | Unknown of string
+let string_of_method_t = function
+ | Get -> "GET" | Post -> "POST" | Put -> "PUT" | Connect -> "CONNECT" | Unknown x -> "Unknown " ^ x
+let method_t_of_string = function
+ | "GET" -> Get | "POST" -> Post | "PUT" -> Put | "CONNECT" -> Connect | x -> Unknown x
-and authorization =
+type authorization =
| Basic of string * string
| UnknownAuth of string
-and request = { m: method_t;
+type request = { m: method_t;
uri: string;
query: (string*string) list;
version: string;
auth: authorization option;
cookie: (string * string) list;
task: string option;
- subtask_of: string option;
- content_type: string option;
+ subtask_of: string option;
user_agent: string option;
- 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
- | "GET" -> Get | "POST" -> Post | "PUT" -> Put | "CONNECT" -> Connect | x -> Unknown x
-
+ close: bool ref;
+ headers: string list;}
let nullreq = { m=Unknown "";
uri="";
auth=None;
cookie=[];
task=None;
- subtask_of=None;
- content_type = None;
+ subtask_of=None;
user_agent = None;
- close= true;
+ close= ref true;
headers=[];}
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
| 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 *)
let uri, query = parse_uri uri in
{ m = method_t_of_string m; uri = uri; query = query;
content_length = None; transfer_encoding = None;
- version = version; cookie = []; auth = None; task = None; subtask_of = None; content_type = None; user_agent = None; close=false; headers=[] }
+ version = version; cookie = []; auth = None; task = None; subtask_of = None; user_agent = None; close=ref 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 }"
+ Printf.sprintf "{ method = %s; uri = %s; query = [ %s ]; content_length = [ %s ]; transfer encoding = %s; version = %s; cookie = [ %s ]; task = %s; subtask_of = [ %s]; user_agent = %s }"
(string_of_method_t x.m) x.uri
(kvpairs x.query)
(default "" (may Int64.to_string x.content_length))
(kvpairs x.cookie)
(default "" x.task)
(default "" x.subtask_of)
- (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)
| UnknownAuth of string
(** Parsed form of the HTTP request line plus cookie info *)
-type request = {
- m: method_t;
- uri: string;
- query: (string*string) list;
- version: string;
- transfer_encoding: string option;
- content_length: int64 option;
- auth: authorization option;
- cookie: (string * string) list;
- task: string option;
- subtask_of: string option;
- content_type: string option;
- user_agent: string option;
- mutable close: bool;
- 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
+type request = { m: method_t;
+ uri: string;
+ query: (string*string) list;
+ version: string;
+ transfer_encoding: string option;
+ content_length: int64 option;
+ auth: authorization option;
+ cookie: (string * string) list;
+ task: string option;
+ subtask_of: string option;
+ user_agent: string option;
+ close: bool ref;
+ headers: string list;}
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
(** Header used for User-Agent string *)
val user_agent_hdr : string
-val content_type_hdr : string
-
val output_http : Unix.file_descr -> string list -> unit
val strip_cr : string -> string
let response_fct req ?(hdrs=[]) s (response_length: int64) (write_response_to_fd_fn: Unix.file_descr -> unit) =
let version = get_return_version req in
- let keep_alive = if req.close then false else true in
+ let keep_alive = if !(req.close) then false else true in
headers s ((http_200_ok_with_content response_length ~version ~keep_alive ()) @ hdrs);
write_response_to_fd_fn s
(** If no handler matches the request then call this callback *)
let default_callback req bio =
response_forbidden (Buf_io.fd_of bio);
- req.close <- true
+ req.close := true
let write_error bio message =
let auth = ref None in
let task = ref None in
let subtask_of = ref None in
- let content_type = ref None in
let user_agent = ref None in
content_length := -1L;
(* Default for HTTP/1.1 is persistent connections. Anything else closes *)
(* the channel as soon as the request is processed *)
- if req.version <> "HTTP/1.1" then req.close <- true;
+ if req.version <> "HTTP/1.1" then req.close := true;
let rec read_rest_of_headers left =
let cl_hdr = "content-length: " in
let auth_hdr = "authorization: " in
let task_hdr = String.lowercase Http.task_id_hdr ^ ": " in
let subtask_of_hdr = String.lowercase Http.subtask_of_hdr ^ ": " in
- let content_type_hdr = String.lowercase Http.content_type_hdr ^ ": " in
let user_agent_hdr = String.lowercase Http.user_agent_hdr ^ ": " in
let r = Buf_io.input_line ~timeout:Buf_io.infinite_timeout ic in
let r = strip_cr r in
then task := Some (end_of_string r (String.length task_hdr));
if String.startswith subtask_of_hdr lowercase_r
then subtask_of := Some (end_of_string r (String.length subtask_of_hdr));
- if String.startswith content_type_hdr lowercase_r
- then content_type := Some (end_of_string r (String.length content_type_hdr));
if String.startswith user_agent_hdr lowercase_r
then user_agent := Some (end_of_string r (String.length user_agent_hdr));
if String.startswith connection_hdr lowercase_r
begin
let token = String.lowercase (end_of_string r (String.length connection_hdr)) in
match token with
- | "keep-alive" -> req.close <- false
- | "close" -> req.close <- true
+ | "keep-alive" -> req.close := false
+ | "close" -> req.close := true
| _ -> ()
end;
if r <> "" then (
auth = !auth;
task = !task;
subtask_of = !subtask_of;
- content_type = !content_type;
user_agent = !user_agent;
headers = headers;
} in
let ty = Http.string_of_method_t req.m in
- D.debug "HTTP %s %s %s%s%s%s%s"
+ D.debug "HTTP %s %s %s%s%s%s"
ty req.uri
(Opt.default " " (Opt.map (fun x -> Printf.sprintf " (Content-length: %Ld)" x) req.content_length))
(Opt.default " " (Opt.map (fun x -> Printf.sprintf " (Task: %s)" x) req.task))
(Opt.default " " (Opt.map (fun x -> Printf.sprintf " (Subtask-of: %s)" x) req.subtask_of))
- (Opt.default " " (Opt.map (fun x -> Printf.sprintf " (Content-Type: %s)" x) req.content_type))
(Opt.default " " (Opt.map (fun x -> Printf.sprintf " (User-agent: %s)" x) req.user_agent));
let table = handler_table req.m in
(* Find a specific handler: the last one whose URI is a prefix of the received
Buf_io.assert_buffer_empty ic;
handlerfn req fd
);
- finished := (req.close)
+ finished := !(req.close)
with
End_of_file ->
DCritical.debug "Premature termination of connection!";
projects / xcp / xen-api-libs.git / commitdiff