# server.tcl
#
#	This file implements the connectServer package of the Ajuba2
#	Server. This package is responsible for loading 
#	component packages in the correct sequence.
#
# Copyright (c) 1998-2000 Ajuba Solutions
#
# RCS: $Id: server.tcl,v 1.84 2000/06/24 02:43:59 mtariq Exp $

set pList [list \
    msgcat \
    serverMsgcat \
    urldispatch \
    jobscheduler \
    resource \
    project \
    ipool \
    serverdb \
    user \
    transport \
    authType \
    addressbook \
    accesscontrol \
    mgmt \
    deliveryMgr \
    projectInfo \
    x509cert \
    Tclx
]

foreach p $pList {
    if {[catch {package require $p} err]} {
	puts stderr "couldn't load package $p: $err"
    }
}

::msgcat::mclocale en

package provide connectServer 1.0

namespace eval connectServer {

    # Manager URLs, Direct URLs in the Manager, and publish URLs need special
    # cases in the accessCheck proc, so we store the patterns to match those
    # URLs against in private namespace vars:  ManagerPattern, SetupPattern,
    # DirectPattern, and PublishPattern.  We also store the location of the
    # setup page so that Management URLs can be redirected to it when the
    # server is new.

    set tmp [connectServerInfo::getDefault ManagerURL]
    variable ManagerPattern "^(${tmp})"
    variable DirectPattern  "^${tmp}/(loginfo|projinfo|msginfo|PublishProject)"
    variable ImagesPattern  "^${tmp}/images"
    variable PublishPattern "^(${tmp}/PublishProject)"
    variable SetupPage      "${tmp}/setup.html"
    variable SetupPattern   "^(${tmp}/(setup\.html|images))"

    variable ServerToken ""
}

# connectServer::LogError
#
#	Log a component intialization error.
#
# Arguments:
#	functionName -- the function that failed 
#	err          -- the error that was reported
#
# Results:
#	None
#
proc ::connectServer::LogErrorAndExit {functionName err} {
    global errorCode
    global errorInfo
    catch {
	::statusLog::log [::statusLog::getUid] SERVER_INITIALIZATION_FAILED \
		[list package $functionName errorText $err errorCode \
		$errorCode errorInfo $errorInfo]
	::statusLog::log [::statusLog::getUid] HALT {}
    	::statusLog::flushBuffer
    }
    puts stderr "initialization error: $functionName $err $errorCode \
	$errorInfo"
    exit
}

# connectServer::init
#
#	Initialize the connect server by invoking the init procedure
#	for component packages. If any component fails, then log the
#	error and terminate the server.
#
# Arguments:
#	None
#
# Results:
#	None
#

proc ::connectServer::init {} {
    # initialize status manager with log file location
    if {[catch {::statusLog::init \
	    [::connectServerInfo::getDefault LogDir] \
	    [::connectServerInfo::getDefault LogFlushSeconds] CS} err]} {
	LogErrorAndExit statusLog::init $err
    }

    # log that the server was started
    if {[catch {::statusLog::log [::statusLog::getUid] START {}}]} {
	LogErrorAndExit statusLog::log $err
    }

    # do initial flush to kick off timer
    if {[catch {::statusLog::flushBuffer} err]} {
	LogErrorAndExit statusLog::flushBuffer $err
    }

    # initialize transport
    if {[catch {::transport::init} err]} {
	LogErrorAndExit ::transport::init $err
    }

    # initialize URL dispatcher
    if {[catch {::urldispatch::init} err]} {
	LogErrorAndExit ::urldispatch::init $err
    }

    # initialize the access control list
    if {[catch {::acl::init} err]} {
	LogErrorAndExit ::acl::init $err
    }

    # initialize the interpreter pool
    if {[catch {::ipool::init} err]} {
	LogErrorAndExit ::ipool::init $err
    }

    # initialize project publishing
    if {[catch {::project::init} err]} {
	LogErrorAndExit ::project::init $err
    }

    # initialize the address book
    if {[catch {::addrbk::init} err]} {
	LogErrorAndExit ::addrbk::init $err
    }

    # initialize the management interface
    if {[catch {::mgmt::init} err]} {
	LogErrorAndExit ::mgmt::init $err
    }

    # initialize the scheduler
    if {[catch {::sched::init} err]} {
	LogErrorAndExit ::sched::init $err
    }

    # initialize the deliveryMgr
    if {[catch {::deliveryMgr::init \
	    [connectServerInfo::getDefault LogDir] \
	    [file join [connectServerInfo::getDefault LogDir] \
	    deadmsg] \
	    [connectServerInfo::getDefault deliveryManagerFlushSeconds] \
	    [connectServerInfo::getDefault deliveryManagerMaxDispatchedMsgs] \
    } err]} {
	LogErrorAndExit ::deliveryMgr::init $err
    }

    # set up access control hook
    Url_AccessInstall ::connectServer::accessCheck

    # Get the server's x509 Certificate for user by the Manager.
    variable ServerToken
    set x509file [lindex [connectServerInfo::getSecurityFilenames] 0]
    array set tmpArray [x509::info $x509file]
    set ServerToken [::authType::x509UP::makeToken "" $tmpArray(subject)]

    return
}

