package Mirimar::Authenticate::AuthTokens;

############################################################################
# Copyright (c) 2001 - 2005 Mirimar Networks & Issac Goldstand             #
# Issac Goldstand <margol@beamartyr.net> reserves the right to be          #
# recognized as the original author of this software                       #
# All other rights reserved by Mirimar Networks                            #
#                                                                          #
# This module is now free software and is released under the same          #
# license as Perl itself. See the Perl README for details.                 #
#                                                                          #
# Usage of this module signifies complete acceptance of the disclaimer(s)  #
# set forth at http://www.mirimar.net/disclaimer.php                       #
#                                                                          #
# An up-to-date copy of this module can be found at                        #
# http://www.beamartyr.net/projects/AuthTokens.pm                          #
############################################################################

use strict;
use warnings qw(all);
use DBI;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $Default_Expire_Offset
            $dbh $dbname $dbhost $dbuser $dbpass );
use Apache;
use Apache::Cookie;
use Apache::Session::MySQL;
use Apache::Constants qw(:response :http);
use URI::Escape;

$dbhost='localhost';
$dbname='tokens';
$dbuser='user';
$dbpass='secret';

BEGIN {
    use Exporter ();
    $VERSION=2.12;
    @ISA=qw(Exporter);
    @EXPORT=();
    @EXPORT_OK=qw ( check_auth establish_auth clear_auth extend_auth expired_auth expdate_auth );
    %EXPORT_TAGS=();
}

### Version History
# 2.06 : Started logging changes here, I guess so anything not mentioned later was in here
# 2.07 : Sept 30, 2001 - Changed new Apache::Requests to Apache::Request->instances
# 2.08 : Sept 30, 2001 - Added DISABLE_UPLOADS=>1 to request objects, as uploads will need it's own Authen/Authz handlers
# 2.09 : Oct  03, 2001 - Started porting login/logout to Authentication module.  Start moving to Authen/Authz (instead of FixUp)
# 2.10 : Oct  03, 2001 - Finished login/loout/form port - It seems to work - revisions to 2.1 will improve this
# 2.11 : Dec  20, 2001 - Fixed redirects
# 2.12 : Jan  13, 2002 - Added abstraction

my %session;
# Default expires time is 3 days
$Default_Expire_Offset=259200; #60*60*24*3
# connect_dbh returns a handle to DBI

 ### START ###
BEGIN {
    my $mysqldsn="DBI:mysql:database=$dbname;host=$dbhost;mysql_compression=1";
    $dbh=DBI->connect($mysqldsn,$dbuser,$dbpass) or die "couldn't connect: ".DBI->errstr;
};

END {
    $dbh->disconnect;
}

### Authentication subroutines

sub establish_auth
{
    my $param_count=scalar(@_);
    my ($unique_id, $expires_time, @challenge_tokens)=@_;
    my ($session_id,$index,$challenge_id)=(0,0,0);
    if (!(defined($expires_time)))
    {
	$expires_time=$Default_Expire_Offset;
    }
    tie %session, 'Apache::Session::MySQL', undef, {Handle=>$dbh,LockHandle=>$dbh};
    $session_id=$session{_session_id};
    $session{unique_id}=$unique_id;
    $session{eoffset}=$expires_time;
    if ($param_count>2)
    {
	$session{ccount}=scalar(@challenge_tokens);
# The followng is commented out, because I fear that I'm re-inventing the wheel
    foreach $index (1..$session{ccount})
    {
	$challenge_id="challenge${index}";
	$session{$challenge_id}=$challenge_tokens[$index-1];
     }
# The following replaces the above commented section
#	$session{challenge}=@challenge_tokens;
    } else {
	$session{ccount}=0;
    }
    $session{expires}=time+$expires_time;
    untie %session;
    return $session_id;
}

