/* ====================================================================
 *
 * Copyright (c) 1996-1998 NeoSoft, Inc.  All rights reserved.
 *
 * You may freely redistribute most NeoSoft extensions to the Apache webserver
 * for any purpose except commercial resale and/or use in secure servers,
 * which requires, in either case, written permission from NeoSoft, Inc.  Any
 * redistribution of this software must retain this copyright, unmodified
 * from the original.
 *
 * Certain NeoSoft extensions, such as those in support of electronic
 * commerce, require a license for use and may not be redistributed
 * without explicit written permission, obtained in advance of any
 * such distribution from NeoSoft, Inc.  These files are clearly marked
 * with a different copyright.
 *
 * Other packages included with this distribution may contain their own
 * copyrights.  It is your responsibility to insure that you are operating
 * in compliance with all relevant copyrights.  The NeoSoft copyright is
 * not intenteded to infringe on the rights of the authors or owners of
 * said copyrights.
 *
 * Some of the software in this file may be derived from code
 * Copyright (c) 1995 The Apache Group.  All rights reserved.
 *
 * Redistribution and use of Apache code in source and binary forms is
 * permitted under most conditions.  Please consult the source code to
 * a standard Apache module, such as mod_include.c, for the exact
 * terms of this copyright.
 *
 * THIS SOFTWARE IS PROVIDED BY NEOSOFT ``AS IS'' AND ANY
 * EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL NEOSOFT, THE APACHE GROUP, OR
 * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
 * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
 * OF THE POSSIBILITY OF SUCH DAMAGE.
 * ====================================================================
 */

/*
 * auth_tcl: authentication via Tcl procs in main interpreter
 *
 * Rob McCool
 * Randy Kunkee
 * Mark Abrams (Video Collage, Inc.)
 *
 */

/*
 * mod_auth_tcl.c: Handles authentication via Tcl
 *
 * If you want to use this module, you must also include mod_neoscript.c
 * in your server, since this module depends on Tcl_Interp *interp to be
 * exported by it.
 *
 * Based on authentication module originally written by Rob McCool and
 * adapted to Shambhala by rst.
 *
 * Alterations from there to present form by Randy Kunkee of NeoSoft.
 *
 */

#include "httpd.h"
#include "http_config.h"
#include "http_core.h"
#include "http_log.h"
#include "http_protocol.h"
#include "ap_compat.h"

#include "tcl.h"
extern Tcl_Interp *interp;

typedef struct tcl_auth_config_struct {
    char *tcl_basic_auth_command;
    char *tcl_basic_access_command;
    char *tcl_access_command;
} tcl_auth_config_rec;

static void *create_tcl_auth_dir_config (pool *p, char *d)
{
    tcl_auth_config_rec *sec =
    (tcl_auth_config_rec *) ap_pcalloc (p, sizeof(tcl_auth_config_rec));
    sec->tcl_basic_auth_command = NULL;
    sec->tcl_basic_access_command = NULL;
    sec->tcl_access_command = NULL;
    return sec;
}

static const char *tcl_set_string_slot(cmd_parms *cmd,
						char *struct_ptr, char *arg)
{
    char *p;
    int offset = (int) (long) cmd->info;
    p = ap_pstrdup(cmd->pool, arg);
    *(char **) (struct_ptr + offset) = p;
    return NULL;
}

command_rec tcl_auth_cmds[] = {
{ "TclAuthBasic", tcl_set_string_slot,
    (void*)XtOffsetOf(tcl_auth_config_rec,tcl_basic_auth_command), OR_AUTHCFG, RAW_ARGS, NULL },
{ "TclAuthAccess", tcl_set_string_slot,
    (void*)XtOffsetOf(tcl_auth_config_rec,tcl_basic_access_command), OR_AUTHCFG, RAW_ARGS, NULL },
{ "TclAccess", tcl_set_string_slot,
    (void*)XtOffsetOf(tcl_auth_config_rec,tcl_access_command), OR_AUTHCFG, RAW_ARGS, NULL },
{ NULL }
};

module MODULE_VAR_EXPORT tcl_auth_module;


/* These functions return 0 if client is OK, and proper error status
 * if not... either AUTH_REQUIRED, if we made a check, and it failed, or
 * SERVER_ERROR, if things are so totally confused that we couldn't
 * figure out how to tell if the client is authorized or not.
 *
 * If they return DECLINED, and all other modules also decline, that's
 * treated by the server core as a configuration error, logged and
 * reported as such.
 */

/*    A u t h e t i c a t i o n
 *
 * Determine user ID, and call Tcl with configured basic auth command.
 * Tcl command must return either a string containing the password, or`
 * an empty string, indicating the user was not found.
 */

