Index: openacs-4/packages/acs-tcl/acs-tcl.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/acs-tcl.info,v
diff -u -r1.90 -r1.91
--- openacs-4/packages/acs-tcl/acs-tcl.info 3 Aug 2018 09:46:35 -0000 1.90
+++ openacs-4/packages/acs-tcl/acs-tcl.info 13 Sep 2018 06:20:36 -0000 1.91
@@ -9,7 +9,7 @@
<implements-subsite-p>f</implements-subsite-p>
<inherit-templates-p>t</inherit-templates-p>
- <version name="5.10.0d18" url="http://openacs.org/repository/download/apm/acs-tcl-5.10.0d18.apm">
+ <version name="5.10.0d19" url="http://openacs.org/repository/download/apm/acs-tcl-5.10.0d19.apm">
<owner url="http://openacs.org">OpenACS</owner>
<summary>The Kernel Tcl API library.</summary>
<release-date>2017-08-06</release-date>
@@ -18,7 +18,7 @@
<license>GPL version 2</license>
<maturity>3</maturity>
- <provides url="acs-tcl" version="5.10.0d18"/>
+ <provides url="acs-tcl" version="5.10.0d19"/>
<requires url="acs-bootstrap-installer" version="5.10.0d4"/>
<requires url="acs-kernel" version="5.10.0d0"/>
Index: openacs-4/packages/acs-tcl/tcl/security-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/security-procs.tcl,v
diff -u -r1.105 -r1.106
--- openacs-4/packages/acs-tcl/tcl/security-procs.tcl 24 Jul 2018 19:42:16 -0000 1.105
+++ openacs-4/packages/acs-tcl/tcl/security-procs.tcl 13 Sep 2018 06:20:36 -0000 1.106
@@ -1660,9 +1660,9 @@
#####
ad_proc -private security::get_https_port {} {
- Return the HTTPS port specified in the AOLserver config file.
+ Return the HTTPS port specified in the server's config file.
- @return The HTTPS port or the empty string if none is configured.
+ @return The HTTPS port number or the empty string if none is configured.
@author Gustaf Neumann
} {
@@ -1675,6 +1675,18 @@
}
}
+ad_proc -private security::get_http_port {} {
+ Return the HTTP port specified in the server's config file.
+
+ @return The HTTP port number or the empty string if none is configured.
+
+ @author Gustaf Neumann
+} {
+ set d [util_driver_info -driver nssock]
+ return [dict get $d port]
+}
+
+
ad_proc -private security::get_qualified_url { url } {
@return secure or insecure qualified url
} {
@@ -1751,10 +1763,17 @@
#
set secure_location $current_location
} elseif {[util::split_location $current_location proto hostname port]} {
+ #
+ # Do not return a location with a port number, when
+ # SuppressHttpPort is set.
+ #
+ set suppress_http_port [parameter::get -parameter SuppressHttpPort \
+ -package_id [apm_package_id_from_key acs-tcl] \
+ -default 0]
set secure_location [util::join_location \
-proto https \
-hostname $hostname \
- -port [security::get_https_port]]
+ -port [expr {$suppress_http_port ? "" : [security::get_https_port]}]]
} else {
error "invalid location $current_location"
}
@@ -1771,16 +1790,24 @@
set http_prefix {http://}
if { [string match "$http_prefix*" $current_location] } {
+ #
# Current location is already insecure - do nothing
+ #
set insecure_location $current_location
+ } elseif {[util::split_location $current_location proto hostname port]} {
+ #
+ # Do not return a location with a port number, when
+ # SuppressHttpPort is set.
+ #
+ set suppress_http_port [parameter::get -parameter SuppressHttpPort \
+ -package_id [apm_package_id_from_key acs-tcl] \
+ -default 0]
+ set insecure_location [util::join_location \
+ -proto http \
+ -hostname $hostname \
+ -port [expr {$suppress_http_port ? "" : [security::get_http_port]}]]
} else {
- # Current location is secure - use location from config file
- set insecure_location [ad_conn location]
- regsub -all {https://} $insecure_location "" insecure_location
- if { ![string match "$http_prefix*" $insecure_location] } {
- # Prepend http://
- set insecure_location ${http_prefix}${insecure_location}
- }
+ error "invalid location $current_location"
}
return $insecure_location
Index: openacs-4/packages/acs-tcl/tcl/test/location-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/location-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/test/location-procs.tcl 13 Sep 2018 06:20:36 -0000 1.1
@@ -0,0 +1,52 @@
+aa_register_case \
+ -cats {api smoke} \
+ -procs {
+ security::get_secure_location
+ security::get_insecure_location
+ util_current_location
+ } \
+ get_insecure_location {
+
+ Test if security::get_insecure_location is working as expected.
+
+ @author Gustaf Neumann
+} {
+
+ aa_run_with_teardown -rollback -test_code {
+ aa_section "security::get_insecure_location"
+
+ set current_location [util_current_location]
+ aa_log "current location '$current_location'"
+
+ set cld [ns_parseurl $current_location]
+ aa_log "current location parts '$cld'"
+ if {[dict exists $cld port] && [dict get $cld port] ne ""} {
+ if {[dict get $cld proto] eq "http"} {
+ aa_log "run tests with port based on HTTP"
+ set insecure [security::get_insecure_location]
+ aa_true "insecure location has same proto as current location" {$insecure eq $current_location}
+
+ set secure [security::get_secure_location]
+ set sld [ns_parseurl $secure]
+ aa_true "secure location starts is HTTPS" {[dict get $sld proto] eq "https"}
+ } else {
+ aa_log "run tests with port based on HTTPS"
+ set secure [security::get_secure_location]
+ aa_true "secure location has same proto as current location" {$insecure eq $current_location}
+
+ set insecure [security::get_insecure_location]
+ set ild [ns_parseurl $insecure]
+ aa_true "insecure location starts is HTTP" {[dict get $ild proto] eq "https"}
+ }
+ } else {
+ aa_log "skip tests with port"
+ }
+
+ }
+}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End: