From 31168da61452bcf98e7c8331ebe1c177b29518cf Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Wed, 26 Sep 2012 16:03:50 -0700 Subject: [PATCH 01/12] Add HTTP 'Authorization' header --- src/request.ml | 2 ++ src/request.mli | 1 + 2 files changed, 3 insertions(+) diff --git a/src/request.ml b/src/request.ml index cf0d27e..531a7be 100644 --- a/src/request.ml +++ b/src/request.ml @@ -26,6 +26,7 @@ type header = | `Http_content_length | `Http_connection | `Http_host + | `Http_authorization | `Server_name | `Server_port | `Remote_port @@ -50,6 +51,7 @@ let header' headers name = | `Http_content_length -> "http_content_length" | `Http_connection -> "http_connection" | `Http_host -> "http_host" + | `Http_authorization -> "http_authorization" | `Server_name -> "server_name" | `Server_port -> "server_port" | `Remote_port -> "remote_port" diff --git a/src/request.mli b/src/request.mli index b34108b..4f73373 100644 --- a/src/request.mli +++ b/src/request.mli @@ -15,6 +15,7 @@ type header = | `Http_content_length | `Http_connection | `Http_host + | `Http_authorization | `Server_name | `Server_port | `Remote_port From 92240cd8fee7ca9b87f5bec2883af08d49fd739e Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Wed, 26 Sep 2012 16:34:16 -0700 Subject: [PATCH 02/12] Add HTTP 'Date' header --- src/request.ml | 2 ++ src/request.mli | 1 + 2 files changed, 3 insertions(+) diff --git a/src/request.ml b/src/request.ml index 531a7be..4d04b08 100644 --- a/src/request.ml +++ b/src/request.ml @@ -27,6 +27,7 @@ type header = | `Http_connection | `Http_host | `Http_authorization + | `Http_date | `Server_name | `Server_port | `Remote_port @@ -52,6 +53,7 @@ let header' headers name = | `Http_connection -> "http_connection" | `Http_host -> "http_host" | `Http_authorization -> "http_authorization" + | `Http_date -> "http_date" | `Server_name -> "server_name" | `Server_port -> "server_port" | `Remote_port -> "remote_port" diff --git a/src/request.mli b/src/request.mli index 4f73373..5d27169 100644 --- a/src/request.mli +++ b/src/request.mli @@ -16,6 +16,7 @@ type header = | `Http_connection | `Http_host | `Http_authorization + | `Http_date | `Server_name | `Server_port | `Remote_port From 1cd03b93dea0a12139fc14096cc3b9b1b5c14cf4 Mon Sep 17 00:00:00 2001 From: Martin Jambon Date: Mon, 1 Oct 2012 11:42:43 -0700 Subject: [PATCH 03/12] Modified to work with ocaml-uri >= 1.2 (query string values returned by the Uri module are now split on commas) --- src/request.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/request.ml b/src/request.ml index cf0d27e..02cb97e 100644 --- a/src/request.ml +++ b/src/request.ml @@ -60,6 +60,9 @@ let header' headers name = List.map snd (List.find_all (fun (n, _) -> n = name) headers) +let concat_query_values l = + List.map (fun (k, vl) -> (k, String.concat "," vl)) l + let make content_length meth uri headers content = let headers = List.map (fun (k, v) -> String.lowercase k, v) headers in { content_length; @@ -67,12 +70,12 @@ let make content_length meth uri headers content = uri; headers = headers; content; - get_params = Uri.query uri; + get_params = concat_query_values (Uri.query uri); post_params = match meth with | `POST when header' headers `Http_content_type = ["application/x-www-form-urlencoded"] -> content >>= fun s -> - Lwt.return (Uri.query_of_encoded s) + Lwt.return (concat_query_values (Uri.query_of_encoded s)) | _ -> Lwt.return [] } From 62029adb522e6a185cc3744ae676d58dcfda9f83 Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Wed, 7 Nov 2012 14:11:13 -0800 Subject: [PATCH 04/12] Add Content-MD5 and Forwarded-For-XXXXX headers --- src/request.ml | 8 ++++++++ src/request.mli | 4 ++++ 2 files changed, 12 insertions(+) diff --git a/src/request.ml b/src/request.ml index 4d04b08..a9a8806 100644 --- a/src/request.ml +++ b/src/request.ml @@ -20,6 +20,7 @@ type header = | `Http_referer | `Http_accept | `Http_content_type + | `Http_content_md5 | `Http_user_agent | `Http_origin | `Http_cache_control @@ -28,6 +29,9 @@ type header = | `Http_host | `Http_authorization | `Http_date + | `Http_x_forwarded_proto + | `Http_x_forwarded_port + | `Http_x_forwarded_for | `Server_name | `Server_port | `Remote_port @@ -46,6 +50,7 @@ let header' headers name = | `Http_referer -> "http_referer" | `Http_accept -> "http_accept" | `Http_content_type -> "http_content_type" + | `Http_content_md5 -> "http_content_md5" | `Http_user_agent -> "http_user_agent" | `Http_origin -> "http_origin" | `Http_cache_control -> "http_cache_control" @@ -54,6 +59,9 @@ let header' headers name = | `Http_host -> "http_host" | `Http_authorization -> "http_authorization" | `Http_date -> "http_date" + | `Http_x_forwarded_proto -> "http_x_forwarded_proto" + | `Http_x_forwarded_port -> "http_x_forwarded_port" + | `Http_x_forwarded_for -> "http_x_forwarded_for" | `Server_name -> "server_name" | `Server_port -> "server_port" | `Remote_port -> "remote_port" diff --git a/src/request.mli b/src/request.mli index 5d27169..d7b3e67 100644 --- a/src/request.mli +++ b/src/request.mli @@ -9,6 +9,7 @@ type header = | `Http_referer | `Http_accept | `Http_content_type + | `Http_content_md5 | `Http_user_agent | `Http_origin | `Http_cache_control @@ -17,6 +18,9 @@ type header = | `Http_host | `Http_authorization | `Http_date + | `Http_x_forwarded_proto + | `Http_x_forwarded_port + | `Http_x_forwarded_for | `Server_name | `Server_port | `Remote_port From e9aca5f24051fe9f6629da5416fd27cd18b18d36 Mon Sep 17 00:00:00 2001 From: Ryland Degnan Date: Thu, 15 Nov 2012 15:25:56 -0800 Subject: [PATCH 05/12] Added exceptionless param function --- src/request.ml | 9 ++++++++- src/request.mli | 4 +++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/request.ml b/src/request.ml index 58b411c..9f47d14 100644 --- a/src/request.ml +++ b/src/request.ml @@ -156,7 +156,13 @@ let meth t = t.meth let uri t = t.uri let path t = Uri.path t.uri let contents t = t.content -let param ?meth ?default t name = + +let param ?meth t name = + match List.Exceptionless.assoc name t.get_params with + | None -> t.post_params >|= List.Exceptionless.assoc name + | r -> Lwt.return r + +let param_exn ?meth ?default t name = Lwt.catch (fun () -> let rec loop = function @@ -184,6 +190,7 @@ let param ?meth ?default t name = ) let params_get t = t.get_params +let params_post t = t.post_params let header t name = header' t.headers name diff --git a/src/request.mli b/src/request.mli index d7b3e67..b749f7d 100644 --- a/src/request.mli +++ b/src/request.mli @@ -37,8 +37,10 @@ val meth : t -> Http_method.t val uri : t -> Uri.t val path : t -> string val contents : t -> string Lwt.t -val param : ?meth:[ `GET | `POST ] -> ?default:string -> t -> string -> string Lwt.t +val param : ?meth:[ `GET | `POST ] -> t -> string -> string option Lwt.t +val param_exn : ?meth:[ `GET | `POST ] -> ?default:string -> t -> string -> string Lwt.t val params_get : t -> (string * string) list +val params_post : t -> (string * string) list Lwt.t val header : t -> header -> string list val cookie : t -> string -> string option From 51a2347ee2931ab8cf12b2815fd8fe5cbc1be69f Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Wed, 28 Nov 2012 13:43:02 -0800 Subject: [PATCH 06/12] Add support for Unix sockets --- src/compatability.ml | 2 +- src/server.ml | 54 +++++++++++++++++++++++++++++++++----------- src/server.mli | 11 ++++++++- 3 files changed, 52 insertions(+), 15 deletions(-) diff --git a/src/compatability.ml b/src/compatability.ml index e42c079..28df92b 100644 --- a/src/compatability.ml +++ b/src/compatability.ml @@ -8,5 +8,5 @@ module Scgi = struct module Scgi_request = Request module Scgi_response = Response - let handler = Server.handler + let handler = Server.handler_inet end diff --git a/src/server.ml b/src/server.ml index 64e2fb4..b678b4d 100644 --- a/src/server.ml +++ b/src/server.ml @@ -1,6 +1,7 @@ type server_name = string type inet_addr = string type port = int +type socket_filename = string let default_read_error_handler exn = prerr_endline (Printexc.to_string exn ^ "\n" ^ Printexc.get_backtrace ()); @@ -15,15 +16,13 @@ let default_write_error_handler exn = Lwt.return () let handler - ?(read_error_handler=default_read_error_handler) - ?(write_error_handler=default_write_error_handler) - name - inet_addr - port + ~read_error_handler + ~write_error_handler + ~sockaddr + ~name f = let _server = - Lwt_io.establish_server - (Unix.ADDR_INET (Unix.inet_addr_of_string inet_addr, port)) + Lwt_io.establish_server sockaddr (fun (inch, ouch) -> Lwt.ignore_result ( lwt response = @@ -62,16 +61,45 @@ let handler lwt () = Lwt_io.write ouch "\r\n" in (* Write the body *) - lwt () = - match response.body with + match response.body with | `Stream (_, s) -> Lwt_io.write_chars ouch s | `String s -> Lwt_io.write ouch s - in - (* The server closes the connection *) - Lwt_io.close ouch with e -> write_error_handler e + finally + (* The server closes the connection *) + try_lwt + lwt () = + Lwt_io.close ouch in + Lwt_io.close inch + with e -> write_error_handler e + ) (* Lwt.ignore_result *) ) (* fun (inch, ouch) -> *) in - print_endline (Printf.sprintf "Started [%s] listening on %s:%d" name inet_addr port) + () + +let handler_inet + ?(read_error_handler=default_read_error_handler) + ?(write_error_handler=default_write_error_handler) + name + inet_addr + port + f = + handler + ~read_error_handler + ~write_error_handler + ~sockaddr: (Unix.ADDR_INET (Unix.inet_addr_of_string inet_addr, port)) + ~name f + +let handler_sock + ?(read_error_handler=default_read_error_handler) + ?(write_error_handler=default_write_error_handler) + name + socket_filename + f = + handler + ~read_error_handler + ~write_error_handler + ~sockaddr: (Unix.ADDR_UNIX socket_filename) + ~name f diff --git a/src/server.mli b/src/server.mli index 38e1c8a..93f97da 100644 --- a/src/server.mli +++ b/src/server.mli @@ -2,8 +2,9 @@ type server_name = string type inet_addr = string type port = int +type socket_filename = string -val handler : +val handler_inet : ?read_error_handler:(exn -> Response.t Lwt.t) -> ?write_error_handler:(exn -> unit Lwt.t) -> server_name -> @@ -11,3 +12,11 @@ val handler : port -> (Request.t -> Response.t Lwt.t) -> unit + +val handler_sock : + ?read_error_handler:(exn -> Response.t Lwt.t) -> + ?write_error_handler:(exn -> unit Lwt.t) -> + server_name -> + socket_filename -> + (Request.t -> Response.t Lwt.t) -> + unit From d7249f5b25a88e544b7172d9b5b3cd9f91b9f309 Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Fri, 7 Dec 2012 16:54:18 -0800 Subject: [PATCH 07/12] Add Response.to_string method --- src/response.ml | 13 +++++++++++++ src/response.mli | 3 +++ 2 files changed, 16 insertions(+) diff --git a/src/response.ml b/src/response.ml index 76a8e35..83d5bd1 100644 --- a/src/response.ml +++ b/src/response.ml @@ -15,3 +15,16 @@ let make ~status ?(headers=[]) ?(body=`String "") () = headers; body; } + +let to_string ?(body_max=1000) t = + let headers_str = String.concat "; " (List.map (fun h -> String.trim (Http_header.to_string h)) t.headers) in + Lwt.return ( + Printf.sprintf + "{ http_status: %d (%s); headers: [ %s]; body: \"%s\";}" + (Http_status.to_int t.status) + (Http_status.to_string t.status) + headers_str + (match t.body with `String b -> String.sub b 0 (min (String.length b) body_max) + | `Stream (Some c, _) -> Printf.sprintf "stream of %d bytes length" c + | `Stream _ -> "[stream of unknown length]") + ) diff --git a/src/response.mli b/src/response.mli index eba1b01..34882e3 100644 --- a/src/response.mli +++ b/src/response.mli @@ -11,3 +11,6 @@ type t = { } val make : status:Http_status.t -> ?headers:(Http_header.t list) -> ?body:body -> unit -> t + +val to_string : ?body_max:int -> t -> string Lwt.t + (** For debugging *) From b5da6312c3e77502e28cefa3e92c808ff4e9e0c7 Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Fri, 7 Dec 2012 17:29:03 -0800 Subject: [PATCH 08/12] Remove Lwt.return --- src/response.ml | 4 +--- src/response.mli | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/response.ml b/src/response.ml index 83d5bd1..60353d6 100644 --- a/src/response.ml +++ b/src/response.ml @@ -18,8 +18,7 @@ let make ~status ?(headers=[]) ?(body=`String "") () = let to_string ?(body_max=1000) t = let headers_str = String.concat "; " (List.map (fun h -> String.trim (Http_header.to_string h)) t.headers) in - Lwt.return ( - Printf.sprintf + Printf.sprintf "{ http_status: %d (%s); headers: [ %s]; body: \"%s\";}" (Http_status.to_int t.status) (Http_status.to_string t.status) @@ -27,4 +26,3 @@ let to_string ?(body_max=1000) t = (match t.body with `String b -> String.sub b 0 (min (String.length b) body_max) | `Stream (Some c, _) -> Printf.sprintf "stream of %d bytes length" c | `Stream _ -> "[stream of unknown length]") - ) diff --git a/src/response.mli b/src/response.mli index 34882e3..6668258 100644 --- a/src/response.mli +++ b/src/response.mli @@ -12,5 +12,5 @@ type t = { val make : status:Http_status.t -> ?headers:(Http_header.t list) -> ?body:body -> unit -> t -val to_string : ?body_max:int -> t -> string Lwt.t +val to_string : ?body_max:int -> t -> string (** For debugging *) From 4af749bde37d46c259f3b5d0221e3fcf08507d7d Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Mon, 10 Dec 2012 12:50:32 -0800 Subject: [PATCH 09/12] Add status retrieval methods for response --- src/response.ml | 4 ++++ src/response.mli | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/src/response.ml b/src/response.ml index 60353d6..76cf37d 100644 --- a/src/response.ml +++ b/src/response.ml @@ -16,6 +16,10 @@ let make ~status ?(headers=[]) ?(body=`String "") () = body; } +let status_int t = Http_status.to_int t.status + +let status_string t = Http_status.to_string t.status + let to_string ?(body_max=1000) t = let headers_str = String.concat "; " (List.map (fun h -> String.trim (Http_header.to_string h)) t.headers) in Printf.sprintf diff --git a/src/response.mli b/src/response.mli index 6668258..b13b3b9 100644 --- a/src/response.mli +++ b/src/response.mli @@ -12,5 +12,9 @@ type t = { val make : status:Http_status.t -> ?headers:(Http_header.t list) -> ?body:body -> unit -> t +val status_int : t -> int + +val status_string : t -> string + val to_string : ?body_max:int -> t -> string (** For debugging *) From 71443542faa6cb35770088926ad38fe7c2c90c06 Mon Sep 17 00:00:00 2001 From: Matthew Tovbin Date: Wed, 20 Mar 2013 17:51:27 -0700 Subject: [PATCH 10/12] Add header to response --- src/response.ml | 3 +++ src/response.mli | 2 ++ 2 files changed, 5 insertions(+) diff --git a/src/response.ml b/src/response.ml index 76cf37d..9ec404b 100644 --- a/src/response.ml +++ b/src/response.ml @@ -20,6 +20,9 @@ let status_int t = Http_status.to_int t.status let status_string t = Http_status.to_string t.status +let add_header header t = + { t with headers = header :: t.headers } + let to_string ?(body_max=1000) t = let headers_str = String.concat "; " (List.map (fun h -> String.trim (Http_header.to_string h)) t.headers) in Printf.sprintf diff --git a/src/response.mli b/src/response.mli index b13b3b9..c942a3a 100644 --- a/src/response.mli +++ b/src/response.mli @@ -16,5 +16,7 @@ val status_int : t -> int val status_string : t -> string +val add_header : Http_header.t -> t -> t + val to_string : ?body_max:int -> t -> string (** For debugging *) From efb9537d7b51c690ad5d9002a8f82098073099d0 Mon Sep 17 00:00:00 2001 From: Martin Jambon Date: Mon, 3 Jun 2013 18:36:13 -0700 Subject: [PATCH 11/12] Add support for custom HTTP statuses. --- src/http_status.ml | 2 ++ src/http_status.mli | 1 + 2 files changed, 3 insertions(+) diff --git a/src/http_status.ml b/src/http_status.ml index d3adc12..519b63e 100644 --- a/src/http_status.ml +++ b/src/http_status.ml @@ -38,6 +38,7 @@ type t = | `Service_unavailable | `Gateway_timeout | `Http_version_not_supported + | `Custom_code of (int * string) ] let values = function @@ -78,6 +79,7 @@ let values = function | `Service_unavailable -> 503, "Service Unavailable" | `Gateway_timeout -> 504, "Gateway Timeout" | `Http_version_not_supported -> 505, "HTTP Version Not Supported" + | `Custom_code (code, name) -> code, name let to_int v = fst (values v) let to_string v = snd (values v) diff --git a/src/http_status.mli b/src/http_status.mli index 63932e8..d49d010 100644 --- a/src/http_status.mli +++ b/src/http_status.mli @@ -4,6 +4,7 @@ type t = | `Bad_request | `Conflict | `Created + | `Custom_code of (int * string) | `Expectation_failed | `Forbidden | `Found From bb846463a0427e360fd4554078e7a11e47337587 Mon Sep 17 00:00:00 2001 From: Martin Jambon Date: Mon, 3 Jun 2013 18:38:32 -0700 Subject: [PATCH 12/12] Fix compilation of sample program --- samples/hello_scgi.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/samples/hello_scgi.ml b/samples/hello_scgi.ml index ccc23d5..e147e16 100644 --- a/samples/hello_scgi.ml +++ b/samples/hello_scgi.ml @@ -21,7 +21,7 @@ let _ = "try --help"; (* Start the handler *) - Server.handler "hello" !addr !port (fun r -> + Server.handler_inet "hello" !addr !port (fun r -> Lwt.return { Response.status = `Ok; headers = [`Content_type "text/plain"];