Permalink
Browse files

[enhance] Stdlib: response headers now really used

- Headers type definition moved from resource_private to resource.
- Modified bslNet to convert opa headers to caml headers (the ones
    used by HttpServer)
- Modified HttpServer to use user's defined headers for answering
  • Loading branch information...
1 parent 5603f4b commit 65c62f3e0f58c2641a25d47d95dd1b06fec20c4a Thomas Refis committed with Nicolas Glondu Aug 10, 2011
View
@@ -206,18 +206,50 @@ let _not_modified ?(include_date=true) () =
then [HSCp.Date (Date.rfc1123 (Unix.gmtime (Unix.time())))] (* RFC2616: 10.3.5 - we have a clock *)
else [])
-let limstr ?(extra="") str lim = let len = String.length str in (String.sub str 0 (min lim len))^(if len > lim then extra else "")
+let limstr ?(extra="") str lim =
+ let len = String.length str in
+ (String.sub str 0 (min lim len)) ^ (if len > lim then extra else "")
+
+let str_of_result = function
+ | Http_common.Result page -> page
+ | _ -> "<html><head><title>Error</title></head><body>Error.</body></html>"
+
+let make_response_with_headers ?(modified_since=None) ?(compression_level=6)
+ ?(cache_response=true) ?(delcookies=false) ?req
+ headers_out status_line _type content =
+ #<If$minlevel 20>Logger.debug "make_response"#<End>;
+ let code = Rd.status_code status_line in
+ let reason = Rd.reason_phrase code in
+ let sl = HSCp.Sl (HSC.http_version_number, code, reason) in
+ let content = str_of_result content in
+ #<If>Logger.debug "make_response: content=%s" (limstr ~extra:"..." content 100)#<End>;
+ let (sched,hr_opt,uri,headers_in,include_body) =
+ match req with
+ Some req -> (req.HST.request_scheduler,
+ (Some req.HST.handle_request),
+ req.HST.request_line.HST.request_uri,
+ req.HST.request_header,
+ (match req.HST.request_line.HST._method with HSCp.Head _ -> false | _ -> true))
+ | _ -> (Scheduler.default,None,"",[],true) in
+ let processed =
+ HSCm.process_content_with_headers sched ~modified_since ~compression_level
+ ~cache_response ~_delcookies:delcookies ~_type hr_opt uri
+ (Rc.ContentString content) headers_in headers_out include_body
+ in match processed with
+ Some (headers_out,body,len) -> {
+ HST.sl = sl;
+ HST.headers = HSCp.Content_Length len :: headers_out;
+ HST.body = body;
+ }
+ | None -> _not_modified ()
let make_response ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero) ?(cache=true)
?(delcookies=false) ?location ?req status_line _type ?content_dispo content =
#<If$minlevel 20>Logger.debug "make_response"#<End>;
let code = Rd.status_code status_line in
let reason = Rd.reason_phrase code in
let sl = HSCp.Sl (HSC.http_version_number, code, reason) in
- let content =
- match content with
- | Http_common.Result page -> page
- | _ -> "<html><head><title>Error</title></head><body>Error.</body></html>" in
+ let content = str_of_result content in
#<If>Logger.debug "make_response: content=%s" (limstr ~extra:"..." content 100)#<End>;
let (sched,hr_opt,uri,headers_in,include_body) =
match req with
@@ -234,7 +266,7 @@ let make_response ?(modified_since=None) ?(compression_level=6) ?(cache_response
let headers_out = match location with
| Some url -> (HSCp.Location url)::headers_out
| None -> headers_out in
- { HST.sl = sl; HST.headers = [HSCp.Content_Length len]@headers_out; HST.body = body }
+ { HST.sl = sl; HST.headers = HSCp.Content_Length len::headers_out; HST.body = body }
| None -> _not_modified ()
let make_response_result ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero)
View
@@ -227,6 +227,59 @@ let is_valid get_md5 mtime_opt hs =
| [] -> false
in aux hs
+let process_content_with_headers sched hr_opt ?(modified_since=None) ?(compression_level=6) ?(cache_response=true)
+ ?(_delcookies=false) ?(use_etag=false) ?(use_md5=false) ?(_type="text/plain")
+ _uri content headers_in headers_out include_body =
+ #<If$minlevel 10>Logger.debug "process_content: modified_since=%s\n%!"
+ (Option.to_string (fun d -> (Date.rfc1123 (Time.gmtime d))) modified_since)#<End>;
+ #<If>Logger.debug "process_content: _type=%s\n%!" _type#<End>;
+ let md5 = ref (false,"") in
+ let get_md5 () =
+ if fst !md5
+ then snd !md5
+ else (let _md5 = Rc.content_md5 content in md5 := (true,_md5); _md5)
+ in
+ if is_valid get_md5 modified_since headers_in
+ then (#<If>Logger.debug "not modified\n%!"#<End>;
+ None)
+ else
+ let time = match hr_opt with Some hr -> hr.HST.hr_timestamp | None -> Time.now () in
+ let time_now = Time.gmtime time in
+ let content_len = Rc.content_length content in
+ let gzip, deflate = is_gzip_deflate headers_in in
+ let compression_level = if Base.is_windows then 0 else compression_level in
+ #<If$minlevel 20>Logger.debug "process_content: compressing(%s)\n%!"
+ (Rc.string_of_content_type (Rc.get_content_type content))#<End>;
+ let compressed, content =
+ if compression_level > 0 && (needs_compressed _type content_len)
+ then HT.content_compress sched gzip deflate compression_level cache_response content content_len
+ else false, content
+ in
+ #<If$minlevel 20>Logger.debug "process_content: compressed=%b\n%!" compressed#<End>;
+ let content_out = if include_body then content else Rc.ContentNone in
+ let cs = if String.is_contained "charset" _type then "" else "; charset=utf-8" in
+ let typeval = (_type^cs,[]) in
+ #<If$minlevel 10>Logger.debug "process_content: md5=%s" (get_md5())#<End>;
+ let headers =
+ [(HSCp.Date (Date.rfc1123 time_now));(HSCp.Server HSC.server_name)]
+ @(if use_etag then [HSCp.ETag (get_md5())] else [])
+ @(if use_md5 then [HSCp.Content_MD5 (get_md5())] else [])
+ @([HSCp.Content_Type typeval])
+ @ headers_out
+ in
+ #<If$minlevel 10>Logger.debug "process_content: headers=%s\n%!"
+ (String.concat "" (List.map HSC.string_of_msg headers))#<End>;
+ let content_encoding = if deflate then "deflate" else if gzip then "gzip" else "identity" in
+ let res =
+ Some (if compressed
+ then (#<If$minlevel 10>Logger.debug "content compressed\n%!"#<End>;
+ (headers@[HSCp.Content_Encoding content_encoding],
+ content_out, Int64.of_int (Rc.content_length content)))
+ else (headers, content_out, Int64.of_int content_len))
+ in
+ #<If$minlevel 20>Logger.debug "process_content: returning\n%!"#<End>;
+ res
+
let process_content sched hr_opt ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero)
?(cache=true) ?(_delcookies=false) ?(use_etag=false) ?(use_md5=false) ?(_type="text/plain") ?content_dispo
_uri content headers_in include_body =
View
@@ -16,6 +16,7 @@
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module List = BaseList
+module HSCp = HttpServerCore_parse
(* The opa scheduler *)
let default_scheduler = BslScheduler.opa
@@ -39,6 +40,50 @@ let default_scheduler = BslScheduler.opa
##extern-type SSL.certificate = Ssl.certificate
##extern-type SSL.secure_type = SslAS.secure_type
+##extern-type WebInfo.private.native_http_header = HSCp.msg
+
+
+##module convertHeader
+
+ ##register set_cookie : string -> WebInfo.private.native_http_header
+ let set_cookie value = HSCp.Set_Cookie value
+
+ ##register last_modified : time_t -> WebInfo.private.native_http_header
+ let last_modified date =
+ let date = Time.milliseconds date in
+ HSCp.Last_Modified (Date.rfc1123 (Time.gmtime date))
+
+ ##register cache_control : string -> WebInfo.private.native_http_header
+ let cache_control s = HSCp.Cache_Control s
+
+ ##register pragma : string -> WebInfo.private.native_http_header
+ let pragma s = HSCp.Pragma s
+
+ ##register location : string -> WebInfo.private.native_http_header
+ let location s = HSCp.Location s
+
+ ##register cdisp_attachment : string -> WebInfo.private.native_http_header
+ let cdisp_attachment s = HSCp.Content_Disposition ("attachment", ["filename="^s])
+
+ ##register expires_at : option(time_t) -> WebInfo.private.native_http_header
+ let expires_at t =
+ let expires =
+ match t with
+ | None -> Time.infinity
+ | Some x -> Time.milliseconds x
+ in
+ let time = Time.now () in (* TODO: HttpServerCommon use a
+ request header here, we should probably do the same *)
+ let time_now = Time.gmtime time in
+ let exp_time =
+ if Time.is_infinite expires then
+ { time_now with Unix.tm_year = time_now.Unix.tm_year + 1 }
+ else if Time.is_positive expires then
+ Time.gmtime (Time.add time expires)
+ else time_now
+ in HSCp.Expires (Date.rfc1123 exp_time)
+
+##endmodule
(** Provides functions from OPA HTTP server, manipulating HTTP
request, make HTTP response, etc.*)
@@ -112,6 +157,18 @@ let default_scheduler = BslScheduler.opa
(** {6 Make weblib response} *)
+ ##register make_response : \
+ option(time_t), \
+ WebInfo.private.native_request, \
+ web_server_status, \
+ caml_list(WebInfo.private.native_http_header), \
+ string, \
+ string -> \
+ WebInfo.private.native_response
+ let make_response ms req stat headers s1 s2 =
+ let modified_since = Option.map Time.milliseconds ms in
+ HttpServer.make_response_with_headers ~modified_since ~req headers stat s1
+ (Http_common.Result s2)
##register make_response_modified_since : \
option(time_t), \
@@ -116,6 +116,8 @@ type web_cache_control = {volatile} /** The resource changes at each request
with [Dynamic_resource.publish] or [Dynamic_resource.custom_publish] and an expiration of [{none}].*/
type web_server_status = external
+type WebInfo.private.native_http_header = external
+
/**
* {1 Interface}
@@ -129,9 +131,89 @@ WebCoreExport =
*/
@private @both_implem startup_date : option = { some = Date.now() }
+@private ll_setcookie : string -> WebInfo.private.native_http_header = %%BslNet.ConvertHeader.set_cookie%%
+@private ll_cache_control : string -> WebInfo.private.native_http_header = %%BslNet.ConvertHeader.cache_control%%
+@private ll_expires_at : option(time_t) -> WebInfo.private.native_http_header = %%BslNet.ConvertHeader.expires_at%%
+@private ll_lastm : time_t -> WebInfo.private.native_http_header = %%BslNet.ConvertHeader.last_modified%%
+@private ll_pragma : string -> WebInfo.private.native_http_header = %%BslNet.ConvertHeader.pragma%%
+@private ll_cdisp_attachment : string -> WebInfo.private.native_http_header = %%BslNet.ConvertHeader.cdisp_attachment%%
+@private ll_location : string -> WebInfo.private.native_http_header = %%BslNet.ConvertHeader.location%%
+
+@private add_ll_header(header : Resource.http_header, lst : list(WebInfo.private.native_http_header)) =
+ match header with
+ | ~{set_cookie} -> [ ll_setcookie(cookie_def_to_string(set_cookie)) | lst ]
+ | ~{location} -> [ ll_location(location) | lst ]
+ | {content_disposition = ~{attachment}} -> [ ll_cdisp_attachment(attachment) | lst ]
+ | ~{lastm} ->
+ match lastm with
+ | {volatile} -> [ ll_cache_control("no-cache") , ll_pragma("no-cache") | lst ]
+ | ~{modified_on} -> [ ll_cache_control("public") , ll_lastm(Date.ll_export(modified_on)) | lst ]
+ | {permanent} ->
+ match startup_date with
+ | {none} -> [ ll_expires_at({none}) | lst ]
+ | ~{some} ->
+ [ ll_expires_at({none}), ll_cache_control("public"),
+ ll_lastm(Date.ll_export(some)) | lst ]
+ end
+ | {check_for_changes_after = duration } ->
+ now = Date.now()
+ expiry = Date.advance(now, duration)
+ te = Date.ll_export(_)
+ [ ll_expires_at({some = te(expiry)}), ll_cache_control("public") ,
+ ll_lastm(te(now)) | lst ]
+ end
+ | _ -> lst
+
+@private cookie_def_to_string(cd) =
+ cd.name ^ "=" ^ cd.value
+ ^ String.implode(cookie_attribute_to_string, ";", cd.attributes)
+
+@private cookie_attribute_to_string(ca) =
+ match ca with
+ | ~{comment} -> "Comment=" ^ comment
+ | ~{domain} -> "Domain=" ^ domain
+ | ~{max_age} -> "Max-Age={max_age}"
+ | ~{path} -> "Path=" ^ path
+ | {secure} -> "Secure"
+ | ~{version} -> "Version={version}"
+
+@private to_ll_headers(headers : list(Resource.http_header)) : list(WebInfo.private.native_http_header) =
+ List.foldl(add_ll_header, headers, [])
+
/**
* Prepare a low-level response
*/
+
+make_response_with_headers(request : WebInfo.private.native_request,
+ status : web_response,
+ headers : list(Resource.http_header),
+ mime_type : string,
+ content : string) : WebInfo.private.native_response =
+(
+ cache_control = // Ugly and redundant, here for legacy reasons
+ check(x) = match x with | { lastm = _ } -> true | _ -> false end
+ match Option.get(List.find(check, headers)) with
+ | ~{lastm} ->
+ match lastm with
+ | {volatile} -> {none}
+ | ~{modified_on} -> {some = Date.ll_export(modified_on)}
+ | {permanent} -> Option.map(Date.ll_export, startup_date)
+ | {check_for_changes_after = _ } -> {some = Date.ll_export(Date.now()) }
+ end
+ | _ -> {none}
+ end
+
+ respond = %% BslNet.Http_server.make_response %%
+ to_caml_list : (WebInfo.private.native_http_header
+ -> WebInfo.private.native_http_header),
+ list(WebInfo.private.native_http_header)
+ -> caml_list(WebInfo.private.native_http_header) =
+ %% BslNativeLib.opa_list_to_ocaml_list %%
+ ll_headers = to_caml_list((x -> x), to_ll_headers(headers))
+ answer = web_err_num_of_web_response(status)
+ respond(cache_control, request, answer, ll_headers, mime_type, content)
+)
+
default_make_response(cache_control: web_cache_control, request: WebInfo.private.native_request, status: web_response, mime_type: string, content: string): WebInfo.private.native_response =
(
make_response_modified_since = %% BslNet.Http_server.make_response_modified_since %%
@@ -131,9 +131,42 @@ type resource_content = external
/**
* {1 Interface}
*/
+type Resource.cookie_attributes =
+ { comment:string }
+ / { domain:string }
+ / { max_age:int }
+ / { path:string }
+ / { secure:void }
+ / { version:int }
+
+type Resource.cookie_def = {
+ name : string ;
+ value : string ;
+ attributes : list(Resource.cookie_attributes) ;
+}
+
+type Resource.http_response_header =
+ { set_cookie:Resource.cookie_def }
+ / { age:int }
+ / { location:string }
+ / { retry_after: { date:string } / { delay:int } }
+ / { server: list(string) }
+ / { content_disposition : { attachment : string } }
+
+type Resource.http_general_header =
+ { lastm : web_cache_control }
+
+type Resource.http_header = Resource.http_general_header / Resource.http_response_header
+
Resource = {{
+add_header(r : resource, h : Resource.http_header) =
+ { r with rc_headers = [h | r.rc_headers] } : Resource.resource
+
+add_headers(r : resource, hs : list(Resource.http_header)) =
+ { r with rc_headers = List.append(hs, r.rc_headers) } : Resource.resource
+
base_url =
commandline : CommandLine.family(option(string)) = {
title = "Specify a base URL"
Oops, something went wrong.

0 comments on commit 65c62f3

Please sign in to comment.