#!/usr/local/bin/tclsh8.6

#
# Validates a pair login/password from a user
#
# Parameters (form or url): none
#
# History
#   2014/04/11 : pda/jean : design
#

#
# Template pages used by this script
#

set conf(page-fail)	login.html

#
# Next actions
# 

set conf(next-fail)	"login"
# welcome page (once logged in)
set conf(next-start)	"start"
# welcome page (anonymous)
set conf(next-index)	"index"

#
# Netmagis general library
#

source /usr/local/lib/netmagis/libnetmagis.tcl

# ::webapp::cgidebug ; exit

#
# Check user password against the crypted password stored in database
# and returns:
# - -1 if a system error occurred (msg sent via stderr in Apache log)
# - 0 if login was not successful
# - 1 if login was successful
#

proc check-password {dbfd login upw} {
    set success 0

    set am [dnsconfig get "authmethod"]
    switch $am {
	pgsql {
	    set qlogin [::pgsql::quote $login]
	    set sql "SELECT password FROM pgauth.user WHERE login = '$qlogin'"
	    set dbpw ""
	    pg_select $dbfd $sql tab {
		set dbpw $tab(password)
	    }

	    if {[pgauth-checkpw $upw $dbpw]} then {
		set success 1
	    } else {
		set success 0
	    }
	}
	ldap {
	    if {$upw eq ""} then {
		return 0
	    }

	    set url       [dnsconfig get "ldapurl"]
	    set binddn    [dnsconfig get "ldapbinddn"]
	    set bindpw    [dnsconfig get "ldapbindpw"]
	    set basedn    [dnsconfig get "ldapbasedn"]
	    set searchuid [dnsconfig get "ldapsearchlogin"]

	    set handle [::ldapx::ldap create %AUTO%]
	    if {[$handle connect $url $binddn $bindpw]} then {
		set filter [format $searchuid $login]

		set e [::ldapx::entry create A%AUTO%]
		if {[catch {set n [$handle read $basedn $filter $e]} m]} then {
		    puts stderr "LDAP search for $login: $m"
		    return -1
		}
		$handle destroy

		switch $n {
		    0 {
			# no login found: success variable is already 0
		    }
		    1 {
			set userdn [$e dn]

			set handle [::ldapx::ldap create %AUTO%]
			if {[$handle connect $url $userdn $upw]} then {
			    set success 1
			}
			$handle destroy
		    }
		    default {
			# more than one login found
			puts stderr "More than one login found for '$login'. Check the ldapbasedn or ldapsearchlogin parameters."
			set success -1
		    }
		}

		$e destroy
	    } else {
		puts stderr "Cannot bind to ldap server: [$handle error]"
		$handle destroy
		set success -1
	    }
	}
    }

    return $success
}

#
# Register user login and redirect to the start page
#

proc welcome-user {dbfd login casticket} {
    global conf

    set msg [register-user-login $dbfd $login $casticket]
    if {$msg ne ""} then {
	d error $msg
    }

    #
    # Redirect user to the start page
    #

    array set ftab2 {
	lastlogin {{yes}}
    }
    puts stdout [::webapp::call-cgi [pwd]/$conf(next-start) ftab2]
}

##############################################################################
# CAS authentication
##############################################################################

