# -*- perl -*-

BEGIN {
    use Exporter   ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

    $VERSION     = 1.00;
    @ISA         = qw(Exporter);
    @EXPORT      = qw();
    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],

    @EXPORT_OK   = qw(setup);
}
our @EXPORT_OK;

use DBI;

sub new {
    my $class = shift;
    my $s = {
	S => {
	    assocdb_path => 'cah-assocs.db';
	    assocdb_dsn => undef,
	    assocdb_user => '',
	    assocdb_password => '',
	    assocdb_table => 'assocs',
	    random_source => '/dev/urandom',
	    associdlen => 128, # bits
	    login_timeout => 86400, # seconds
	    param_name => 'cah_associd',
	    cookie_name => 'cah_associd', # make undef to disable cookie
	    cgi => undef,
	    get_param => sub { $s->_c()->param($s->{S}{param_name}) },
	    get_cookie => sub { $s->{S}{cookie_name}
				? $s->_c()->cookie($s->{S}{cookie_name})
				: '' },
	    get_method => sub { $s->_c()->request_method() },
	},
	D => undef,
    };
    my ($k,$v);
    while (($k,$v,@_) = @_) {
	die "unknown setting $k" unless exists $s->{S}{$k};
	$s->{S}{$k} = $v;
    }
    bless $s, $class;
    return $s;
}

sub _c ($) {
    my ($s) = @_;
    return $s->{S}{cgi};
}

sub _dbopen ($) {
    my ($s) = @_;
    my $dbh = $s->{D};
    return $dbh if $dbh; 

    $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";

    my $u = umask 077;
    $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user}, 
		     $s->{S}{assocdb_password}, { 
			 AutoCommit => 0, RaiseError => 1,
		     });
    die "${assocdb_dsn} $! ?" unless $dbh;
    $s->{D} = $dbh;

    $dbh->do("BEGIN");

    eval {
	$dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
		 " associd VARCHAR PRIMARY KEY,".
                 " username VARCHAR,".
		 " last INTEGER"
		 ")");
    };
    return $dbh;
}

sub record_login ($$) {
    my ($s,$nusername) = @_;
    my $rsp = $s->{S}{random_source};
    my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
    my $bytes = ($s->{S}{associdlen} + 7) >> 3;
    my $nassocbin;
    $!=0;
    read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
    close $rsf;
    my $nassoc = unpack "H*", $nassocbin;
    my $dbh = $s->_dbopen();
    $dbh->do("INSERT INTO $s->{S}{assocdb_table}".
	     " (associd, username, last) VALUES (?,?,?)", {},
	     $nassoc, $nusername, time);
    $dbh->do("COMMIT");
    $username = $nusername;
    $assoc =    $nassoc;
}

sub _check ($) {
    my ($s) = @_;
    my $qassoc = $s->{S}{param_get}();
    if (!defined $qassoc) {
	$qassoc = $s->{S}{cookie_get}();
	return undef unless defined $qassoc;
	return undef unless $s->{S}{get_method}() eq 'GET';
    }
    my $dbh = $s->_dbopen();
    my ($nusername, $nlast) =
	$dbh->selectrow_array("SELECT username, last".
			      " FROM $s->{S}{assocdb_table}".
			      " WHERE associd = ?", {}, $qassoc);
    return undef unless defined $nusername;
    my $timeout = $s->{S}{login_timeout};
    return undef unless !defined $timeout || time <= $nlast + $timeout;

    return ($nusername, $qassoc);
}

sub check ($) {
    my ($s) = @_;

    my ($nusername, $qassoc) = $s->_check() or return undef;

    # hooray
    $dbh->do("UPDATE $s->{S}{assocdb_table}".
	     " SET last = ?".
	     " WHERE associd = ?", {}, time, $qassoc);
    $dbh->do("COMMIT");

    $username = $nusername;
    $assoc =    $qassoc;
    return $username;
}

sub logout ($) {
    my ($s) = @_;

    if (my ($nusername, $qassoc) = $s->_check()) {
	$dbh->do("DELETE FROM $s->{S}{assocdb_table}".
		 " WHERE associd = ?", {}, $qassoc);
	$dbh->do("COMMIT");
    }
}
