ad_library {
The ACS Request Processor: the set of routines called upon every
single HTTP request to an ACS server.
@author Jon Salz (jsalz@arsdigita.com)
@creation-date 15 May 2000
@cvs-id $Id: request-processor-procs.tcl,v 1.138 2018/05/17 08:21:11 trenner Exp $
}
#####
#
# PUBLIC API
#
#####
ad_proc -public rp_internal_redirect {
-absolute_path:boolean
path
} {
Tell the request processor to return some other page.
The path can either be relative to the current directory (e.g. "some-template")
relative to the server root (e.g. "/packages/my-package/www/some-template"), or
an absolute path (e.g. "/home/donb/openacs-4/templates/some-cms-template").
When there is no extension then the request processor will choose the
matching file according to the extension preferences.
Parameters will stay the same as in the initial request.
Keep in mind that if you do an internal redirect to something other than
the current directory, relative links returned to the clients
browser may be broken (since the client will have the original URL).
Use rp_form_put or rp_form_update if you want to feed query variables to the redirected page.
@param absolute_path If set the path is an absolute path within the host filesystem
@param path path to the file to serve
@see rp_form_put, rp_form_update
} {
# protect from circular redirects
if { ![info exists ::__rp_internal_redirect_recursion_counter] } {
set ::__rp_internal_redirect_recursion_counter 0
} elseif { $::__rp_internal_redirect_recursion_counter > 10 } {
error "rp_internal_redirect: Recursion limit exceeded."
} else {
incr ::__rp_internal_redirect_recursion_counter
}
if { [string is false $absolute_path_p] } {
if { [string index $path 0] ne "/" } {
# it's a relative path, prepend the current location
set path "[file dirname [ad_conn file]]/$path"
} else {
set path "$::acs::rootdir$path"
}
}
# save the current file setting
set saved_file [ad_conn file]
rp_serve_abstract_file $path
# restore the file setting. we need to do this because
# rp_serve_abstract_file sets it to the path we internally
# redirected to, and rp_handler will cache the file setting
# internally in the ::tcl_url2file variable when PerformanceModeP is
# switched on. This way it caches the location that was originally
# requested, not the path that we redirected to.
ad_conn -set file $saved_file
}
ad_proc rp_getform {} {
This proc is a simple wrapper around AOLserver's standard ns_getform
proc, that will create the form if it doesn't exist, so that you
can then add values to that form. This is useful in conjunction
with rp_internal_redirect to redirect to a different page with
certain query variables set.
@author Lars Pind (lars@pinds.com)
@creation-date August 20, 2002
@return the form ns_set, just like ns_getform, except it will
always be non-empty.
} {
# The form may not exist, if there's nothing in it
if { [ns_getform] ne "" } {
# It's there
return [ns_getform]
} {
# It doesn't exist, create a new one
# This is the magic global Tcl variable that AOLserver uses
# to store the ns_set that contains the query args or form.
global _ns_form
# Simply create a new ns_set and store it in the global _ns_set variable
set _ns_form [ns_set create]
return $_ns_form
}
}
ad_proc rp_form_put { name value } {
This proc adds a query variable to AOLserver's internal ns_getform
form, so that it'll be picked up by ad_page_contract and other procs
that look at the query variables or form supplied. This is useful
when you do an rp_internal_redirect to a new page, and you want to
feed that page with certain query variables.
Note that the variable will just be appended to the form ns_set
which may not be what you want, if it exists already you will
now have two entries in the ns_set which may cause ad_page_contract to
break. Also, only simple variables may be added, not arrays.
@author Lars Pind (lars@pinds.com)
@creation-date August 20, 2002
@return the form ns_set, in case you're interested. Mostly you will want to discard the result.
} {
set form [rp_getform]
ns_set put $form $name $value
return $form
}
ad_proc rp_form_update { name value } {
Identical to rp_form_put, but uses ns_set update instead.
@return the form ns_set, in case you're interested. Mostly you will want to discard the result.
} {
set form [rp_getform]
ns_set update $form $name $value
return $form
}
ad_proc -private rp_registered_proc_info_compare { info1 info2 } {
A comparison predicate for registered procedures, returning -1, 0,
or 1 depending the relative sorted order of $info1 and $info2 in the
procedure list. Items with longer paths come first.
} {
set info1_path [lindex $info1 1]
set info2_path [lindex $info2 1]
set info1_path_length [string length $info1_path]
set info2_path_length [string length $info2_path]
if { $info1_path_length < $info2_path_length } {
return 1
}
if { $info1_path_length > $info2_path_length } {
return -1
}
return 0
}
ad_proc -public ad_register_proc {
-sitewide:boolean
{ -debug f }
{ -noinherit f }
{ -description "" }
method path proc { arg "" }
} {
Registers a procedure (see ns_register_proc for syntax). Use a
method of "*" to register GET, POST, and HEAD filters. If debug is
set to "t", all invocations of the procedure will be logged in the
server log.
@param sitewide specifies that the filter should be applied on a
sitewide (not subsite-by-subsite basis).
} {
if {$method eq "*"} {
# Shortcut to allow registering filter for all methods. Just
# call ad_register_proc again, with each of the three methods.
foreach method { GET POST HEAD } {
ad_register_proc -debug $debug -noinherit $noinherit $method $path $proc $arg
}
return
}
if {$method ni { GET POST HEAD PUT DELETE }} {
error "Method passed to ad_register_proc must be one of GET, POST, HEAD, PUT and DELETE"
}
set proc_info [list $method $path $proc $arg $debug $noinherit $description [info script]]
nsv_lappend rp_registered_procs . $proc_info
}
ad_proc -private rp_invoke_filter { conn filter_info why } {
Invokes the filter described in $argv, writing an error message to
the browser if it fails (unless kind is trace
).
} {
set startclicks [clock clicks -microseconds]
lassign $filter_info filter_index debug_p arg_count proc arg
rp_debug -debug $debug_p "Invoking $why filter $proc"
switch -- $arg_count {
0 { set cmd $proc }
1 { set cmd [list $proc $why] }
2 { set cmd [list $proc $conn $why] }
default { set cmd [list $proc $conn $arg $why] }
}
set errno 0
ad_try -auto_abort=false {
{*}$cmd
} trap {AD EXCEPTION ad_script_abort} {r} {
#
# no need to propagate the exception
#
set result filter_return
} on error {errMsg} {
set errno 1
} on ok {r} {
set result $r
}
if { $errno == 1 } {
# Uh-oh - an error occurred.
ds_add rp [list filter [list $why [ns_conn method] [ns_conn url] $proc $arg] \
$startclicks [clock clicks -microseconds] "error" $::errorInfo]
# make sure you report catching the error!
set error_msg "result $result filter $proc for [ns_conn request] errorInfo is $::errorInfo"
rp_debug $error_msg
ns_log error "rp_invoke_filter: $error_msg"
rp_report_error
set result filter_return
} elseif {$result ni {"filter_ok" "filter_break" "filter_return"} } {
set error_msg "error in filter $proc for [ns_conn request]. Filter returned invalid result \"$result\""
ds_add rp [list filter [list $why [ns_conn method] [ns_conn url] $proc $arg] \
$startclicks [clock clicks -microseconds] "error" $error_msg]
# report the bad filter_return message
rp_debug -debug t -ns_log_level error $error_msg
rp_report_error -message $error_msg
ns_log error "rp_invoke_filter: $error_msg"
set result filter_return
} else {
ds_add rp [list filter [list $why [ns_conn method] [ns_conn url] $proc $arg] \
$startclicks [clock clicks -microseconds] $result]
}
rp_debug -debug $debug_p "Done invoking $why filter $proc (returning $result)"
return $result
}
ad_proc -private rp_invoke_proc { conn argv } {
Invokes a registered procedure.
} {
set startclicks [clock clicks -microseconds]
lassign $argv proc_index debug_p arg_count proc arg
rp_debug -debug $debug_p "Invoking registered procedure $proc"
switch -- $arg_count {
0 { set cmd $proc }
1 { set cmd [list $proc $arg] }
default { set cmd [list $proc $conn $arg] }
}
ad_try -auto_abort=false {
{*}$cmd
} trap {AD EXCEPTION ad_script_abort} {r} {
# do nothing on ad_script_aborts
ns_log notice "rp_invoke_proc: aborted cmd: $cmd"
ds_add rp [list registered_proc $cmd $startclicks [clock clicks -microseconds]]
} on error {errMsg} {
ds_add rp [list registered_proc $cmd $startclicks [clock clicks -microseconds] error $::errorInfo]
rp_debug "error in $proc for [ns_conn method] [ns_conn url]?[ns_conn query] errorInfo is $::errorInfo"
ns_log Error "rp_invoke_proc: '$cmd' returned error: $errMsg\n$::errorInfo"
rp_report_error
} on ok {r} {
ds_add rp [list registered_proc $cmd $startclicks [clock clicks -microseconds]]
} finally {
rp_debug -debug $debug_p "Done Invoking registered procedure $proc"
}
rp_finish_serving_page
}
ad_proc -private rp_finish_serving_page {} {
if { [info exists ::doc_properties(body)] } {
rp_debug "Returning page:[info level [expr {[info level] - 1}]]: [ns_quotehtml [string range $::doc_properties(body) 0 100]]"
doc_return 200 text/html $::doc_properties(body)
}
}
ad_proc -public ad_register_filter {
{ -debug f }
{ -priority 10000 }
{ -critical f }
{ -description "" }
kind method path proc { arg "" }
} {
Registers a filter that gets called during page serving. The filter
should return one of
filter_ok
, meaning the page serving will continue;
filter_break
meaning the rest of the filters of
this type will not be called;
filter_return
meaning the server will close the
connection and end the request processing.
File | Size | Date |
---|---|---|
.. | ||
$link | $size | $time |
$::errorInfo
if none is specified).
} {
if { ![info exists message] } {
# We need 'message' to be a copy, because errorInfo will get overridden by some of the template parsing below
set message $::errorInfo
}
set error_url "[ad_url][ad_conn url]?[export_entire_form_as_url_vars]"
# set error_file [template::util::url_to_file $error_url]
set error_file [ad_conn file]
#set package_key [ad_conn package_key]
set prev_url [get_referrer]
set feedback_id [db_nextval acs_object_id_seq]
set user_id [ad_conn user_id]
set bug_package_id [ad_conn package_id]
set error_info $message
set vars_to_export [export_vars -form { error_url error_info user_id prev_url error_file feedback_id bug_package_id }]
ds_add conn error $message
set params [list]
#Serve the stacktrace
set params [list [list stacktrace $message] \
[list user_id $user_id] \
[list error_file $error_file] \
[list prev_url $prev_url] \
[list feedback_id $feedback_id] \
[list error_url $error_url] \
[list bug_package_id $bug_package_id] \
[list vars_to_export $vars_to_export]]
set error_message $message
if {[parameter::get -package_id $::acs::kernel_id -parameter RestrictErrorsToAdminsP -default 0]
&& ![permission::permission_p -object_id [ad_conn package_id] -privilege admin]
} {
set message {}
#set params [lreplace $params 0 0 [list stacktrace $message]]
lset params 0 [list stacktrace $message]
}
ad_try {
set rendered_page [ad_parse_template -params $params "/packages/acs-tcl/lib/page-error"]
} on error {errorMsg} {
# An error occurred during rendering of the error page
ns_log Error "rp_filter: error $errorMsg rendering error page (!)\n$::errorInfo"
set rendered_page "" } ns_return 500 text/html $rendered_page ad_log error $error_message } ad_proc -private rp_path_prefixes {path} { Returns all the prefixes of a path ordered from most to least specific. } { if {[string index $path 0] ne "/"} { set path "/$path" } set path [string trimright $path /] if { $path eq "" } { return "/" } set components [split $path "/"] set prefixes [list] for {set i [expr {[llength $components] -1}]} {$i > 0} {incr i -1} { lappend prefixes "[join [lrange $components 0 $i] /]/" lappend prefixes [join [lrange $components 0 $i] /] } lappend prefixes "/" return $prefixes } ad_proc -private rp_handle_request {} { } { set startclicks [clock clicks -microseconds] if { [rp_performance_mode] } { set current_url [ad_conn url] if {[info exists ::tcl_url2file($current_url)] && [info exists ::tcl_url2path_info($current_url)] } { ad_conn -set file $::tcl_url2file($current_url) ad_conn -set path_info $::tcl_url2path_info($current_url) rp_serve_concrete_file $::tcl_url2file($current_url) return } rp_debug "performance mode: no ::tcl_url2file mapping for $current_url available; perform usual lookup" } set resolve_values $::acs::pageroot[string trimright [ad_conn package_url] /] if {[ad_conn package_key] ne ""} { # # Only in cases where the URL refers to a mounted package, # include it for path checking. # lappend resolve_values {*}[apm_package_url_resolution [ad_conn package_key]] } foreach resolve_value $resolve_values { lassign $resolve_value root match_prefix set extra_url [ad_conn extra_url] if { $match_prefix ne "" } { if { [string first $match_prefix $extra_url] == 0 } { # An empty root indicates we should reject the # attempted reference. This is used to block # references to embedded package # [sitewide-]admin pages that avoid the # request processor permission check. if { $root eq "" } { break } set extra_url [string trimleft \ [string range $extra_url [string length $match_prefix] end] /] } else { continue } } ds_add rp [list notice "Trying rp_serve_abstract_file $root/$extra_url" $startclicks [clock clicks -microseconds]] ad_try { rp_serve_abstract_file "$root/$extra_url" set ::tcl_url2file([ad_conn url]) [ad_conn file] set ::tcl_url2path_info([ad_conn url]) [ad_conn path_info] } trap {AD EXCEPTION notfound} {val} { #ns_log notice "rp_handle_request: AD_TRY NOTFOUND <$val> URL <$root/$extra_url>" ds_add rp [list notice "File $root/$extra_url: Not found" $startclicks [clock clicks -microseconds]] ds_add rp [list transformation [list notfound "$root / $extra_url" $val] $startclicks [clock clicks -microseconds]] continue } trap {AD EXCEPTION redirect} {url} { #ns_log notice "rp_handle_request: AD_TRY redirect $url" ds_add rp [list notice "File $root/$extra_url: Redirect" $startclicks [clock clicks -microseconds]] ds_add rp [list transformation [list redirect $root/$extra_url $url] $startclicks [clock clicks -microseconds]] ad_returnredirect $url } trap {AD EXCEPTION directory} {dir_index} { #ns_log notice "rp_handle_request: AD_TRY directory $dir_index" ds_add rp [list notice "File $root/$extra_url: Directory index" $startclicks [clock clicks -microseconds]] ds_add rp [list transformation [list directory $root/$extra_url $dir_index] $startclicks [clock clicks -microseconds]] continue } return } if {[info exists dir_index] && ![string match "*/CVS/*" $dir_index] } { if { [nsv_get rp_directory_listing_p .] } { ns_returnnotice 200 "Directory listing of $dir_index" \ [rp_html_directory_listing $dir_index] return } } # OK, we didn't find a normal file. Let's look for a path info style thingy, # visiting possible file matches from most specific to least. foreach prefix [rp_path_prefixes $extra_url] { foreach resolve_value $resolve_values { lassign $resolve_value root match_prefix set extra_url [ad_conn extra_url] if { $match_prefix ne "" } { if { [string first $match_prefix $extra_url] == 0 } { set extra_url [string trimleft \ [string range $extra_url [string length $match_prefix] end] /] } else { continue } } ad_try { ad_conn -set path_info \ [string range $extra_url [string length $prefix]-1 end] rp_serve_abstract_file \ -noredirect \ -nodirectory \ -extension_pattern ".vuh" \ $root$prefix set ::tcl_url2file([ad_conn url]) [ad_conn file] set ::tcl_url2path_info([ad_conn url]) [ad_conn path_info] } trap {AD EXCEPTION notfound} {val} { ds_add rp [list transformation [list notfound $root$prefix $val] \ $startclicks [clock clicks -microseconds]] continue } trap {AD EXCEPTION redirect} {url} { ds_add rp [list transformation [list redirect $root$prefix $url] \ $startclicks [clock clicks -microseconds]] ad_returnredirect $url } trap {AD EXCEPTION directory} {dir_index} { ds_add rp [list transformation [list directory $root$prefix $dir_index] \ $startclicks [clock clicks -microseconds]] continue } return } } ds_add rp [list transformation [list notfound $root/$extra_url notfound] $startclicks [clock clicks -microseconds]] ns_returnnotfound } ad_proc -private rp_handler {} { The request handler, which responds to absolutely every HTTP request made to the server. } { if { ![info exists ::ad_conn] } { # DRB: handle obscure case where we are served a request like GET # http://www.google.com. In this case AOLserver 4.0.10 (at # least) doesn't run the preauth filter "rp_filter", but # rather tries to serve /global/file-not-found directly. # rp_handler dies a horrible death if it's called without # ::ad_conn being set up. My fix is to simply redirect to the # url AOLserver substitutes if ::ad_conn does not exist # (rp_filter begins with ad_conn -reset) ... ns_log warning "rp_handler: Obscure case, where ::ad_conn is not set, redirect to [ns_conn url]" ad_returnredirect [ns_conn url] return } if {[info exists ::ad_conn(extra_url)] && $::ad_conn(extra_url) ne "" && ![string match "*$::ad_conn(extra_url)" [ns_conn url]] } { # # On internal redirects, the current ::ad_conn(extra_url) might be # from a previous request, which might have lead to a not-found # error pointing to a new url. This can lead to an hard-to find # loop which ends with a "recursion depth exceeded". There is a # similar problem with ::ad_conn(package_key) and # ::ad_conn(package_url) Therefore, we refetch the url info in case, # in case, and reset these values. These variables seem to be # sufficient to handle request processor loops, but maybe other # variables have to be reset either. # # However, also internal redirects to error pages happens the # same way, but we need to deliver the current url (coming # from ns_url) and not the original url before the redirect # (the extra_url). Similarly we have to reset the package_key # and package_url to point to the subsite package to deliver # the error pages. This is especially important on # host-node-mapped subsites, when e.g. the error pages are # mapped to /shared/404 etc. # set status [ns_conn status] if {$status < 200 || $status >= 300} { ad_conn -set extra_url [ns_conn url] ad_conn -set package_key "acs-subsite" ad_conn -set package_url / } else { array set node [site_node::get -url [ad_conn url]] ad_conn -set extra_url [string range [ad_conn url] [string length $node(url)] end] ad_conn -set package_key $node(package_key) ad_conn -set package_url $node(url) } } # JCD: keep track of rp_handler call count to prevent dev support from recording # information twice when for example we get a 404 internal redirect. We should probably set recursion_count [ad_conn recursion_count] ad_conn -set recursion_count [incr recursion_count] rp_debug "rp_handler: handling request: [ns_conn method] [ns_conn url]?[ns_conn query]" ad_try { rp_handle_request } on error {errorMsg} { set error_msg "errorMsg $errorMsg while serving [ns_conn request]" append error_msg "\n\tad_url <[ad_conn url]> maps to file <[ad_conn file]>" rp_debug "error in rp_handler: $error_msg" ns_log error "rp_handler no-script-abort: $error_msg\n$::errorCode\n$::errorInfo" rp_report_error } } ad_proc -private rp_serve_abstract_file { -noredirect:boolean -nodirectory:boolean {-extension_pattern ".*"} path } { Serves up a file given the abstract path. Raises the following exceptions in the obvious cases:[ns_quotehtml $error_message]
If -set is passed then it sets a property.
If the property has not been set directly by OpenACS it will be passed on to AOLservers/NaviServers ns_conn
: http://www.aolserver.com/docs/devel/tcl/api/conn.html#ns_conn. If it is not a valid option for ns_conn
either then it will throw an error.
Valid options for ad_conn are: ajax_p, behind_proxy_p, behind_secure_proxy_p, browser_id, deferred_dml, extra_url, instance_name, last_issue, mobile_p, node_id, object_id, object_type, object_url, package_id, package_key, package_url, path_info, peeraddr, recursion_count, request, sec_validated, session_id, start_clicks, subsite_id, subsite_node_id, subsite_url, system_p, token, untrusted_user_id, user_id, vhost_package_url, vhost_subsite_url, vhost_url.
Added recursion_count to properly deal with internalredirects.
} {
global ad_conn
set flag [lindex $args 0]
if {[string index $flag 0] ne "-"} {
set var $flag
set flag "-get"
} else {
set var [lindex $args 1]
}
switch -- $flag {
-connected_p {
return [info exists ad_conn(request)]
}
-set {
set ad_conn($var) [lindex $args 2]
}
-unset {
unset ad_conn($var)
}
-reset {
if {[info exists ad_conn]} {
unset ad_conn
}
array set ad_conn {
request ""
sec_validated ""
browser_id ""
session_id ""
user_id ""
untrusted_user_id 0
token ""
last_issue ""
deferred_dml ""
start_clicks ""
node_id ""
object_id ""
object_url ""
object_type ""
package_id ""
package_url ""
instance_name ""
package_key ""
extra_url ""
file ""
system_p 0
path_info ""
system_p 0
recursion_count 0
form_count -1
}
array unset ad_conn subsite_id
array unset ad_conn locale
}
-get {
# Special handling for the form, because "ns_conn form" can
# cause the server to hang until the socket times out. This
# happens on pages handling multipart form data, where
# ad_page_contract already has called ns_getform and has
# retrieved all data from the client. ns_getform has its
# own caching, so calling it instead of [ns_conn form]
# is OK.
switch -- $var {
form {
return [ns_getform]
}
all {
return [array get ad_conn]
}
default {
if { [info exists ad_conn($var)] } {
return $ad_conn($var)
}
# Fallback
switch -- $var {
locale {
set ad_conn(locale) [parameter::get \
-parameter SiteWideLocale \
-package_id [apm_package_id_from_key "acs-lang"] \
-default {en_US}]
return $ad_conn(locale)
}
node_id {
# This is just a fallback, when the request
# processor has failed to set the actual site
# node, e.g. on invalid requests. When the
# fallback is missing, ns_conn spits out an
# error message since it does not know what a
# "node_id" is. The fallback is especially
# necessary, when a template is used for the
# error message, the templating system cannot
# determine the appropriate template without
# the node_id. In case of failure, the
# toplevel node_is is returned.
array set node [site_node::get -url /]
set ad_conn($var) $node(node_id)
ns_log notice "ad_conn: request processor did not set
It should be called only when the method to return the data to the
client is going to be ns_return. In other cases, e.g. ns_returnfile,
one can assume that the returned content is not dynamic and can in
fact be cached. Besides that, AOLserver implements its own handling
of Last-Modified headers with ns_returnfile. Also it should be
called as late as possible - shortly before ns_return, so that
other code has the chance to set no_cache_control_p to 1 before
it runs.
This proc can be disabled per request by calling
"ad_conn -set no_http_cache_control_p 1" before this proc is reached.
It will not modify any headers if this variable is set to 1.
If the acs-kernel parameter CacheControlP is set to 0 then
it's fully disabled.
@author Tilmann Singer (tils-oacs@tils.net)
} {
if { ![parameter::get -package_id $::acs::kernel_id -parameter HttpCacheControlP -default 0]} {
return
}
if { [info exists ::ad_conn(no_http_cache_control_p)] && $::ad_conn(no_http_cache_control_p) } {
return
}
set headers [ad_conn outputheaders]
# Check if any relevant header is already present - in this case
# don't touch anything.
set modify_p 1
if { [ns_set ifind $headers "cache-control"] > -1
|| [ns_set ifind $headers "expires"] > -1 } {
set modify_p 0
} else {
for { set i 0 } { $i < [ns_set size $headers] } { incr i } {
if { [string tolower [ns_set key $headers $i]] eq "pragma"
&& [string tolower [ns_set value $headers $i]] eq "no-cache"
} {
set modify_p 0
break
}
}
}
# Set three headers, to be sure it won't get cached. If you are in
# doubt, check the spec:
# http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html
if { $modify_p } {
# actually add the headers
ns_setexpires 0
ns_set put $headers "Pragma" "no-cache"
ns_set put $headers "Cache-Control" "no-cache"
}
# Prevent subsequent calls of this proc from adding the same
# headers again.
ad_conn -set no_http_cache_control_p 1
}
# -------------------------------------------------------------------------
# procs for hostname-based subsites
# -------------------------------------------------------------------------
ad_proc ad_host {} {
Returns the hostname as it was typed in the browser,
provided forcehostp is set to 0.
} {
set host_and_port [ns_set iget [ns_conn headers] Host]
if { [regexp {^([^:]+)} $host_and_port match host] } {
return $host
} else {
return ""
}
}
ad_proc ad_port {} {
Returns the port as it was typed in the browser,
provided forcehostp is set to 0.
} {
set host_and_port [ns_set iget [ns_conn headers] Host]
if { [regexp {^([^:]+):([0-9]+)} $host_and_port match host port] } {
return ":$port"
} else {
return ""
}
}
namespace eval ::acs {}
ad_proc root_of_host {host} {
Maps a hostname to the corresponding sub-directory.
} {
set key ::acs::root_of_host($host)
if {[info exists $key]} {return [set $key]}
set $key [root_of_host_noncached $host]
}
ad_proc -private root_of_host_noncached {host} {
Helper function for root_of_host, which performs the actual work.
} {
#
# The main hostname is mounted at /.
#
foreach driver {nssock nsssl} {
set driver_section [ns_driversection -driver $driver]
set configured_hostname [ns_config $driver_section hostname]
if { $host eq $configured_hostname } {
return ""
}
}
#
# Other hostnames map to subsites.
#
set node_id [util_memoize [list rp_lookup_node_from_host $host]]
if {$node_id eq ""} {
set host [regsub "www\." $host ""]
set node_id [util_memoize [list rp_lookup_node_from_host $host]]
}
if { $node_id ne "" } {
set url [site_node::get_url -node_id $node_id]
return [string range $url 0 end-1]
} else {
# Hack to provide a useful default
return ""
}
}
ad_proc -private rp_lookup_node_from_host { host } {
if {$host ne ""} {
if {![regexp {^[\w.@+/=$%!*~\[\]-]+$} $host]} {
binary scan [encoding convertto utf-8 $host] H* hex
ad_log error "rp_lookup_node_from_host: host <$host> (hex $hex) contains invalid characters"
ad_return_complaint 1 "invalid request"
ad_script_abort
}
return [db_string node_id {} -default ""]
}
}
ad_proc -public request_denied_filter { why } {
Deny serving the request
} {
ad_return_forbidden \
"Forbidden URL" \
"No, we're not going to show you this file
"
return filter_return
}
if {[ns_info name] eq "NaviServer"} {
# this is written for NaviServer 4.99.1 or newer
foreach filter {rp_filter rp_resources_filter request_denied_filter} {
set cmd ${filter}_aolserver
if {[info commands $cmd] ne ""} {rename $cmd ""}
rename $filter $cmd
proc $filter {why} "$cmd \$why"
}
set cmd rp_invoke_filter_conn
if {[info commands $cmd] ne ""} {rename $cmd ""}
rename rp_invoke_filter $cmd
proc rp_invoke_filter { why filter_info} "$cmd _ \$filter_info \$why"
set cmd rp_invoke_proc_conn
if {[info commands $cmd] ne ""} {rename $cmd ""}
rename rp_invoke_proc $cmd
proc rp_invoke_proc { argv } "$cmd _ \$argv"
}
#
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End: