#
#    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 that facilitate module writting. It should be loaded from the Master only,
# not Sessions.
#//#

namespace eval helper {
    # Misc
    namespace export parseconf secs2age
    
    # File Operations
    namespace export checkfs removeline
    
    # Handle blocking
    namespace export timeout blocks break_event
    
    # Process Control
    namespace export kill killall isrunning ptyexec pidof
    
    # Dependency checking
    namespace export kernel_has busybox_has
    
    # Argument type checking
    namespace export ishostname isdomainname isip isip4 isip6 isipport isemail
    
    # Access of Session I/O from Master
    namespace export sget sputs sflush sread ask

interp create -safe -- ::helper::parseconf_interp

# Parse a configuration file consisting of instructions of the form var = val.
# Load these definitions in the $gvar shared memory array, that belongs to
# corresponding MikroConf module.
#
# The "val" part of each assignment can refer to other variables that belong to
# different MikroConf modules. But in order for these other variables to be
# in-scope, the corresponding module name (or modules as a list) must be provided 
# as the last argument.
#
# Note: Once the variables of module A become accessible in module B, then
# a third module C that loads B's variables, will load A's as well, automatically.
#
# Note: The "conf" shared memory array is accessible to all modules by default.
#
# @param gvar The name of the shared memory array.
# @param filepath The name/path of the configuration file to parse.
# @param args List of MikroConf module names whose variables should be in scope of \
  the parsed configuration instructions. The variable assignments in MikroConf \
  initialization file is by default within scope.
proc parseconf {gvar filepath args} {
    if {$gvar ne "conf"} {
        lappend args conf ;# conf is within scope by default.
    }
    parseconf_interp eval [list namespace eval $gvar {}]
    foreach ns $args {
        foreach var [parseconf_interp eval [list info vars ${ns}::*]] {
            parseconf_interp eval [list namespace inscope $gvar [list upvar $var [namespace tail $var]]]
        }
    }
    foreach line [split [::fileutil::cat $filepath] "\n"] {
        if {[lempty $line] || [string match {#*} $line]} {
            continue
        }
        lassign [split $line =] var val
        set var [string trim $var]
        set val [string trim $val]
        set val [parseconf_interp eval [list namespace inscope $gvar [list subst -nocommands $val]]]
        parseconf_interp eval [list namespace inscope $gvar [list variable $var $val]]
        tsv::set $gvar $var $val
    }
}

# Check that a filesystem entity exists and it has specific properties.
# The following flags are supported:
#   r : Entity is readable
#   w : Entity is writable
#   x : Entity is executable
#   f : Entity is a file
#   d : Entity is a directory
#   c : Create entity if it does not exist
# Any combinatio of these flags can be used.
#
# @param type "-dir" or "-file"
# @param path The path of the entity.
# @param flags A list of flags to check.
# @param text The text to write to the file, if it is being created (flag 'c').
# @error
proc checkfs {type path {flags {}} {text {}}} {
    if {! [file exists $path]} {
        if {"c" in $flags} {
            log::Info "Warning: $path does not exist; creating now.."
            switch -exact -- $type {
                "-dir" {file mkdir $path}
                "-file" {write_file "$path" "$text"}
                default {error "unrecognized type: $type"}
            }
        } else {
            error "$path does not exist"
        }
    }

    switch -exact -- $type {
        "-dir" {
            if {! [file isdirectory $path]} {
                error "$path is not a directory"
            }
        }
        "-file" {
            if {! [file isfile $path]} {
                error "$path is not a file"
            }
        }
        default {error "unrecognized type: $type"}
    }
        
    foreach f $flags {
        switch -- $f {
            "r" {
                if {! [file readable $path]} {
                    error "$path file is not readable"
                }
            }
            "w" {
                if {! [file writable $path]} {
                    error "$path file is not writable"
                }
            }
            "x" {
                if {! [file executable $path]} {
                    error "$path file is not executable"
                }
            }
            "c" {}
            default {
                error "unrecognized option $f"
            }
        }
    }
}

# Checks that a string is a valid IP hostname.
#
# Validity:
# Hostnames, like all domain names[1], are made up of a series of "labels",
# with each label being separated by a dot. Each label must be between 1 and 63
# characters long, and there is a maximum of 255 characters when all labels are combined.
# Unlike domain names, hostname labels can only be made up of the ASCII letters 'a' through 'z'
# (case-insensitive), the digits '0' through '9', and the hyphen. Labels cannot start nor end
# with a hyphen. Special characters other than the hyphen (and the dot between labels) are
# not allowed, although they are sometimes used anyway. 
#
# @todo How many labels?
# @todo Can a label start with [0-9]? (currently we don't allow)?
#
# @link http://tools.ietf.org/html/rfc952
#
# @param str The input string to check.
# @return '1' is it is hostname is legal, otherwise '0'.
proc ishostname {str} {
    set RE {^[a-zA-Z]([a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?(\.[a-zA-Z]([a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?)*$}
    return [expr {0 < [string length $str] <= 255 && [regexp $RE $str]}]
}

# Checks that a string is a valid IP domain name.
#
# Validity:
# Like hostnames (see above) but also the underscore character can be used.
#
# @todo Verify validity.
# @todo Support for international domain names (e.g. with greek characters in them)
#
# @link http://tools.ietf.org/html/rfc1034
#
# @param str The input string to check.
# @return '1' is it is hostname is legal, otherwise '0'.
proc isdomainname {str} {
    set RE {^[a-zA-Z]([a-zA-Z0-9_-]{0,61}[a-zA-Z0-9])?(\.[a-zA-Z]([a-zA-Z0-9_-]{0,61}[a-zA-Z0-9])?)*$}
    return [expr {0 < [string length $str] <= 255 && [regexp $RE $str]}]
}

# Checks if an string represents a legal IPv4 address.
#
# @param str The input string to check.
# @return '1' is it is a legal IPv4, otherwise '0'.
proc isip4 {str} {
    set octet {(\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5])}
    set RE "^[join [list $octet $octet $octet $octet] {\.}]\$"
    return [regexp $RE $str]
}

# Checks if an string represents a legal IPv6 address.
#
# @param str The input string to check.
# @return '1' is it is a legal IPv6, otherwise '0'.
proc isip6 { str } {
    expr {[ip::version $str] == 6}
}

# Checks if an string represents a legal IP address (v4 or v6).
#
# @param str The input string to check.
# @return '1' is it is a legal IP, otherwise '0'.
proc isip {str} {
    return [expr {[isip4 $str] || [isip6 $str]}]
}

# Checks if a string has a format that is compatible with normal RFC SMTP email address formats.
#
# @limit It does not account for comments embedded within email \
addresses, which are defined even though seldom used.
#
# @param str The input string to check.
# @return '1' is it is valid email address, otherwise '0'.
proc isemail {str} {
    return [regexp {^[A-Za-z0-9._-]+@[A-Za-z0-9.-]+$} $str]
}

# Check if a string is a valid TCP/UDP port number.
#
proc isipport {port} {
    return [expr {[string is integer $port] && (0 <= $port <= 65535)}]
}

# Remove lines from a file that match a given pattern. Update file in place.
# A temporary file $filepath.new is used internally.
#
# @param filepath The filepath of the file. The file must pre-exist.
# @param pattern A "string match" pattern.
# @error
proc removeline {filepath pattern} {
    set fd [open "${filepath}.new" w]
    if {[catch {
        foreach line [split [::fileutil::cat $filepath] "\n"] {
            if {! [string match $pattern $line]} {
                puts $fd $line
            }
        }
    } errMsg errStack]} {
        close $fd
        return -options $errStack $errMsg
    }
    close $fd
    
    if {[catch {
        file rename -force ${filepath}.new $filepath
    } errMsg errStack]} {
        file delete -force ${filepath}.new
        return -options $errStack $errMsg
    }
}

# Convert a duration in secs to a string describing the duration, involving days, hours, mins & secs.
#
# @assume Input argument is sane.
# @param secs Absolute number of seconds.
# @param format Requests a specific format for the returned string. Supported: -full -simple
# @return A string.
proc secs2age {secs {format -full}} {
    set days [expr {$secs / 86400}]
    set secs [expr {$secs % 86400}]
    set hours [expr {$secs / 3600}]
    set secs [expr {$secs % 3600}]
    set mins [expr {$secs / 60}]
    set secs [expr {$secs % 60}]
    
    set result {}
    switch -exact -- $format {
        "-full" {
            if {$days != 0} { append result "$days Days " }
            if {$hours != 0} { append result "$hours Hours " }
            if {$mins != 0} { append result "$mins Mins " }
            append result "$secs Secs "
        }
        "-simple" {
            if {$days != 0} { append result "${days}D" }
            if {$hours != 0} { append result "${hours}H" }
            if {$mins != 0} { append result "${mins}M" }
            append result "${secs}S"
        }
    }
    
    return $result
}

# Execute a script in the context of the caller, but wait up to $secs number of secs 
# for the script to finish evaluation. If after $secs seconds the script is still executing
# then it will be forcefully interrupted. The interruption will seem to the caller like an
# error that the script generated.
#
# This procedure should be used always to avoid blocking the Master for an unknown
# period of time. However notice that this procedure alone doesn't safeguards the Master
# from blocking. See ::helper::blocks for mitigating this.
#
# @todo Make to interrupt script evaluation when Ctrl ^ + x is presssed.
# @param secs Number of seconds to wait.
# @param script Script to execute.
# @error
proc timeout {secs script} {    
    if {[catch {
        signal trap SIGALRM {error "Timeout waiting"}
        alarm $secs
        uplevel $script
    } result options]} {
        # Either timeout or an error while evaluating the script.
        signal ignore SIGALRM ;# For the case of error
        return -options $options $result
    }
    signal ignore SIGALRM
}

proc blocks {script} {
# XXX
    uplevel $script
}

proc break_event {sid} {
# XXX
}

# Check that the running kernel supports a specific feature.
#
# @param feature The name of the feature to be checked, e.g. CONFIG_INOTIFY.
# @return '1' if supported, '0' otherwise.
# @error
proc kernel_has {feature} {
    Global KERNEL_CHKS
    if {! $KERNEL_CHKS} { return 1 }
    global KCONFIG
    return [expr {("${feature}=y" in $KCONFIG) || ("${feature}=m" in $KCONFIG)}]
}

# Check that the installed busybox supports a specific feature.
#
# @param feature The name of the feature to be checked, e.g. CONFIG_ASH
# @return '1' if supported, '0' otherwise.
# @error
proc busybox_has {feature} {
    Global BUSYBOX_CHKS
    if {! $BUSYBOX_CHKS} { return 1 }
    global BCONFIG
    return [expr {"${feature}=y" in $BCONFIG}]
}

# Find if a certain executable (usually a daemon) is running.
#
# @param name Name of executable e.g. syslogd
proc isrunning {name} {
    if {[catch {exec pidof $name}]} { ;# 'pidof' exits with error if no process found.
        return 0
    } else {
        return 1
    }
}

# Return a list of process ids for all the processes with executable $name.
#
# @param name Name of executable e.g. syslogd
# @return A list of PIDs, or the empty list.
proc pidof {name} {
    if {[catch {
        exec pidof $name
    } result]} {
        return
    }
    return $result
}

# Send a signal to a process.
# @todo Check to see if it was actually killed, and log error if not.
proc kill {sig ps} {
    log::Debug "Killing process $ps ($sig)"
    exec kill -${sig} $ps
}

# Kill all processses with the specified name.
# First try -TERM, then try -KILL. Log errors.
#
# @param name Name of executable e.g. syslogd
# @todo Check to see if it was actually killed, and log error if not.
proc killall {name} {
    log::Debug "Killing process $name"
    catch { exec killall -q -TERM $name }
    catch { exec killall -q -KILL $name }
}

# Access the version of "flush" of the Session.
#
# @param args The standard "flush" arguments.
proc sflush {args} {
    # Note: The operation here must be asynchronous, becase these wrappers
    # are used from log, emit .. which can be initiated from within Session/Slave.
    set sid [::session::get_sessionId]
    Thread::bgsend $sid [list flush {*}$args]
}

# Access the version of "gets" of the Session.
#
# @param args The standard "flush" arguments.
proc sgets {args} {
    # Note: The operation here must be asynchronous, becase these wrappers
    # are used from log, emit .. which can be initiated from within Session/Slave.
    set sid [::session::get_sessionId]
    Thread::bgsend $sid [list nbgets {*}$args]
}

# Access the version of "read" of the Session.
#
# @param args The standard "flush" arguments.
proc sread {args} {
    # Note: The operation here must be asynchronous, becase these wrappers
    # are used from log, emit .. which can be initiated from within Session/Slave.
    set sid [::session::get_sessionId]
    Thread::bgsend $sid [list read {*}$args]
}

# Access the version of "puts" of the Session.
#
# @param args The standard "flush" arguments.
proc sputs {args} {
    # Note: The operation here must be asynchronous, becase these wrappers
    # are used from log, emit .. which can be initiated from within Session/Slave.
    set sid [::session::get_sessionId]
    Thread::bgsend $sid [list more {*}$args]
}

# A convenience proc to prompt the user for some value.
# This is an interactive procedure that operates in a Session thread.
#
#   ask ?options? question
#
# The following options are supported:
#   -type <type> : The answer is accepted only if it is of type <type>, which can
#       be any of the types supported by "string is <type>". Default type: "ascii".
#   -default <value> : Specifies the default value which is used when the user
#       presses enter without providing a value.
#   -list <list> : The list of possible answers (can be used in conjuction with -type,
#       or on its own).
#   -min <min> : When the answer is a number, this is the minimum acceptable.
#   -max <max> : When the answer is a number, this is the maximum acceptable.
#   -check <proc> : Execute the specifies procedure with a single argument the
#       user's answer, and it should return a boolean. If true the answer is valid,
#       otherwise is not acceptable.
#   -eval <string> : Similar to -check , but this is a Tcl script that is evaluated on
#       global scope. Any occurence of %% inside <string> is substituted with the
#       provided answer by the user.
#   -switch <switch> : This switch simplifies execution of external programs that
#       accept command line switches, that depend on user's answers. For boolean
#       answers "ask" will return <switch> verbatim, whereas for any other type it will
#       return "<switch> <answer>".
#   -neg : When -type is boolean, this switch will reverse the normal return value.
#       Instead of returning <switch> when answer is true, it returns it when it evaluates
#       to false.
#   -noswitch : When used together with -default, this switch will cause "ask" to return
#       nothing (no switch), when the user provided the default value.
#   -hidedef : This will hide the the square brackets after the question with the default answer.
#   -nonewline : See the "nbgets" procedure in thread.tcl.
#   -noecho : See the "nbgets" procedure in thread.tcl.
#   -end : See the "nbgets" procedure in thread.tcl.
#   -length : See the "nbgets" procedure in thread.tcl.
#
# @param args See description above.
# @return Either the empty list or a string.
# @error
proc ask {args} {
    array set Param {
        "-type" ascii
        "-end" "\n"
    }
    
    set switches {}
    for {set i 0} {$i < [llength $args]} {incr i} {
        set arg [lindex $args $i]
        switch -exact -- $arg {
            "-type" -
            "-default" -
            "-list" -
            "-min" -
            "-max" -
            "-check" -
            "-eval" -
            "-switch" {
                set Param($arg) [lindex $args [incr i]]
            }
            "-neg" -
            "-hidedef" -
            "-noswitch" {
                set Param($arg) 1
            }
            "-nonewline" -
            "-noecho" {
                lappend switches $arg
            }
            "-end" -
            "-length" {
                lappend switches $arg [lindex $args [incr i]]
            }
            default {
                set question $arg
                break
            }
        }
    }
    
    for {} {1} {} {
        sputs -nonewline $question
        if {[info exists Param(-default)] && ! [info exists Param(-hidedef)]} {
            sputs -nonewline "\[$Param(-default)\] "
        }
        
        if {[catch {
            set answer [sgets {*}$switches]
        } errMsg errStack]} {
            sputs "" ;# newline
            return -options $errStack $errMsg
        }
        
        # Enforce default.
        if {[lempty $answer]} {
            if {[info exists Param(-default)]} {
                set answer $Param(-default)
            } else {
                continue
            }
            
        } else {
            # Check type.
            if {! [string is $Param(-type) $answer]} {
                sputs "illegal value; wrong type"
                continue
            }
            
            # Check min.
            if {[info exists Param(-min)]} {
                if {$answer < $Param(-min)} {
                    sputs "out of range; minimum allowed is: $Param(-min)"
                    continue
                }
            }
    
            # Check max.
            if {[info exists Param(-max)]} {
                if {$answer > $Param(-max)} {
                    sputs "out of range; maximum allowed is: $Param(-max)"
                    continue
                }
            }
            
            # Check "-list".
            if {[info exists Param(-list)]} {
                if {$answer ni $Param(-list)} {
                    sputs "illegal value; not one of possible options"
                    continue
                }
            }
            
            # Check "-check".
            if {[info exists Param(-check)]} {
                if {! [$Param(-check) $answer]} {
                    sputs "illegal value"
                    continue
                }
            }
            
            # Check "-eval".
            if {[info exists Param(-eval)]} {
                set txt [string map "%% {$answer}" $Param(-eval)]
                if {! [eval $txt]} {
                    sputs "illegal value"
                    continue
                }
            }
        }
        
        if {$Param(-type) eq "boolean"} {
            if {[info exists Param(-switch)]} {
                if {[info exists Param(-noswitch)] && [info exists Param(-default)] && $answer eq $Param(-default)} {
                    return
                }
                if {bool($answer)} {
                    if {[info exists Param(-neg)]} {
                        return
                    }
                    return $Param(-switch)
                } else {
                    if {[info exists Param(-neg)]} {
                        return $Param(-switch)
                    }
                    return
                }
            }
            return $answer
        } else {
            if {[info exists Param(-noswitch)] && [info exists Param(-default)] && $answer eq $Param(-default)} {
                return
            }
            if {[info exists Param(-switch)]} {
                return "$Param(-switch) $answer"
            }
            return $answer
        }
    }
}

} ;# End of Namespace