sub check_auth
{
    my $param_count=scalar(@_);
    my ($auth_token, @challenge_tokens)=@_;
    my ($index,$unique_id,$challenge_id,$ok)=(0,"","",1);
    tie %session, 'Apache::Session::MySQL', $auth_token, {Handle=>$dbh,LockHandle=>$dbh};
    if (!($auth_token eq $session{_session_id})) #oops - we made one by accident!!!
    {
	eval 'tied %session->delete;'; 
	return undef;
    }
    if ($param_count>1) 
    {
	$ok=$ok && ($session{ccount}==scalar(@challenge_tokens));
	foreach $index (1..$session{ccount})
	{
	    $challenge_id="challenge${index}";
	    $ok=$ok && ($session{$challenge_id} eq $challenge_tokens[$index-1]);
        }
    } else {
	$ok=($ok && $session{ccount}==0);
    }
    if ($ok==1)
    {
	$unique_id=$session{unique_id};
	$session{expires}=time+$session{eoffset};
    } else {
	undef $unique_id;
    }
    untie %session;
    return $unique_id;
}

sub clear_auth
{
    my ($auth_token)=@_;
    tie %session, 'Apache::Session::MySQL', $auth_token, {Handle=>$dbh,LockHandle=>$dbh};
    tied(%session)->delete;
}

sub extend_auth
{
    my ($auth_token, $expires_time)=@_;
    tie %session, 'Apache::Session::MySQL', $auth_token, {Handle=>$dbh,LockHandle=>$dbh};
    $session{expires}=$session{expires}+($expires_time-$session{eoffset});
    $session{eoffset}=$expires_time;
    untie %session;
}

sub expired_auth
{
    my ($auth_token)=@_;
    my $retval;
    tie %session, 'Apache::Session::MySQL', $auth_token, {Handle=>$dbh,LockHandle=>$dbh};
    if ($session{expires}<time) {$retval=-1;} else {$retval=0;}
    untie %session;
}

sub expdate_auth
{
    my ($auth_token)=@_;
    my $retval;
    tie %session, 'Apache::Session::MySQL', $auth_token, {Handle=>$dbh,LockHandle=>$dbh};
    $retval=$session{expires};
    untie %session;
    return $retval;
}

### mod_perl handlers

### Default Authen/Authz handlers

sub handler($) # Main authentication handler
{
    my $r=shift;
    $r->err_header_out('Auth-Ver'=>$VERSION);
    return OK unless $r->is_initial_req; #only the first internal request
    my $uvalidated=1;
    my $gvalidated=1;
    my $guest_uid=undef;
    my $uid=undef;
    my $q=Apache::Request->instance($r,DISABLE_UPLOADS=>1);
# Check member logins
    my %cookies=Apache::Cookie->fetch;
    my $cookid=undef;
    if (defined($cookies{'sessionlid'}))
    {
	$cookid=$cookies{'sessionlid'}->value;
    }
    if (!(defined($cookid)))
    {
	$uvalidated=0;
    } else {
	$uid=eval ('check_auth($cookid);');
	if (!(defined($uid)))
	{
	    $uvalidated=0;
	}
    }
# Check guest (new email) login
    if (!(defined($q->param('sessionlid'))))
    {
	$gvalidated=0;
    } else {
	$guest_uid=eval 'check_auth($q->param("sessionlid"),$q->param("authid"),$q->param("fid"));';
	if (!(defined($guest_uid)))
	{
	    $gvalidated=0;
	} else {
	    if (!(defined($uid)))
	    {
		$cookid=$q->param("sessionlid");
	    }
	}
    }
    if (($uvalidated==0) && ($gvalidated==0))
    { # No authentication found (expired?)
	$r->log_error("AUTHEN FAILED");
	my $cookie=Apache::Cookie->new($r,-name=>"sessionlid",-value=>$cookid,-expires=>"+1s",-path=>'/'); #expire the cookie
	$cookie->bake;
	$r->no_cache(1);
	$r->header_out("Location"=>"/nologin?endurl=".uri_escape($r->uri."?".$r->args));
	return HTTP_MOVED_TEMPORARILY;
    }

    # Return authentication cookie
    my $etime=expdate_auth($cookid);
    my $stime=gmtime($etime);
    my $cookie=Apache::Cookie->new($r,-name=>"sessionlid",-value=>$cookid,-expires=>$stime,-path=>'/');
    $cookie->bake;
    if ($uvalidated) {
	$r->subprocess_env("UID",$uid);
	$r->pnotes('uid'=>$uid);
    }
    if ($gvalidated) {
	$r->subprocess_env("GFID",$q->param("fid"));
	$r->pnotes('gfid'=>$q->param('fid'));
    }
    return OK;
}