# connectServer::shutdown --
#
#	Halt the Connect server.
#
# Arguments:
#
#	logMessage -- text written to data field of log entry
#	type -- how to shut the server down
#		"hard" will force a shutdown
#		"soft" will allow projects to disable gracefully
#	callback -- callback to invoke after success / failure of shutdown
#       timeout -- for "soft" shutdown, time after which server will
#		shut down regardless of success; -1 means do not forcefully
#		shut down the server if there are errors
#
# Results:
#	Returns an error if the "type" parameter is invalid
#	Otherwise this routine does not return
#

proc ::connectServer::shutdown {{logMessage {}} {type {hard}} \
    {callback {}} {timeout {-1}}} {

    #
    # Validate the input
    #

    if {$type != "hard"} {
    	return -code error "Shutdown mode $type not supported"
    }

    #
    # Let the project module disable any projects
    #

    ::project::shutdown

    #
    # log that the server was halted
    #

    ::statusLog::log [::statusLog::getUid] HALT $logMessage

    #
    # ensure that the log was written
    #

    ::statusLog::flushBuffer

    #
    # actually shut down the server
    #

    Httpd_Shutdown

    #
    # remove the PID file (Unix servers)
    #

    file delete [file join [::connectServerInfo::serverRootDir] conf httpd.pid]

    exit
}

# connectServer::setEnv
#
#	Wrapper function around Cgi_SetEnv to fix up some values.
#
# Arguments:
#	sock -- socket for incoming http request
#	path -- full url path
#       var  -- value to update
#
# Results:
#	None
#

proc ::connectServer::setEnv {sock path var} {
    upvar 1 $var connectEnv
    upvar #0 Httpd$sock data
    Cgi_SetEnv $sock $path connectEnv
    # does this make any sense for action handlers?
    catch {unset connectEnv(PATH_TRANSLATED)}
    set connectEnv(REMOTE_USER) $data(connectUser)
    if {[info exists data(mime,authorization)]} {
	set parts [split $data(mime,authorization)]
	set type [lindex $parts 0]
	set connectEnv(AUTH_TYPE) $type 
    }
}

# connectServer::accessCheck
#
#	Validate a user.
#	This is a callback from tclhttpd registered via Url_AccessInstall
#
# Arguments:
#	sock -- socket for incoming http request
#	url  -- url for which access is being determined
#
# Results:
#	"ok" if access is granted; "denied" if it isn't		

