# -*- perl -*-

# This is part of CGI::Auth::Hybrid, a perl CGI authentication module.
# Copyright (C) 2012 Ian Jackson.
# 
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Affero General Public License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

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;
use CGI;

#---------- verifier object methods ----------

sub new_verifier {
    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',
	    promise_check_mutate => 0,
	    cookie_name => 'cah_associd', # make undef to disable cookie
	    get_param => sub { $_[0]->param($s->{S}{param_name}) },
	    get_cookie => sub { $s->{S}{cookie_name}
				? $_[0]->cookie($s->{S}{cookie_name})
				: '' },
	    get_method => sub { $_[0]->request_method() },
	},
	Dbh => undef,
    };
    my ($k,$v);
    while (($k,$v,@_) = @_) {
	die "unknown setting $k" unless exists $s->{S}{$k};
	$s->{S}{$k} = $v;
    }
    bless $s, $class;
    $s->_dbopen();
    return $s;
}

sub _dbopen ($) {
    my ($s) = @_;
    my $dbh = $s->{Dbh};
    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->{Dbh} = $dbh;

    $dbh->do("BEGIN");

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

#---------- request object methods ----------

sub new_request {
    my ($classbase, $cgi, @extra) = @_;
    if (!ref $classbase) {
	$classbase = $classbase->new_verifier(@extra);
    } else {
	die if @extra;
    }
    my $r = {
	S => $classbase->{S},
	Dbh => $classbase->{Dbh},
	Cgi => $cgi,
    };
    bless $r, ref $classbase;
}

sub _cm ($$@) {
    my ($r,$methname, @args) = @_;
    my $methfunc = $r->{S}{$methname};
    return $methfunc->($r->{Cgi}, $r, @args);
}

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

sub _check ($) {
    my ($r) = @_;
    my $qassoc = $r->_cm('get_param');
    my ($nassoc,$nmutate);
    if (!defined $r->{S}{cookie_name}) {
	# authentication is by hidden form parameter only
	return undef unless defined $qassoc;
	$nassoc = $qassoc;
	$nmutate = 1;
    } else {
	# authentication is by cookie
	# the cookie suffices for read-only GET requests
	# for mutating and non-GET requests we require hidden param too
	my $cassoc = $r->_cm('get_cookie');
	return undef unless defined $cassoc;
	$nassoc = $cassoc;
	if (defined $qassoc && $qassoc eq $cassoc) {
	    $nmutate = 1;
	} else {
	    return undef unless $r->{S}{promise_check_mutate};
	    return undef unless $r->_cm('get_method') eq 'GET';
	    $nmutate = 0;
	}
    }
    my $dbh = $r->{Dbh};
    my ($nusername, $nlast) =
	$dbh->selectrow_array("SELECT username, last".
			      " FROM $r->{S}{assocdb_table}".
			      " WHERE associd = ?", {}, $nassoc);
    return undef unless defined $nusername;
    my $timeout = $r->{S}{login_timeout};
    return undef unless !defined $timeout || time <= $nlast + $timeout;

    # hooray
    return ($nusername, $nassoc, $nmutate);
}

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

    my ($nusername, $nassoc, $nmutate) = $r->_check() or return undef;

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

    $r->{Username} = $nusername;
    $r->{Assoc} = $nassoc;
    $r->{Mutate} = $nmutate;
    return $nusername;
}

sub check_mutate ($) {
    my ($r) = @_;
}

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

    my ($nusername, $nassoc, $nmutate) = $r->_check();
    return undef unless $nmutate;
    $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
	     " WHERE associd = ?", {}, $nassoc);
    $dbh->do("COMMIT");
    return $nusername;
}

sub username ($) {
    my ($r) = @_;
    return $r->{Username};

sub hiddenv ($) {
    my ($r) = @_;
    return defined $r->{A} ? $r->{A} : '';
}

sub hiddena ($) {
    my ($r) = @_;
    return (-name => $r->{param_name},
	    -default => $r->hiddenv());
}

sub hiddenh ($) {
    my ($r) = @_;
    return hidden($r->hiddena());
}

sub cookieac ($) {
    my ($r) = @_;
    return (-name => $r->{cookie_name},
	    -value => hiddenv());
	    
