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"]; 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/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 diff --git a/src/request.ml b/src/request.ml index cf0d27e..9f47d14 100644 --- a/src/request.ml +++ b/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,6 +72,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 +82,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 [] } @@ -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 diff --git a/src/request.mli b/src/request.mli index b34108b..b749f7d 100644 --- a/src/request.mli +++ b/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 diff --git a/src/response.ml b/src/response.ml index 76a8e35..9ec404b 100644 --- a/src/response.ml +++ b/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]") diff --git a/src/response.mli b/src/response.mli index eba1b01..c942a3a 100644 --- a/src/response.mli +++ b/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 *) 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