# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package hostalive 1.0
# Meta as::author      {Emmanuel Frecon}
# Meta as::build::date 2015-05-22
# Meta as::license     BSD
# Meta as::origin      http://sourceforge.net/projects/til
# Meta description     This module interfaces the PING command line tool to
# Meta description     check the liveness of hosts.
# Meta platform        tcl
# Meta require         {Tcl 8.2}
# Meta require         logger
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.2
package require logger

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide hostalive 1.0

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# hostalive.tcl --
#
#	This modules interfaces the PING command line tool to check
#	the liveness of hosts.
#
# Copyright (c) 2004-2005 by the Swedish Institute of Computer Science.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.



package require Tcl 8.2
package require logger

package provide hostalive 1.0

namespace eval ::hostalive {
    # Initialise the global state
    variable HA
    if {![::info exists HA]} {
	array set HA {
	    idgene        0
	    loglevel      "warn"
	    hosts         ""
	    pingexe       ""
	    headermax     5
	    -period       5
	    -alivecb      ""
	    inheritance   "-period -alivecb"
	}
	variable log [::logger::init [string trimleft [namespace current] ::]]
	${log}::setlevel $HA(loglevel)
    }

    namespace export loglevel new get head syncget synchead infile cancel
}


# ::hostalive::loglevel -- Set/Get current log level.
#
#	Set and/or get the current log level for this library.
#
# Arguments:
#	loglvl	New loglevel
#
# Results:
#	Return the current log level
#
# Side Effects:
#	None.
proc ::hostalive::loglevel { { loglvl "" } } {
    variable HA
    variable log

    if { $loglvl != "" } {
	if { [catch "${log}::setlevel $loglvl"] == 0 } {
	    set HA(loglevel) $loglvl
	}
    }

    return $HA(loglevel)
}


# ::hostalive::__platform -- Return platform unique identification
#
#       This command forms a unique string for the platform on which
#       the current interpreter is running.  The string contains not
#       only the operating system, but also the CPU architecture.
#       This implementation originates from critcl (I think).
#       Examples of returned strings are Windows-x86, Linux-x86 or
#       Darwin-ppc
#
# Arguments:
#	none
#
# Results:
#	Returns a unique platform identification string.
#
# Side Effects:
#	None.
proc ::hostalive::__platform {} {
    global tcl_platform

    set plat [lindex $tcl_platform(os) 0]
    set mach $tcl_platform(machine)
    switch -glob -- $mach {
	sun4* { set mach sparc }
	intel -
	i*86* { set mach x86 }
	"Power Macintosh" { set mach ppc }
    }
    switch -- $plat {
	AIX   { set mach ppc }
	HP-UX { set mach hppa }
    }
    return "$plat-$mach"
}


# ::hostalive::__pingclose -- Close pipe
#
#	This command stops the monitoring of a host through closing
#	the file descriptor of the last ping command that was started.
#
# Arguments:
#	id	Identifier of the watch
#
# Results:
#	none
#
# Side Effects:
#	Will close the pipe file descriptor in some cases.
proc ::hostalive::__pingstop { id } {
    variable HA
    variable log

    set idx [lsearch $HA(hosts) $id]
    if { $idx >= 0 } {
	set varname "::hostalive::Monitor_${id}"
	upvar \#0 $varname Monitor

	${log}::debug "Closing ping pipe for $id ($Monitor(fullname))"
	fileevent $Monitor(fd) readable ""
	catch {close $Monitor(fd)}
	set Monitor(fd) ""
    }
}


# ::hostalive::__pingread -- Reads ping lines.
#
#	This command reads ping lines.  It closes the file descriptor
#	if the EOF was reached (PING died!), or if we were in
#	autoclose mode, which means that the ping implementation does
#	not support the ability to set the period or to continuously
#	ping a host.
#
# Arguments:
#	id	Identifier of the watch
#
# Results:
#	none
#
# Side Effects:
#	Will close the pipe file descriptor in some cases.
proc ::hostalive::__pingread { id } {
    variable HA
    variable log

    set idx [lsearch $HA(hosts) $id]
    if { $idx >= 0 } {
	set varname "::hostalive::Monitor_${id}"
	upvar \#0 $varname Monitor

	# EOF reached or blocked. PING has probably died, so restart the whole
	# continuous ping processing again.
	if { [fblocked $Monitor(fd)] || [eof $Monitor(fd)] } {
	    ${log}::warn "EOF reached or blocked, ping probably died,\
                          restarting"
	    __pingstop $id
	    after [expr {$Monitor(-period) * 1000}] \
		::hostalive::__pingstart $id
	    return
	}

	# Otherwise, there is perhaps something to read.  If there is
	# (non-empty), analyse what is being said there and conclude
	# if the host is alive or not.
	set line [gets $Monitor(fd)]
	if { $line ne "" } {
	    ${log}::debug "Analysing: $line"

	    # Guess state of host
	    set oldstate $Monitor(state)
	    if { [regexp "time(=|<|>)" $line] } {
		set Monitor(state) on
	    } else {
		set Monitor(state) off
	    }
	    
	    # Tell the callers
	    if { $oldstate ne $Monitor(state) && $Monitor(-alivecb) ne "" } {
		if { [catch {eval $Monitor(-alivecb) $id $Monitor(hostname) \
				 $Monitor(state) $Monitor(fullname) \
				 $Monitor(ip)} err] } {
		    ${log}::warn "Error when calling liveness callback: $err"
		}
	    }
	    ${log}::info "$Monitor(fullname) at $Monitor(ip): $Monitor(state)"
	    if { [string is true $Monitor(autoclose)] } {
		__pingstop $id
		after [expr {$Monitor(-period) * 1000}] \
		    ::hostalive::__pingstart $id
	    }
	}
    }
}


