#
#    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/>.
#

#//#
# Procedures to safe interpreter policies in Slave interpreters.
#
# In this file:
#   * Security policy definitions per-AUTHMODE.
#   * Policy switching.
#   * Activation/deactivation of in-line scripting.
#   * Wrapper procedures that enforce session policy:
#
# The security policy defines which Tcl commands are accessible from within the
# safe interpreter in which the command prompt string is evaluated, which includes
# MikroConf commands and Tcl scripts.
#
# When we change AUTHMODE (lower to higher privilege or vise versa) we delete
# the previous "Slave" interpreter and create a new one to evaluatate user in-line code
# and MikroConf commands. This means that all interpreter state is lost:
# Any declared user procedures that are not saved, variables, renames etc are lost
# after changing AUTHMODE. The same happens when deactivate and reactivate inline scripting,
# which translates to changing to a very very limitted AUTHMODE where only MikroConf
# commands are accepted.
#
# Note that deactivation of inline scripting only affects
# command execution and command substitution. It does not affect variable
# substitution which is always possible.
#
#//#

namespace eval policy {
namespace export policy scripting
# Using ::procedure::load and ::pty::ptyexec

# Define policy for the different AUTHMODEs. Every policy defines a modification
# offset from the initial condition of the safe interpreter. If a policy for an
# AUTHMODE is not found, the "user" policy will be used instead.
#
# We start from a safe interpreter, so that we don't have to worry much about
# future unsafe Tcl commands.
#
# The initial state of the safe interpreter of Tcl 8.5.1 is (subject to change in future versions):
#       aliases: clock
#       hidden: file socket open unload pwd glob exec encoding fconfigure load source exit cd
#       visible: tell subst eof list pid time eval lassign lrange fblocked lsearch gets case lappend
#                   proc break variable llength return linsert error catch clock info split array if concat
#                   join lreplace fcopy global switch update close for append lreverse format read
#                   package set binary namespace scan apply trace seek while chan flush after
#                   vwait dict continue uplevel foreach lset rename fileevent regexp lrepeat upvar
#                   expr unset regsub interp puts incr lindex lsort string
#
# So if you want to expose some of the hidden commands, enter them in the "expose" list.
# If you want to hide one of the visible, append it in the "hide" list.
# To establish an alias for a by-default hidden command just enter it in the "alias" list. If
# by default is visible, enter it also in the "hide" list. "bgexec" and "unknown" procedures are
# always available even when inline scripting is turned off.
#
# Note that "info body" cannot be used to view the body of a protected
# command, as well as any aliases, hidden and builins (set, puts, ...).
# Also note that the 'history' command is not created on a slave interpreter by default,
# it exists only on the Master.
#
# All alias targets are expected to be found inside the Session thread/interp. If an alias
# specification has the form:
#        alias {rename}
# then the target will be automatically set to "::policy::slave_rename". However if the form is:
#        alias {{rename ::_rename}}
# then the target will be set to whatever the second argument is.
#
# Finally if a request for an action cannot be performed (e.g. hide an already hidden
# command) MikroConf will log it and cause an error (which is not caught in purpose).

variable Policy {
    bg {
        hide {clock chan interp rename package}
        expose {}
        alias {unknown proc gets read fileevent fconfigure flush}
    }
    priv {
        hide {clock chan interp package}
        expose {cd exec file glob load open pwd socket}
        alias {rename proc unknown gets read fileevent fconfigure flush}
    }
    user {
        hide {clock chan interp package}
        expose {}
        alias {rename proc unknown gets read fileevent fconfigure}
    }
}

# The above recommened minimums have the following rationale:
#       clock: We hide it because there is a MikroConf command with same name.
#       interp: We don't want the user to create new interpreters, because
#                   these new interpreters don't inherit the restrictions of
#                   the parent for Command Execution Speed.
#       info : We need to invoke at any time "$SLAVE invokehidden info ...".
#       unknown : This command is executed when the entered text is
#                 not recognized as a Tcl command. An attempt is made to
#                 recognize the command as a MikroConf command, in which case it
#                 executes it and returns whatever it is returned by the command.
#                 Otherwise, if the command is a single word 
#                   then the default behavior is to regard it as an attempt to
#                   connect to a host with that host name. Otherwise an error 
#                   message is displayed.
#       rename & proc : We provide secure versions of these commands
#               that name restrictions on user-defined procedures. 'proc' should be aliased in
#               bg Policy for user-registered procedures to be evaluated.
#       fconfigure & flush: We want to protect standard I/O from changing
#               its properties (buffering, blocking etc) regardless of the scope of
#               these changes (Slave alone, Slave-Session, or Slave-Session-Master)
#       fileevent : We have already a fileevent for stdin. We don't want the user
#               to register other fileevents for any standard I/O that would replace (or
#               compete) with the one already in place.
#       bgerror : Should always be available to report background errors, which
#               can occur with scripting off or on.
#       gets : Due to the nature of the I/O redirection from shell to MikroConf and
#                 back to shell, we cannot use Tcl's gets. Tcl's gets assumes that stdin
#                is in blocking mode, with echo enabled (as well as line buffering
#                and cannonical mode). We can not enable echo on MikroConf
#                because it is the shell that set the real terminal in raw & no-echo mode.
#               Therefore, we simulate echo and the standard behavior of 'gets'.
#       package : Due to a name collision with the same name MikroConf command.
#                 Afterall, all available packages and commands will be loaded by default.
#
#               
# Note: The following commands are left visible in purpose, but can be
#            made hidden or aliases.
#   close : The standard I/O can be closed on Slave, but this does not
#               affect the Session interpreter which is sharing these I/O. Of
#               course after closing the standard I/O, the user session will be
#               largely impaired, but it won't affect parallel or future sessions,
#               of the users ability to terminate the session with the escape
#               sequence.
#   after : Since Session & Slave interpreters share the same event
#               loop, and since this event loop will be activated (vwait) from
#               Session, any after command will be automatically scheduled
#               for execution inside Slave. This means that scheduled commands
#               can pop up while the user is in an undergoing async interaction
#               with a MikroConf command. This can cause scheduled
#               actions with 'after' and async actions from an on-going
#               MikroConf command to be intermingled. Although this can
#               distract/confuse the user, it has no other side-effects. 
#   interp : The 'interp' command of a safe interpreter cannot be used
#                to change the state of the safe interpreter itself.

# Creates a safe interpreter used to evaluate user's in-line scripting and applies a security policy to it.
#
# @assume The command "info" is available in a newly created safe interpreter.
#
# @param authmode The AUTHMODE of which the policy we are switching to.
proc policy {authmode} {    
    global sid
    variable Policy 
    Session $sid SLAVE INLINE
    Session -rw $sid COMMANDS ALIASES HIDDEN

    log::Debug "Enforcing Tcl security policy in session \"$sid\""
    
    if {[interp exists $SLAVE]} {
        interp delete $SLAVE
    }    
    interp create -safe $SLAVE

    # Share standard I/O.
    # Note: If the user closes them in Slave, they remain open in Session interpreter.
    interp share {} stdin $SLAVE
    interp share {} stdout $SLAVE
    interp share {} stderr $SLAVE
    
    # Record initial state in these variables.
    set COMMANDS [$SLAVE eval [list info commands]] ;# This requires "info" to be available after safe interp creation
    set ALIASES [$SLAVE aliases]
    set HIDDEN [$SLAVE hidden]

    if {! $INLINE} {
        foreach cmd $COMMANDS {
            interp hide $SLAVE $cmd
        }
        foreach cmd $ALIASES {
            interp alias $SLAVE $cmd {}
        }
        interp alias $SLAVE unknown {} ::policy::slave_unknown $SLAVE
        interp alias $SLAVE bgerror {} ::policy::slave_bgerror $SLAVE
        return
    }
    
    # If a policy is not explicitly defined for this AUTHMODE, then use the most restrictive "user" policy.
    if {! [dict exists $Policy $authmode]} {
        set authmode "user"
    }
    
    set tohide [dict get $Policy $authmode hide]
    set toexpose [dict get $Policy $authmode expose]
    set toalias [dict get $Policy $authmode alias]

    foreach cmd [::struct::set union $COMMANDS $toalias] {
        if {$cmd in $tohide} { ;# Note: aliases can be hidden, but only if there is no original command of same name already hidden.
            interp hide $SLAVE $cmd
        } elseif {$cmd in $toexpose} {
            interp alias $SLAVE $cmd {} ::policy::slave_all $SLAVE $cmd
        } elseif {[set pos [lsearch -exact -index 0 $toalias $cmd]] >= 0} {
            catch { interp hide $SLAVE $cmd }
            if {[llength [lindex $toalias $pos]] == 1} {
                interp alias $SLAVE $cmd {} ::policy::slave_${cmd} $SLAVE
            } else { ;# == 2
                interp alias $SLAVE $cmd {} [lindex $toalias $pos 1] $SLAVE
            }
        } else {
            interp hide $SLAVE $cmd
            interp alias $SLAVE $cmd {} ::policy::slave_all $SLAVE $cmd
        }
    }
    
    # Load registered user procedures in trusted sessions only.
    if {$authmode eq "priv" || $authmode eq "bg"} {
        loadprocs
    }
}

# Load all registered procedures to this session.
proc loadprocs {} {
    global sid
    Session $sid SLAVE

    log::Debug "Loading procedures in session \"$sid\""
    
    foreach name [procedures getlist] {
        lassign [procedures getproc $name] args body
        if {[catch {
            $SLAVE invokehidden proc $name $args $body
        } errMsg errStack]} {
            log::Alert -stack $errStack "Failed to load user procedures in user session $sid: " $errMsg
        }
    }
}

# Activates/Deactivates/Resets in-line scripting on the fly.
# Scripting is deactivated by recreating the Slave interpeter, having all Tcl commands,
# and procedures hidden, except for "unknown" and "bgerror".
#
# @param action "on" or "off".
proc scripting {action} {
    global sid
    Session $sid SLAVE AUTHMODE
    Session -rw $sid INLINE

    switch -exact -- $action {
        "off" {
            set INLINE 0
        }
        "on" {
            set INLINE 1
        }
        default {
            log::Error -error "invalid subcommand"
        }
    }
    
    policy $AUTHMODE
}

################################
# Wrappers section
################################

# Few words regarding wrapper commands:
#
# The wrappers enforce some security checks on the respective commands. For example,
# preventing the user from messing up with stdout, stderr and stdin. However, the command itself is
# eventually executed in the Slave interpreter after having (potentially) being modified in
# the Session. We do this by invoking hidden commands on the Slave/Safe interpreter.

# All commands in Slave are aliases to Session wrappers. If a command doesn't have
# a unique wrapper, it is linked to slave_all wrapper, which in turn calls the hidden command
# on the Slave. By having all commands hidden we can always recover them, whereas
# at the same time the user can rename overwrite aliases like normal. Pictorically, when
# the user executes a buildin Tcl command on the Slave, the following sequence of events
# occurs:
#
#   Slave: fconfigure "..." --> Session: slave_fconfigure "...." --> Slave: invoke hidden fconfigure "..."
#

# Wrapper for all the commands that don't have a wrapper of their own.
#
# @param slave The name of the interpreter from which this procedure was called
# @param name The name of the command executed on the Slave interpreter
# @param args The remaining command arguments (if any)
proc slave_all {slave name args} {
    $slave invokehidden $name {*}$args
}

# Wrapper for 'gets' to use the version of the Session.
#
# @param slave The name of the interpreter from which this procedure was called
# @param args The remaining command arguments (if any)
proc slave_gets {slave args} {
    nbgets {*}$args
}

# Wrapper for 'fconfigure'
# We don't allow the user to mess up with the fconfigure settings of stdout, stderr and stdin.
#
# @assume The syntax of the command will continue have channelId as its first argument.
#
# @param slave The name of the interpreter from which this procedure was called
# @param channelId The channel to operate on
# @param args The remaining command arguments (if any)
proc slave_fconfigure {slave channelId args} {    
    if {$charnnelId in [list stdout stderr stdin]} {
        error "action not permitted"
    }
    
    $slave invokehidden fconfigure $channelId {*}$args
}

# Wrapper for 'read'
# We don't allow the user to read from stdin.
#
# @assume The syntax of the command will not change in future versions of Tcl, or we need to update this code
#
# @param slave The name of the interpreter from which this procedure was called
# @param args The standard command arguments for read (if any)
proc slave_read {slave args} {
    if {"stdin" in $args} {
        error "action not permitted"
    }
    
    $slave invokehidden read {*}$args
}

# Wrapper for 'flush'
# We don't allow the user to mess up with stdout, stderr and stdin.
#
# @assume The syntax of the command will continue have channelId as its first argument.
#
# @param slave The name of the interpreter from which this procedure was called
# @param channelId The channel to operate on
# @param args The remaining command arguments (if any)
proc slave_flush {slave channelId} {    
    if {$charnnelId in [list stdout stderr stdin]} {
        error "action not permitted"
    }
    
    $slave invokehidden flush $channelId
}

# Wrapper for 'fileevent'
# We don't allow the user to mess up with the fconfigure settings of stdout, stderr and stdin.
#
# @assume The syntax of the command will continue have channelId as its first argument.
#
# @param slave The name of the interpreter from which this procedure was called
# @param channelId The channel to operate on
# @param args The remaining command arguments (if any)
proc slave_fileevent {slave channelId args} {    
    if {$charnnelId in [list stdout stderr stdin]} {
        error "action not permitted"
    }
    
    $slave invokehidden fileevent $channelId {*}$args
}

# Wrapper for 'rename' that enforce naming restrictions on user-defined procedures.
#
# @param slave The name of the interpreter from which this procedure was called
# @param args The regular Tcl rename arguments
proc slave_rename {slave args} {
    global sid
    
    if {[llength $args] != 2} {
        error {wrong # args: should be "rename oldName newName"}
    }
    lassign $args from to

    if {! [regexp {^[A-Z_0-9].*$} $from] || ! [regexp {^[A-Z_0-9].*$} $to]} {
        error "procedure names should start with a capital latin letter, underscore or number"
    }

    $slave invokehidden rename $from $to
}

# Get the $policy policy for $authmode authmode.
#
# @param authmode Name of authentication mode.
# @param policy Name of policy.
# @return A list describing the policy.
proc get_policy {authmode policy} {
    variable Policy
    if {[dict exists $Policy $authmode]} {
        return [dict get $Policy $authmode $policy]
    } else {
        return [dict get $Policy "user" $policy]
    }
}

# Wrapper for 'proc' that enforce naming restrictions on user-defined procedures.
#
# @param slave The name of the interpreter from which this procedure was called
# @param args The regular Tcl proc arguments
proc slave_proc {slave args} {
    global sid
    
    if {[llength $args] != 3} {
        error {wrong # args: should be "proc name args body"}
    }
    lassign $args name params body
    
    if {! [regexp {^[A-Z_0-9].*$} $name]} {
        error "procedure name should start with a capital latin letter, underscore or number"
    } 
    
    $slave invokehidden proc $name $params $body
}

# This is the unknown procedure on the Slave, linked here as an alias.
# If it is executed it means that the provided command is neither a build-in
# Tcl command, nor a user-defined procedure. Hence we first check to see if
# its a MikroConf command. If not recognized as MikroConf command, then if
# it is a single argument, unknown assumes that it is a hostname that
# we want to connect to, otherwise it displays an error.
#
# @param slave The name of the interpreter from which this procedure was called
# @param args The command name and arguments that are not known to the interpreter
# @error
proc slave_unknown {slave args} {
    global sid ptid
   
    if {[tsv::get $sid TERM]} { return } ;# Do nothing. Skip any command.
    
    # If recognized as a MikroConf command, give it to Master for execution
    if {[sysconf match $sid -count $args 0]} {
        return [Thread::bgsend $ptid [list sysconf execute $sid $args]]
    }
    
    Session $sid TRYCONNECT
    if {$TRYCONNECT} {
        if {[llength $args] != 1} {
            error "invalid command name \"[lindex $args 0]\""
        }

        # Note: "exec" bypasses shell interpretation and substitutions, so we don't have to
        #       worry of specially crafted input to exec that tries to circumvent security. An
        #       example is: exec -- telnet {; cat /etc/passwd}.
        #       Telnet will literally try to connect to host {; cat /etc/passwd}, and it will fail.
        # We don't propagate a possible error in purpose, because the error is printed 
        # by telnet on stderr, and we don't want to print a second error message. 
        ptyexec telnet $args
    } else {
        error "invalid command name \"[lindex $args 0]\""
    }
}

# Error handling procedure for slave interpreters.
#
# @param slave The slave interpreter that generated the error
# @param msg The error message to display
proc slave_bgerror {slave msg} {
    # errorInfo and errorCode hold info regarding the error, but we don't use them
    puts "background error occured: $msg"
}

} ;# End of Namespace