# auth.tcl
#
# Basic authentication
# This module parses .htaccess files and does the Basic Authentication
# protocol.  There is some generality in here to support multiple
# authentication schemes, but in practice only Basic is used right now.
#
# Each .htaccess file is parsed once and the information is kept in a
# Tcl global array named auth$filename, and upvar aliases this to "info".
# "info" contains the info provided by the .htaccess file ( info(htaccessp,..) )
# The AuthUserFile ( info(user,..) ) and the AuthGroupFile( info(group,..) )
#
# There is also support for ".tclaccess" files in each directory.
# These contain hook code that define password checking procedures
# that apply at that point in the hierarchy.
#
# Brent Welch (c) 1997 Sun Microsystems
# Brent Welch (c) 1998-2000 Ajuba Solutions
# Piet Vloet (c) 2001
# Brent Welch (c) 2001
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: auth.tcl,v 1.14.6.2 2002/08/30 22:25:39 welch Exp $

package provide httpd::auth 2.0
package require base64

# Auth_InitCrypt --
# Attempt to turn on the crypt feature used to store crypted passwords.

proc Auth_InitCrypt {} {
    package require crypt
}
proc Auth_AccessFile {args} {
    Stderr "Auth_AccessFile is obsolete: use Auth_InitCrypt instead"
    Auth_InitCrypt
}

# Auth_Check --
# This looks for access files along the path.
# It returns a "cookie" that is checked by Auth_Verify.
# NOTE: this looks for the lowest (i.e., deepest) access file
# and only returns information about one. Consider changing
# Auth_Check/Auth_Verify to check all files.

proc Auth_Check {sock directory pathlist} {
    global auth
    set cookie {}

    # Make sure we do checks in the root
    if {$pathlist==""} {
	 set pathlist ./
    }

    # Look for the .htaccess files that keep Basic Authtication info
    # or .tclaccess files with a general authorization callback
    set path $directory
    foreach component $pathlist {
        if {![file isdirectory $path]} {
            # Don't bother looking if we are in an "artificial"
            # url domain that isn't mapped to files.
            break
        }
	foreach {name type} {.htaccess Basic .tclaccess Tcl} {
	    set file [file join $path $name]
	    if {[file exists $file]} {
		set cookie [list $type $file]
		# Keep looking for cookie files lower in the directory tree
            }
	}
	set path [file join $path $component]
    }

    # Block access to the access control files themselves.
    # We toss in a block against the .tml files as well,
    # although that isn't strictly clean modularity.
    set tail [file tail $path]
    if {$tail == ".tclaccess" ||
          $tail == ".htaccess" ||
          $tail == ".tml"} {
        set cookie [list Deny $path]
        return $cookie
    }

    return $cookie
}

proc Auth_Verify {sock cookie} {
    if {[llength $cookie] == 0} {
	return 1
    }
    set type [lindex $cookie 0]
    set key [lindex $cookie 1]
    if {$type == "Deny"} {
        return 0
    } else {
        return [AuthVerify$type $sock $key]
    }
}

# Auth_VerifyCallback -- 
#
#       Check for a Basic authorization string, and use a callback
#       to verify the password
#
# Arguments:
#       sock            Handle on the client connection
#       realm           Realm for basic authentication.  This appears
#                       in the password prompt from the browser.
#       callback        Tcl command to check the password.  This gets
#                       as arguments the sock, realm, username and password.
#
# Results:
#                       return 1 or 0, 1 for success.

proc Auth_VerifyCallback {sock realm callback} {
    upvar #0 Httpd$sock data

    if {![info exists data(mime,authorization)]} {
	set ok 0
    } else {
	set parts [split $data(mime,authorization)]
	set type [lindex $parts 0]
	set code [lindex $parts 1]
	if {[string compare $type Basic] != 0} {
	    set user {}
	    set pass {}
	} else {
	    set parts [split [base64::decode $code] :]
	    set user [lindex $parts 0]
	    set pass [lindex $parts 1]
	}
	set ok [eval $callback {$sock $realm $user $pass}]
    }
    if {!$ok} {
	Httpd_RequestAuth $sock Basic $realm
	return 0
    } else {
	set data(auth_type) Basic
	set data(remote_user) $user
	set data(session) $realm,$user
	return 1
    }
}

# AuthVerifyTcl --
#
#       "Tcl" verification uses a .tclaccess file that defines the
#       realm and callback to use to check the password.
#
# Arguments:
#       sock    Handle on the client connection
#       file    Tcl source file that contains set commands for
#               realm and callback
#
# Results:
#       1 for success, 0 for access denied.

proc AuthVerifyTcl {sock file} {
    upvar #0 Httpd$sock data


    # The file contains definitions for the "realm" variable
    # and the "callback" script value.

    set realm Realm
    set callback AuthNullCallback
    catch {source $file}

    return [Auth_VerifyCallback $sock $realm $callback]
}