### Login/Logout Handlers

sub login($)
{
    my $r=shift;
    $r->no_cache(1);
    my $q=Apache::Request->new($r, DISABLE_UPLOADS=>1);
    my $cookid=undef;
    my %cookies=Apache::Cookie->fetch;
    eval '$cookid=$cookies{sessionlid}->value || undef;';
    my $endurl=$q->param('endurl') || "";
    $endurl=~s/^(\/)//; #remove leading / - provided by $c{url}{http(s)}
    my $uid=undef;
    if (defined($cookid)) { #Attempt to login via authentication token
        $uid=eval ('check_auth($cookid)') || undef;
        if (defined($uid)) {
	    if ($uid!=0) {
        	    if ($endurl ne "")
			{
			    $r->header_out("Location"=>$endurl);
			    return HTTP_MOVED_TEMPORARILY;
			}
        	    else
			{
			    $r->header_out("Location"=>"/start");
			    return HTTP_MOVED_TEMPORARILY;
			}
	    } else { #If we have a token, and the token didn't check, we'd better try to dump it - but eval it, just in case
		eval ('clear_auth($cookid);');
	    }
        } #defined uid
    } #in any case, let's check username password now...
    if (!($q->param('lname') && $q->param('pchal')))
    {	# No authentication supplied
	$r->header_out("Location"=>"/nologin?endurl=".uri_escape($endurl));
	return HTTP_MOVED_TEMPORARILY;
    }
    my $auth=TFile::Authenticate::UserID->new($q->param('lname'));
    if (!($auth->check($q->param('pchal')))) { #Auth failed
	$r->header_out("Location","/nologin?endurl=".uri_escape($endurl));
   	return HTTP_MOVED_TEMPORARILY;
    }
    my $auth_token=establish_auth($auth->uid); # 3-day authentication
    my $check_uid=check_auth($auth_token); # Verify
    my $etime=expdate_auth($auth_token);
    my $stime=gmtime($etime);
    warn "Error creating session: ${$auth->uid} - $auth_token - $check_uid" unless ($auth->uid == $check_uid);
    # Set cookie
    my $cookie=Apache::Cookie->new($r,-name=>"sessionlid",-value=>$auth_token,-expires=>$stime,-path=>'/');
    $cookie->bake;
    if ($endurl ne "")
    {
        &printredirect($r,$endurl);
	return OK;
    } else {
        &printredirect($r,"/start"); #default
	return OK;
    }
}

sub logout($)
{
    my $r=shift;
    my $cookid=undef;
    my %cookies=Apache::Cookie->fetch();
    $r->no_cache(1);
    if (defined($cookies{sessionlid})) 
    {
        $cookid=$cookies{sessionlid}->value();
        eval 'clear_auth($cookid);';
        my $cookie=Apache::Cookie->new($r,-name=>"sessionlid",-value=>"",-expires=>"+1s");
        $cookie->bake();
        $r->send_http_header("text/html");
        print "<HTML><BODY BGCOLOR=\"White\">User logged out</BODY></HTML>";
    } else {
        $r->send_http_header("text/plain");
        print "User not logged in!!!\n";
    }
    return OK;
}

sub loginform($)
{
    my $r=shift;
    my %args=$r->args;
    my $endurl=$args{endurl} || "";
    $r->send_http_header('text/html');
    my $s=$r->server;
    my $name=$s->server_hostname;
    return OK if $r->header_only;
    {
	print <<EOF
<HTML>
<HEAD>
<META NAME="AUTHOR" CONTENT="Issac Goldstand <margol\@beamartyr.net>">
<TITLE>User not logged in</TITLE>
</HEAD>
<BODY>
<H1>User Not Logged In</H1>
<TABLE WIDTH="90%">
<TR><TD VALIGN="TOP" WIDTH="60%">
<H3>You are not logged into our system.  This could be because you have been automatically logged out.  To view your start page, please login in below</H3>
</TD><TD><TABLE>
<FORM ACTION=\"https://$name/cgi-bin/login\" METHOD=\"POST\">
<TR><TD>Login Name</TD><TD><INPUT NAME="lname" MAXLENGTH="30"/></TD></TR>
<TR><TD>Password</TD><TD><INPUT TYPE="PASSWORD" NAME="pchal" MAXLENGTH="15"/></TD></TR><TR><TD COLSPAN=2><CENTER>
<INPUT TYPE="HIDDEN" NAME="endurl" VALUE="$endurl"/>
<INPUT TYPE="SUBMIT" VALUE="Login"></CENTER></TD></TR></TABLE></FORM></TABLE>
</BODY></HTML>
EOF
    }
    return OK;
}

