package CGI::LoginManager;
require 5.004;
use Carp 'croak';
use CGI;
use DBI;
use URI::Escape;
use Digest::MD5;

$CGI::LoginManager::VERSION='0.1';

# Defaults
our %defaults = (
   'table'         => 'Users',
   'usernamecol'   => 'username',
   'passwordcol'   => 'password',
   'sessidcol'     => 'sessid',
   'atimecol'      => 'sessatime',
   'timeout'       => 3600,
   'granularity'   => 300,
   'usernamefield' => 'username',
   'passwordfield' => 'password',
   'cookiename'    => 'LMSID',
   'justexpired'   => 0,
   'invalid'       => 0,
   'customauth'    => undef
);

## A login manager object contains the following attributes
#
# timeout         Idle time before a session expires (in seconds)
# granularity     Minimum difference in seconds between the last access time
#                 and the current time that justifies a database UPDATE of
#                 atimecol
# username
# password        Only exists if the user is to be authenticated by login/pass
# sessid
# atime
# table           Database table where user information is stored
# usernamecol     Column in the table where the username is stored
# passwordcol     Column in the table where the password is stored
# sessidcol       Column in the table where the session ID is stored
# atimecol        Instant of last session access
# cookiename      Name of the cookie to be sent to the browser
# dbparms         Parameters to connect to the database, in case the user
#                 wants LoginManager to establish the connection itself;
#                 see DBI->connect() for a list of the parameters
# dbh             Database handle
# cgi             CGI object reference
# justexpired     A session ID was provided in a cookie, but it has expired
# invalid         A session ID was provided in a cookie, but it does not
#                 match any session ID in the database
# customauth      A custom authentication function accepting the username
#                 and password as parameters and returning 1 on success and
#                 0 on failure
# 

# This module assumes the existence of a table like this:
# CREATE TABLE Users ( username varchar(32) NOT NULL PRIMARY KEY,
#                      password VARCHAR(32) NOT NULL,
#                      sessid VARCHAR(32),
#                      sessatime INT UNSIGNED
#                    );


# Create a LoginManager instance
# Can be passed an optional hash reference with default parameter overrides
sub new {
   my ($self, $params) = @_;
   $class = ref $self || $self;
   $params = {} unless $params;
   my %newobj = (%defaults, %$params);
   $self = bless \%newobj, $class;     # New self
   # Create CGI object, if necessary
   $self->cgi(CGI->new()) unless defined $self->cgi;
   # Connect to the database, if necessary
   unless (defined $self->dbh) {
      croak "ERROR: LoginManager->new() requires either dbh or dbparms"
            unless defined $self->{'dbparms'};
      my $dbh = DBI->connect(@{$self->{'dbparms'}})
            or croak $DBI::errstr;
      $self->dbh($dbh);
   }
   return $self;
}


# This is the main method in this module
# Returns true if the user is authorized to access the page; otherwise, it
# does not return
# First it tries to find a valid session in the cookie
# If there is no cookie or the session is invalid, it tries to find a username
# and password in the received form data and use those to authenticate the
# user; if the user is authenticated, a brand new session will be created and
# the page will be reloaded with the original form information intact; if the
# user cannot be authenticated, a login page will be shown.
sub authorize {
   my ($self) = @_;
   my $q = $self->cgi;
   return 1 if ($self->_getInfoBySessid);
   if ($self->_getInfoByUsernamePassword) {
      $self->_redirectToOriginal;
      exit 0;
   }
   $self->_loginPage;
   exit 0;
}


# Delete an active session
sub delete {
   my ($self) = @_;
   my $q = $self->cgi;
   return unless ($self->_getInfoBySessid);
   $self->sessid('');   # Works because empty session IDs are invalid
   $self->_flush();
}


