Index: openacs-4/packages/xotcl-core/xotcl-core.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v diff -u -N -r1.106 -r1.106.2.1 --- openacs-4/packages/xotcl-core/xotcl-core.info 31 Jan 2019 14:32:23 -0000 1.106 +++ openacs-4/packages/xotcl-core/xotcl-core.info 23 Feb 2019 19:02:55 -0000 1.106.2.1 @@ -10,7 +10,7 @@ t xotcl - + Gustaf Neumann

XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)

2017-08-06 @@ -43,7 +43,7 @@ BSD-Style 2 - + Index: openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl,v diff -u -N -r1.68 -r1.68.2.1 --- openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 16 Nov 2018 18:39:51 -0000 1.68 +++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 23 Feb 2019 19:02:55 -0000 1.68.2.1 @@ -287,7 +287,7 @@ set ::subscription_count 0 set ::message_count 0 - ::xotcl::Class create Subscriber -parameter {key channel user_id mode} + ::xotcl::Class create Subscriber -parameter {key channel user_id mode {start_of_page ""}} Subscriber proc current {-key } { set result [list] if {[info exists key]} { @@ -338,16 +338,8 @@ Subscriber instproc send {msg} { #ns_log notice "SEND <$msg> [:mode]" :log "" - if {[:mode] eq "scripted"} { - ::sec_handler_reset - set emsg [encoding convertto utf-8 $msg] - #ns_log notice "SEND data <$msg> encoded <$emsg>" - set smsg "\n" - set smsg [format %x [string length $smsg]]\r\n$smsg\r\n - } else { - set smsg $msg - } + ::sec_handler_reset + set smsg [::xo::mr::bgdelivery encode_message [:mode] $msg] #my log "-- sending to subscriber for [:key] $smsg ch=[:channel] \ # mode=[:mode], user_id [:user_id]" try { @@ -362,7 +354,7 @@ "POSIX ECONNRESET {connection reset by peer}" } if {$::errorCode in $ok_errors} { - throw {CLIENTDISCONNECT} {client disconnected} + throw {AD_CLIENTDISCONNECT} {client disconnected} } else { throw $::errorCode $errorMsg } @@ -376,7 +368,7 @@ foreach s [set :subscriptions($key)] { try { $s $method $argument - } trap {CLIENTDISCONNECT} {errMsg} { + } trap {AD_CLIENTDISCONNECT} {errMsg} { ns_log warning "$method to subscriber $s (key=$key): $errMsg" $s destroy } on error {errMsg} { @@ -411,22 +403,8 @@ #my log "-- cl=[:info class], subscriptions([:key]) = $subscriptions([:key])" fconfigure [:channel] -translation binary - if {[:mode] eq "scripted"} { - set content_type "text/html;charset=utf-8" - set encoding "Cache-Control: no-cache\r\nTransfer-Encoding: chunked\r\n" - set body "[string repeat { } 1024]\r\n" - set body [format %x [string length $body]]\r\n$body\r\n - } else { - # Chrome refuses to expose partial response to ajax unless we - # set content_type to octet stream. Drawback is we have to - # force the translation on the channel. - set content_type "application/octet-stream" - set encoding "" - fconfigure [:channel] -encoding utf-8 - set body "" - } - - puts -nonewline [:channel] "HTTP/1.1 200 OK\r\nContent-type: $content_type\r\n$encoding\r\n$body" + fconfigure [:channel] -encoding utf-8 + puts -nonewline [:channel] ${:start_of_page} flush [:channel] } @@ -769,14 +747,14 @@ } ##################################### -bgdelivery proc subscribe {key {initmsg ""} {mode default} } { +bgdelivery proc -deprecated subscribe {key {initmsg ""} {mode default} } { set ch [ns_conn channel] thread::transfer [:get_tid] $ch #my do ::Subscriber sweep $key :do ::Subscriber new -channel $ch -key $key -user_id [ad_conn user_id] -mode $mode } -bgdelivery proc send_to_subscriber {key msg} { +bgdelivery proc -deprecated send_to_subscriber {key msg} { :do -async ::Subscriber broadcast $key $msg } ##################################### Index: openacs-4/packages/xotcl-core/tcl/message-relay-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/message-relay-procs.tcl,v diff -u -N --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/tcl/message-relay-procs.tcl 23 Feb 2019 19:02:55 -0000 1.1.2.1 @@ -0,0 +1,225 @@ +xo::library doc { + GenericMessageRelay procs + + Provide means to publish a subscription key and let clients write to + these keys. These functions are used e.g. by the chat. + + @creation-date 2019-02-23 + @author Gustaf Neumann +} + +namespace eval ::xo { + + nx::Class create ::xo::MessageRelay { + :public method subscribe {key {-initmsg ""} {-mode default}} { + # + # Subscribe to a service identified by a key. + # + # @param key unique id for a (potentially new communication hub) + # @param initmsg optional message to be sent, when subscription happens + # @param mode optional mode + # + } + + :public method send_to_subscriber {key msg} { + # + # Send a message to a service identified by the key + # (communication hub). + # + # @param key id for an existing communication hub + # @param msg message to be sent + # + } + + :public method sweep {key} { + # + # Check existing subscriptions and clean stale ones. + # + # @param key key of the communication hub + # + } + + :public method can_be_used {} { + # + # Check, if a message relay can be used in the current + # configuration. + # + + return 1 + } + + :method start_of_page {mode} { + # + # Compose reply header. + # + if {$mode eq "scripted"} { + set content_type "text/html;charset=utf-8" + set encoding "Cache-Control: no-cache\r\nTransfer-Encoding: chunked\r\n" + set body "[string repeat { } 1024]\r\n" + set body [format %x [string length $body]]\r\n$body\r\n + } else { + # + # Chrome refuses to expose partial response to ajax unless we + # set content_type to octet stream. Drawback is we have to + # force the translation on the channel. + # + set content_type "application/octet-stream" + set encoding "" + set body "" + } + return "HTTP/1.1 200 OK\r\nContent-type: $content_type\r\n$encoding\r\n$body" + } + + :public method encode_message {mode msg} { + # + # Provide different "encoding" depending on the mode. Notice + # that for one chat, multiple clients might have difference + # modes, since the modes are determined at also by the + # capabilities of the client browser. So the incoming message + # has to be recoded multiple times. + # + if {$mode eq "scripted"} { + #::sec_handler_reset + set emsg [encoding convertto utf-8 $msg] + #ns_log notice "SEND data <$msg> encoded <$emsg>" + set jsMsg "\n" + set msg [format %x [string length $jsMsg]]\r\n$jsMsg\r\n + } + #ns_log notice "#### [self] encode_message <$mode> returns <$msg>" + return $msg + } + + } +} + +namespace eval ::xo::mr { + # + # Create a dummy message relay (which can be always used) + # + xo::MessageRelay create ::xo::mr::none + + # + # Message Relay based on bgdelivery. This interface works directly + # on the socket and is therefore only useful for plain HTTP + # connections. + # + xo::MessageRelay create ::xo::mr::bgdelivery { + + :public object method subscribe {key {-initmsg ""} {-mode default} } { + ns_log notice "#### [self] subscribe <$key> mode <$mode>" + set ch [ns_conn channel] + thread::transfer [::bgdelivery get_tid] $ch + # ::bgdelivery do ::Subscriber sweep $key + ::bgdelivery do ::Subscriber new \ + -channel $ch -key $key \ + -user_id [ad_conn user_id] -mode $mode \ + -start_of_page [:start_of_page $mode] + } + + :public object method send_to_subscriber {key msg} { + ns_log notice "#### [self] send_to_subscriber $key $msg" + ::bgdelivery do -async ::Subscriber broadcast $key $msg + } + + :public object method can_be_used {} { + # + # We require support from the web server, an installed + # bgdelivery. This method does not work on HTTPS, since this + # method writes to the raw sockets. + # + return [expr { + [info commands ::thread::mutex] ne "" + && [info commands ::bgdelivery] ne "" + && ![security::secure_conn_p] + }] + } + + :public object method sweep {key} { + ::bgdelivery do ::Subscriber sweep chat-[:chat_id]} + } + + # + # Message Relay based on ns_connchan. This interface works on the + # full connection structure and can therefore be used for HTTP and + # HTTPS connections. + # + xo::MessageRelay create ::xo::mr::connchan { + + :object method cleanup {key handle} { + + catch {ns_connchan close $handle} + catch {nsv_unset mr_connchan_$key $handle} + } + + :public object method subscribe {key {-initmsg ""} {-mode ""} } { + #ns_log notice "#### [self] subscribe $key mode $mode" + # + # Unplug the connection channel from the current connection + # thread. The currently unplugged channels can be queried via + # "ns_connchan list" + # + set handle [ns_connchan detach] + + # + # should check and append + # + if {![nsv_exists mr_connchan_$key $handle]} { + nsv_set mr_connchan_$key $handle $mode + try { + ns_connchan write $handle [:start_of_page $mode] + } on error {errorMsg} { + ns_log warning "message relay: write on <$key> failed: $errorMsg" + :cleanup $key $handle + } + } else { + ns_log warning "message relay: duplicate registration for <$key> attempted" + } + + #::bgdelivery do ::Subscriber new \ + # -channel $ch -key $key \ + # -user_id [ad_conn user_id] -mode $mode + } + + :public object method send_to_subscriber {key msg} { + # + # Write directly to the subscribers from the connection + # thread. It would be possible, to perform asynchronous + # operations via "ns_connchan callback", which would be handled + # in the background. Not sure, this is necessary. + # + + #ns_log notice "#### [self] send_to_subscriber <[nsv_array names mr_connchan_$key]>" + + foreach handle [nsv_array names mr_connchan_$key] { + try { + ns_connchan write $handle [:encode_message [nsv_array names mr_connchan_$key $handle] $msg] + } on error {errorMsg} { + ns_log warning "message relay: duplicate registration for <$key> attempted" + :cleanup $key $handle + } + } + } + + :public object method can_be_used {} { + return [expr {[info commands ::ns_connchan] ne ""}] + } + + :public object method sweep {key} { + # + # For the time being, do nothing. Since the chat is verbose on + # logins/logouts, write operations will fail, in which case the + # array is cleaned up. If this is not sufficient, probably a + # "ns_connchan eof" operation would be useful. + # + } + } +} + +::xo::library source_dependent +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xowiki/xowiki.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/xowiki.info,v diff -u -N -r1.180 -r1.180.2.1 --- openacs-4/packages/xowiki/xowiki.info 9 Feb 2019 00:18:28 -0000 1.180 +++ openacs-4/packages/xowiki/xowiki.info 23 Feb 2019 19:02:55 -0000 1.180.2.1 @@ -10,7 +10,7 @@ t xowiki - + Gustaf Neumann

A xotcl-based enterprise wiki system with multiple object types

2017-08-06 @@ -55,8 +55,8 @@ BSD-Style 2 - - + + Index: openacs-4/packages/xowiki/tcl/chat-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/chat-procs.tcl,v diff -u -N -r1.54 -r1.54.2.1 --- openacs-4/packages/xowiki/tcl/chat-procs.tcl 18 Jan 2019 16:39:36 -0000 1.54 +++ openacs-4/packages/xowiki/tcl/chat-procs.tcl 23 Feb 2019 19:02:55 -0000 1.54.2.1 @@ -16,14 +16,28 @@ {mode default} {encoder noencode} {timewindow 600} - {sweepinterval 5} + {sweepinterval 60} {login_messages_p t} {logout_messages_p t} {conf {}} + {message_relay {bgdelivery connchan none}} } Chat instproc init {} { # :log "-- " + + # + # Work through the list of provided message_relays an select a + # usable one. + # + set :mr ::xo::mr::none + foreach mr ${:message_relay} { + if {[::xo::mr::$mr can_be_used]} { + set :mr ::xo::mr::$mr + break + } + } + set :now [clock clicks -milliseconds] if {![info exists :user_id]} { set :user_id [ad_conn user_id] @@ -79,17 +93,19 @@ set user_id [expr {$uid ne "" ? $uid : ${:user_id}}] set color [:user_color $user_id] set msg [ns_quotehtml $msg] + # :log "-- msg=$msg" + :broadcast_msg [Message new -volatile -time [clock seconds] \ + -user_id $user_id -color $color [list -msg $msg]] - if {[info commands ::thread::mutex] ne "" && - [info commands ::bgdelivery] ne ""} { - # we could use the streaming interface - :broadcast_msg [Message new -volatile -time [clock seconds] \ - -user_id $user_id -color $color [list -msg $msg]] - } :register_nsvs ${:now}.$user_id $user_id $msg $color [clock seconds] - # this in any case a valid result, but only needed for the polling interface - if {$get_new} {:get_new} + # + # This in any case a valid result, but only needed for the polling + # interface + # + if {$get_new} { + :get_new + } } Chat instproc current_message_valid {} { @@ -134,9 +150,9 @@ } } ::xo::clusterwide nsv_set ${:array}-seen ${:session_id} ${:now} - # :log "--c setting session_id ${:session_id}: ${:now}" + # :log "--chat setting session_id ${:session_id}: ${:now}" } else { - # :log "--c nothing new for ${:session_id}" + # :log "--chat nothing new for ${:session_id}" } :render } @@ -148,26 +164,24 @@ :add [Message new -time $secs -user_id $user -msg $msg -color $color] } } - #my log "--c setting session_id ${:session_id}: ${:now}" + #my log "--chat setting session_id ${:session_id}: ${:now}" ::xo::clusterwide nsv_set ${:array}-seen ${:session_id} ${:now} :render } Chat instproc sweeper {} { #:log "--core-chat starting" foreach {user timestamp} [nsv_array get ${:array}-last-activity] { - #ns_log notice "--core-chat at user $user with $timestamp" set ago [expr {(${:now} - $timestamp) / 1000}] #ns_log notice "--core-chat Checking: now=${:now}, timestamp=$timestamp, ago=$ago" - # was 1200 if {$ago > 300} { :logout -user_id $user -msg "auto logout" # ns_log warning "-user_id $user auto logout" - try {::bgdelivery do ::Subscriber sweep chat-[:chat_id]} + ${:mr} sweep chat-[:chat_id] } } :broadcast_msg [Message new -volatile -type "users" -time [clock seconds]] - :log "-- ending" + #:log "-- ending" } Chat instproc logout {{-user_id ""} {-msg ""}} { @@ -209,12 +223,12 @@ Chat instproc user_active {user_id} { # was the user already active? - :log "--chat login already avtive? [nsv_exists ${:array}-last-activity $user_id]" + #:log "--chat login already avtive? [nsv_exists ${:array}-last-activity $user_id]" return [nsv_exists ${:array}-last-activity $user_id] } Chat instproc login {} { - :log "--chat login" + :log "--chat login mode=${:mode}" if {${:login_messages_p} && ![:user_active ${:user_id}]} { :add_msg -uid ${:user_id} -get_new false [_ xotcl-core.has_entered_the_room] } elseif {${:user_id} > 0 && ![nsv_exists ${:array}-login ${:user_id}]} { @@ -224,7 +238,7 @@ ::xo::clusterwide nsv_set ${:array}-last-activity ${:user_id} ${:now} } :encoder noencode - :log "--c setting session_id ${:session_id}: ${:now}" + #:log "--chat setting session_id ${:session_id}: ${:now} mode=${:mode}" return [:get_all] } @@ -305,14 +319,14 @@ Chat instproc broadcast_msg {msg} { #:log "--chat broadcast_msg" - ::xo::clusterwide \ - bgdelivery send_to_subscriber chat-[:chat_id] [:json_encode_msg $msg] + ${:mr} send_to_subscriber chat-[:chat_id] [:json_encode_msg $msg] } Chat instproc subscribe {-uid} { set user_id [expr {[info exists uid] ? $uid : ${:user_id}}] set color [:user_color $user_id] - bgdelivery subscribe chat-[:chat_id] "" [:mode] + #ns_log notice "--CHAT [self] subscribe chat-${:chat_id} -mode ${:mode} via <${:mr}>" + ${:mr} subscribe chat-${:chat_id} -mode ${:mode} } Chat instproc render {} { @@ -339,7 +353,7 @@ :new -volatile -chat_id $chat_id -user_id 0 -session_id 0 -init -sweeper } } - :log "-- ending" + #:log "-- ending" } ChatClass method initialize_nsvs {} { @@ -394,7 +408,7 @@ set mode polling # # Check, whether we have the tcllibthread and a sufficiently new - # aolserver/NaviServer supporting bgdelivery transfers. + # AOLserver/NaviServer supporting bgdelivery transfers. # if {[info commands ::thread::mutex] ne "" && ![catch {ns_conn contentsentlength}]} { @@ -403,10 +417,12 @@ # set mode scripted-streaming if {![regexp msie|opera [string tolower [ns_set get [ns_conn headers] User-Agent]]]} { - # Explorer doesn't expose partial response until request state != 4, while Opera fires - # onreadystateevent only once. For this reason, for every browser except them, we could - # use the nice mode without the spinning load indicator. # + # Explorer doesn't expose partial response until request state + # != 4, while Opera fires onreadystateevent only once. For + # this reason, for every browser except them, we could use the + # nice mode without the spinning load indicator. + # set mode streaming } } @@ -473,11 +489,11 @@ switch -- $mode { polling { set jspath /resources/xowiki/chat.js - set subscribe_url ${base_url}&m=get_new + set subscribe_url ${base_url}&m=get_new&=polling } streaming { set jspath /resources/xowiki/streaming-chat.js - set subscribe_url ${base_url}&m=subscribe + set subscribe_url ${base_url}&m=subscribe&mode=streaming } scripted-streaming { set jspath /resources/xowiki/scripted-streaming-chat.js @@ -551,6 +567,7 @@ -session_id $session_id \ -mode $mode \ -conf $conf + #:log "--CHAT created c1 with mode=$mode" set data [c1 login] if {$data ne ""} { @@ -584,6 +601,8 @@ }] + #:log "--CHAT create HTML for mode=$mode" + switch -- $mode { "polling" { append html [subst -nocommands { Index: openacs-4/packages/xowiki/www/chat.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/www/chat.tcl,v diff -u -N -r1.2 -r1.2.2.1 --- openacs-4/packages/xowiki/www/chat.tcl 20 Nov 2018 18:41:05 -0000 1.2 +++ openacs-4/packages/xowiki/www/chat.tcl 23 Feb 2019 19:02:55 -0000 1.2.2.1 @@ -1,9 +1,10 @@ ad_page_contract { - a tiny chat client + A tiny chat client @author Gustaf Neumann (gustaf.neumann@wu-wien.ac.at) @creation-date Jan 31, 2006 @cvs-id $Id$ + } -query { m:word id:integer @@ -15,32 +16,37 @@ if {![::xo::ChatClass is_chat_p $class]} { ns_returnnotfound - ad_script_abort -} -#ns_log notice "--chat m=$m session_id=$s [clock format [lindex [split $s .] 1] -format %H:%M:%S] mode=$mode" -$class create c1 -destroy_on_cleanup -chat_id $id -session_id $s -mode $mode -switch -- $m { - add_msg { - #ns_log notice "--c call c1 $m '$msg'" - ns_return 200 application/json [c1 $m $msg] - ad_script_abort - #ns_log notice "--c add_msg returns '$_'" +} else { + + #ns_log notice "### chat.tcl mode <$mode> class <$class>" + #ns_log notice "--chat m=$m session_id=$s [clock format [lindex [split $s .] 1] -format %H:%M:%S] mode=$mode" + + $class create c1 -destroy_on_cleanup -chat_id $id -session_id $s -mode $mode + switch -- $m { + add_msg { + #ns_log notice "--c call c1 $m '$msg'" + ns_return 200 application/json [c1 $m $msg] + } + get_new { + ns_return 200 application/json [c1 $m] + } + login - + subscribe - + get_all { + set _ [c1 $m] + ns_return 200 text/html [subst {$_}] + } + default { + ns_log error "--c unknown method $m called." + } } - get_new { - ns_return 200 application/json [c1 $m] - ad_script_abort - } - login - - subscribe - - get_all {set _ [c1 $m]} - default {ns_log error "--c unknown method $m called."} } +ad_script_abort + #ns_log notice "--chat.tcl $m: returns '$_'" -ns_return 200 text/html [subst {$_}] - # Local variables: # mode: tcl # tcl-indent-level: 2