#! /usr/bin/expect --
#
# Last updated : Mon Nov 11 23:12:09 2002
#

# I'd forgotten that expect was basically tcl with some extra bits so
# we can use it to prompt at the end with a suitable timeout and have
# actions carry on...

## JSP: functions etc

# Make the authentication attempt
proc doAuth { } {
    global status c rhost rport user pword rlogi
    global authstring doc realm
    
    if {$authstring == ""} {
	set authstring [ base64::encode "$user:$pword" ]
    }
    
    set stc [doWebFetch $rhost $rport $rlogi]

    if { $stc != "200" } {
	set authstring ""
	if {$stc == "401"} {
	    set status "Failed $realm"
	} else {
	    set matched ""
	    regexp {^[0-9]+$} $stc matched
	    if {$matched != ""} {
		set status "Failed to authenticate: code $stc"
	    } else {
		set status "Failed to authenticate: $stc"
	    }
	}
	return
    }
    set refpat {Refresh: +([0-9]+)}
    set matched ""
    set sub1 ""
    regexp $refpat $doc matched sub1

    if { $sub1 != "" } {
	set retry [expr $sub1 * 1000]
    } else {
	puts "No Refresh guessing 100 secs"
	set retry 100000
    }

    # call outselves again later to re-authenticate
    after $retry doAuth
}

# Set the realm...
proc getrealm {} {
  global status rhost rport rlogi realm argv
  set stc [doWebFetch $rhost $rport $rlogi]
  if { $stc == "401" } {
      set status "Enter $realm"
  }
}

# Update the status string to say how long we have been connected
proc updatelogged {} {
    global lsec status
    set secs [expr [clock seconds] - $lsec]
    set mins [expr $secs / 60]
    set secs [expr $secs % 60]
    set hors [expr $mins / 60]
    set mins [expr $mins % 60]
    if {$hors > 23} {
	set days [expr $hors / 24]
	set hors [expr $hors %24]
	if {$days > 1} {
	    set dstr "days"
	} else {
	    set dstr "day"
	}
	set status [format "Logged in for %d %s %2.2d:%2.2d:%2.2d" $days $dstr $hors $mins $secs]
    } else {
	set status [format "Logged in for %2.2d:%2.2d:%2.2d" $hors $mins $secs]
    }
    # For debugging
#    puts $status
#    # Call again (will this always be right?)
#    after 5000 updatelogged
}

# Disconnect from network   
proc doDeauth {} {
    global status authstring rhost rport rlogo realm

    set stc [doWebFetch $rhost $rport $rlogo]
    set status "Enter $realm"
}

# fetch a web page from the specified server/port, return the http
# code and dump the returned page in the global doc
proc doWebFetch {rh rp path} {
    global uagent authstring doc realm
    
    set status "connecting..."
    if { [catch { set Shandle [ socket $rh $rp ] } ] } {
	close $Shandle
	return "Connect failed"
    }

    puts $Shandle "GET $path HTTP/1.0"
    puts $Shandle "User-Agent: $uagent"
    if {$authstring != ""} {
	puts $Shandle "Authorization: Basic $authstring"
    }
    puts $Shandle ""
    flush $Shandle
    set doc [read $Shandle]
    close $Shandle
    
    set needauth {HTTP.*401.*Authorization Required.*Authenticate: Basic realm="([A-Za-z ]*)"}
    set sub1 ""
    set matched ""
    regexp $needauth $doc matched sub1
    if { $sub1 != "" } {
	set status "Failed $sub1"
	set authstring ""
	set realm $sub1
	return 401
    }
    set statpat {^HTTP/.\.. *([0-9]+) }
    regexp $statpat $doc matched sub1
    return $sub1
}


## JSP: included from the tcllib base64 module (since it isn't
## standard with freewrap's wish code).

namespace eval base64 {
    variable base64 {}
    variable base64_en {}

    # We create the auxiliary array base64_tmp, it will be unset later.

    set i 0
    foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
	    a b c d e f g h i j k l m n o p q r s t u v w x y z \
	    0 1 2 3 4 5 6 7 8 9 + /} {
	set base64_tmp($char) $i
	lappend base64_en $char
	incr i
    }

    #
    # Create base64 as list: to code for instance C<->3, specify
    # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
    # ascii chars get a {}. we later use the fact that lindex on a
    # non-existing index returns {}, and that [expr {} < 0] is true
    #

    # the last ascii char is 'z'
    scan z %c len
    for {set i 0} {$i <= $len} {incr i} {
	set char [format %c $i]
	set val {}
	if {[info exists base64_tmp($char)]} {
	    set val $base64_tmp($char)
	} else {
	    set val {}
	}
	lappend base64 $val
    }

    # code the character "=" as -1; used to signal end of message
    scan = %c i
    set base64 [lreplace $base64 $i $i -1]

    # remove unneeded variables
    unset base64_tmp i char len val

    namespace export encode decode
}