d cgi-register {ticket ^ST-.*} {
    {ticket	1 1}
} {
    global conf
    global libconf

    #
    # Specific packages required for the CAS case
    #

    package require http
    package require tls
    package require tdom

    set am [dnsconfig get "authmethod"]
    if {$am ne "casldap"} then {
	::webapp::redirect "login"
	exit 0
    }

    set casurl [dnsconfig get "casurl"]
    set home [::webapp::myurl 1]
    set fmt "$casurl/serviceValidate?ticket=%s&service=$home/$libconf(next-login)"
    set valurl [format $fmt $ticket]

    #
    # Send the validation request for the ticket received from the client
    #

    set cafile [get-local-conf "cafile"]
    if {$cafile eq "" || ! [file exists $cafile]} then {
	d error [mc "CAS login failed (%s)" "invalid 'cafile' in netmagis.conf"]
    }
    ::http::register https 443 [list ::tls::socket -tls1 1 \
						    -require 1 \
						    -cafile $cafile \
						]
    if {[catch {set token [::http::geturl $valurl]}]} then {
	d error [mc "CAS login failed (%s)" "Cannot establish HTTPS connection to CAS server"]
    }

    set status [::http::status $token]

    if {$status ne "ok"} then {
	d error [mc "Invalid CAS answer"]
    }
    
    upvar #0 $token state

    array set meta $state(meta)
    switch -glob $meta(Content-Type) {
	{text/plain;*} {
	    # CAS v1
	    d error [mc "Invalid CAS answer"]
	}
	{text/html;*} {
	    # CAS v2
	    set body $state(body)

	    #
	    # Obtained from auth-cas in OpenACS
	    # This code uses the tdom package
	    #

	    set query "//cas:serviceResponse/cas:authenticationSuccess/cas:user/text()"
	    dom parse $body document
	    $document documentElement root
	    set textNode [$root selectNodes $query]
	    if {$textNode eq ""} then {
		# validation failed, return error message
		set query "//cas:serviceResponse/cas:authenticationFailure"
		dom parse $body document
		$document documentElement root

		set textNode [$failureNode selectNodes text()]
		set reason [$textNode nodeValue]
		d error [mc "CAS login failed (%s)" $reason]
	    }

	    set login [$textNode nodeValue]
	    if {! [check-login $login]} then {
		d error [mc "Invalid login (%s)" $login]
	    }

	    welcome-user $dbfd $login $ticket
	}
	{*} {
	    d error [mc "Invalid CAS answer"]
	}
    }
    exit 0
}

d cgi-register {logoutRequest ^.+$} {
    {logoutRequest	1 1}
} {
    #
    # This script is called when the CAS server process a logout request.
    # Some user has requested a logout via a "Logout" button in an
    # application (which may be Netmagis, but may be another application):
    # the CAS server then signals every application registered with the
    # CAS ticket that the session must be closed.
    # We may be in one of these 2 cases:
    # 1- logout is made via Netmagis: Netmagis has already processed the
    #    logout request (line moved from global.utmp to global.wtmp table)
    #    and we are called as for every application. Since the CAS ticket
    #    is no longer in the global.utmp table, we ignore the request
    # 2- logout is made via another application. We close the session
    #    given the received CAS ticket.
    #
    # Example of logoutRequest:
    # <samlp:LogoutRequest
    #         xmlns:samlp="urn:oasis:names:tc:SAML:2.0:protocol"
    #         ID="LR-40617-oR2kJ7sSlZjJ41FU4LpOPw5paOqurNSdlGZ"
    #         Version="2.0"
    #         IssueInstant="2015-02-25T11:51:29Z">
    #     <saml:NameID xmlns:saml="urn:oasis:names:tc:SAML:2.0:assertion">
    #         @NOT_USED@
    #     </saml:NameID>
    #     <samlp:SessionIndex>
    #         ST-226629-kovHNpibasDBPNXxf5s5-cas2
    #     </samlp:SessionIndex>
    # </samlp:LogoutRequest>
    #

    package require tdom

    set query "//samlp:LogoutRequest/samlp:SessionIndex/text()"
    dom parse $body document
    $document documentElement root
    set casticket [$root selectNodes $query]

    if {$casticket eq ""} then {
	# Emit a message for the Web server log
	# (we cannot display an HTML page since this request is done
	# by the CAS server)
	puts stderr "CAS protocol error: no session ticket found"
	exit 1
    }

    #
    # Search the CAS ticket in our active sessions
    #

    set qcas [::pgsql::quote $casticket]
    set login ""
    set sql "SELECT login, token FROM global.utmp WHERE casticket = '$qcas'"
    pg_select $dbfd $sql tab {
	set login $tab(login)
	set token $tab(token)
    }

    #
    # Process to logout only if ticket has been found
    #

    if {$login ne ""} then {
	set msg [register-user-logout $dbfd $login $token "" "logout"]
	if {$msg ne ""} then {
	    # Emit a message for the Web server log
	    puts stderr "CAS logout: $msg"
	    exit 1
	}
    }

    exit 0
}

