# -*- 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_core ($) {
    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;
	}
    }

# pages/param-sets are
#   n normal non-mutating page
#   r retrieval of information for JS, non-mutating
#   m mutating page
#   u update of information by JS, mutating
#   i login
#   o logout

    # Case analysis, cookie mode, app promises re mutate:
    # cook par meth  form
    #                      
    #  y   y   GET   nr       fine, show page or send data
    #
    #  y   -   GET   n        cross-site link
    #                           show data
    #  y1  y2  GET   n        intra-site link
    #                           from session no longer known to browser
    #                           do not revoke y2 as not a POST so not RESTful
    #                           treat as cross-site link, show data
    #  y   n   GET   n        intra-site link from stale session,
    #                           treat as cross-site link, show data
    #
    #  y   -   GET    r       bug or attack, fail
    #  y1  y2  GET    r       intra-site data request
    #                           from session no longer known to browser
    #                           do not revoke y2 as not a POST so not RESTful
    #                           fail
    #  y   n   GET    r       intra-site data request from stale session
    #                           fail
    #
    #  -/n y2  GET   n        cross-site link
    #                         but user has cleared cookies, revoke session
    #                           show login form
    #
    #  -/n y2  GET    rmuio   user has cleared cookies, revoke session
    #                           then as for   - - GET
    #
    #  n   any GET   n        cross-site link but user not logged in
    #                           show login form
    #
    #  n   any GET    r       data request from stale session
    #                           fail
    #
    #  any any GET     muoi   bug or attack, fail
    #
    #  y   y   POST  nrmu     mutation is OK, do operation
    #  y   y   POST      o    logout
    #  y   y   POST       i   login, redirect to GET of remaining params
    #
    #  any -   POST           bug or xsrf attack, fail
    #
    #  n/y1 y2 POST   r       intra-site form submission
    #                           from session no longer known to browser
    #                           revoke y2
    #                           show "session interrupted" login form
    #  n/y1 y2 POST    m      intra-site js operation
    #                           from session no longer known to browser
    #                           revoke y2
    #                           fail
    #  y   n   POST  r        intra-site form submission from stale session
    #                           show "session interrupted"
    #  y   n   POST    m      intra-site form submission from stale session
    #                           fail
    #
    #  -   y2  GET            intra-site link or data request
    #                           from session no longer known to browser
    #                           fail

    #  -   y2        any      req from old session y2, del y2, show login
    #  y1  y2        any      req from old session y2, del y2, show y1 main

    #  y1 any  GET   non-mut  cross-site link
    #  y1 any  GET   non-mut  no mutation, show page providing new par
    #
    #  A   B         any      page from old session or cross-site request
    #  any y2 POST  logout    do logout y2


    #  any any GET   mutate   bug or attack, forbidden, call die

    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) = @_;

    return if exists $r->{Username};
    ($r->{Username}, $r->{Assoc}, $r->{Mutate}) = $r->_check();

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

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 check ($) {
    my ($r) = @_;
    $r->_check();
    return !!defined $r->{Username};
}

sub check_mutate ($) {
    my ($r) = @_;
    $r->check();
    return $r->{Mutate};
}

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

sub hidden_val ($) {
    my ($r) = @_;
    $r->check();
    return defined $r->{Assoc} ? $r->{Assoc} : '';
}

#---------- simple wrappers ----------

sub hidden_hargs ($) {
    my ($r) = @_;
    return (-name => $r->{S}{param_name},
	    -default => $r->hidden_val());
}

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

sub cookiea_cargs ($) {
    my ($r) = @_;
    return (-name => $r->{S}{cookie_name},
	    -value => hidden_val());
}

__END__

=head1 NAME

CGI::Auth::Hybrid - web authentication optionally using cookies

=head1 SYNOPSYS

 my $verifier = CGI::Auth::Hybrid->new_verifier(setting => value,...);
 my $authreq = $verifier->new_request($cgi_request_object);

 my $authreq = CGI::Auth::Hybrid->new_request($cgi_request_object,
                                              setting => value,...);

=head1 USAGE PATTERN FOR SIMPLE APPLICATIONS

 if ( form submission is login request ) {
     check login details, if wrong print error and quit
     $authreq->record_login(...username...);
 }
 if ( form submission is logout request ) {
     my $logged_out_user = $authreq->logout();
     if (!defined $logged_out_user) {
	 print "you are not logged in" error and quit
     } else {
	 print "goodbye $username you are now logged out" and quit
     }
 }
 if ( !$authreq->check() ) {
     display login form, quit


=head1 USAGE PATTERN FOR FANCY APPLICATIONS

 if ( form submission is login request ) {
     check login details, if wrong print error and quit
     $authreq->record_login(...username...);
 }
 if ( !$authreq->check() ) {
     display login form, quit
 if ( form submission is logout request ) {
     die unless $authreq->mutate();
     my $logged_out_user = $authreq->logout();
     if (!defined $logged_out_user) {
	 print "you are not logged in" error and quit
     } else {
	 print "goodbye $username you are now logged out" and quit
     }
 }


advantages of cookie
 - user can sort of log out by clearing cookies
 - sophisticated applications can have get-requests
