Pull in latest changes.

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"];

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

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)

src/http_status.mli

@@ -4,6 +4,7 @@ type t =
     | `Bad_request
     | `Conflict
     | `Created
+    | `Custom_code of (int * string)
     | `Expectation_failed
     | `Forbidden
     | `Found

src/request.ml

@@ -20,12 +20,18 @@ type header =
   | `Http_referer
   | `Http_accept
   | `Http_content_type
+  | `Http_content_md5
   | `Http_user_agent
   | `Http_origin
   | `Http_cache_control
   | `Http_content_length
   | `Http_connection
   | `Http_host
+  | `Http_authorization
+  | `Http_date
+  | `Http_x_forwarded_proto
+  | `Http_x_forwarded_port
+  | `Http_x_forwarded_for
   | `Server_name
   | `Server_port
   | `Remote_port
@@ -44,12 +50,18 @@ 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"
       | `Http_content_length -> "http_content_length"
       | `Http_connection -> "http_connection"
       | `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"
@@ -60,19 +72,22 @@ 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;
     meth;
     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 []
   }
 
@@ -141,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
@@ -169,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
 

src/request.mli

@@ -9,12 +9,18 @@ type header =
   | `Http_referer
   | `Http_accept
   | `Http_content_type
+  | `Http_content_md5
   | `Http_user_agent
   | `Http_origin
   | `Http_cache_control
   | `Http_content_length
   | `Http_connection
   | `Http_host
+  | `Http_authorization
+  | `Http_date
+  | `Http_x_forwarded_proto
+  | `Http_x_forwarded_port
+  | `Http_x_forwarded_for
   | `Server_name
   | `Server_port
   | `Remote_port
@@ -31,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
 

src/response.ml

@@ -15,3 +15,21 @@ let make ~status ?(headers=[]) ?(body=`String "") () =
     headers;
     body;
   }
+
+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
+      "{ 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]")

src/response.mli

@@ -11,3 +11,12 @@ 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 add_header : Http_header.t -> t -> t
+
+val to_string : ?body_max:int -> t -> string
+  (** For debugging *)

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

src/server.mli

@@ -2,12 +2,21 @@
 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 ->
   inet_addr ->
   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