# base64::encode --
#
#	Base64 encode a given string.
#
# Arguments:
#	args	?-maxlen maxlen? ?-wrapchar wrapchar? string
#	
#		If maxlen is 0, the output is not wrapped.
#
# Results:
#	A Base64 encoded version of $string, wrapped at $maxlen characters
#	by $wrapchar.
    
proc base64::encode {args} {
    set base64_en $::base64::base64_en
	
    # Set the default wrapchar and maximum line length to match the output
    # of GNU uuencode 4.2.  Various RFC's allow for different wrapping 
    # characters and wraplengths, so these may be overridden by command line
    # options.
    set wrapchar "\n"
    set maxlen 60

    if { [llength $args] == 0 } {
	error "wrong # args: should be \"[lindex [info level 0] 0]\
		?-maxlen maxlen? ?-wrapchar wrapchar? string\""
    }

    set optionStrings [list "-maxlen" "-wrapchar"]
    for {set i 0} {$i < [llength $args] - 1} {incr i} {
	set arg [lindex $args $i]
	set index [lsearch -glob $optionStrings "${arg}*"]
	if { $index == -1 } {
	    error "unknown option \"$arg\": must be -maxlen or -wrapchar"
	}
	incr i
	if { $i >= [llength $args] - 1 } {
	    error "value for \"$arg\" missing"
	}
	set val [lindex $args $i]
	
	# The name of the variable to assign the value to is extracted
	# from the list of known options, all of which have an
	# associated variable of the same name as the option without
	# a leading "-". The [string range] command is used to strip
	# of the leading "-" from the name of the option.
	#
	# FRINK: nocheck
	set [string range [lindex $optionStrings $index] 1 end] $val
    }
    
    # [string is] requires Tcl8.2; this works with 8.0 too
    if {[catch {expr {$maxlen % 2}}]} {
	error "expected integer but got \"$maxlen\""
    }
    
    set string [lindex $args end]
    
    set result {}
    set state 0
    set length 0
    
    
    # Process the input bytes 3-by-3
    
    binary scan $string c* X
    foreach {x y z} $X {
	# Do the line length check before appending so that we don't get an
	# extra newline if the output is a multiple of $maxlen chars long.
	if {$maxlen && $length >= $maxlen} {
	    append result $wrapchar
	    set length 0
	}
	
	append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] 
	if {$y != {}} {
	    append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] 
	    if {$z != {}} {
		append result \
			[lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
		append result [lindex $base64_en [expr {($z & 0x3F)}]]
	    } else {
		set state 2
		break
	    }
	} else {
	    set state 1
	    break
	}
	incr length 4
    }
    if {$state == 1} {
	append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== 
    } elseif {$state == 2} {
	append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]=  
    }
    return $result
}
## End of included section


## JSP: startup etc

set lver "0.85"
set osver "unknown"
if [catch {set osver "$tcl_platform(platform)/$tcl_platform(os)"}] {
    puts "no platform?"
}

# Set user agent string, and version string
set uagent "lauth/exp-$lver ($osver)"
set Version "Laptop Network Authenticator: $uagent"

set w .
set doc ""

# We are connecting to the echo port on this host as a test...
set rhost castellan.amtp.cam.ac.uk
set rport 80
set rlogi "/cgi-bin/authenticate/laptop-users/enable-laptop2.cgi";
set rlogo "/cgi-bin/authenticate/laptop-users/disable-laptop2.cgi"

# This is the current status
set status "Not logged in"
set realm ""

set authstring ""

set status "Laptop authenticator "
puts "$status"

if {$argv == "-V"} {
    puts $Version
    exit
}

if {$argc > 1} {
    puts "Only one username please!"
    exit
}

getrealm
puts "$status"

# Repeatedly prompt for username/password 'til they get one which is right!
while {$authstring == ""} {
    set user ""
    set pword ""
    if {$argv != ""} {
	set user $argv
	puts " Username: $user"
	set argv ""
    }
    while {$user == ""} {
	puts -nonewline " Username: "
	flush stdout
	gets stdin user
    }

    set pword ""
    while {$pword == ""} {
	puts -nonewline " Password: "
	flush stdout
	stty -echo
	gets stdin pword
	stty echo
	puts ""
    }

    # Try to authenticate with this user/pword
    doAuth
    set lsec [clock seconds]
    if {$authstring == ""} {
	puts "Authentication failed"
    } else {
	puts "Authenitcated as $user"
    }
}
puts ""

# This is the expect default timeout
set timeout 5

# Wait for user to hit return to log out...
while {$authstring != ""} {
    updatelogged
    puts -nonewline "\r$status. Hit enter to log out: "
    flush stdout
    expect_tty {
	"^v\n$" {puts "$Version"}
	"^\n$" {puts ""; set authstring ""}
    }
}
puts ""
doDeauth
puts "Logged out"