From: ian Date: Sun, 25 May 2008 11:46:45 +0000 (+0000) Subject: multiplexer "select" seems to work X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=02ebaa0dfd12b5fc995641bc0892e9aece9a66b8;p=trains.git multiplexer "select" seems to work --- diff --git a/hostside/README.commands b/hostside/README.commands index 9ffb95a..2fac063 100644 --- a/hostside/README.commands +++ b/hostside/README.commands @@ -6,6 +6,8 @@ Protocol over new hostside stdin and to multiplexer: - result of command by another client + result of command by us & asynchronous + other prefixes + = related to this actual connection ====================================================================== @@ -84,7 +86,7 @@ COMMANDS AND RESPONSES P> [...] results in: R< ?nak unknown-command|permission-denied|invalid-syntax [: ] - R< ?executing [...] + R< ?executing consequential messages including picio, signalling problems etc. then one of these R< ?ack ok @@ -113,20 +115,24 @@ MULTIPLEXER FACILITIES or M< =denied and later perhaps - M< =failed : + A< =failed : regardless of selected message patterns otherwise there is no need to quit - just send eof - M< select [~]... - first match wins; ~ discards the message; if nothing matches, - all are selected; patterns are matched against message with - _ replacing spaces and added to the end; patterns which contain - no * have _* appended; default is ~debug; total pattern length - is limited for safety and if it is too long it is truncated. - M> =select - - M< replay [~]... - M> - M> =replay + M> select [~]... + first match wins; ~ discards the message. + in pattern + -+./:0-9a-zA-Z match themselves + _ matches nonempty sequence of whitespace + * matches any non-whitespace + ? matches any single character + _ is matched against + if no match, it is as if the following patterns were appended + ?info ?warning ~-* ~&* ~+debug * + + M> replay [~]... + M< +executing replay + M< + M< +ack replay ok MULTIPLEXER-IMPLEMENTED FUNCTIONALITY AFFECTING WHOLE SYSTEM diff --git a/hostside/multiplex b/hostside/multiplex index fb45a14..6b8056f 100755 --- a/hostside/multiplex +++ b/hostside/multiplex @@ -1,18 +1,48 @@ -x#!/usr/bin/tclsh8.4 +#!/usr/bin/tclsh8.4 + +# per connection: +# c/$conn(super) 0 or 1 +# c/$conn(ipaddr) +# [msel/$conn "$msg "] 0 or 1 +# +# globals: +# $cmdqueue [list $conn $cmd ...] +# $master socket +# $permissions [list allow|super|deny $ipaddrhex $maskhex ...] #---------- i/o to realtime ---------- proc cmdqueue-check {args} { } proc compile-glob-patterns {pats procname} { + if {[llength $pats] > 20 || [string length $pats] > 200} { + cmderr LimitExceeded "too many, or too long, patterns" + } + set def "\n" + append def " switch -regexp -- \$m {\n" foreach pat $pats { - if {[catch { string match $pat "" } emsg]} { - + set neg [regsub {^~} $pat {} pat] + if {[regexp {[^-+./:0-9a-zA-Z_*?]} $pat]} { + cmderr BadCmd "pattern contains invalid character" + } + regsub -all {[-+./:]} $pat {\\&} pat + regsub -all {_} $pat {\s+} pat + regsub -all {\*} $pat {\S+} pat + regsub -all {\?} $pat {.} pat + append pat {\s} + append def " [list ^$pat " return [expr {!$neg}] "]\n" + } + append def { {^.(?:info|warning)\s} { return 1 }} "\n" + append def { {^[-&]\S|^\+debug\s} { return 0 }} "\n" + append def " }\n" + append def " return 1\n" + puts $def + proc $procname {m} $def +} -proc cmd/select {args} { +proc cmd/select {conn args} { upvar #0 c/$conn c - check-glob-patterns $args - set c(selected) $args + compile-glob-patterns $args msel/$conn } #---------- connection and commands ---------- @@ -23,7 +53,7 @@ proc client-inputline {conn l} { upvar #0 c/$conn c set cmd ? set r [catch { - if {[regexp {^#}] $l} return; # comments ?! ok then ... + if {[regexp {^#} $l]} return; # comments ?! ok then ... set l [string trim $l] if {![string length $l]} return if {![regexp {^((!?)[-a-z0-9]+)(?:\s.*)?$} $l dummy cmd priv]} { @@ -32,30 +62,35 @@ proc client-inputline {conn l} { if {[regexp {[^ \t!-~]} $l]} { error "improper character" {} {TRAIN CMDNAK invalid-syntax} } - if {[string length $priv && !$c(super)]} { + if {[string length $priv] && !$c(super)} { error "" {} {TRAIN CMDNAK permission-denied} } if {![catch { info args cmd/$cmd }]} { - xmit $conn "+executing $cmd\n" - eval [list cmd/$cmd $conn] [split $l] + xmit $conn "+executing $cmd" + eval [list cmd/$cmd $conn] [lrange [split $l] 1 end] } else { lappend cmdqueue $conn $l after idle cmdqueue-check } } emsg] - if {$r==0 || $r==2} return + if {$r==2} return + if {$r==0} { xmit $conn "+ack $cmd ok"; return } switch -glob $errorCode { + {TRAIN REPORTED*} { + } {TRAIN CMDNAK*} { set el [concat [list +nack] [lrange $errorCode 2 end]] if {[string length $emsg]} { append el ": " $emsg } - xmit $conn "$el\n" + xmit $conn "$el" } {TRAIN CMDERR*} { set el [concat [list +ack $cmd] [lrange $errorCode 2 end]] - xmit $conn "$el : $emsg\n" + xmit $conn "$el : $emsg" } * { - error $emsg $errorInfo $errorCode + set ei $errorInfo; set ec $errorCode + kill-conn-ierr $conn + error $emsg $ei $ec } } } @@ -64,52 +99,65 @@ proc client-eof {conn} { kill-conn $conn "" } #---------- general IO ---------- -proc readable {$conn whatfor} { +proc readable {whatfor conn} { while {[gets $conn l]>=0} { $whatfor-inputline $conn $l } if {[eof $conn]} { $whatfor-eof $conn } } -proc xmit {conn msg} { puts -nonewline $conn $msg } +proc xmit-always {conn msg} { puts $conn $msg } + +proc xmit {conn msg} { + append msg "\n" + if {[msel/$conn $msg]} { puts -nonewline $conn $msg } +} #---------- error handling ---------- proc kill-conn {conn msg} { upvar #0 c/$conn c global cmdqueue - if {[string length $msg]} { catch { client-out $conn $msg } } + if {[string length $msg]} { catch { xmit-always $conn $msg } } catch { close $conn } catch { unset c } + catch { rename msel/$conn {} } set qn {} - foreach tconn tl $cmdqueue { + foreach {tconn tl} $cmdqueue { if {[string compare $tconn $tl]} { lappend qn $tconn $tl } } set cmdqueue $qn - fixme delete compiled glob patterns proc } proc report-unexpected {headmsg emsg} { - puts stderr \ -"========== $headmsg ==========\n\ -$r\n\ -$errorInfo\n\ -$errorCode\n" + if {[catch { + global errorInfo errorCode + puts stderr \ +"========== $headmsg ==========\n +$errorCode\n +$errorInfo\n +$emsg\n +========================================\n" + } e]} { exit 16 } } proc bgerror {emsg} { global errorInfo errorCode catch { report-unexpected {UNEXPECTED UNTRAPPED ERROR} $emsg } - exit 127 + exit 12 +} + +proc kill-conn-ierr {conn} { + kill-conn $conn "=failed : Internal error" } proc trapping {proc conn args} { global errorInfo errorCode - if {![catch { eval #0 [list $proc $conn] $args } r]} { return $r } + if {![catch { uplevel #0 [list $proc $conn] $args } r]} { return $r } switch -glob $errorCode { - {TRAIN EXPECTED*} { kill-conn $conn "=failed : $r\n" } + {TRAIN EXPECTED*} { kill-conn $conn "=failed : $r" } {TRAIN SILENT*} { kill-conn $conn } * { report-unexpected {UNEXPECTED ERROR} $r - kill-conn $conn "=failed : Internal error\n" + kill-conn-ierr $conn } } } @@ -119,7 +167,7 @@ proc trapping {proc conn args} { proc find-permission {ipaddr} { global permissions set ipaddr [ipaddr2hex $ipaddr] - foreach keyword paddr pmask { + foreach {keyword paddr pmask} $permissions { if {[expr {($ipaddr & $pmask) == $paddr}]} { return $keyword } } return deny @@ -135,12 +183,11 @@ proc connected {conn} { super { set c(super) 1 } default { error "$perm ?" } } - set c(selected) {} fixme make compiled globs - fixme list of things per conn + compile-glob-patterns {} msel/$conn xmit-always $conn =connected - xmit-always $conn =permission [lindex {normal super} $c(super)] - fileevent $conn readable [list trapping readable $conn client] + xmit-always $conn "=permission [lindex {normal super} $c(super)]" + fileevent $conn readable [list trapping readable client $conn] } proc newconn {conn ipaddr port} { @@ -150,7 +197,7 @@ proc newconn {conn ipaddr port} { trapping connected $conn } -proc try-bind {$addr} { +proc try-bind {addr} { global master errorInfo errorCode if {![catch { set master [socket -server newconn -myaddr $addr 2883] @@ -165,16 +212,16 @@ proc ipaddr2hex {addr} { } set val 0x foreach octet [split $addr .] { append val [format %02x $octet] } - if {[string length $val != 10]} { + if {[string length $val] != 10} { error "invalid numbers in ip address $addr (calculated $val ?!)" } return $val } -proc binding {address blist} { +proc binding {addr blist} { global master permissions if {[info exists master]} return - if {![try-bind $address]} return + if {![try-bind $addr]} return set permissions {} foreach {keyword pattern} $blist { switch -exact $keyword allow - super - deny { } \ @@ -184,12 +231,20 @@ proc binding {address blist} { } set ipaddr [ipaddr2hex $host] set mask [expr {$masklen==0 ? 0 : 0xffffffff << (32-$masklen)}] - if {$ipaddr & $mask} { error "non-zero bits outside mask in $pattern" } + set mask [format %#10x $mask] + if {$ipaddr & ~$mask} { + error "non-zero bits outside mask in $pattern ($ipaddr/$mask)" + } lappend permissions $keyword $ipaddr $mask } } -proc readconfig {} { +proc startup {} { + global cmdqueue catch { close $master }; catch { unset master } source multiplex-config + set cmdqueue {} } + +startup +vwait end