##############################################################################
# Authentication failure management
##############################################################################

#
# Remove all failed authentications older than 1 day
#

proc clean-authfail {dbfd} {
    set sql "DELETE FROM global.authfail
		    WHERE lastfail < LOCALTIMESTAMP - INTERVAL '1 DAY'"
    if {! [::pgsql::execsql $dbfd $sql msg]} then {
	puts stderr "Error in expiration of failed logins: $msg"
	# We don't exit with this error. In case the database is
	# failing, we will report another database error later
	# with an error message related to the action of the user.
    }
}

#
# Remove failed authentication entry (for login/ip) in case of successful login
#

proc reset-authfail {dbfd otype origin} {
    set qorigin [::pgsql::quote $origin]
    set sql "DELETE FROM global.authfail
		    WHERE otype = '$otype' AND origin = '$qorigin'"
    if {! [::pgsql::execsql $dbfd $sql msg]} then {
	puts stderr "Error in resetting failed $otype: $msg"
    }
}

#
# Update login/ip entry in case of failed login
# Returns delay until end of blocking period (<= 0 if no more blocking)
#

proc update-authfail {dbfd otype origin} {
    set failXthreshold1 [dnsconfig get "fail${otype}threshold1"]
    set failXthreshold2 [dnsconfig get "fail${otype}threshold2"]
    set failXdelay1     [dnsconfig get "fail${otype}delay1"]
    set failXdelay2     [dnsconfig get "fail${otype}delay2"]

    #
    # Start of critical section
    #

    d dblock global.authfail

    #
    # Get current status
    #

    set qorigin [::pgsql::quote $origin]
    set sql "SELECT nfail
		    FROM global.authfail
		    WHERE otype = '$otype' AND origin = '$qorigin'"
    set nfail -1
    pg_select $dbfd $sql tab {
	set nfail $tab(nfail)
    }

    #
    # Update current status according to various thresholds
    #

    if {$nfail == -1} then {
	set sql "INSERT INTO global.authfail (origin, otype, nfail)
		    VALUES ('$qorigin', '$otype', 1)"
    } elseif {$nfail >= $failXthreshold2} then {
	set sql "UPDATE global.authfail
		    SET nfail = nfail+1,
			lastfail = NOW (),
			blockexpire = NOW() + '$failXdelay2 second'
		    WHERE otype = '$otype' AND origin = '$qorigin'"
    } elseif {$nfail >= $failXthreshold1} then {
	set sql "UPDATE global.authfail
		    SET nfail = nfail+1,
			lastfail = NOW (),
			blockexpire = NOW() + '$failXdelay1 second'
		    WHERE otype = '$otype' AND origin = '$qorigin'"
    } else {
	set sql "UPDATE global.authfail
		    SET nfail = nfail+1,
			lastfail = NOW ()
		    WHERE otype = '$otype' AND origin = '$qorigin'"
    }

    if {! [::pgsql::execsql $dbfd $sql msg]} then {
	d dbabort "authfail update" $msg
    }

    #
    # End of critical section
    #

    d dbcommit "authfail update"

    #
    # Return delay until end of blocking
    #

    return [check-failed-delay $dbfd $otype $origin]
}

#
# In case of failed login attempt, ban both login and IP address
#

proc update-authfail-both {dbfd srcaddr login} {
    set d1 [update-authfail $dbfd "ip"    $srcaddr]
    set d2 [update-authfail $dbfd "login" $login]
    return [expr max($d1,$d2)]
}


