#!perl -T
use strict;      # !!!IN DEVELOPMENT ONLY!!!
use warnings;    # !!!IN DEVELOPMENT ONLY!!!

BEGIN
{ 
    @INC = qw( c:/perl/lib c:/perl/site/lib );
    sub CONFIG() { '../data/conf/site.conf' }
    delete @ENV{ qw( IFS CDPATH ENV PATH SHELL COMSPEC WINDIR ) };
}

use CGI;                             # THE module for CGI
use CGI::Carp qw( fatalsToBrowser ); # !!!IN DEVELOPMENT ONLY!!!
use Digest::MD5 qw( md5_base64 );    # for password encryption
use Apache::Session::File;

$CGI::DISABLE_UPLOADS = 1;           # Disable uploads
$CGI::POST_MAX        =   1 * 1024;  # Maximum number of bytes per post


# initialize objects
my $config = do( CONFIG );
my $q = CGI->new();

# create list of valid params and untainting code
my %valid_params = (
    username => qr/^([a-zA-Z\d_]{4,16})$/,
    password => qr/^([\x20-\x7E]{4,16})$/,
    remember => qr/^(on)$/,
    newuser  => qr/^(on)$/,
);

# create list of messages
my %messages = (
    error  => 'Your username and password information did not match. Check to ' 
        . 'see that you do not have Caps Lock on, hit the back button, and '
        . 'try again.', 
    exists => 'The username you have selected already exists. Please select '
        . 'another username. If you have forgotten your password, please call '
        . 'an administrator.',
);

# get valid parameters from cgi object
my %params = get_valid_params( $q, \%valid_params );

# untaint parameters
for( keys %params )
{
    # !!!TODO!!! check 'ref' line for subtle bugs
    ( display_message( $messages{error} ) && exit )
        unless ref($valid_params{$_}) eq 'Regexp';
    if( $params{$_} =~ /$valid_params{$_}/ )
    {
        $params{$_} = $1;
    }
    else
    {
        display_message( $messages{error} ) && exit;
    }
}

# create session
my $session_id = create_session( $config );

my $userfile = get_userfile( $config, $params{username} );
open( USER, '<', $userfile ) or display_message( $messages{error} ), exit;
chomp ( my ( $real_digest, $sessionID ) = <USER> );
close USER or display_message( $messages{error} ), exit;

# create digest
my $user_digest = create_digest( $params{password}, $config->{salt} );

# verify digest and continue if valid
if ( verify_digest( $user_digest, $real_digest ) )
{
    my $sid = create_sessionid();
    $sessionID = $sid;

## !!!UNTAINT - WHY!!!
( $userfile ) = ( $userfile =~ /(.*)/ );

    open( USER, '>', $userfile ) 
        or display_message( $messages{error} ), exit;
    print USER $real_digest, $/, $sid, $/;
    close USER or display_message( $messages{error} ), exit;

    display_message( "Hello, $params{username}. Good password" ) && exit;
}

# fall-through error
display_message( $messages{error} );
exit;


## subs follow

# display messages to browser ( given scalar )
sub display_message($)
{
    my $message = shift;
    print
        $q->header(),
        $q->start_html(),
        $q->p( $message ),
        $q->end_html(),
    ;
}

# get valid parameters from cgi object ( given cgi_object, hash_ref )
sub get_valid_params($$)
{
    my( $q, $valid_params ) = ( shift, shift );
    
    my %params = 
        map  { $_ => get_param_data( $q, $_ ) }   # return key-value pairs of
        grep { exists $valid_params->{$_} }       # valid_params members from
        $q->param;                                # cgi object param list
    return %params;
}

# determines and returns proper type (array or scalar) for CGI parameter
# ( given cgi_object, scalar )
sub get_param_data($$)
{
    my( $q, $name ) = ( shift, shift );
    my @values = $q->param( $name );
    return @values > 1
        ? \@values
        : $values[0];
}

# create user file
sub create_userfile
{
    my ( $config, $username, $digest ) = ( shift, shift, shift );
    local *USER;
    my $userfile = $config->{ users } . $username;

## !!!UNTAINT - WHY!!!
( $userfile ) = ( $userfile =~ /^(.*)$/ ) ;

    open( USER, '>', $userfile )
        && print USER $digest, $/;
}

# get user file
sub get_userfile
{
    my ( $config, $username ) = ( shift, shift );
    $config->{ users } . $username;
}

# create MD5 digest
sub create_digest
{
    my $data = shift || '';
    my $salt = shift;
    return md5_base64( $data, $salt );
}

# verify MD5 digests match
sub verify_digest
{
    my ($user_digest, $real_digest) = (shift, shift);
    if( defined $user_digest 
        && defined $real_digest 
        && $user_digest eq $real_digest )
    { return $real_digest }
    return undef;
}

# create a session id
# !!!TODO!!!
sub create_sessionid { sprintf '%06d', rand( 999_999 ) } # fake a session id

# create a session
sub create_session 
{
    my $config = shift;
    tie my %session, 'Apache::Session::File', undef, 
        { 
            Directory     => $config->{sessions}{dir},
            LockDirectory => $config->{sessions}{locks},
            Transaction   => $config->{sessions}{trans},
        };
    my $sid = $session{_session_id};
    undef %session;
    return $sid;
}

# retrieve an existing session (given $session_id)
sub retrieve_session 
{
    my $session_id = shift;
    tie my %session, 'Apache::Session::File', $session_id, 
        { Directory => $config->{sessions}{dir} };
    return %session;
}

# verify session
# !!!TODO!!!
sub verify_session 
{
}

sub set_session_data
{
    my $sid = shift;
    my %data = @_;
    my %session = retrieve_session( $sid );
    while( my( $key, $value ) = each %data ) { $session{$key} = $value }
    undef %session;
}

# remove session (given $session_id)
sub remove_session 
{
    my %session = retrieve_session( shift );
    tied(%session)->delete;
}