### Other helper subs

sub login_auth_bypass($)
{
    my $r=shift;
    $r->err_header_out('Auth-Ver'=>$VERSION);
    $r->log_error("BYPASS AUTHEN - OK");
    return OK; # Authenticate ALL for login
}

sub printredirect($$) # Called by login to print a redirect
{
    my $r=shift;
    my $end="/".shift;
    my $s=$r->server;
    my $name=$s->server_hostname;
    $end=~s/^\/{2,}/\//;
    $r->log_error("Refresh: $end");
    $r->header_out("Refresh"=>"0;url=http://".$name."$end");
    $r->send_http_header('text/html');
    $r->print("<HTML></HTML>");
}

### Objects

### UserID object. One of the subtypes of the generic User object.
package Mirimar::Authenticate::AuthTokens::UserID;
use DBIx::Objexts; # Not really compatible (yet), but the original framework was :-)
use DBI;
use vars qw(@ISA $dbh);

### START ###
BEGIN {
    my $mysqldsn="DBI:mysql:database=$dbname;host=$dbhost;mysql_compression=1";
    $dbh=DBI->connect($mysqldsn,$dbuser,$dbpass) or die "couldn't connect: ".DBI->errstr;
    @ISA=qw(DBIx::Object);
}

END {
    $dbh->disconnect;
}

sub _blank {
    %{$_[0]}=(
	UID    => undef,
	LOGIN  => "",
	CRYPT  => "",
	VALID  => 0,
    );
}

sub _refresh($$) {
    my $self=shift;
    my $sth=$dbh->prepare_cached("SELECT UID,login,crypt FROM passwd WHERE (login=?)");
    $sth->execute(shift);
    if ($sth->rows!=1) {
	$self->_blank;
    } else {
	my $res=$sth->fetchrow_hashref;
	$self->{UID}=$res->{UID};
	$self->{LOGIN}=$res->{login};
	$self->{CRYPT}=$res->{crpyt};
	$self->{VALID}=1;
    }
    $sth->finish;
    return $self;
}

sub update {
    my $self=shift;
    my $sth=$dbh->prepare_cached("UPDATE passwd SET crypt=? WHERE login=?");
    $self->{VALID}=$sth->execute($self->crypt,$self->login);
    $sth->finish;
    return $self->valid;
}    

sub refresh {
    my $self=shift;
    $self->_refresh($self->{login});
    return $self->valid;
}    

sub uid {
    return $_[0]->{UID};
}

sub login {
    return $_[0]->{UID};
}

sub crypt {
    my $self=shift;
    if (@_) {$self->{CRYPT}=CORE::crypt(shift,join( '',('.','/',0..9,'a'..'z','A'..'Z')[rand 64, rand 64]));$self->_taint;}
    return $self->{CRYPT};
}

sub check {
    my $self=shift;
    return 0 unless $self->valid;
    return ($self->crypt eq CORE::crypt(shift,$self->crypt));
}

### Guest authentication

package Mirimar::Authenticate::AuthTokens::Guest;

sub create_session($$) {
    my ($expires,$md5)=@_;
    my $ctx=Digest::MD5->new;
    $ctx->add(rand);
    $ctx->add($md5);
    $ctx->add(time);
    $ctx->add(rand);
    my $authid=$ctx->hexdigest(); #entropic enough? I think so...
    my $sessionlid=Mirimar::Authenticate::AuthTokens::establish_auth(0,$expires,$authid,$md5);
    my $check_uid=Mirimar::Authenticate::AuthTokens::check_auth($sessionlid,$authid,$md5);
    if (!($check_uid==0)) {die "failed check";}
    return ($sessionlid,$authid,$md5);
}

