- result of command by another client
+ result of command by us
& asynchronous
+ other prefixes
+ = related to this actual connection
======================================================================
P> <command> [<arguments>...]
results in:
R< ?nak unknown-command|permission-denied|invalid-syntax [: <message...>]
- R< ?executing <command> [<arguments>...]
+ R< ?executing <command>
consequential messages including picio, signalling problems etc.
then one of these
R< ?ack <command> ok
or
M< =denied
and later perhaps
- M< =failed : <message>
+ A< =failed : <message> regardless of selected message patterns
otherwise there is no need to quit - just send eof
- M< select [~]<glob-pattern>...
- 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 [~]<glob-pattern>...
- M> <all saved messages, ie those marked with S< above>
- M> =replay
+ M> select [~]<pattern>...
+ 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
+ <pattern>_ is matched against <message><spc>
+ if no match, it is as if the following patterns were appended
+ ?info ?warning ~-* ~&* ~+debug *
+
+ M> replay [~]<glob-pattern>...
+ M< +executing replay
+ M< <all saved messages, ie those marked with S< above>
+ M< +ack replay ok
MULTIPLEXER-IMPLEMENTED FUNCTIONALITY AFFECTING WHOLE SYSTEM
-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 ----------
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]} {
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
}
}
}
#---------- 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
}
}
}
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
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} {
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]
}
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 { } \
}
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
~ijackson / trains.git / commitdiff