# ::hostalive::__pingstart -- Start pinging a host
#
#	This command starts to watch for the presence of a remote
#	host.  It parses the header got back from PING, stores the
#	fullname (unalised) of the host, its IP number and sees to
#	parse the answers from PING.
#
# Arguments:
#	id	Identifier of the watch
#
# Results:
#	?
#
# Side Effects:
#	Will start pinging the remote host.
proc ::hostalive::__pingstart { id } {
    variable HA
    variable log

    set idx [lsearch $HA(hosts) $id]
    if { $idx >= 0 } {
	set varname "::hostalive::Monitor_${id}"
	upvar \#0 $varname Monitor

	# Build the command.  Be sure to understand the pingalways and
	# pingperiod options if we can, since these might help us not
	# restarting the ping program over and over.
	set Monitor(autoclose) on
	set cmd "$HA(pingexe)"
	if { $HA(pingperiod_opt) ne "" } {
	    append cmd " [format $HA(pingperiod_opt) $Monitor(-period)]"
	    if { $HA(pingalways_opt) ne "" } {
		append cmd " $HA(pingalways_opt)"
		set Monitor(autoclose) off
	    }
	}
	if { [string is true $Monitor(autoclose)] } {
	    if { $HA(pingcount_opt) ne "" } {
		append cmd " [format $HA(pingcount_opt) 1]"
	    }
	}
	append cmd " $Monitor(hostname)"

	if { [catch {open "|$cmd"} fd] } {
	    ${log}::warn "Could not start ping as '$cmd'!"
	} else {
	    ${log}::debug "Started ping with: '$cmd'"
	    set Monitor(fd) $fd
	    fconfigure $fd -buffering line

	    # Read header
	    set nbread 0
	    while { $nbread < $HA(headermax) } {
		set line [gets $fd]
		incr nbread
		if { $line ne "" } {
		    ${log}::debug "Header line: $line"
		    # The following algorithm is able to handle the
		    # following types of lines, which are ping results

		    # on a number of architectures:
		    # Pinging doping.sics.se [193.10.65.131] with 32 bytes of data:
		    # PING doping.sics.se (193.10.65.131): 56 data bytes
		    # PING jenny.sics.se (193.10.64.99) 56(84) bytes of data.

		    # First try to look for the word PING (no matter the case)
		    set idx [string first "PING" [string toupper $line]]
		    if { $idx >= 0 } {
			# Once we have found PING, advance to the
			# beginning of the next word, which should
			# contain the full unaliased name of the host
			set idx [string first " " $line $idx]
			incr idx
			set end [string first " " $line $idx]
			set fullname \
			    [string trim [string range $line $idx $end]]
			if { $fullname != $Monitor(fullname) } {
			    set Monitor(fullname) $fullname
			}
			if { [regexp {\d+\.\d+\.\d+\.\d+} $fullname] } {
			    set Monitor(ip) $fullname
			} else {
			    set Monitor(ip) "?.?.?.?"
			}

			# The IP number seem to be enclosed in
			# repeating characters.  The algorithm below
			# does more than what I have seen, it tries to
			# be smart..
			foreach enclosure { "()" "\[\]" "<>" "\"\"" } {
			    set open \
				[string first [string index $enclosure 0] \
				     $line $end]
			    if { $open >= 0 } { break }
			}
			if { $open >= 0 } {
			    set close \
				[string first [string index $enclosure 1] \
				     $line $open]
			    incr open
			    incr close -1
			    set ip \
				[string trim [string range $line $open $close]]
			    if { $ip != $Monitor(ip) } {
				set Monitor(ip) $ip
			    }
			}

			# Get off the header analysis loop, we are
			# ready to get on analysing the ping lines.
			break
		    }
		}
	    }
	    
	    # Now start reading what PING really says...
	    fconfigure $fd -blocking off -buffering line
	    fileevent $fd readable [list ::hostalive::__pingread $id]
	}
    } else {
	${log}::warn "$id does not identify a known host monitoring"
    }
}