1;
 
=head1 NAME

Mirimar::Authenticate::AuthTokens - Manages session-persistant authentication data

=head1 SYNOPSIS

    #!/usr/bin/perl
    use Mirimar::Authenticate::AuthTokens qw(establish_auth check_auth
                                        extend_auth expired_auuth clear_auth);

    $auth_token = establish_auth($unique_id, $expire_offset,
                                             @challange_tokens); 
    # Establish $auth_token as key to retrieve $unique_id later on

    ...

    $unique_id = check_auth($auth_token, @challange_tokens); 
    # Use previously obtained $auth_token to 
    # retrieve original $unique_id

    ...
    
    extend_auth($auth_token, $expire_offset+(60*60*24*3));
    # Extend the life of $authtoken by 3 days (measured in seconds)

    ...

    if (expired_auth($auth_token)
    {
	clear_auth($auth_token);
    }
    # Remove $auth_token from authentication
    # database if it has expired

=head1 DESCRIPTION

Mirimar::Authenticate::AuthTokens is an attempt to create transparant user
authentication using Apache::Session as a base session manager.  The goal is 
to have a unified library of authenication checks against a centeralized
session database.  Included is the option to provide optional (but
persistant) authentication tokens.  The beauty of the 
system is that the optional tokens can DIFFER FROM USER TO USER.

Additionally, there is an expiration date on the data.  The expiration
date is dynamically calculated based on the last access time of the
authentication entry, and a time offset which can be provided.

This module used to be part of several internal projects and was recently
released as-is to the public domain in the hopes that it might help others.

=head1 INTERFACE

=over

=item *

establish_auth ($unique_id [, $expire_time_offset [, @challenge_tokens]])

Creates, and returns, an authentication token linked to $unique_id.
Additionally, it initializes an expiration ticket on the authentication
entry, which is equal to time() + $expire_time_offset.  If 
$expire_time_offset is not provided, then the default value of 3 days
is used.  The default time is changeable via the variable
$TFile::Authenticate::Default_Expire_Offset.
Lastly, an optional array of challenge tokens may be provided.  If
they are provided, then subsequent calls to check_authentication
must provide the EXACT same array of challenge tokens in order to
recieve the unique_id in return.  In order to use this, however, an
expiration date MUST be provided.

=item *

check_auth ( $auth_token [, @challenge_tokens])

Searches for an entry in the authentication database with matching
$auth_token (returned from establish_authentication).  If additional
challenge tokens were originally supplied, they must be resupplied in
the EXACT SAME FORM in order to authenticate the request.  Should the
request be authenticated, then the unique id stored in the authentication
database will be returned.  Otherwise, the function will return undef.
Additionally, should the authentication be successful, the expiration
date on the authentication entry will be updated to the current time, 
plus the offset provided at the token's creation time.  Note that if the 
authentication token is found, but the wrong challenge tokens are provided,
or aren't accurate, the expiration date will NOT be updated.

=item *

clear_auth ( $auth_token )

Permanently removes the authentication token matching $auth_token
from the authentication database.

=item *

extend_auth ( $auth_token, $expire_time_offset )

Alters the expiration date offset for the authentication token.
Additionally, it recomputes the expiration date based on the
new offset.  However, this is computed based on the difference
between the old and new offsets, and is NOT refreshed based
on the current time.

=item *

expired_auth ( $auth_token )

Returns true (-1) if the authentication token has expired.  Does
NOT remove the token from the database.  To do that, use clear_auth.

=item *

expdate_auth ( $auth_token )

Returns the expiration date stamp for the authentcation token.
Useful for feeding to a browser as a cookie's expiration date.

=back

=head1 AUTHOR

Copyright (c) 2001 - 2005 Mirimar Networks & Issac Goldstand
Issac Goldstand <margol@beamartyr.net> reserves the right to be recognized
as the original author of this software
All other rights reserved by Mirimar Networks

This module is now free software and is released under the same
license as Perl itself. See the Perl README for details.

Usage of this module signifies complete acceptance of the disclaimer(s) set
forth at http://www.mirimar.net/disclaimer.php

=head1 SEE ALSO

Apache::Session(3)

=cut