# Flush the in-memory LoginManager object to the database after properly
# updating the atime
sub _flush {
   my ($self) = @_;
   my $dbupdate = << "END";
UPDATE $self->{'table'}
SET    $self->{'sessidcol'} = ?,
       $self->{'atimecol'} = ?
WHERE  $self->{'usernamecol'} = ?
END
   my $dbh = $self->{'dbh'};
   my $sth = $dbh->prepare($dbupdate)
      or croak $dbh->errstr;
   $sth->execute($self->sessid, $self->atime(time), $self->username)
      or croak $dbh->errstr;
   $dbh->commit unless $dbh->{'AutoCommit'};
}


# Flush only if the difference in access time justifies it
sub _conditionalFlush {
   my ($self) = @_;
   $self->_flush() if (time > $self->atime + $self->granularity);
}


# Retrieves info from the database to self using (username, password) as key
# Returns 1 if successful, 0 otherwise
sub _getInfoByUsernamePassword {
   my ($self) = @_;
   my $q = $self->cgi;
   my $username = $q->param($self->{'usernamefield'});
   my $password = $q->param($self->{'passwordfield'});
   return 0 unless ($username and $password);
   my $sth;
   if (defined($self->{'customauth'})) {
      return 0 unless $self->{'customauth'}->($username, $password) == 1;
      my $dbquery = << "END";
SELECT $self->{'sessidcol'}, $self->{'atimecol'}
FROM   $self->{'table'}
WHERE  $self->{'usernamecol'} = ?
END
      $sth = $self->{'dbh'}->prepare($dbquery)
         or croak $self->{'dbh'}->errstr;
      $sth->execute($username)
         or croak $self->{'dbh'}->errstr;
      # Authentication fails whenever the username is not in the database,
      # even if the custom authentication was successful
      return 0 if $sth->rows == 0;
   } else {
      $password = $self->_hashPassword($password);
      my $dbquery = << "END";
SELECT $self->{'sessidcol'}, $self->{'atimecol'}
FROM   $self->{'table'}
WHERE  $self->{'usernamecol'} = ? AND $self->{'passwordcol'} = ?
END
      $sth = $self->{'dbh'}->prepare($dbquery)
         or croak $self->{'dbh'}->errstr;
      $sth->execute($username, $password)
         or croak $self->{'dbh'}->errstr;
      return 0 if $sth->rows == 0;
   }
   my @data = $sth->fetchrow_array;
   $self->username($username);
   $self->sessid($data[0]);
   $self->atime($data[1]);
   $self->sessid($self->newSessid);
   $self->_flush;
   return 1;
}


# Retrieves info from the database to self using (sessid) as key
# Returns 1 if successful, 0 otherwise
sub _getInfoBySessid {
   my ($self, $sessid) = @_;
   my $q = $self->cgi;
   my $sessid = $q->cookie($self->{'cookiename'});
   return 0 unless $sessid;   # Empty session IDs are invalid
   my $dbquery = << "END";
SELECT $self->{'usernamecol'}, $self->{'atimecol'}
FROM   $self->{'table'}
WHERE  $self->{'sessidcol'} = ?
END
   my $sth = $self->{'dbh'}->prepare($dbquery)
      or croak $self->{'dbh'}->errstr;
   $sth->execute($sessid)
      or croak $self->{'dbh'}->errstr;
   if ($sth->rows == 0) {
      $self->invalid(1);
      return 0;
   }
   my @data = $sth->fetchrow_array;
   $self->{'username'} = $data[0];
   $self->{'sessid'} = $sessid;
   $self->{'atime'} = $data[1];
   if ($self->expired) {
      $self->justexpired(1);
      return 0;
   }
   $self->_conditionalFlush();   # Update sessatime, if necessary
   return 1;
}


# Hash the password with the same function used to store it in the database
sub _hashPassword {
   my ($self, $password) = @_;
   # Default hashing function is a simple hex MD5
   return Digest::MD5::md5_hex($password);
}


