hostside/multiplex

   1 #!/usr/bin/tcl
   2
   3 # per connection:
   4 #    c/$conn(super)          0 or 1
   5 #    c/$conn(ipaddr)
   6 #    [msel/$conn "$msg "]    0 or 1
   7 #    [mreplay/$conn "$msg "] 0 or 1 during replay only
   8 #    c/$conn(q)              [list $inputline ...]
   9 #
  10 # globals:
  11 #    $queueing            [list $conn ...]
  12 #    $master              socket
  13 #    $permissions         [list allow|super|deny $ipaddrhex $maskhex ...]
  14 #    $realtime            pipes
  15 #    $realtime_retry      [list $timeoutid $awaitedpongmsg|{} $buf]
  16 #    $realtime_last_retries        [list $now $now $now ... $now]
  17 #    $replay("$pri $key") $rhs     $pri is \d\d; causes replay of  "$key $rhs"
  18 #    $detect0($seg)       unset -> 1 or irrelevant; [after ...]
  19 #    $conns($conn)        1
  20 #
  21 # configs set directly in multiplex-config:
  22 #    $records          [list filename.record ...]
  23 #    $detectlag        <ms>
  24 #
  25 # $conn is in $queueing iff c/$conn(q) is nonempty
  26 #
  27 # globals relating to realtime's command execution state:
  28 #                           awaiting        awaiting  executing global
  29 #                   idle     executing/nak   ack       internal cmd     dead
  30 #
  31 #    $realtime       set      set            set          ?             unset
  32 #    $currentcmd     unset    $cmd           $cmd         $cmd          unset
  33 #    $currentconn    unset    $conn or {}    $conn or {}  $conn         unset
  34 #    $executing      0        0              1            2             0
  35 #
  36 # globals relating to realtime start/stop:
  37 #                     manual      ready to   running   awaiting off
  38 #    $realtime         any          unset      set       unset
  39 #    $realtime_retry   unset        {}         {}        [list ...]
  40 #
  41 # realtime_last_retries is unset at startup, and becomes unset when we
  42 # enter auto mode.  unset means in auto mode we have to set it.
  43 # It contains the last few startup times.
  44 #
  45 # replay priorities and messages:
  46 #    10 stastate
  47 #    40 warning realtime-failed
  48 #    41 warning save-dump-failed
  49 #    42 info save-dump
  50 #    50 resolution ....
  51 #    55 picio out on|off
  52 #    60 movpos ...
  53 #       train ...
  54 #       picio out polarity ...
  55 #    70 detect <seg> 0|1
  56
  57 set libdir .
  58 catch { set libdir $env(TRAINS_HOSTSIDE) }
  59 source $libdir/lib.tcl
  60
  61 #---------- replay, general utilities, etc. ----------
  62
  63 proc compile-glob-patterns {pats procname} {
  64     if {[llength $pats] > 20 || [string length $pats] > 200} {
  65         cmderr LimitExceeded "too many, or too long, patterns"
  66     }
  67     set def "\n"
  68     append def "    switch -regexp -- \$m {\n"
  69     foreach pat $pats {
  70         set neg [regsub {^~} $pat {} pat]
  71         if {[regexp {[^-+./&|:=0-9a-zA-Z_*?]} $pat]} {
  72             cmderr BadCmd "pattern contains invalid character"
  73         }
  74         regsub -all {[-+./&|:=]} $pat {\\&} pat
  75         regsub -all {_} $pat {\s+} pat
  76         regsub -all {\*} $pat {\S+} pat
  77         regsub -all {\?} $pat {.} pat
  78         append pat {\s}
  79         append def "    [list ^$pat " return [expr {!$neg}] "]\n"
  80     }
  81     append def {    {^[-&]\S|^\+debug\s} { return 0 }} "\n"
  82     append def "    }\n"
  83     append def "    return 1\n"
  84     proc $procname {m} $def
  85 }
  86
  87 proc nargs {l {n 0}} {
  88     if {[llength $l]!=$n} { cmderr BadCmd "wrong number of arguments" }
  89 }
  90
  91 proc cmderr {ecode emsg} { error $emsg "" [list TRAIN CMDERR $ecode] }
  92
  93 proc lputs {m} {
  94     global lputs
  95     if {!$lputs} return
  96     if {[regexp \
  97  {^\<[<&] picioh (?:in msg|out) 8[89a-f]|^\<[<&] picio (?:in pong|out ping)} \
  98             $m]} \
  99         return
 100     puts $m
 101 }
 102
 103 proc xmit-relevantly {m {tlog 0}} {
 104     global executing currentconn conns
 105     if {$tlog} {
 106         puts "@[clock format [clock seconds] -format {%Y-%m-%d %T %Z}] $m"
 107     }
 108     if {$executing} {
 109         puts "<* $m"
 110         set myconn $currentconn
 111         if {[string length $currentconn]} {
 112             trapping xmit-only-noreport $currentconn +$m
 113         }
 114         set othersm -$m
 115     } else {
 116         lputs "<& $m"
 117         set myconn {}
 118         set othersm &$m
 119     }
 120     foreach conn [array names conns] {
 121         if {[string compare $myconn $conn]} {
 122             trapping xmit-only-noreport $conn $othersm
 123         }
 124     }
 125 }
 126
 127 proc xmit-relevantly-savereplay {pri key rhs {tlog 0}} {
 128     set pk "$pri $key"
 129     upvar #0 replay($pk) rep
 130     set rep $rhs
 131     xmit-relevantly "$key $rhs" $tlog
 132 }
 133
 134 proc savereplay-clear {pk} {
 135     upvar #0 replay($pk) rep; catch { unset rep }
 136 }
 137
 138 proc savereplay-clear-re {re} { # re is anchored at start
 139     global replay
 140     if {![info exists replay]} return
 141     foreach pk [array names replay] {
 142         if {[regexp -- ^$re "$pk "]} { unset replay($pk) }
 143     }
 144 }
 145
 146 proc save-dump-failed-warn {fpre howpre emsg} {
 147     global errorCode
 148     switch -glob $errorCode {
 149         {POSIX *} {
 150             set k [lindex $errorCode 1]
 151             set m [lindex $errorCode 2]
 152             xmit-relevantly-savereplay 41 \
 153                     "warning save-dump-failed" "$fpre$k : $howpre$m"
 154         }
 155         * {
 156             xmit-relevantly-savereplay 41 \
 157                     "warning save-dump-failed" "$fpre: $emsg"
 158         }
 159     }
 160 }
 161
 162 proc save-dump {} {
 163     global errorCode
 164
 165     savereplay-clear "41 warning save-dump-failed"
 166     savereplay-clear "42 info save-dump"
 167
 168     set now [clock seconds]
 169     set now [clock format $now -format %Y-%m-%dT%H-%M-%S%z]
 170     set dumpdir +dump.$now
 171
 172     if {[catch {
 173         file mkdir $dumpdir
 174     } emsg]} {
 175         save-dump-failed-warn "" "mkdir $dumpdir: " $emsg
 176         error $emsg "" {TRAIN REPORTED}
 177     }
 178
 179     foreach f {
 180         +realtime.log
 181         +persist.data +persist.data.new +persist.data.old
 182         +persist.conv +persist.conv.new +persist.conv.old
 183     } {
 184         if {[catch { link $f $dumpdir/$f } emsg]} {
 185             switch -glob $errorCode {
 186                 {POSIX ENOENT *} { }
 187                 * { save-dump-failed-warn "$f " "link $f $dumpdir/: " $emsg }
 188             }
 189         }
 190     }
 191     xmit-relevantly-savereplay 42 "info save-dump" "$dumpdir" 1
 192 }
 193
 194 #---------- multiplexer-implemented command ----------
 195
 196 proc local/select {conn args} {
 197     upvar #0 c/$conn c
 198     compile-glob-patterns $args msel/$conn
 199 }
 200
 201 proc global/!save-dump {conn args} {
 202     nargs $args
 203     if {[catch { save-dump } emsg]} {
 204         cmderr HostSupportSystemsProblem "failed to save dump: $emsg"
 205     }
 206 }
 207
 208 proc do-replay {conn} {
 209     global replay
 210     foreach pk [lsort [array names replay]] {
 211         set pri [string range $pk 0 2]
 212         set lhs [string range $pk 3 end]
 213         set r [string trimright $replay($pk) "\n"]
 214         foreach m [split $r "\n"] {
 215             puts "<$conn|$pri|$lhs $m"
 216             xmit-only-noreport $conn "|$lhs $m"
 217         }
 218     }
 219 }
 220
 221 proc local/replay {conn args} {
 222     if {[llength $args]} {
 223         rename msel/$conn mreplay/$conn ;# park it here for a moment
 224         compile-glob-patterns $args msel/$conn
 225     }
 226     do-replay $conn
 227     if {[llength $args]} {
 228         rename msel/$conn {}
 229         rename mreplay/$conn msel/$conn
 230     }
 231 }
 232
 233 proc local/select-replay {conn args} {
 234     upvar #0 c/$conn c
 235     compile-glob-patterns $args msel/$conn
 236     do-replay $conn
 237 }
 238
 239 #---------- automatic realtime restart ----------
 240
 241 proc global/!realtime {conn args} {
 242     global realtime realtime_retry realtime_last_retries
 243     nargs $args 1
 244     set how [lindex $args 0]
 245
 246     # perhaps kill the running instance
 247     # this switch also checks the argument
 248     switch -exact -- $how {
 249         kill - stop - restart - start - start-manual {
 250             if {[info exists realtime]} {
 251                 realtime-failed killed "termination requested by command"
 252             }
 253         }
 254         auto {
 255         }
 256         default {
 257             cmderr BadCmd "unknown !realtime subcommand"
 258         }
 259     }
 260
 261     # set the operating mode
 262     switch -exact -- $how {
 263         auto {
 264             realtime-retry-reset
 265             set realtime_retry {}
 266             catch { unset realtime_last_retries }
 267         }
 268         stop - start - start-manual {
 269             realtime-retry-reset
 270             catch { unset realtime_retry }
 271         }
 272     }
 273
 274     # (re)start if applicable
 275     switch -exact -- $how {
 276         start - restart {
 277             realtime-start {}
 278         }
 279         start-manual {
 280             realtime-start -m
 281         }
 282         default {
 283             after idle realtime-retry-check
 284         }
 285     }
 286 }
 287
 288 proc realtime-retry-reset {} {
 289     global realtime_retry serchan
 290     if {![info exists realtime_retry]} return
 291     if {![llength $realtime_retry]} return
 292     manyset $realtime_retry timeoutid
 293     fileevent $serchan readable {}
 294     after cancel $timeoutid
 295     set realtime_retry {}
 296 }
 297
 298 proc realtime-retry-check {} {
 299     global realtime_retry realtime
 300     global realtime_last_retries restart_min_mean_interval
 301     if {![info exists realtime_retry]} return
 302     if {[llength $realtime_retry]} return
 303     if {[info exists realtime]} return
 304
 305     if {![info exists realtime_last_retries]} {
 306         set realtime_last_retries {0 0 0 0 0}
 307     }
 308     set oldest [lindex $realtime_last_retries 0]
 309     set now [clock seconds]
 310     if {$now - $oldest <
 311         $restart_min_mean_interval * [llength $realtime_last_retries]} {
 312         xmit-relevantly-savereplay 40 \
 313             "warning realtime-failed" looping-disabled
 314         unset realtime_retry
 315         return
 316     }
 317     set realtime_last_retries [lrange $realtime_last_retries 1 end]
 318     lappend realtime_last_retries $now
 319
 320     realtime-start {}
 321 }
 322
 323 proc realtime-retry-realtime-failed {} {
 324     global realtime_retry serchan
 325     if {![info exists realtime_retry]} return
 326     if {[llength $realtime_retry]} { error "huh? $realtime_retry" }
 327     fileevent $serchan readable realtime-retry-serchan-readable
 328     set after [after 500 realtime-retry-send-ping]
 329     set realtime_retry [list $after {} {}]
 330 }
 331
 332 proc realtime-retry-send-ping {} {
 333     global realtime_retry urandom serchan
 334     manyset $realtime_retry after pong buf
 335     set x [read $urandom 2]
 336     binary scan $x H* x
 337     if {[string length $x] != 4} { error "urandom short read `$x'" }
 338     set x [expr "0x$x & 0x077f"]
 339     set ping [format %04x [expr {0x8800 ^ $x}]]
 340     set pong [format %04x [expr {0x885a ^ $x}]]
 341     #puts "<! picioh out await-off $pong  (await $pong)"
 342     puts -nonewline $serchan [binary format H* $ping]
 343     set after [after 700 realtime-retry-now-off]
 344     set realtime_retry [list $after $pong {}]
 345 }
 346
 347 proc realtime-retry-serchan-readable {} {
 348     global realtime_retry serchan
 349     manyset $realtime_retry after pong buf
 350     set x [read $serchan]
 351     binary scan $x H* x
 352     #puts "<! picioh in await-off $x"
 353     if {![string length $x] && [eof $serchan]} { error "eof on serial port" }
 354     append buf $x
 355     while {[regexp {^((?:[89a-f].)*[0-7].)(.*)$} $buf dummy msg buf]} {
 356         if {![string compare 09 $msg]} {
 357             realtime-retry-now-off
 358             return
 359         }
 360         if {![string compare $pong $msg]} {
 361             after cancel $after
 362             set after [after 200 realtime-retry-send-ping]
 363             set realtime_retry [list $after {} {}]
 364             return
 365         }
 366     }
 367     set realtime_retry [list $after $pong $buf]
 368 }
 369
 370 proc realtime-retry-now-off {} {
 371     realtime-retry-reset
 372     realtime-retry-check
 373 }
 374
 375 #---------- connection and commands ----------
 376
 377 proc client-inputline {conn l} {
 378     global queueing
 379     upvar #0 c/$conn c
 380     puts "$conn> $l"
 381     client-disable-readable $conn
 382     if {![llength $c(q)]} { lappend queueing $conn }
 383     lappend c(q) $l
 384     after idle process-queues
 385 }
 386
 387 proc process-queues {} {
 388     global queueing currentcmd
 389     while {![info exists currentcmd] && [llength $queueing]} {
 390         set conn [lindex $queueing 0]
 391         set queueing [lrange $queueing 1 end]
 392
 393         upvar #0 c/$conn c
 394         if {![llength $c(q)]} continue
 395
 396         set l [lindex $c(q) 0]
 397         set c(q) [lrange $c(q) 1 end]
 398         if {[llength $c(q)]} {
 399             lappend queueing $conn
 400         } else {
 401             client-enable-readable $conn
 402         }
 403
 404         trapping process-command $conn $l
 405     }
 406 }
 407
 408 proc process-command {conn l} {
 409     global currentcmd currentconn realtime executing
 410     global errorInfo errorCode
 411     upvar #0 c/$conn c
 412     set cmd ?
 413     set r [catch {
 414         if {[regexp {^#} $l]} return; # comments ?!  ok then ...
 415         set l [string trim $l]
 416         if {![string length $l]} return
 417         if {![regexp {^((!?)[-+a-z0-9]+)(?:\s.*)?$} $l dummy cmd priv]} {
 418             error "improper command name" {} {TRAIN CMDNAK BadCmd}
 419         }
 420         if {[regexp {[^ \t!-~]} $l]} {
 421             error "improper character" {} {TRAIN CMDNAK BadCmd}
 422         }
 423         if {[string length $priv] && !$c(super)} {
 424             error "" {} {TRAIN CMDNAK PermissionDenied}
 425         }
 426
 427         if {![catch { info args global/$cmd }]} {
 428             set currentcmd $cmd
 429             set currentconn $conn
 430             set executing 2
 431             xmit-relevantly "executing $cmd"
 432             eval [list global/$cmd $conn] [lrange [split $l] 1 end]
 433         } elseif {![catch { info args local/$cmd }]} {
 434             xmit-only $conn "+executing $cmd"
 435             eval [list local/$cmd $conn] [lrange [split $l] 1 end]
 436         } elseif {![info exists realtime]} {
 437             error "" {} {TRAIN CMDNAK realtime-not-running}
 438         } else {
 439             set currentcmd $cmd
 440             set currentconn $conn
 441             if {[catch {
 442                 puts ">> $l"
 443                 puts $realtime $l
 444             } emsg]} {
 445                 if {[string match {POSIX EPIPE *} $errorCode]} {
 446                     realtime-failed EPIPE ""
 447                 } elseif {[string match {POSIX *} $errorCode]} {
 448                     realtime-failed [lindex $errorCode 1] \
 449                             "write failed: [lindex $errorCode 2]"
 450                 } else {
 451                     realtime-failed ?write-[lindex $errorCode 0] \
 452                             "puts failed ($errorCode): $emsg"
 453                 }
 454             }
 455             return
 456         }
 457     } emsg]
 458     if {$r==2} return
 459     if {$r==0} {
 460         set m "ack $cmd ok"
 461         if {$executing} {
 462             xmit-relevantly $m
 463             set executing 0
 464             unset currentconn
 465             unset currentcmd
 466         } else {
 467             xmit-only $conn +$m
 468         }
 469         return
 470     }
 471     switch -glob $errorCode {
 472         {TRAIN REPORTED*} {
 473         }
 474         {TRAIN CMDNAK*} {
 475             set el [concat [list +nack] [lrange $errorCode 2 end]]
 476             if {[string length $emsg]} { append el ": " $emsg }
 477             xmit-only $conn "$el"
 478         }
 479         {TRAIN CMDERR*} {
 480             set el [concat [list +ack $cmd] [lrange $errorCode 2 end]]
 481             xmit-only $conn "$el : $emsg"
 482             set executing 0
 483             catch { unset currentconn }
 484             catch { unset currentcmd }
 485         }
 486         * {
 487             set ei $errorInfo; set ec $errorCode
 488             kill-conn-ierr $conn
 489             error $emsg $ei $ec
 490         }
 491     }
 492 }
 493
 494 proc client-eof {conn} {
 495     puts "$conn>\$"
 496     kill-conn $conn ""
 497 }
 498
 499 proc client-enable-readable {conn} {
 500     fileevent $conn readable [list trapping readable client $conn]
 501 }
 502 proc client-disable-readable {conn} {
 503     fileevent $conn readable {}
 504 }
 505
 506 #---------- general IO ----------
 507
 508 proc xmit-puts {conn msg} {
 509     global conns errorInfo
 510     if {![info exists conns($conn)]} return
 511     if {[catch { puts -nonewline $conn $msg } emsg]} {
 512         kill-conn $conn "=failed client-io : $emsg"
 513         error $emsg $errorInfo {TRAIN REPORTED}
 514     }
 515 }
 516
 517 proc xmit-only-always {conn msg} {
 518     puts "<$conn $msg"
 519     xmit-puts $conn "$msg\n"
 520 }
 521 proc xmit-only-noreport {conn msg} {
 522     append msg "\n"
 523     if {[msel/$conn $msg]} { xmit-puts $conn $msg }
 524 }
 525 proc xmit-only {conn msg} {
 526     xmit-only-noreport $conn $msg
 527 }
 528
 529 #---------- error handling ----------
 530
 531 proc kill-conn {conn msg} {
 532     global conns queueing currentconn
 533     upvar #0 c/$conn c
 534     catch { unset conns($conn) } ;# do this first to stop any recursion
 535     if {[info exists currentconn]} {
 536         if {![string compare $currentconn $conn]} { set currentconn {} }
 537     }
 538     puts "<$conn\$ closing : $msg"
 539     if {[string length $msg]} { catch { xmit-only-always $conn "$msg" } }
 540     catch { close $conn }
 541     if {[set ix [lsearch -exact $queueing $conn]] >= 0} {
 542         set queueing [lreplace $queueing $ix $ix]
 543     }
 544     catch { unset c }
 545     catch { rename msel/$conn {} }
 546     catch { rename mreplay/$conn {} }
 547     set qn {}
 548     set cmdqueue $qn
 549 }
 550
 551 proc report-unexpected {headmsg emsg} {
 552     if {[catch {
 553         global errorInfo errorCode
 554         puts stderr \
 555 "========== $headmsg ==========\n
 556 $errorCode\n
 557 $errorInfo\n
 558 $emsg\n
 559 ========================================\n"
 560     } e]} { exit 16 }
 561 }
 562
 563 proc bgerror {emsg} {
 564     global errorInfo errorCode
 565     catch { report-unexpected {UNEXPECTED UNTRAPPED ERROR} $emsg }
 566     exit 12
 567 }
 568
 569 proc kill-conn-ierr {conn} {
 570     kill-conn $conn "=failed : Internal error"
 571 }
 572
 573 proc trapping {proc conn args} {
 574     global errorInfo errorCode
 575     if {![catch { uplevel #0 [list $proc $conn] $args } r]} { return $r }
 576     switch -glob $errorCode {
 577         {TRAIN EXPECTED*} { kill-conn $conn "=failed : $r" }
 578         {TRAIN REPORTED*} { kill-conn $conn "" }
 579         * {
 580             report-unexpected {UNEXPECTED ERROR} $r
 581             kill-conn-ierr $conn
 582         }
 583     }
 584 }
 585
 586 #---------- realtime subprocess ----------
 587
 588 proc realtime-failed {k m} {
 589     global realtime currentcmd currentconn executing
 590     global errorInfo errorCode replay
 591     # if $m is "", use wait status
 592     if {![string length $m]} {
 593         set r [catch {
 594             fconfigure $realtime -blocking 1
 595             close $realtime
 596         } emsg]
 597         if {!$r} {
 598             set m "unexpectedly closed pipe ?!"
 599             set k unexpected
 600         } elseif {[string match {CHILDSTATUS*} $errorCode]} {
 601             set m "exited with status [lindex $errorCode 2]"
 602             set k "exit[lindex $errorCode 2]"
 603         } elseif {[string match {CHILDKILLED*} $errorCode]} {
 604             set m "killed by signal [lindex $errorCode 3]"
 605             set k [lindex $errorCode 2]
 606         } else {
 607             set m "failed confusingly ($errorCode): $emsg"
 608             set k ?wait-[lindex $errorCode 0]
 609         }
 610     } else {
 611         catch { close $realtime }
 612     }
 613     puts "<<\$ $k : $m"
 614     catch { unset realtime }
 615     if {[catch {
 616         set sef [open +realtime.stderr r]
 617         while {[gets $sef l] >= 0} {
 618             xmit-relevantly-savereplay 40 \
 619                     "warning realtime-failed stderr" ": $l"
 620         }
 621         close $sef
 622         unset sef
 623     } emsg]} {
 624         if {![string match {POSIX ENOENT *} $errorCode]} {
 625             xmit-relevantly-savereplay 40 \
 626                     "warning realtime-failed stderr" "unreadable : $emsg"
 627         }
 628         catch { close $sef }
 629     }
 630     xmit-relevantly-savereplay 40 \
 631             "warning realtime-failed" "reason $k : $m"
 632     catch { save-dump }
 633     if {$executing==2} {
 634         # internal commands need to deal with it themselves
 635     } elseif {$executing} {
 636         xmit-relevantly "ack $currentcmd SystemFailed realtime : $m"
 637         set executing 0
 638     } elseif {[info exists currentcmd]} {
 639         xmit-relevantly "nak SystemFailed realtime : $m"
 640         unset currentcmd
 641         unset currentconn
 642     }
 643     realtime-notrunning
 644     realtime-retry-realtime-failed
 645 }
 646
 647 proc realtime-notrunning {} {
 648     xmit-relevantly-savereplay 10 stastate Crashed
 649 }
 650
 651 proc realtime-start {xopts} {
 652     global realtime records realtime_xopts dev_railway libdir
 653     if {[info exists realtime]} { error "realtime already running" }
 654     realtime-retry-reset
 655     set cl [concat \
 656             [list 2> +realtime.stderr $libdir/realtime -v2 -s$dev_railway] \
 657             $realtime_xopts $xopts]
 658     foreach f $records { lappend cl $libdir/$f }
 659     puts "<> $cl"
 660     savereplay-clear-re "40 warning realtime-failed"
 661     if {[catch {
 662         set realtime [open |$cl r+]
 663         fconfigure $realtime -translation binary -buffering line -blocking 0
 664         fileevent $realtime readable [list readable realtime $realtime]
 665     } emsg]} {
 666         realtime-failed start $emsg
 667         error "realtime failed : $emsg" "" {TRAIN REPORTED}
 668     }
 669 }
 670
 671 proc realtime-eof {dummy} { realtime-failed EOF "" }
 672
 673 proc detect0timeout {seg} {
 674     global replay
 675     upvar #0 detect0($seg) d0
 676     unset d0
 677     set key "detect $seg"
 678     set pk "70 $key"
 679     set replay($pk) 0
 680     xmit-relevantly "$key 0"
 681 }
 682
 683 proc clear-replay-detects {} {
 684     global replay
 685     foreach k [array names replay] {
 686         if {[regexp {^.. detect } $k]} { unset replay($k) }
 687     }
 688 }
 689
 690 proc realtime-inputline {dummy l} {
 691     global detectlag replay testmode
 692     global executing currentcmd currentconn
 693
 694     if {$testmode && [regexp {^%(.*)} $l dummy rhs]} {
 695         set r [catch { uplevel #0 $rhs } emsg]
 696         if {$r} { puts "** $emsg\n" } else { puts "=> $emsg\n" }
 697         return
 698     }
 699
 700     lputs "<< $l"
 701     set tlog 0
 702
 703     if {[regexp {^(detect (\w+)) ([01])$} $l dummy key seg value]} {
 704         upvar #0 detect0($seg) d0
 705         catch { after cancel $d0 }
 706         if {$value} {
 707             if {[info exists d0]} { unset d0; return }
 708         } else {
 709             set d0 [after $detectlag detect0timeout $seg]
 710             return
 711         }
 712         set pri 70
 713     } elseif {[regexp {^(stastate) (.*)$} $l dummy key value]} {
 714         switch -exact -- $value {
 715             Settling {
 716                 clear-replay-detects
 717                 savereplay-clear-re {^60 train \S+ speed }
 718             }
 719             Resolving {
 720                 savereplay-clear-re {^50 resolution }
 721                 savereplay-clear-re {^60 train \S+ (?:at|has) }
 722                 savereplay-clear-re {^60 movpos }
 723             }
 724         }
 725         set pri 10
 726         set tlog 1
 727     } elseif {[regexp {^(resolution) (.*)$} $l dummy key addvalue]} {
 728         set pri 50
 729     } elseif {[regexp {^(picio out) (on|off)$} $l dummy key value]} {
 730         set pri 55
 731     } elseif {[regexp -expanded {
 732         ^( movpos \s \S+ \s (?: feat \s \S+ | position) |
 733            train  \s \S+ \s (?: has | at | speed \s commanding ) |
 734            picio  \s out \s polarity
 735         ) \s (.*) $
 736               } $l dummy key value]} {
 737         set pri 60
 738     }
 739     if {[info exists key]} {
 740         set pk "$pri $key"
 741         upvar #0 replay($pk) rep
 742         if {[info exists value]} {
 743             set rep $value
 744         } else {
 745             append rep $addvalue "\n"
 746         }
 747     }
 748
 749     switch -regexp -- $l {
 750         {^executing\s|^nak\s} {
 751             set executing 1
 752         }
 753     }
 754
 755     xmit-relevantly $l $tlog
 756
 757     switch -regexp -- $l {
 758         {^ack\s|^nak\s} {
 759             set executing 0
 760             unset currentcmd
 761             unset currentconn
 762             after idle process-queues
 763         }
 764     }
 765 }
 766
 767 #---------- new connections ----------
 768
 769 proc find-permission {ipaddr} {
 770     global permissions
 771     set ipaddr [ipaddr2hex $ipaddr]
 772     foreach {keyword paddr pmask} $permissions {
 773         if {[expr {($ipaddr & $pmask) == $paddr}]} { return $keyword }
 774     }
 775     return deny
 776 }
 777
 778 proc connected {conn} {
 779     global conns
 780     upvar #0 c/$conn c
 781     fconfig-trainproto $conn
 782     set c(q) {}
 783     set conns($conn) 1
 784     set perm [find-permission $c(ipaddr)]
 785     switch -exact $perm {
 786         deny { kill-conn $conn =denied; return }
 787         allow { set c(super) 0 }
 788         super { set c(super) 1 }
 789         default { error "$perm ?" }
 790     }
 791     compile-glob-patterns {?info ?warning} msel/$conn
 792
 793     xmit-only-always $conn =connected
 794     xmit-only-always $conn "=permission [lindex {normal super} $c(super)]"
 795     client-enable-readable $conn
 796 }
 797
 798 proc newconn {conn ipaddr port} {
 799     upvar #0 c/$conn c
 800     catch { unset c }
 801     puts "$conn new-client $conn $ipaddr,$port"
 802     set c(ipaddr) $ipaddr
 803     trapping connected $conn
 804 }
 805
 806 proc try-bind {addr} {
 807     global master errorInfo errorCode port
 808     if {![catch {
 809         set master [socket -server newconn -myaddr $addr $port]
 810     } emsg]} { return 1 }
 811     if {[string match {POSIX EADDRNOTAVAIL *} $errorCode]} { return 0 }
 812     error $emsg $errorInfo $errorCode
 813 }
 814
 815 proc ipaddr2hex {addr} {
 816     if {![regexp {^\d+\.\d+\.\d+\.\d+$} $addr]} {
 817         error "invalid ip address $addr"
 818     }
 819     set val 0x
 820     foreach octet [split $addr .] { append val [format %02x $octet] }
 821     if {[string length $val] != 10} {
 822         error "invalid numbers in ip address $addr (calculated $val ?!)"
 823     }
 824     return $val
 825 }
 826
 827 proc binding {addr blist} {
 828     global master permissions port
 829     if {[info exists master]} return
 830     if {![try-bind $addr]} return
 831     puts "bound to $addr,$port"
 832     set permissions {}
 833     foreach {keyword pattern} $blist {
 834         switch -exact $keyword allow - super - deny { } \
 835                 default { error "unknown binding keyword $keyword" }
 836         if {![regexp {^(.*)/(\d+)$} $pattern dummy host masklen]} {
 837             set host $pattern; set masklen 32
 838         }
 839         set ipaddr [ipaddr2hex $host]
 840         set mask [expr {$masklen==0 ? 0 : 0xffffffff << (32-$masklen)}]
 841         set mask [format %#10x $mask]
 842         if {$ipaddr & ~$mask} {
 843             error "non-zero bits outside mask in $pattern ($ipaddr/$mask)"
 844         }
 845         lappend permissions $keyword $ipaddr $mask
 846     }
 847 }
 848
 849 proc startup {} {
 850     global queueing executing testmode realtime port urandom serchan
 851     global dev_railway libdir lputs
 852     catch { close $master }; catch { unset master }
 853
 854     setting testmode 0 {[01]}
 855     setting lputs 0 {[01]}
 856     setting dev_railway {} {/.*}
 857     setting restart_min_mean_interval 5 {^\d+}
 858     setting realtime_xopts {} {.*}
 859     parse-argv {}
 860
 861     uplevel #0 source $libdir/multiplex-config
 862     set queueing {}
 863     set executing 0
 864
 865     set urandom [open /dev/urandom r]
 866     fconfigure $urandom -buffering none -translation binary
 867
 868     set serchan [open $dev_railway {RDWR NOCTTY NONBLOCK}]
 869     fconfigure $serchan -translation binary -buffering none -blocking 0
 870
 871     realtime-notrunning
 872
 873     if {!$testmode} {
 874         start_commandloop
 875         after idle realtime-retry-check
 876     } else {
 877         fconfig-trainproto stdin
 878         fconfig-trainproto stdout
 879         fileevent stdin readable [list readable realtime stdin]
 880         set realtime stdout
 881     }
 882 }
 883
 884 startup
 885 vwait end