static int authenticate_basic_user_via_tcl (request_rec *r)
{
    tcl_auth_config_rec *sec =
      (tcl_auth_config_rec *)ap_get_module_config (r->per_dir_config, &tcl_auth_module);
    conn_rec *c = r->connection;
    const char *sent_pw;
    char errstr[MAX_STRING_LEN];
    int res;

    if ((res = get_basic_auth_pw (r, &sent_pw))) return res;

    if(!sec->tcl_basic_auth_command)
	return DECLINED;

    /*
     * 9/24/97: let the Tcl code compare the password.  This allows for
     * retries and cache invalidations.  TCL_ERROR means the code trapped
     * and we should log the entire errorInfo value for debugging.
     * An empty return value means the password is okay, and anything else
     * is a reason for failure to be logged.
     */
    if (Tcl_VarEval(interp, sec->tcl_basic_auth_command, " ", c->user, " ", sent_pw, (char*)0)) {
	sprintf(errstr,"Tcl auth_command error: %s\n%s",interp->result, Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY));
	log_reason (errstr, r->uri, r);
	note_basic_auth_failure (r);
	return AUTH_REQUIRED;
    }
    if (interp->result[0] != '\0') {
	log_reason (interp->result, r->uri, r);
	note_basic_auth_failure (r);
	return AUTH_REQUIRED;
    }
    return OK;
}

/*   A u t h o r i z a t i o n
 *
 * after authenticating who a user is Apache enters the authorizarion phase.
 * In this phase we determine if this user should be granted access to the
 * requested location.  Naming this routine check_user_authorization_via_tcl
 * might makes things a bit less confusing
 */

static int check_user_access_via_tcl (request_rec *r) {
    tcl_auth_config_rec *sec =
      (tcl_auth_config_rec *)ap_get_module_config (r->per_dir_config, &tcl_auth_module);
    char *user = r->connection->user;
    int m = r->method_number;
    int method_restricted = 0;
    int code;
    register int x;
    char *t;
    array_header *reqs_arr = (array_header *) requires(r);
    require_line *reqs;

    /* BUG FIX: tadc, 11-Nov-1995.  If there is no "requires" directive,
     * then any user will do.
     */
    if (!reqs_arr)
	return (OK);

    if (! sec->tcl_basic_access_command)
	return AUTH_REQUIRED;

    reqs = (require_line *)reqs_arr->elts;

    for(x=0; x < reqs_arr->nelts; x++) {

	if (! (reqs[x].method_mask & (1 << m))) continue;

	method_restricted = 1;

	t = reqs[x].requirement;
	code = Tcl_VarEval(interp, sec->tcl_basic_access_command, " ", user, " ", t, (char*)NULL);
	if (code == TCL_ERROR)
	{
	    log_reason ("Tcl access_command error", interp->result, r);
	    note_basic_auth_failure (r);
	    return AUTH_REQUIRED;
	}
	if (strcmp(interp->result, "OK") == 0)
	    return OK;
	else if (strcmp(interp->result, "AUTH_REQUIRED") == 0) {
	    note_basic_auth_failure (r);
	    return AUTH_REQUIRED;
	}
    }

    if (!method_restricted)
      return OK;

    note_basic_auth_failure (r);
    return AUTH_REQUIRED;
}

/* A c c e s s
 *
 * Access control doesnt care about user identity, so the user doesnt
 * need to enter anything. This routine gets called for attempts to
 * access any file within a directory with a defined access procedure
 * (through .htaccess or elsewhere). To define an access procedure the
 * .htacess file should contain a line that looks like this:
 *    TclAccess my_access_procedure
 * my_access_procedure is a tcl procedure which is defined within
 * neowebscript (for instance, in neowebscript's init.tcl). This
 * routine will be passed the name of the file whose access is being
 * attempted. Note that the access procedure can use the webenv array,
 * so the file whose access is being attempted is also available as
 *	$webenv(DOCUMENT_URI).
 * The access procedure must return one of the following:
 *	OK return allows access
 *	FORBIDDEN return denies access
 *	DECLINED return passes decision on to any other handlers
 *		which may exist
 */

static int ck_direct_access_via_tcl (request_rec *r) {
    tcl_auth_config_rec *sec =
      (tcl_auth_config_rec *)ap_get_module_config(r->per_dir_config,
						  &tcl_auth_module);
    char errstr[MAX_STRING_LEN];
    int code;
    char *t;

    if (!sec->tcl_access_command)
	return DECLINED;

    propagate_vars_to_nws(interp, r) ;

    code = Tcl_VarEval(interp, sec->tcl_access_command, " ",
		       r->filename, (char*)NULL);
    if (code == TCL_ERROR) {
	sprintf(errstr,"Tcl ck_direct_access call error: %s\n%s",
		interp->result,
		Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY));
	log_reason (errstr, r->uri, r);
	return DECLINED ;
    }

    if (strcmp(interp->result,"OK") == 0)
       return OK ;
    if (strcmp(interp->result,"DECLINED") == 0)
       return DECLINED ;
    if (strcmp(interp->result,"FORBIDDEN") == 0)
       return FORBIDDEN ;

    /* there is an access routine but we dont understand it's return, so */
    return DECLINED ;
}

module tcl_auth_module = {
   STANDARD_MODULE_STUFF,
   NULL,			/* initializer */
   create_tcl_auth_dir_config,	/* dir config creater */
   NULL,			/* dir merger --- default is to override */
   NULL,			/* server config */
   NULL,			/* merge server config */
   tcl_auth_cmds,		/* command table */
   NULL,			/* handlers */
   NULL,			/* filename translation */
   authenticate_basic_user_via_tcl,	/* authentication - who is it? */
   check_user_access_via_tcl,	/* authorization - do we let him/her in? */
   ck_direct_access_via_tcl,	/* access (for instance by host id) */
   NULL,			/* type_checker */
   NULL,			/* fixups */
   NULL				/* logger */
};