Skip to content

Commit

Permalink
[enhance] Stdlib: response headers now really used
Browse files Browse the repository at this point in the history 
- 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
Thomas Refis authored and Nicolas Glondu committed Sep 7, 2011
1 parent 5603f4b commit 65c62f3
Show file tree
Hide file tree
Showing 7 changed files with 312 additions and 52 deletions.
44 changes: 38 additions & 6 deletions libnet/httpServer.ml
View file
Expand Up @@ -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
Expand All @@ -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)
Expand Down
53 changes: 53 additions & 0 deletions libnet/httpServerCommon.ml
View file
Expand Up @@ -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 =
Expand Down
57 changes: 57 additions & 0 deletions opabsl/mlbsl/bslNet.ml
View file
Expand Up @@ -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
Expand All @@ -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.*)
Expand Down Expand Up @@ -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), \
Expand Down
82 changes: 82 additions & 0 deletions stdlib/core/web/core/reply.opa
View file
Expand Up @@ -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}
Expand All @@ -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 %%
Expand Down
33 changes: 33 additions & 0 deletions stdlib/core/web/resource/resource.opa
View file
Expand Up @@ -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"
Expand Down

0 comments on commit 65c62f3

Please sign in to comment.