# Show the login page
sub _loginPage {
   my ($self) = @_;
   my $q = $self->cgi;
   my $url = $q->url();
   my $scriptname = $url;  # Always the same script
   $scriptname =~ s/^http:/https:/; # Except we login through https
   print $q->header(-type => 'text/html');
   print $q->start_html('Login');
   print $q->start_form(-action => $scriptname);  # Self
   print $q->p('Username:', $q->textfield(-name => $self->{'usernamefield'}));
   print $q->p('Password:',
      $q->password_field(-name     => $self->{'passwordfield'},
                         -default  => '',
                         -override => 1));
   print $q->p($q->submit(-value => 'Login'),
               $q->hidden(-name    => 'reqmethod',
                          -default => $q->request_method),
               $q->hidden(-name    => 'requrl',
                          -default => $url),
               $q->hidden(-name    => 'reqpathinfo',
                          -default => $q->path_info),
               $q->hidden(-name    => 'reqquery',
                          -default => $q->query_string));
   print $q->end_form();
   if ($self->justexpired) {
      print $q->p('Your session has expired, please login again.');
   }
   if ($self->invalid) {
      print $q->p('Your session is invalid. Perhaps you logged in in another computer?');
   }
   if ($q->param($self->{'usernamefield'})) {
      # Username present but failed authentication
      print $q->p('Wrong credentials, please try again.');
   }
   print $q->end_html();
}


# Redirect to original page
sub _redirectToOriginal {
   my ($self) = @_;
   my $q = $self->cgi;
   my $method = $q->param('reqmethod');
   my $url = $q->param('requrl');
   my $pathinfo = $q->param('reqpathinfo');
   my $query = $q->param('reqquery');

   print $self->header(-type => 'text/html'); # Includes the cookie
   print $q->start_html('Login succeeded');
   print $q->start_form(-method => $method,
                        -action => $url.$pathinfo);
   print $q->p('Login succeeded. Press "Continue" to go back to the page you had requested.');
   # Generate one hidden field per parameter of the original request 
   foreach my $pair (split(/&/, $query)) {
      my ($name, $value) = split(/=/, $pair);
      $name = uri_unescape($name);
      $value = uri_unescape($value);
      print $q->hidden(-name     => $name,
                       -default  => $value,
                       -override => 1);
   }
   # Plain XHTML since buttons created by the CGI::submit method always
   # have a name, adding an extraneous parameter
   print $q->p('<input type="submit" value="Continue" />');
   print $q->end_form();
   print $q->end_html();
}


#### Accessor methods ####

sub username {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'username'} = $value;
   } else {
      $self->{'username'};
   }
}

sub sessid {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'sessid'} = $value;
   } else {
      $self->{'sessid'};
   }
}

sub atime {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'atime'} = $value;
   } else {
      $self->{'atime'};
   }
}

sub justexpired {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'justexpired'} = $value;
   } else {
      $self->{'justexpired'};
   }
}

sub invalid {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'invalid'} = $value;
   } else {
      $self->{'invalid'};
   }
}

sub expired {
   my ($self) = @_;
   return (time > $self->atime + $self->timeout);
}

sub granularity {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'granularity'} = $value;
   } else {
      $self->{'granularity'};
   }
}

sub timeout {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'timeout'} = $value;
   } else {
      $self->{'timeout'};
   }
}

sub cgi {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'cgi'} = $value;
   } else {
      $self->{'cgi'};
   }
}

sub dbh {
   my ($self, $value) = @_;
   if (defined $value) {
      $self->{'dbh'} = $value;
   } else {
      $self->{'dbh'};
   }
}

sub cookie {
   my ($self) = @_;
   my $q = $self->cgi;
   $q->cookie(-name  => $self->{'cookiename'},
              -value => $self->sessid);
}

sub header {
   my $self = shift;
   my $q = $self->cgi;
   $q->header(-cookie => $self->cookie, @_);
}

sub redirect {
   my $self = shift;
   my $q = $self->cgi;
   $q->redirect(-cookie => $self->cookie, @_);
}

sub newSessid {
   my $md5 = new Digest::MD5();
   $md5->add($$ , time, rand(time));
   return $md5->hexdigest();
}

1;