#
# Delay until end of blocking period
#
# Input:
#   - dbfd: database handle
#   - otype: "ip" or "login"
#   - origin: IP address or login name
# Output:
#   - return value: delay (in seconds) until access is allowed
#	(or 0 if not blocked or negative value if access is allowed again)
#

proc check-failed-delay {dbfd otype origin} {
    set qorigin [::pgsql::quote $origin]
    set sql "SELECT EXTRACT (EPOCH FROM blockexpire - LOCALTIMESTAMP(0))
			AS delay
		FROM global.authfail
    		WHERE otype = '$otype' AND origin = '$qorigin'
		    AND blockexpire IS NOT NULL"
    set delay 0
    pg_select $dbfd $sql tab {
	set delay $tab(delay)
    }
    return $delay
}

##############################################################################
# Display login page and validate access
##############################################################################

d cgi-register {} {
    {login	0 1}
    {logout	0 1}
    {pw		0 1}
} {
    global conf
    global env

    if {[info exists env(REMOTE_ADDR]} then {
	set srcaddr $env(REMOTE_ADDR)
    } else {
	set srcaddr "::1"
    }

    set am [dnsconfig get "authmethod"]

    clean-authfail $dbfd

    set delay [check-failed-delay $dbfd "ip" $srcaddr]
    if {$delay > 0} then {
	set delay [update-authfail $dbfd "ip" $srcaddr]
	d error [mc {IP address '%1$s' temporarily blocked. Retry in %2$d seconds} $srcaddr $delay]
    }

    set message ""
    if {$logout ne ""} then {
	if {$uid eq "-"} then {
	    set message ""

	    if {$am eq "casldap"} then {
		::webapp::redirect "index"
		exit 0
	    }
	} else {
	    set qtoken [::pgsql::quote [::webapp::get-cookie "session"]]
	    set message [register-user-logout $dbfd [d uid] $qtoken "" "logout"]
	    if {$message eq ""} then {
		set message [mc "Logout successful"]
	    }
	    d writelog "auth" "logout [d uid] $qtoken"

	    d uid "-"
	    d euid {- -1}
	    d module "anon"
	    # leave login unmodified for the "login" page

	    if {$am eq "casldap"} then {
		set casurl [dnsconfig get "casurl"]
		set home [::webapp::myurl 1]
		set url "$casurl/logout?service=$home/$conf(next-index)"
		::webapp::redirect $url
		exit 0
	    }
	}
    } else {
	if {[string trim $login] ne ""} then {
	    if {! [check-login $login]} then {
		d error [mc "Invalid login (%s)" $login]
	    }

	    set delay [check-failed-delay $dbfd "login" $login]
	    if {$delay > 0} then {
		set delay [update-authfail-both $dbfd $srcaddr $login]
		d error [mc {Login '%1$s' temporarily blocked. Retry in %2$d secondes} $login $delay]
	    }

	    set ok [check-password $dbfd $login $pw]
	    switch $ok {
		-1 {
		    # system error
		    set message [mc "Login failed due to an internal error"]
		}
		0 {
		    # login unsuccessful
		    set delay [update-authfail-both $dbfd $srcaddr $login]
		    if {$delay <= 0} then {
			set message [mc "Login failed"]
		    } else {
			set message [mc "Login failed. Please retry in %d seconds" $delay]
		    }
		}
		1 {
		    # login successful
		    welcome-user $dbfd $login ""
		    reset-authfail $dbfd "ip"    $srcaddr
		    reset-authfail $dbfd "login" $login
		    exit 0
		}
	    }
	}

	if {$am eq "casldap"} then {
	    ::webapp::redirect "start"
	    exit 0
	}
    }

    #
    # Restitute form parameters
    #

    set login [::webapp::html-string $login]

    #
    # End of script: output page and close database
    #

    d urlset "%URLFORM%" $conf(next-fail) {}
    d result $conf(page-fail) [list \
				    [list %MESSAGE% $message] \
				    [list %LOGIN%   $login] \
    				]
}

##############################################################################
# Main procedure
##############################################################################

d cgi-dispatch "dns" "anon"
