# # Copyright (C) 2010 Alexandros Stergiakis # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU Affero General Public License as # published by the Free Software Foundation, either version 3 of the # License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Affero General Public License for more details. # # You should have received a copy of the GNU Affero General Public License # along with this program. If not, see . # #//# # This is the entry point for every new MikroConf session. # #//# # Note: Global variable 'ptid' contains the thread id of the parent (Master thread). # Note: Any new thread doesn't inherit the loaded packages & available procedures on its parent. # Note: Remember that working path is that of the parent thread. # Note: Loading the same binary package (like Tclx) in a thread, that has already been loaded in Master thread, does # not introduce any additional memory utilization. The code is reused. Might apply to Tcl-coded packages. However # it does not apply to files sourced with "source" command. package require unix 0.5 ################################ # Initiallization ################################ set sid [thread::id] set BASE_DIR [tsv::get conf BASE_DIR] source [file join $BASE_DIR lib.tcl] source [file join $BASE_DIR pty.tcl] source [file join $BASE_DIR policy.tcl] unset BASE_DIR namespace import ::policy::scripting ::policy::policy ::pty::ptyexec ################################ # Remap I/O ################################ Session $sid STDIN STDOUT # The following makes the file ChannelId provided as the second argument an alias to the first. # It doesn't close either of the channels. Closing one closes the other as well, but still to free # up memory you need to run close on both of them. # dup2 - Makes two Tcl File Handles to point to the same file descriptor. # It also copies all the file handle options (fconfigure). # The name is misleading, in the sense that it does not use the dup/dup2 # system calls. (Unline TclX "dup" command). dup2 $STDIN stdin dup2 $STDOUT stdout dup2 $STDOUT stderr unset STDIN STDOUT ################################ # Wrappers ################################ # Wrappers for log reporting procedures so that they also report the originating session/threadid. namespace eval log { proc Debug {args} { ::unknown log::Debug -session $::sid {*}$args } proc Info {args} { ::unknown log::Info -session $::sid {*}$args } proc Notice {args} { ::unknown log::Notice -session $::sid {*}$args } proc Warning {args} { ::unknown log::Warning -session $::sid {*}$args } proc Error {args} { ::unknown log::Error -session $::sid {*}$args } proc Critical {args} { ::unknown log::Critical -session $::sid {*}$args } proc Alert {args} { ::unknown log::Alert -session $::sid {*}$args } proc Emergency {args} { ::unknown log::Emergency -session $::sid {*}$args } } # This version of unknown looks for the unknown procedure on the # Master thread and if found, executes it there and bring back the result. # If it's not found in the Master thread, then the "unknown" of the master # thread will be executed. # Note that this overwrites the original unknown, which we don't need. # # @param args The regular arguments to unknown. # @error proc unknown {args} { global ptid # We let the result and the error propagate. Thread::bgsend $ptid $args } rename exit _exit # Terminate session. # # @param reason Reason for termination. proc exit {{reason "Unspecified"}} { global ptid sid Thread::bgsend $ptid [list ::session::close_session $sid $reason] } # Called on session termination to clean up memory etc. proc cleanup {} { global sid Session $sid SLAVE STDIN STDOUT interp delete $SLAVE catch {close $STDIN} catch {close $STDOUT} thread::release ;# Reference count should now reach 0. } ################################ # Error handling in Session ################################ # Our own error handling procedure for the Master interpreter # # @param msg The error message to display proc bgerror {msg} { global sid errorInfo errorCode # Note: We don't have to rename bgerror just in case another error occurs within bgerror because: # If another Tcl error occurs within the bgerror command (for example, because no bgerror command # has been defined) then Tcl reports the error itself by writing a message to stderr. # If several background errors accumulate before bgerror is invoked to process them, bgerror will # be invoked once for each error, in the order they occurred. However, if bgerror returns with a break # exception, then any remaining errors are skipped without calling bgerror. # # Informationally: This is not the case for "unknown". If an unknown command is executed from # within "unknown", the "unknown" command is executed again recursively. And since the same # code is executed to handle the situation, an endless loop can easily occur. # The following message should be displayed on the users' terminal (if this is a user session). puts stderr $msg log::Error -stack $errorInfo -code $errorCode "Background error in session $sid: $msg" } # Custom errorproc to handle background errors arrising from asynchronous script executions # between threads. If we don't use one, then errors are printed to stderr, which we don't want. # bgerror is executed as well, after this. # # @param threadId Thread Id. # @param errorInfo Error info. proc errorproc {threadId errorInfo} { puts stderr $msg log::Error -stack $stacktrace "Background error in thread $threadId: $errorInfo" } thread::errorproc errorproc ################################ # I/O Wrappers ################################ # A 'gets' wrapper to simulate the behavior of Tcl's gets command when operating on a nonblocking non-canonical # channel, which is what stdin is in a Session thread. # # We have the following requirements from the implementation: # 1. It doesn't set the channel in blocking mode, which would prevent ::session::session_close from closing the session. # 2. When Ctrl + C is pressed, then it returns imediately an empty list. # 3. When Ctrl + ^ and then x, is pressed then it terminates imediately returning an error to the caller which will cause # it to terminate as well. # # It only supports the one-line argument syntax of the original gets: # gets channelId # # Backspace can be used as in the original command. The following options are supported: # -noecho : The typed characters are not displayed back to the user. Appropriate for passwords. (default: echo characters) # -nonewline : Don't print a new line when the user presses enter to submit the string. (default: print newline) # -end : Specifies a string that will signify the end of input. Defaults to newline. This option allow getting multi-line text. # -length : Set a limit on the number of characters the user can enter. (default: no limit) # # @error proc nbgets {args} { global LINE global nbgets_special global nbgets_done global nbgets_break global nbgets_chcount set LINE {} lassign {0 0 0 0} nbgets_special nbgets_done nbgets_break nbgets_chcount # Note: length is set to a hard-coded maximum string input length, that # serves for avoiding Memory DoS attacks. array set Param { noecho 0 nonewline 0 length 100000 end "\n" } for {set i 0} {$i < [llength $args]} {incr i} { switch -exact -- [lindex $args $i] { "-noecho" { set Param(noecho) 1 } "-nonewline" { set Param(nonewline) 1 } "-end" { set Param(end) [lindex $args [incr i]] } "-length" { set Param(length) [lindex $args [incr i]] } default { break } } } set args [lrange $args $i end] # Acceptable syntax after this point: # gets channelId ?varName? switch -exact -- [llength $args] { 0 { set channelId stdin } 1 { set channelId $args } 2 { # This is necessary because we cannot use uplevel/upvar to set a variable on caller's # context, since the caller resides in a different interpreter or a different interpreter & thread. error "unlike Tcl's gets, this version of gets doesn't support the ?varName? parameter" } default { error "wrong # args: should be \"gets channelId\"" } } if {$channelId ne "stdin"} { return [gets $channelId] } fileevent stdin readable [list nbgets_event $channelId [array get Param]] vwait ::nbgets_done if {$nbgets_break} { error "\nbreak sequence pressed" } return $LINE } # Fileevent handler to process and record user input. # # @param channel The channel user input is coming from. # @param param A serialized array with the parameters supported by "nbgets". proc nbgets_event {channel param} { global LINE global nbgets_special global nbgets_done global nbgets_break global nbgets_chcount array set Param $param set ESC "\033" if {[eof $channel]} { fileevent $channel readable {} exit "Connection lost while waiting for user input" } set char [read stdin 1] if {$nbgets_special} { switch -exact -- $char { \u0078 { ;# Ctrl + ^ and then 'x' fileevent stdin readable {} set LINE "" set nbgets_done 1 set nbgets_break 1 ;# On espace sequence we generate error, so that # the caller will halt its operations, and return imediately. } \u0073 { ;# Ctrl + ^ and then 's' # Resize terminal # Handled in session.tcl. } \u0072 { ;# Ctrl + ^ and then 'r' # Reset terminal # Handled in session.tcl. } default { # Consume $data. Do nothing. } } set nbgets_special 0 return } switch -exact -- $char { \u0003 { ;# ^C break fileevent stdin readable {} set LINE "" ;# On espace sequence we return nothing, so that the caller will continue its operations. # Caller cannot distinguise between user entered nothing, and the espace sequence. puts "" ;# newline to prettify output. set nbgets_done 1 } \u007f { ;# backspace if {! $Param(noecho) && $nbgets_chcount > 0} { puts -nonewline "$ESC\[D" puts -nonewline " " puts -nonewline "$ESC\[D" incr nbgets_chcount -1 } set LINE [string range $LINE 0 end-1] } \u001e { ;# Ctrl + ^ (Enter special mode) set nbgets_special 1 } default { if {$char eq "\r"} { set char "\n" } if {[string is print $char] || $char eq "\n"} { set index [expr {[string length $Param(end)]-1}] append LINE $char if {[string range $LINE end-$index end] eq $Param(end)} { set LINE [string range $LINE 0 end-[string length $Param(end)]] if {! $Param(nonewline)} { puts "" } fileevent stdin readable {} set nbgets_done 1 return } if {[string length $LINE] >= $Param(length)} { puts -nonewline "\u7" set LINE [string range $LINE 0 end-1] continue } if {! $Param(noecho)} { puts -nonewline $char } incr nbgets_chcount } else { puts -nonewline "\u7" } } } } # Like 'puts' but automatically switches to --more-- functionality when the string to be printed is going # to take more lines than those available on the remote terminal screen. The follow prerequisites # must also be fulfilled for this to happen: # * The output channel is stdout. # * Flow control is enabled. # We outsource the --more-- functionalily from the external 'more' busybox utility. # # @assume The syntax of the command will not change. # @param args The normal arguments for the 'puts' command. # @error proc more {args} { global sid Session $sid COLUMNS ROWS FLOW set channelId stdout switch -exact -- [llength $args] { 1 { ;# puts string lassign $args txt append txt \n } 2 { if {[lindex $args 0] eq "-nonewline"} { ;# puts -nonewline string lassign $args {} txt } else { ;# puts channelId string lassign $args channelId txt append txt \n } } 3 { ;# puts -nonewline channelId string if {[lindex $args 0] eq "-nonewline"} { ;# puts -nonewline string lassign $args {} channelId txt } else { error "unrecognized option [lindex $args 0]" } } default { error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\"" } } # The easy checks go first, for efficiency. The next checks are more computation intensive. if {$channelId ne "stdout" || ! $FLOW} { puts -nonewline $channelId $txt return } # Calculate the number of lines that the command will take set total 0 foreach line [split $txt "\n"] { incr total [expr { int( ceil( double([string length $line]) / $COLUMNS ) ) }] } # If output does not fit in a screenful, we use --more-- # Note: We cannot use Memchan to store the output, because it only has effect on Tcl code # (not external apps), so we use a regular file. if {$total > $ROWS} { global sid Global WORK_DIR set fd [open [file join $WORK_DIR $sid] w] ;# let the error propagate puts -nonewline $fd $txt close $fd ;# let the error propagate unset txt if {[catch { ptyexec more [file join $WORK_DIR $sid] } errMsg errStack]} { catch { file delete [file join $WORK_DIR $sid] } log::Error -error -stack $errStack "Failed to execute more: " $errMsg } catch { file delete [file join $WORK_DIR $sid] } } else { puts -nonewline $channelId $txt } return } ################################ # Buffering for synchronous output ################################ set outBuffer {} # If prompt is busy executing some command, buffer incoming messages for printing. # Otherwise print at once. # # @param txt The message to be printed. proc pushbuf {txt} { global sid outBuffer Session $sid OUTBUF_SIZE BUSY if {! $BUSY} { puts $txt } else { if {[llength $outBuffer] == $OUTBUF_SIZE} { set outBuffer [lrange $outBuffer 1 end] } lappend outBuffer $txt } } # Retrieve pending messages to be printed. # # @param num The number of messages to retrieve (the oldest ones). If {} then all messages are retrieved. # @return A list of pending messages in chronological order from oldest to most recent. proc popbuf {{num "all"}} { global outBuffer if {$num eq "all"} { set num [llength $outBuffer] } set buf [lrange $outBuffer 0 $num-1] set outBuffer [lrange $num-1 end] return $buf } # Retrieve the number of pending messages. # # @return The number of pending messages. proc bufsize {} { global outBuffer return [llength $outBuffer] }