# ::hostalive::new -- Start a new continuous ping
#
#	This command starts to watch for the presence of a remote host.
#
# Arguments:
#	host	Name or IP of host
#	args	list of options (-period -alivecb)
#
# Results:
#	Return the identifier of the hostalive continuous check or a negative
#       number on error.
#
# Side Effects:
#	Will start pinging the remote host.
proc ::hostalive::new { hostname args } {
    variable HA
    variable log
    global env

    if { $HA(pingexe) eq "" } {
	# Decide default values. Work on most unix systems.
	switch [__platform] {
	    Linux-x86 {
		set HA(pingalways_opt) "-n"
		set HA(pingcount_opt) "-c %d"
		set HA(pingperiod_opt) "-i %d"
		set pingexe "/bin/ping"
	    }
	    Windows-x86 {
		set HA(pingalways_opt) "-t"
		set HA(pingcount_opt) "-n %d"
		set HA(pingperiod_opt) ""
		set pingexe \
		    [file join [file dirname $env(COMSPEC)] ping.exe]
	    }
	    default {
		set HA(pingalways_opt) "-n"
		set HA(pingcount_opt) "-c %d"
		set HA(pingperiod_opt) "-i %d"
		set pingexe "ping"
	    }
	}
	set HA(pingexe) [auto_execok $pingexe]
	if { $HA(pingexe) eq "" } {
	    ${log}::warn "Could not expand $pingexe to an executable"
	    return -1
	}
    }

    set id [incr HA(idgene)]
    set varname "::hostalive::Monitor_${id}"
    upvar \#0 $varname Monitor

    set Monitor(hostname) $hostname
    set Monitor(fullname) ""
    set Monitor(ip) ""
    set Monitor(fd) ""
    set Monitor(state) ""
    foreach opt $HA(inheritance) {
	set Monitor($opt) $HA($opt)
    }
    lappend HA(hosts) $id
    eval config $id $args

    __pingstart $id

    return $id
}


# ::hostalive::config -- Configure a get operation
#
#	This command set or get the options of a get operation.
#
# Arguments:
#	cid	Connection identifier
#	args	list of options (-timeout -retries -redirects)
#
# Results:
#	Return all options, the option requested or set the options
#
# Side Effects:
#	None.
proc ::hostalive::config { id args } {
    variable HA
    variable log

    # Check that this is one of our hosts
    set idx [lsearch $HA(hosts) $id]
    if { $idx < 0 } {
	${log}::warn "Mass get URL identifier $id is not valid"
	return -code error "Identifier invalid"
    }

    set varname "::hostalive::Monitor_${id}"
    upvar \#0 $varname Monitor

    set o [lsort [array names Monitor "-*"]]

    if { [llength $args] == 0 } {      ;# Return all results
	set result ""
	foreach name $o {
	    lappend result $name $Monitor($name)
	}
	return $result
    }

    foreach {opt value} $args {        ;# Get onr or set some
	if { [lsearch $o $opt] == -1 } {
	    return -code error "Unknown option $opt, must be: [join $o ", " ]"
	}
	if { [llength $args] == 1 } {  ;# Get one config value
	    return $Monitor($opt)
	}
	set Monitor($opt) $value         ;# Set the config value
    }
}


# ::hostalive::defaults -- Set/Get defaults for all new connections
#
#	This command sets or gets the defaults opetions for all new
#	connections, it will not perpetrate on existing pending
#	connections, use ::hostalive::config instead.
#
# Arguments:
#	args	List of -key value or just -key to get value
#
# Results:
#	Return all options, the option requested or set the options
#
# Side Effects:
#	None.
proc ::hostalive::defaults { args } {
    variable HA
    variable log

    set o [lsort [array names HA "-*"]]

    if { [llength $args] == 0 } {      ;# Return all results
	set result ""
	foreach name $o {
	    lappend result $name $HA($name)
	}
	return $result
    }

    foreach {opt value} $args {        ;# Get onr or set some
	if { [lsearch $o $opt] == -1 } {
	    return -code error "Unknown option $opt, must be: [join $o ,]"
	}
	if { [llength $args] == 1 } {  ;# Get one config value
	    return $HA($opt)
	}
	set HA($opt) $value           ;# Set the config value
    }
}