proc AuthNullCallback {sock realm user pass} {
    upvar #0 Httpd$sock data
    global auth
    if {[info exists auth($realm,$user)]} {
	switch -exact -- $auth($realm,$user) \
	    $pass {
		Stderr "Session: $realm,$user"
		return 1
	    } \
	    PasswordRequired {
		set auth($realm,$user) $pass
		Stderr "Session: $realm,$user"
		return 1
	    } \
	    default {
		return 0
	    }
    } else {
	set auth($realm,$user) PasswordRequired
	return 0
    }
}

# AuthVerifyBasic - see if the user is granted access.
# First domain based protection is performed. In the case the
# user is not in the domain user based protection is performed.
# The user must be in a group or mentioned as user. The password
# must match the user's entry.  If neither group nor user are
# required for the operation, then the check passes.

proc AuthVerifyBasic {sock file} {
    upvar #0 auth$file info
    upvar #0 Httpd$sock data
    AuthParseHtaccess $sock $file
    set op $data(proto) ;# GET, POST etc.

    if {[info exists info(htaccessp,order,$op)]} {
	if {! [AuthVerifyNet $sock $file $op]} {
	    Httpd_Error $sock 403
	    return 0
	}
    }
    if {![info exists info(htaccessp,require,$op,group)] &&
	    ![info exists info(htaccessp,require,$op,user)]} {
	# No "require group .." or "require user .." in .htaccess file
	return 1
    }
    set ok 0
    if {[info exists data(mime,authorization)]} {
	set ok 1
	set parts [split $data(mime,authorization)]
	set type [lindex $parts 0]
	set code [lindex $parts 1]
	if {[string compare $type Basic] != 0} {
	    set ok 0
	} else {
	    set parts [split [base64::decode $code] :]
	    set user [lindex $parts 0]
	    set pass [lindex $parts 1]
	    if {[info exists info(htaccessp,require,$op,group)]} {
		if {![AuthGroupCheck $sock $file \
			$info(htaccessp,require,$op,group) $user]} {
		    set ok  0   ;# Not in a required group
		}
	    }
	    if {! $ok} {
		if {[info exists info(htaccessp,require,$op,user)]} {
		    set ok 1
		    if {![AuthUserCheck $sock $file \
			    $info(htaccessp,require,$op,user) $user]} { 
			set ok  0   ;# Not the required user
		    }
		}
	    }
	}
	if {$ok} {
	    set crypt [AuthGetPass $sock $file $user]
	    set salt [string range $crypt 0 1]
	    set crypt2 [crypt $pass $salt]
	    if {[string compare $crypt $crypt2] != 0} {
		set ok 0        ;# Not the right password
	    }
	}
    }
    if {! $ok} {
	Httpd_RequestAuth $sock Basic $info(htaccessp,name)
    } else {
	set data(auth_type) Basic
	set data(remote_user) $user
	set data(session) $info(htaccessp,name),$user
    }
    return $ok
}

proc AuthUserCheck  {sock file users user } {
    return [expr {[lsearch $users $user] >= 0}]
}

# Parse the AuthGroupFile.                          
# The information is built up in the info array

proc AuthGroupCheck {sock file groups user} {
    upvar #0 auth$file info
    set mtime [file mtime $info(htaccessp,groupfile)]

    # Only parse the group file if it has changed

    if {![info exists info(group,mtime)] || ($mtime > $info(group,mtime))} {
	foreach i [array names info "group*"] {
	    unset info($i)
	}
	if {[catch {open $info(htaccessp,groupfile)} in]} {
	    return 0
	}
	while {[gets $in line] >= 0} {
	    if {[regexp {^([^:]+):[      ]*(.+)} $line x key value]} {
		set info(group,$key) [split $value " ,"]
	    }
	}
	close $in
	set info(group,mtime) $mtime
    }

    foreach index $groups {
	if {[info exist info(group,$index)]} {
	    if {[lsearch $info(group,$index) $user] >= 0} {
		return 1
	    }
	}
    }
    return 0
}

# Parse the AuthUserFile.
# The information is built up in the info array

proc AuthGetPass {sock file user} {
    upvar #0 auth$file info
    set mtime [file mtime $info(htaccessp,userfile)]
    if {![info exists info(user,mtime)] || ($mtime > $info(user,mtime))} {
	foreach i [array names info "user*"] {
	    unset info($i)
	}
	if {[catch {open $info(htaccessp,userfile)} in]} {
	    return *
	}
	while {[gets $in line] >= 0} {
	    if {[regexp {^([^:]+):[      ]*([^:]+)} $line x key value]} {
		set info(user,$key) $value
	    }
	}
	close $in
	set info(user,mtime) $mtime
    }
    if {[info exists info(user,$user)]} {
	return $info(user,$user)
    } else {
	return *
    }
}

