Index: openacs-4/packages/acs-kernel/acs-kernel.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-kernel/acs-kernel.info,v diff -u -N -r1.150.2.39 -r1.150.2.40 --- openacs-4/packages/acs-kernel/acs-kernel.info 3 Oct 2021 18:20:37 -0000 1.150.2.39 +++ openacs-4/packages/acs-kernel/acs-kernel.info 11 Oct 2021 20:11:37 -0000 1.150.2.40 @@ -30,7 +30,7 @@ - + Index: openacs-4/packages/acs-tcl/tcl/20-memoize-init.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/20-memoize-init.tcl,v diff -u -N -r1.7.2.1 -r1.7.2.2 --- openacs-4/packages/acs-tcl/tcl/20-memoize-init.tcl 28 Oct 2020 15:39:19 -0000 1.7.2.1 +++ openacs-4/packages/acs-tcl/tcl/20-memoize-init.tcl 11 Oct 2021 20:11:37 -0000 1.7.2.2 @@ -1,42 +1,8 @@ # Create the cache used by util_memoize. -# Note: we must pass the package_id to parameter::get, because -# otherwise parameter::get will end up calling util_memoize to figure -# out the package_id. - ns_cache create util_memoize -size \ - [parameter::get -package_id [ad_acs_kernel_id] -parameter MaxSize -default 200000] + [parameter::get -package_id $::acs::kernel_id -parameter MaxSize -default 200000] - -# We construct the body of util_memoize_flush differently depending -# on whether clustering is enabled and what command is available for -# cluster-wide flushing. - -if {[namespace which ncf.send] ne ""} { - set flush_body { - ncf.send util_memoize $script - } -} elseif {[server_cluster_enabled_p] && [namespace which server_cluster_httpget_from_peers] ne ""} { - set flush_body { - server_cluster_httpget_from_peers "/SYSTEM/flush-memoized-statement.tcl?statement=[ns_urlencode $script]" - } -} else { - set flush_body {} -} - -append flush_body { - ns_cache flush util_memoize $script -} - -ad_proc -public util_memoize_flush {script} { - Forget any cached value for script. If clustering is - enabled, flush the caches on all servers in the cluster. - - @param script The Tcl script whose cached value should be flushed. -} $flush_body - -unset flush_body - # Local variables: # mode: tcl # tcl-indent-level: 4 Index: openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl,v diff -u -N -r1.10.2.17 -r1.10.2.18 --- openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl 7 Oct 2021 15:42:45 -0000 1.10.2.17 +++ openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl 11 Oct 2021 20:11:37 -0000 1.10.2.18 @@ -537,14 +537,19 @@ } proc cache_flush_all {cache pattern} { + # # Provide means to perform a wildcard-based cache flushing on # (cluster) machines. - foreach n [ns_cache names $cache $pattern] {ns_cache flush $cache $n} + # + foreach n [ns_cache names $cache $pattern] { + ns_cache flush $cache $n + } } nx::Class create Cluster { :property host :property {port 80} + :property {url /acs-cluster-do} set :allowed_host_patterns [list] set :url /acs-cluster-do @@ -569,29 +574,55 @@ acs::cache_flush_all "" } + :object method log {args} { + ns_log notice "cluster: [join $args { }]" + } + :method log {args} { + ns_log notice "cluster host ${:host} ${:port}: [join $args { }]" + } + # - # handling the ns_filter methods + # Handling the ns_filter methods # :public object method trace args { - :log "" + #:log "trace" return filter_return } :public object method preauth args { - :log "" + #:log "preauth" :incoming_request return filter_return } :public object method postauth args { - :log "" + #:log "postauth" return filter_return } + :public object method allowed_command {cmd} { + # + # Check, which command are allowed to be executed in the + # cluster. + # + + #ns_log notice "--cluster allowed [dict keys ${:allowed_command}]?" + set cmd_name [lindex $cmd 0] + #ns_log notice "--cluster can i execute $cmd_name? [dict exists ${:allowed_command} $cmd_name]" + if {[dict exists ${:allowed_command} $cmd_name]} { + set except_RE [dict get ${:allowed_command} $cmd_name] + #ns_log notice "--cluster [list regexp $except_RE $cmd] -> [regexp $except_RE $cmd]" + set allowed [expr {$except_RE eq "" || ![regexp $except_RE $cmd]}] + } else { + set allowed 0 + } + return $allowed + } + # # handle incoming request issues # - :public object method incoming_request {} { + :public object method incoming_request {} { set cmd [ns_queryget cmd] set addr [lindex [ns_set iget [ns_conn headers] x-forwarded-for] end] if {$addr eq ""} {set addr [ns_conn peeraddr]} @@ -623,16 +654,9 @@ error "refuse to execute commands from $host (command: '$cmd')" } } - set cmd_name [lindex $cmd 0] - set key allowed_command($cmd_name) - #ns_log notice "--cluster $key exists ? [info exists :$key]" - if {[info exists :$key]} { - set except_RE [set :$key] - #ns_log notice "--cluster [list regexp $except_RE $cmd] -> [regexp $except_RE $cmd]" - if {$except_RE eq "" || ![regexp $except_RE $cmd]} { - ns_log notice "--cluster executes command '$cmd' from host $host" - return [eval $cmd] - } + if {[::acs::Cluster allowed_command $cmd]} { + ns_log notice "--cluster executes command '$cmd' from host $host" + return [eval $cmd] } error "command '$cmd' from host $host not allowed" } @@ -646,10 +670,17 @@ } } - :public object method message args { - :log "--cluster outgoing request to [:host]:[:port] // $args" + :public method message args { + :log "--cluster outgoing request to ${:host}:${:port} // $args" - utl::http::get -url http://[:host]:[:port]/[:url]?cmd=[ns_urlencode $args] + try { + ns_http run http://${:host}:${:port}/${:url}?cmd=[ns_urlencode $args] + } on error {errorMsg} { + ns_log warning "-cluster: send message to http://${:host}:${:port}/${:url}?cmd=[ns_urlencode $args] failed: $errorMsg" + } on ok {result} { + ns_log notice "-cluster: response $result" + } + #util::http::get -url } } } Index: openacs-4/packages/acs-tcl/tcl/cluster-init.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/cluster-init.tcl,v diff -u -N -r1.1.2.1 -r1.1.2.2 --- openacs-4/packages/acs-tcl/tcl/cluster-init.tcl 6 Aug 2020 20:12:55 -0000 1.1.2.1 +++ openacs-4/packages/acs-tcl/tcl/cluster-init.tcl 11 Oct 2021 20:11:37 -0000 1.1.2.2 @@ -2,20 +2,32 @@ # Check if cluster is enabled, and if, set up the custer objects # if {[server_cluster_enabled_p]} { - set my_ip [ns_config ns/server/[ns_info server]/module/nssock Address] - set my_port [ns_config ns/server/[ns_info server]/module/nssock port] + set driver_section [ns_driversection -driver nssock] + set my_ips [ns_config $driver_section address] + set my_ports [ns_config -int $driver_section port] - foreach host [server_cluster_all_hosts] { - set port 80 - regexp {^(.*):(.*)} $host _ host port - if {"$host-$port" eq "$my_ip-$my_port"} continue - ::acs::Cluster create CS_${host}_$port -host $host -port $port + set cluster_do_url [::acs::Cluster eval {set :url}] + + foreach hostport [server_cluster_all_hosts] { + set d {port 80} + set d [dict merge $d [ns_parsehostport $hostport]] + dict with d { + if {$host in $my_ips && $port in $my_ports} { + ns_log notice "Cluster: server $host $port is no cluster peer" + continue + } + ns_log notice "Cluster: server $host $port is a cluster peer" + ::acs::Cluster create CS_${host}_${port} \ + -host $host \ + -port $port \ + -url $cluster_do_url + } } foreach ip [parameter::get -package_id [ad_acs_kernel_id] -parameter ClusterAuthorizedIP] { if {[string first * $ip] > -1} { ::acs::Cluster eval [subst { - :lappend allowed_host_patterns $ip + lappend allowed_host_patterns $ip }] } else { ::acs::Cluster eval [subst { @@ -26,16 +38,23 @@ set url [::acs::Cluster eval {set :url}] - # Check, if the filter url mirrors a site node. If so, - # the cluster mechanism will not work, if the site node - # requires a login. Clustering will only work if the - # root node is freely accessible. + # + # TODO: The following test does not work yet, since + # "::xo::db::sql::site_node" is not yet defined. This requires + # more refactoring from xo* to the main infrastructure. + # + if {0} { + # Check, if the filter url mirrors a site node. If so, + # the cluster mechanism will not work, if the site node + # requires a login. Clustering will only work if the + # root node is freely accessible. - array set node [site_node::get -url $url] - if {$node(url) ne "/"} { - ns_log notice "***\n*** WARNING: there appears a package mounted on\ - $url\n***Cluster configuration will not work\ - since there is a conflict with the AOLserver filter with the same name!\n" + array set node [site_node::get -url $url] + if {$node(url) ne "/"} { + ns_log notice "***\n*** WARNING: there appears a package mounted on" \ + "$url\n***Cluster configuration will not work" \ + "since there is a conflict with the filter with the same name! (n)" + } } #ns_register_filter trace GET $url ::acs::Cluster Index: openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl,v diff -u -N -r1.18.2.1 -r1.18.2.2 --- openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 9 Aug 2019 19:51:02 -0000 1.18.2.1 +++ openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 11 Oct 2021 20:11:37 -0000 1.18.2.2 @@ -61,6 +61,15 @@ ns_cache flush util_memoize $script } +ad_proc -public util_memoize_flush {script} { + Forget any cached value for script. If clustering is + enabled, flush the caches on all servers in the cluster. + + @param script The Tcl script whose cached value should be flushed. +} { + ::acs::clusterwide ns_cache flush util_memoize $script +} + ad_proc -public util_memoize_flush_regexp { -log:boolean expr Index: openacs-4/packages/acs-tcl/tcl/server-cluster-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/server-cluster-procs.tcl,v diff -u -N -r1.10.2.1 -r1.10.2.2 --- openacs-4/packages/acs-tcl/tcl/server-cluster-procs.tcl 20 Dec 2019 20:35:43 -0000 1.10.2.1 +++ openacs-4/packages/acs-tcl/tcl/server-cluster-procs.tcl 11 Oct 2021 20:11:38 -0000 1.10.2.2 @@ -7,7 +7,7 @@ } ad_proc server_cluster_enabled_p {} { Returns true if clustering is enabled. } { - return [parameter::get -package_id [ad_acs_kernel_id] -parameter ClusterEnabledP -default 0] + return [parameter::get -package_id $::acs::kernel_id -parameter ClusterEnabledP -default 0] } ad_proc server_cluster_all_hosts {} { @@ -16,31 +16,21 @@ } { if { ![server_cluster_enabled_p] } { - return [list] + return {} } - return [parameter::get -package_id [ad_acs_kernel_id] -parameter ClusterPeerIP] + return [parameter::get -package_id $::acs::kernel_id -parameter ClusterPeerIP] } ad_proc server_cluster_peer_hosts {} { Returns a list of all hosts, excluding this host, in the server cluster. -} { - set peer_hosts [list] - set my_ip [ns_config ns/server/[ns_info server]/module/nssock Address] - - foreach host [server_cluster_all_hosts] { - #AGUSTIN - if { ![regexp {(.*):(.*)} $host match myhost myport] } { - set myport 80 - set myhost $host - } - if { $myhost ne $my_ip } { - lappend peer_hosts $host - } - } - - return $peer_hosts +} { + return [lmap cluster_server [::acs::Cluster info instances] { + util::join_location \ + -hostname [$cluster_server cget -host] \ + -port [$cluster_server cget -port] + }] } ad_proc server_cluster_authorized_p { ip } { @@ -57,7 +47,7 @@ return 1 } - foreach glob [parameter::get -package_id [ad_acs_kernel_id] -parameter ClusterAuthorizedIP] { + foreach glob [parameter::get -package_id $::acs::kernel_id -parameter ClusterAuthorizedIP] { if { [string match $glob $ip] } { return 1 } @@ -80,7 +70,7 @@ ad_proc -private server_cluster_logging_p {} { Returns true if we're logging cluster requests. } { - return [parameter::get -package_id [ad_acs_kernel_id] -parameter EnableLoggingP -default 0] + return [parameter::get -package_id $::acs::kernel_id -parameter EnableLoggingP -default 0] } ad_proc -private server_cluster_httpget_from_peers { @@ -109,7 +99,7 @@ AOLserver (for instance, if we have the aolservers sitting behind a load balancer). } { - set canonical_server [parameter::get -package_id [ad_acs_kernel_id] -parameter CanonicalServer] + set canonical_server [parameter::get -package_id $::acs::kernel_id -parameter CanonicalServer] if { $canonical_server eq "" } { ns_log Error "Your configuration is not correct for server clustering. Please ensure that you have the CanonicalServer parameter set correctly." return 1