[http] added a generic response builder

diff --git a/libs/http/http.ml b/libs/http/http.ml
index b87c8480ea7dbafc1a8bb53c1a24328349b2c115..ea514eefac185026c39b7df877290199edfd50be 100644 (file)
--- a/libs/http/http.ml
+++ b/libs/http/http.ml
@@ -87,6 +87,7 @@ let rec strip_leading_spaces = function
                strip_leading_spaces clist
        | cl -> cl
 
+(* Header utilities *)
 
 type header_fields = (string * string list) list
 
@@ -101,6 +102,9 @@ let rec add_header fname fvalue =
 let lookup_header name hdrs =
        List.assoc (String.lowercase name) hdrs
 
+let is_header_present hdr headers =
+       try ignore (lookup_header hdr headers); true
+       with Not_found -> false
 
 type version =
        | HTTP09
@@ -481,6 +485,114 @@ end
 
 
 module Response_header = struct
+       type status =
+               (* Informational 1xx *)
+               | Status_continue
+               | Status_switching_protocols
+
+               (* Successful 2xx *)
+               | Status_ok
+               | Status_created
+               | Status_accepted
+               | Status_non_authoritative
+               | Status_no_content
+               | Status_reset_content
+               | Status_partial_content
+
+               (* Redirection 3xx *)
+               | Status_multiple_choices
+               | Status_moved_permanently
+               | Status_found
+               | Status_see_other
+               | Status_not_modified
+               | Status_use_proxy
+               | Status_temporary_redirect
+
+               (* Client Error 4xx *)
+               | Status_bad_request
+               | Status_unauthorized
+               | Status_payment_required
+               | Status_forbidden
+               | Status_not_found
+               | Status_method_not_allowed
+               | Status_not_acceptable
+               | Status_proxy_authentication_required
+               | Status_request_timeout
+               | Status_conflict
+               | Status_gone
+               | Status_length_required
+               | Status_precondition_failed
+               | Status_request_entity_too_large
+               | Status_request_uri_too_large
+               | Status_unsupported_media_type
+               | Status_requested_range_not_satisfiable
+               | Status_expectation_failed
+
+               (* Server Error 5xx *)
+               | Status_internal_server_error
+               | Status_not_implemented
+               | Status_bad_gateway
+               | Status_service_unavailable
+               | Status_gateway_timeout
+               | Status_version_not_supported
+
+               (* Other *)
+               | Status_other of int * string
+
+       let status_info = function
+               (* Informational 1xx *)
+               | Status_continue -> 100, "Continue"
+               | Status_switching_protocols -> 101, "Switching Protocols"
+
+               (* Successful 2xx *)
+               | Status_ok -> 200, "Ok"
+               | Status_created -> 201, "Created"
+               | Status_accepted -> 202, "Accepted"
+               | Status_non_authoritative -> 203, "Non-Authoritative Information"
+               | Status_no_content -> 204, "No Content"
+               | Status_reset_content -> 205, "Reset Content"
+               | Status_partial_content -> 206, "Partial Content"
+
+               (* Redirection 3xx *)
+               | Status_multiple_choices -> 300, "Multiple Choices"
+               | Status_moved_permanently -> 301, "Moved Permanently"
+               | Status_found -> 302, "Found"
+               | Status_see_other -> 303, "See Other"
+               | Status_not_modified -> 304, "Not Modified"
+               | Status_use_proxy -> 305, "Use Proxy"
+               | Status_temporary_redirect -> 307, "Temporary Redirect"
+
+               (* Client Error 4xx *)
+               | Status_bad_request -> 400, "Bad Request"
+               | Status_unauthorized -> 401, "Unauthorized"
+               | Status_payment_required -> 402, "Payment Required"
+               | Status_forbidden -> 403, "Forbidden"
+               | Status_not_found -> 404, "Not Found"
+               | Status_method_not_allowed -> 405, "Method Not Allowed"
+               | Status_not_acceptable -> 406, "Not Acceptable"
+               | Status_proxy_authentication_required -> 407, "Proxy Authentication Required"
+               | Status_request_timeout -> 408, "Request Timeout"
+               | Status_conflict -> 409, "Conflict"
+               | Status_gone -> 410, "Gone"
+               | Status_length_required -> 411, "Length Required"
+               | Status_precondition_failed -> 412, "Precondition Failed"
+               | Status_request_entity_too_large -> 413, "Request Entity Too Large"
+               | Status_request_uri_too_large -> 414, "Request-URI Too Large"
+               | Status_unsupported_media_type -> 415, "Unsupported Media Type"
+               | Status_requested_range_not_satisfiable -> 416, "Range Not Satisfiable"
+               | Status_expectation_failed -> 417, "Expectation Failed"
+
+               (* Server Error 5xx *)
+               | Status_internal_server_error -> 500, "Internal Server Error"
+               | Status_not_implemented -> 501, "Not Implemented"
+               | Status_bad_gateway -> 502, "Bad Gateway"
+               | Status_service_unavailable -> 503, "Service Unavailable"
+               | Status_gateway_timeout -> 504, "Gateway Timeout"
+               | Status_version_not_supported -> 505, "HTTP Version Not Supported"
+
+               (* Other *)
+               | Status_other (code, reason) -> code, reason
+
        type cursor =
                | Start
                | In_version of char list
@@ -1240,4 +1352,19 @@ module Response = struct
                match resp.payload with
                | Some p -> Payload.serialize_of_response resp.response buf p
                | None   -> ()
+
+       let make_response ?payload ~headers status =
+               let code, reason = Response_header.status_info status in
+               let payload_length = (match payload with
+                                       | None -> 0
+                                       | Some p -> Buffer.length p.Payload.content) in
+               let headers = (if is_header_present "Content-Length" headers then headers
+                              else (add_header "Content-Length" (Printf.sprintf "%d" payload_length)
+                                      headers)) in
+               let resp_header = { Response_header.version = HTTP11;
+                                   Response_header.status_code = code;
+                                   Response_header.reason_phrase = reason;
+                                   Response_header.headers = headers }
+               in { response = resp_header;
+                    payload = payload }
 end

diff --git a/libs/http/http.mli b/libs/http/http.mli
index 730fc7c687ab58315395ff86acb50120b92e2177..2c2826947abfbc5e98d6cd7aded8b0d88cd9e666 100644 (file)
--- a/libs/http/http.mli
+++ b/libs/http/http.mli
@@ -16,6 +16,10 @@
 
 type header_fields = (string * string list) list
 
+val add_header : string -> string -> header_fields -> header_fields
+val is_header_present : string -> header_fields -> bool
+val lookup_header : string -> header_fields -> string list (* can throw Not_found *)
+
 type version = HTTP09 | HTTP10 | HTTP11
 
 module Headers : sig
@@ -65,6 +69,62 @@ module Request_header : sig
 end
 
 module Response_header : sig
+       type status =
+               (* Informational 1xx *)
+               | Status_continue
+               | Status_switching_protocols
+
+               (* Successful 2xx *)
+               | Status_ok
+               | Status_created
+               | Status_accepted
+               | Status_non_authoritative
+               | Status_no_content
+               | Status_reset_content
+               | Status_partial_content
+
+               (* Redirection 3xx *)
+               | Status_multiple_choices
+               | Status_moved_permanently
+               | Status_found
+               | Status_see_other
+               | Status_not_modified
+               | Status_use_proxy
+               | Status_temporary_redirect
+
+               (* Client Error 4xx *)
+               | Status_bad_request
+               | Status_unauthorized
+               | Status_payment_required
+               | Status_forbidden
+               | Status_not_found
+               | Status_method_not_allowed
+               | Status_not_acceptable
+               | Status_proxy_authentication_required
+               | Status_request_timeout
+               | Status_conflict
+               | Status_gone
+               | Status_length_required
+               | Status_precondition_failed
+               | Status_request_entity_too_large
+               | Status_request_uri_too_large
+               | Status_unsupported_media_type
+               | Status_requested_range_not_satisfiable
+               | Status_expectation_failed
+
+               (* Server Error 5xx *)
+               | Status_internal_server_error
+               | Status_not_implemented
+               | Status_bad_gateway
+               | Status_service_unavailable
+               | Status_gateway_timeout
+               | Status_version_not_supported
+
+               (* Other *)
+               | Status_other of int * string
+
+       val status_info : status -> (* status code *) int * (* reason phrase *) string
+
        type state
        val init_state : unit -> state
        val num_bytes_parsed : state -> int
@@ -184,4 +244,6 @@ module Response : sig
        val connection_closed : state -> unit
 
        val serialize : Buffer.t -> t -> unit
+
+       val make_response : ?payload:Payload.t -> headers:header_fields -> Response_header.status -> t
   end