proc ::connectServer::accessCheck {sock url} {
    upvar #0 Httpd$sock data
    variable ManagerPattern

    if {$::mgmt::isNewServer} {
	variable ManagerPattern
	variable PublishPattern
	variable SetupPattern
	variable SetupPage

	# The server is new, and no users have been set up, so restrict access
	# to help the user setup.

	if {[regexp $SetupPattern $url]} {
	    # Allow access to the images and setup.html page.

	    return "ok"
	} elseif {![regexp $ManagerPattern $url] \
	    || [regexp $PublishPattern $url]} {
	    # Disallow access to non-Manager and Publishing pages.

	    Httpd_Error $sock 403 "no access"
	    return "denied"
	}

	# For Manager pages, automatically redirect to the setup page.

	Httpd_RedirectSelf $SetupPage $sock
	return "denied"

    }

    # Images require no authentication.

    if {[regexp $::connectServer::ImagesPattern $url]} {
	return "ok"
    }

    # If Direct URLs are accessed with the server's own x509 certificate,
    # allow the connection.

    if {[regexp $::connectServer::DirectPattern $url]} {
	# Temporary hole for direct URL access
	return "ok"

	# Get token from transport layer.

	set token [transport::getToken $sock]

	# Allow the direct URLs for the Manager if they are using the servers
	# own x509 cert.

	variable ServerToken
	if {[string equal $token $ServerToken]} {
	    # Let the script that processes this URL know the user through
	    # which access was granted.
	    
#	    upvar #0 Httpd$sock data
#	    global env
#	    set env(REMOTE_USER) $user
#	    set data(connectUser) $user
#	    set data(remote_user) $user
	    return "ok"
	}
    }

    # Get token from transport layer.

    set token [transport::getToken $sock]

    # Convert the token to a user.

    set user [::addrbk::getUser $token]
    
    # Check whether the user has access to this URL.
    
    if {[::acl::getPermission $user $url]} {
	# Let the script that processes this URL know the user through which
	# access was granted.

	upvar #0 Httpd$sock data
	global env
	set env(REMOTE_USER) $user
	set data(connectUser) $user
	set data(remote_user) $user
	return "ok"
    }

    # Either the user doesn't have access to the URL, or the URL simply 
    # isn't known to the Ajuba server.
    # If the url is unknown then generate a 404 "Not Found" result
    # Bug 5619

    if {0} {
    # fix for bug 5619 currently disabled
    if {$user != "anonymous" && ![regexp $ManagerPattern $url]} {
    	set isKnown 0
	set domainList [project::getDomainNames]
    	foreach res [resource::getMatches $url] {
	    if {[lsearch $domainList $res] >= 0} {
	    	set isKnown 1
		break
	    }
	}
	if {$isKnown == 0} {
	    Httpd_ReturnData $sock text/html "Not Found" 404
	    return "denied"
	}
    }
    }
    
    # Log unauthorized access attempts
    # Note that we will be over reporting the initial access
    # by a valid user who is treated as anonymous until challenged
    # for his authorization
    # Bug 4720
    catch {::statusLog::log [::statusLog::getUid] \
	    UNAUTHORIZED_ACCESS_ATTEMPT \
	    [list user $user ipaddr $data(ipaddr) \
		url $url]}
    Httpd_RequestAuth $sock Basic Ajuba2Server
    return "denied"
}

# CgiCancel --
#
#	Kills a cgi process prematurely, usually because the user
#	has decided to cancel their post.
#
#	This procedure was placed here to patch the procedure of
# 	the same name in tclhttp/lib/cgi.tcl.  This revised version
#	uses Tclx's kill instead of executing the kill process in 
#	order to allow Windows servers to kill cgi processes.  This
#	fix was added in response to Ajuba2 bug #5682 and should not
#	be removed until tclhttpd offers a cross-platform way of
#	killing cgi processes.
#
# Arguments:
#	fd	Pipe connection to the cgi process.
#	sock	Socket connection between the server and the browser.
#
# Results:
#	None.
#
# Side effects:
#	Logs the CgiCancel event.

proc CgiCancel {fd sock} {
    upvar \#0 Httpd$sock data

    Log $sock CgiCancel $data(url)

    # Use the Tclx "kill" command to kill the cgi process.

    catch {kill [pid $fd]}
    CgiClose $fd $sock
    return
}