From 016389c66e77855caab2d44a67d302141fedba8f Mon Sep 17 00:00:00 2001 From: David Scott Date: Mon, 26 Oct 2009 16:32:15 +0000 Subject: [PATCH] [refactoring] Move http-svr from xen-api.hg to xen-api-libs.hg Signed-off-by: Thomas Gazagnaire --- http-svr/Makefile | 23 ++++------- http-svr/http.ml | 90 +++++++++++++------------------------------- http-svr/http.mli | 48 +++++++---------------- http-svr/http_svr.ml | 20 ++++------ 4 files changed, 54 insertions(+), 127 deletions(-) diff --git a/http-svr/Makefile b/http-svr/Makefile index 1e6b2f7..d30f3f3 100644 --- a/http-svr/Makefile +++ b/http-svr/Makefile @@ -5,21 +5,18 @@ OCAMLOPT = ocamlopt 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) @@ -33,13 +30,13 @@ http_svr.cma: $(foreach obj,$(OBJS),$(obj).cmo) $(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 $@ $< @@ -48,18 +45,12 @@ META: META.in 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 diff --git a/http-svr/http.ml b/http-svr/http.ml index d698482..f8e2456 100644 --- a/http-svr/http.ml +++ b/http-svr/http.ml @@ -76,8 +76,6 @@ let task_id_hdr = "Task-id" let subtask_of_hdr = "Subtask-of" -let content_type_hdr = "Content-Type" - let user_agent_hdr = "User-Agent" let myprint fmt = debug fmt @@ -98,12 +96,16 @@ let strip_cr r = 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; @@ -112,24 +114,10 @@ and request = { m: method_t; 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=""; @@ -140,10 +128,9 @@ let nullreq = { m=Unknown ""; 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 = @@ -156,15 +143,21 @@ 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 @@ -210,25 +203,23 @@ 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 *) 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)) @@ -237,38 +228,11 @@ let pretty_string_of_request x = (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) diff --git a/http-svr/http.mli b/http-svr/http.mli index 0666596..d6f96a0 100644 --- a/http-svr/http.mli +++ b/http-svr/http.mli @@ -25,45 +25,25 @@ type authorization = | 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 @@ -84,8 +64,6 @@ val subtask_of_hdr : string (** 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 diff --git a/http-svr/http_svr.ml b/http-svr/http_svr.ml index e643a56..5a7f6c8 100644 --- a/http-svr/http_svr.ml +++ b/http-svr/http_svr.ml @@ -87,7 +87,7 @@ let get_return_version req = 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 @@ -142,7 +142,7 @@ let response_file ?(hdrs=[]) ~mime_content_type s file = (** 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 = @@ -170,7 +170,6 @@ let handle_connection _ ss = 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; @@ -190,7 +189,7 @@ let handle_connection _ ss = (* 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 @@ -200,7 +199,6 @@ let handle_connection _ ss = 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 @@ -220,8 +218,6 @@ let handle_connection _ ss = 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 @@ -229,8 +225,8 @@ let handle_connection _ ss = 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 ( @@ -247,17 +243,15 @@ let handle_connection _ ss = 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 @@ -278,7 +272,7 @@ let handle_connection _ ss = 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!"; -- 2.39.5