# Check the allow/deny lists for this operation

proc AuthVerifyNet {sock file op} {
    upvar #0 auth$file info
    set order [split $info(htaccessp,order,$op) ,]
    set peer [fconfigure $sock -peername]
    set rname [string tolower [lindex $peer 1]]
    set raddr [lindex $peer 0]
    set ok 0
    foreach way $order {
	if {![info exists info(htaccessp,network,$way,$op)]} {
	    continue
	}
	foreach addr $info(htaccessp,network,$way,$op) {
	    if {[AuthNetMatch $sock $addr $rname $raddr]} {
		if {[string compare $way "allow"] == 0} {
		    set ok 1
		} else {
		    set ok 0
		}
	    }
	}
    }
    if {! $ok} {
	Log $sock AuthVerifyNet "access denied to $rname in [file tail [file dirname $file]]"
    }
    return $ok
}

proc AuthNetMatch {sock addr rname raddr} {
    if {[string compare $addr "all"] == 0} {
	return 1
    }
    if {[string match *$addr $rname] || [string match ${addr}* $raddr]} {
	return 1
    }
    return 0
}

# Parse the htaccess file.  Uhler would probably regsub/subst this,
# but here we just call a Tcl proc to handle each "command" in the file.
# The information is built up in the info array.

proc AuthParseHtaccess {sock file} {
    upvar #0 auth$file info
    set mtime [file mtime $file]
    if {![info exists info] || ($mtime > $info(htaccessp,mtime))} {
	# Parse .htaccess file
	foreach i [array names info "htaccessp*"] {
	    unset info($i)
	}
	set info(htaccessp,mtime) $mtime
	set info(htaccessp,userfile) {}
	set info(htaccessp,groupfile) {}
	if {[catch {open $file} in]} {
	    return 1
	}
	set state [list vars]
	foreach line [split [read $in] \n] {
	    if {[regexp ^# $line] || [string length [string trim $line]] == 0} {
		continue
	    }
	    if {[regexp <(.+)> $line x tag]} {
		set line $tag
	    }
	    set words [split $line]
	    set cmd [string tolower [lindex $words 0]]
	    if {[catch {
		eval {Ht-$cmd auth$file} [lrange $words 1 end]
	    } err]} {
		Log $sock Error $err
	    }
	}
	close $in
    }
    return 1
}
proc Ht-authtype {infoName type} {
    upvar #0 $infoName info
    set info(htaccessp,type) $type
}
proc Ht-authname {infoName name} {
    upvar #0 $infoName info
    set info(htaccessp,name) $name
}

proc Ht-authuserfile {infoName file} {
    upvar #0 $infoName info
    set info(htaccessp,userfile) $file
}

proc Ht-authgroupfile {infoName file} {
    upvar #0 $infoName info
    set info(htaccessp,groupfile) $file
}

proc Ht-limit {infoName args} {
    upvar #0 $infoName info
    set info(htaccessp,limit) $args       ;# List of operations, GET, POST, ...
}

proc Ht-/limit {infoName args} {
    upvar #0 $infoName info
    set info(htaccessp,limit) {}
}

proc Ht-require {infoName key list} {
    upvar #0 $infoName info
    if {![info exists info(htaccessp,limit)]} {
	set info(htaccessp,limit) {}
    }
    foreach op $info(htaccessp,limit) {
	if {![info exists info(htaccessp,require,$op,$key)]} {
		set info(htaccessp,require,$op,$key) {}
	    }
	    foreach a $list {
		lappend info(htaccessp,require,$op,$key) $a
	    }
     }
}

proc Ht-order {infoName value} {
    upvar #0 $infoName info
    if {![info exists info(htaccessp,limit)]} {
	set info(htaccessp,limit) {}
    }
    foreach op $info(htaccessp,limit) {
	if {[info exists info(htaccessp,order,$op)]} {
		 unset info(htaccessp,order,$op)
	}
	set info(htaccessp,order,$op) $value
    }
}

proc Ht-deny {infoName args} {
    HtByNet $infoName deny $args
}
proc Ht-allow {infoName args} {
    HtByNet $infoName allow $args
}
proc HtByNet {infoName how list} {
    upvar #0 $infoName info
    if {![info exists info(htaccessp,limit)]} {
	set info(htaccessp,limit) {}
    }
    if {[string compare [lindex $list 0] "from"] == 0} {
	set list [lrange $list 1 end]
    }
    foreach op $info(htaccessp,limit) {
	if {![info exists info(htaccessp,network,$how,$op)]} {
	    set info(htaccessp,network,$how,$op) {}
	}
	foreach a $list {
	    lappend info(htaccessp,network,$how,$op) [string tolower $a]
	}
    }
}
