#
#    Copyright (C) 2010 Alexandros Stergiakis <alsterg@gmail.com>
#
#    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 <http://www.gnu.org/licenses/>.
#

#//#
# 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 <string> : Specifies a string that will signify the end of input. Defaults to newline. This option allow getting multi-line text.
#        -length <num> : 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]
}