# -*- perl -*-

# This is part of CGI::Auth::Flexible, a perl CGI authentication module.
# Copyright (C) 2012 Ian Jackson.
# Copyright (C) 2012 Citrix.
# 
# 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/>.

use strict;
use warnings FATAL => 'all';

package CGI::Auth::Flexible;
require Exporter;

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();
}
our @EXPORT_OK;

use DBI;
use CGI qw/escapeHTML/;
use Locale::gettext;
use URI;
use IO::File;
use Fcntl qw(:flock);
use POSIX;
use Digest;
use Digest::HMAC;
use Digest::SHA;
use Data::Dumper;
use File::Copy;
use Cwd qw/realpath/;


#---------- public utilities ----------

sub flatten_params ($) {
    my ($p) = @_;
    my @p;
    foreach my $k (keys %$p) {
        next if $k eq '';
	foreach my $v (@{ $p->{$k} }) {
	    push @p, $k, $v;
	}
    }
    return @p;
}

#---------- default callbacks ----------

sub has_a_param ($$) {
    my ($r,$cn) = @_;
    foreach my $pn (@{ $r->{S}{$cn} }) {
	return 1 if $r->_ch('get_param',$pn);
    }
    return 0;
}

sub get_params ($) {
    my ($r) = @_;
    my %p;
    my $c = $r->{Cgi};
    foreach my $name ($c->param()) {
	$p{$name} = [ $c->param($name) ];
    }
    return \%p;
}

sub get_cookie_domain ($$$) {
    my ($c,$r) = @_;
    my $uri = new URI $r->_ch('get_url');
    return $uri->host();
}

sub login_ok_password ($$) {
    my ($c, $r) = @_;
    my $username_params = $r->{S}{username_param_names};
    my $username = $r->_ch('get_param',$username_params->[0]);
    my $password = $r->_rp('password_param_name');
    my $error = $r->_ch('username_password_error', $username, $password);
    return defined($error) ? (undef,$error) : ($username,undef);
}

sub do_redirect_cgi ($$$$) {
    my ($c, $r, $new_url, $cookie) = @_;
    $r->_print($c->header($r->_cgi_header_args($cookie,
					       -status => '303 See other',
					       -location => $new_url)),
	       $r->_ch('gen_start_html',$r->_gt('Redirection')),
	       '<a href="'.escapeHTML($new_url).'">',
	       $r->_gt("If you aren't redirected, click to continue."),
	       "</a>",
	       $r->_ch('gen_end_html'));
}

sub gen_some_form ($$) {
    my ($r, $params, $bodyfn) = @_;
    # Calls $bodyfn->($c,$r) which returns @formbits
    my $c = $r->{Cgi};
    my @form;
    my $pathinfo = '';
    $pathinfo .= $params->{''}[0] if $params->{''};
    push @form, ('<form method="POST" action="'.
		 escapeHTML($r->_ch('get_url').$pathinfo).'">');
    push @form, $bodyfn->($c,$r);
    foreach my $n (keys %$params) {
        next if $n eq '';
        foreach my $val (@{ $params->{$n} }) {
            push @form, ('<input type="hidden"'.
                         ' name="'.escapeHTML($n).'"'.
                         ' value="'.escapeHTML($val).'">');
        }
    }
    push @form, ('</form>');
    return join "\n", @form;
}

sub gen_plain_login_form ($$) {
    my ($c,$r, $params) = @_;
    return $r->gen_some_form($params, sub {
        my @form;
        push @form, ('<table>');
        my $sz = 'size="'.$r->{S}{form_entry_size}.'"';
        foreach my $up (@{ $r->{S}{username_param_names}}) {
            push @form, ('<tr><td>',$r->_gt(ucfirst $up),'</td>',
                         '<td><input type="text" '.$sz.
                         ' name='.$up.'></td></tr>');
        }
        push @form, ('<tr><td>'.$r->_gt('Password').'</td>',
                     '<td><input type="password" '.$sz.
                     ' name="'.$r->{S}{password_param_name}.'"></td></tr>');
        push @form, ('<tr><td colspan="2">',
                     '<input type="submit"'.
                     ' name="'.$r->{S}{dummy_param_name_prefix}.'login"'.
                     ' value="'.$r->_gt('Login').'"></td></tr>',
                     '</table>');
        return @form;
    });
}

sub gen_postmainpage_form ($$$) {
    my ($c,$r, $params) = @_;
    return $r->gen_some_form($params, sub {
        my @form;
        push @form, ('<input type="submit"',
                     ' name="'.$r->{S}{dummy_param_name_prefix}.'submit"'.
                     ' value="'.$r->_gt('Continue').'">');
        return @form;
    });
}

sub gen_plain_login_link ($$) {
    my ($c,$r, $params) = @_;
    my $url = $r->url_with_query_params($params);
    return ('<a href="'.escapeHTML($url).'">'.
	    $r->_gt('Log in again to continue.').
	    '</a>');
}

sub gen_srcdump_link_html ($$$$) {
    my ($c,$r,$anchor,$specval) = @_;
    my %params = ($r->{S}{srcdump_param_name} => [ $specval ]);
    return '<a href="'.escapeHTML($r->url_with_query_params(\%params)).'">'.
	$anchor."</a>";
}
sub gen_plain_licence_link_html ($$) {
    my ($c,$r) = @_;
    gen_srcdump_link_html($c,$r, 'GNU Affero GPL', 'licence');
}
sub gen_plain_source_link_html ($$) {
    my ($c,$r) = @_;
    gen_srcdump_link_html($c,$r, 'Source available', 'source');
}

sub gen_plain_footer_html ($$) {
    my ($c,$r) = @_;
    return ('<hr><address>',
	    ("Powered by Free / Libre / Open Source Software".
	     " according to the ".$r->_ch('gen_licence_link_html')."."),
	    $r->_ch('gen_source_link_html').".",
	    '</address>');
}

#---------- licence and source code ----------

sub srcdump_dump ($$$) {
    my ($c,$r, $thing) = @_;
    die if $thing =~ m/\W/ || $thing !~ m/\w/;
    my $path = $r->_get_path('srcdump');
    my $ctf = new IO::File "$path/$thing.ctype", 'r'
	or die "$path/$thing.ctype $!";
    my $ct = <$ctf>;
    chomp $ct or die "$path/$thing ?";
    $ctf->close or die "$path/$thing $!";
    my $df = new IO::File "$path/$thing.data", 'r'
	or die "$path/$thing.data $!";
    $r->_ch('dump', $ct, $df);
}

sub dump_plain ($$$$) {
    my ($c, $r, $ct, $df) = @_;
    $r->_print($c->header('-type' => $ct));
    my $buffer;
    for (;;) {
	my $got = read $df, $buffer, 65536;
	die $! unless defined $got;
	return if !$got;
	$r->_print($buffer);
    }
}

sub srcdump_process_item ($$$$$$) {
    my ($c, $v, $dumpdir, $item, $outfn, $needlicence, $dirsdone) = @_;
    if ($v->_ch('srcdump_system_dir', $item)) {
	$outfn->("srcdump_process_item: srcdump_system_dir, skipping $item");
	return;
    }
    my $upwards = $item;
    for (;;) {
	$upwards =~ s#/+$##;
	$upwards =~ s#/+\.$##;
	last unless $upwards =~ m#[^/]#;
	foreach my $try (@{ $v->{S}{srcdump_vcs_dirs} }) {
#print STDERR "TRY $item $upwards $try\n";
	    if (!stat "$upwards/$try") {
		$!==&ENOENT or $!==&ENOTDIR or die "check $upwards/$try $!";
		next;
	    }
#print STDERR "VCS $item $upwards $try\n";
            if ($dirsdone->{$upwards}++) {
		$outfn->("srcdump_process_item: did $upwards,".
			 " skipping $item");
		return;
	    }
#print STDERR "VCS $item $upwards $try GO\n";
	    $try =~ m/\w+/ or die;
	    return $v->_ch('srcdump_byvcs', $dumpdir, $upwards, $outfn, lc $&);
	}
	$upwards =~ s#/*[^/]+$##;
    }
    return $v->_ch('srcdump_novcs', $dumpdir, $item, $outfn);
}

sub srcdump_novcs ($$$$$) {
    my ($c, $v, $dumpdir, $item, $outfn) = @_;
    stat $item or die "$item $!";
    if (-d _) {
	my $script = 'find -type f -perm +004';
	foreach my $excl (@{ $v->{S}{srcdump_excludes} }) {
	    $script .= " \\! -name '$excl'";
	}
	$script .= " -print0";
	return srcdump_dir_cpio($c,$v,$dumpdir,$item,$outfn,'novcs',$script);
    } elsif (-f _) {
	return srcdump_file($c,$v,$dumpdir,$item,$outfn);
    } else {
	die "$item not file or directory";
    }
}

sub srcdump_byvcs ($$$$$$) {
    my ($c, $v, $dumpdir, $dir, $outfn, $vcs) = @_;
#print STDERR "BYVCS GIT $dir\n";
    return srcdump_dir_cpio($c,$v,$dumpdir,$dir,$outfn,$vcs,
			    $v->{S}{"srcdump_vcsscript_$vcs"});
}

sub srcdump_file ($$$$) {
    my ($c,$v,$dumpdir,$file,$outfn) = @_;
    my $outfile = $outfn->("srcdump_file saved $file", "src");
    copy($file,$outfile) or die "$file $outfile $!";
}

sub srcdump_dir_cpio ($$$$$$$) {
    my ($c,$v,$dumpdir,$dir,$outfn,$how,$script) = @_;
    my $outfile = $outfn->("srcdump_dir_cpio $how saved $dir", "tar");
#print STDERR "CPIO $dir >$script<\n";
    my $pid = fork();
    defined $pid or die $!;
    if (!$pid) {
	$SIG{__DIE__} = sub {
	    print STDERR "CGI::Auth::Flexible srcdump error: $@\n";
	    exit 127;
	};
	open STDOUT, ">", $outfile or die "$outfile $!";
	chdir $dir or die "chdir $dir: $!";
	exec '/bin/bash','-ec',"
            set -o pipefail
	    (
	     $script
	    ) | (
	     cpio -Hustar -o --quiet -0 -R 1000:1000 || \
             cpio -Hustar -o --quiet -0
            )
            ";
	die $!;
    }
    $!=0; (waitpid $pid, 0) == $pid or die "$!";
    die "$dir ($how $script) $outfile $?" if $?;
}

sub srcdump_dirscan_prepare ($$) {
    my ($c, $v) = @_;
    my $dumpdir = $v->_get_path('srcdump');
    mkdir $dumpdir or $!==&EEXIST or die "mkdir $dumpdir $!";
    my $lockf = new IO::File "$dumpdir/generate.lock", 'w+'
	or die "$dumpdir/generate.lock $!";
    flock $lockf, LOCK_EX or die "$dumpdir/generate.lock $!";
    my $needlicence = "$dumpdir/licence.tmp";
    unlink $needlicence or $!==&ENOENT or die "rm $needlicence $!";
    if (defined $v->{S}{srcdump_licence_path}) {
	copy($v->{S}{srcdump_licence_path}, $needlicence)
	    or die "$v->{S}{srcdump_licence_path} $!";
	$needlicence = undef;
    }
    unlink <"$dumpdir/s.[a-z][a-z][a-z].*">;
    my @srcfiles = qw(licence.data manifest.txt);
    my $srcoutcounter = 'aaa';

    my $reportfh = new IO::File "$dumpdir/manifest.txt", 'w' or die $!;
    my $outfn = sub {
	my ($message, $extension) = @_;
	if (defined $extension) {
	    my $leaf = "s.$srcoutcounter.$extension";
	    $srcoutcounter++;
	    push @srcfiles, $leaf;
	    print $reportfh "$leaf: $message\n" or die $!;
	    return "$dumpdir/$leaf";
	} else {
	    print $reportfh "none: $message\n" or die $!;
	    return undef;
	}
    };
    my %dirsdone;
    foreach my $item ($v->_ch('srcdump_listitems')) {
	if ($item eq '.' && $v->{S}{srcdump_filter_cwd}) {
	    my @bad = grep { !m#^/# } values %INC;
	    die "filtering . from srcdump items and \@INC but already".
		" included @bad " if @bad;
	    @INC = grep { $_ ne '.' } @INC;
	    next;
	}
	if (!lstat "$item") {
	    die "stat $item $!" unless $!==&ENOENT;
	    $outfn->("srcdump_dirscan_prepare stat ENOENT, skipping $item");
	    next;
	};
	if (-l _) {
	    $item = realpath($item);
	    if (!defined $item) {
		die "realpath $item $!" unless $!==&ENOENT;
		$outfn->("srcdump_dirscan_prepare realpath ENOENT,".
			 " skipping $item");
	    }
	}
	if (defined $needlicence) {
	    foreach my $try (@{ $v->{S}{srcdump_licence_files} }) {
		last if copy("$item/$try", $needlicence);
		$!==&ENOENT or $!==&ENOTDIR or die "copy $item/$try $!";
	    }
	}
	$v->_ch('srcdump_process_item', $dumpdir, $item,
		$outfn, \$needlicence, \%dirsdone);
	$dirsdone{$item}++;
    }
    close $reportfh or die $!;
    srcdump_install($c,$v, $dumpdir, 'licence', 'text/plain');
    $!=0;
    my @cmd = (qw(tar -zvvcf), "$dumpdir/source.tmp",
	       "-C", $dumpdir, qw(  --), @srcfiles);
    my $r = system(@cmd);
    if ($r) {
	print STDERR "CGI::Auth::Flexible tar failed ($r $!) @cmd\n";
	die "tar failed";
    }
    die "licence file not found" unless defined $needlicence;
    srcdump_install($c,$v, $dumpdir, 'source', 'application/octet-stream');
    close $lockf or die $!;
}

sub srcdump_install ($$$$$) {
    my ($c,$v, $dumpdir, $which, $ctype) = @_;
    rename "$dumpdir/$which.tmp", "$dumpdir/$which.data"
	or die "$dumpdir/$which.data $!";
    my $ctf = new IO::File "$dumpdir/$which.tmp", 'w'
	or die "$dumpdir/$which.tmp $!";
    print $ctf $ctype, "\n" or die $!;
    close $ctf or die $!;
    rename "$dumpdir/$which.tmp", "$dumpdir/$which.ctype"
	or die "$dumpdir/$which.ctype $!";
}

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

sub new_verifier {
    my $class = shift;
    my $verifier = {
	S => {
            dir => undef,
	    assocdb_dbh => undef, # must have AutoCommit=0, RaiseError=1
	    assocdb_path => 'caf-assocs.db',
	    keys_path => 'caf-keys',
	    srcdump_path => 'caf-srcdump',
	    assocdb_dsn => undef,
	    assocdb_user => '',
	    assocdb_password => '',
	    assocdb_table => 'caf_assocs',
	    random_source => '/dev/urandom',
	    secretbits => 128, # bits
	    hash_algorithm => "SHA-256",
	    login_timeout => 86400, # seconds
	    login_form_timeout => 3600, # seconds
	    key_rollover => 86400, # seconds
	    assoc_param_name => 'caf_assochash',
	    dummy_param_name_prefix => 'caf__',
	    cookie_name => "caf_assocsecret",
	    password_param_name => 'password',
	    srcdump_param_name => 'caf_srcdump',
	    username_param_names => [qw(username)],
	    form_entry_size => 60,
	    logout_param_names => [qw(caf_logout)],
	    loggedout_param_names => [qw(caf_loggedout)],
	    promise_check_mutate => 0,
	    get_param => sub { $_[0]->param($_[2]) },
	    get_params => sub { $_[1]->get_params() },
	    get_path_info => sub { $_[0]->path_info() },
	    get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) },
	    get_method => sub { $_[0]->request_method() },
	    check_https => sub { !!$_[0]->https() },
	    get_url => sub { $_[0]->url(); },
            is_login => sub { defined $_[1]->_rp('password_param_name') },
            login_ok => \&login_ok_password,
            username_password_error => sub { die },
	    is_logout => sub { $_[1]->has_a_param('logout_param_names') },
	    is_loggedout => sub { $_[1]->has_a_param('loggedout_param_names') },
	    is_page => sub { return 1 },
	    handle_divert => sub { return 0 },
	    do_redirect => \&do_redirect_cgi, # this hook is allowed to throw
	    cookie_path => "/",
	    get_cookie_domain => \&get_cookie_domain,
	    encrypted_only => 1,
	    gen_start_html => sub { $_[0]->start_html($_[2]); },
	    gen_footer_html => \&gen_plain_footer_html,
	    gen_licence_link_html => \&gen_plain_licence_link_html,
	    gen_source_link_html => \&gen_plain_source_link_html,
	    gen_end_html => sub { $_[0]->end_html(); },
	    gen_login_form => \&gen_plain_login_form,
	    gen_login_link => \&gen_plain_login_link,
	    gen_postmainpage_form => \&gen_postmainpage_form,
	    srcdump_dump => \&srcdump_dump,
	    srcdump_prepare => \&srcdump_dirscan_prepare,
	    srcdump_licence_path => undef,
	    srcdump_licence_files => [qw(AGPLv3 CGI/Auth/Flexible/AGPLv3)],
	    srcdump_listitems => sub { (@INC, $ENV{'SCRIPT_FILENAME'}, $0); },
	    srcdump_filter_cwd => 1,
	    srcdump_system_dir => sub {
		$_[2] =~ m#^/etc/|^/usr/(?!local/)(?!lib/cgi)#;
	    },
	    srcdump_process_item => \&srcdump_process_item,
	    srcdump_vcs_dirs => [qw(.git .hg .bzr .svn CVS)],
	    srcdump_vcsscript_git => "
                 git ls-files -z
                 git ls-files -z --others --exclude-from=.gitignore
                 find .git -print0
                            ",
	    srcdump_vcsscript_hg => "false hg",
	    srcdump_vcsscript_bzr => "false bzr",
	    srcdump_vcsscript_svn => "false svn",
	    srcdump_vcsscript_cvs => "false cvs",
	    srcdump_byvcs => \&srcdump_byvcs,
	    srcdump_novcs => \&srcdump_novcs,
	    srcdump_excludes => [qw(*~ *.bak *.tmp), '#*#'],
	    dump => \&dump_plain,
	    gettext => sub { gettext($_[2]); },
	    print => sub { print $_[2] or die $!; },
            debug => sub { }, # like print; msgs contain trailing \n
	},
	Dbh => undef,
    };
    my ($k,$v);
    while (($k,$v,@_) = @_) {
	die "unknown setting $k" unless exists $verifier->{S}{$k};
	$verifier->{S}{$k} = $v;
    }
    bless $verifier, $class;
    $verifier->_dbopen();
    $verifier->_ch('srcdump_prepare');
    return $verifier;
}

sub _db_setup_do ($$) {
    my ($v, $sql) = @_;
    my $dbh = $v->{Dbh};
    eval {
	$v->_db_transaction(sub {
            local ($dbh->{PrintError}) = 0;
	    $dbh->do($sql);
        });
    };
}

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

    $dbh = $v->{S}{assocdb_dbh};
    if ($dbh) {
        die if $dbh->{AutoCommit};
        die unless $dbh->{RaiseError};
    } else {
        $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb');
        my $dsn = $v->{S}{assocdb_dsn};

        my $u = umask 077;
        $dbh = DBI->connect($dsn, $v->{S}{assocdb_user},
                            $v->{S}{assocdb_password}, {
                                AutoCommit => 0,
                                RaiseError => 1,
                                ShowErrorStatement => 1,
                            });
        umask $u;
        die "$dsn $! ?" unless $dbh;
    }
    $v->{Dbh} = $dbh;

    $v->_db_setup_do("CREATE TABLE $v->{S}{assocdb_table} (".
		     " assochash VARCHAR PRIMARY KEY,".
		     " username VARCHAR NOT NULL,".
		     " last INTEGER NOT NULL".
		     ")");
    $v->_db_setup_do("CREATE INDEX $v->{S}{assocdb_table}_timeout_index".
		     " ON $v->{S}{assocdb_table}".
                     " (last)");
    return $dbh;
}

sub disconnect ($) {
    my ($v) = @_;
    my $dbh = $v->{Dbh};
    return unless $dbh;
    $dbh->disconnect();
}

sub _db_transaction ($$) {
    my ($v, $fn) = @_;
    my $retries = 10;
    my $rv;
    my $dbh = $v->{Dbh};
#print STDERR "DT entry\n";
    for (;;) {
#print STDERR "DT loop\n";
	if (!eval {
	    $rv = $fn->();
#print STDERR "DT fn ok\n";
	    1;
	}) {
#print STDERR "DT fn error\n";
	    { local ($@); $dbh->rollback(); }
#print STDERR "DT fn throwing\n";
	    die $@;
	}
#print STDERR "DT fn eval ok\n";
	if (eval {
	    $dbh->commit();
#print STDERR "DT commit ok\n";
	    1;
	}) {
#print STDERR "DT commit eval ok ",Dumper($rv);
	    return $rv;
	}
#print STDERR "DT commit throw?\n";
	die $@ if !--$retries;
#print STDERR "DT loop again\n";
    }
}

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

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

sub _ch ($$@) { # calls an application hook
    my ($r,$methname, @args) = @_;
    my $methfunc = $r->{S}{$methname};
    die "$methname ?" unless $methfunc;
    return $methfunc->($r->{Cgi}, $r, @args);
}

sub _rp ($$@) {
    my ($r,$pnvb) = @_;
    my $pn = $r->{S}{$pnvb};
    my $p = scalar $r->_ch('get_param',$pn)
}

sub _debug ($@) {
    my ($r,@args) = @_;
    $r->_ch('debug',@args);
}

sub _get_path ($$) {
    my ($r,$keybase) = @_;
    my $leaf = $r->{S}{"${keybase}_path"};
    return $r->_absify_path($leaf);
}

sub _absify_path ($$) {
    my ($v,$leaf) = @_;
    return $leaf if $leaf =~ m,^/,;
    my $dir = $v->{S}{dir};
    die "relying on cwd by default ?!  set dir" unless defined $dir;
    return "$dir/$leaf";
}

sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); }
sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); }

sub construct_cookie ($$$) {
    my ($r, $cooks) = @_;
    return undef unless $cooks;
    my $c = $r->{Cgi};
my @ca = (-name => $r->{S}{cookie_name},
                             -value => $cooks,
                             -path => $r->{S}{cookie_path},
                             -domain => $r->_ch('get_cookie_domain'),
                             -expires => '+'.$r->{S}{login_timeout}.'s',
                             -secure => $r->{S}{encrypted_only});
    my $cookie = $c->cookie(@ca);
#print STDERR "CC $r $c $cooks $cookie (@ca).\n";
    return $cookie;
}

# 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
#   O "you have just logged out" page load

# in cook and par,
#    -         no value supplied (represented in code as $cookt='')
#    n, nN     value not in our db
#    t, tN     temporary value (in our db, no logged in user yet)
#    y, yN     value corresponds to logged-in user
# and, aggregated conditions:
#    a, aN     anything including -
#    x, xN     t or y
# if N differs the case applies only when the two values differ
# (eg,   a1 y2   does not apply when the logged-in value is supplied twice)

# "stale session" means request originates from a page from a login
# session which has been revoked (eg by logout); "cleared session"
# means request originates from a browser which has a different (or
# no) cookie.

    # Case analysis, cookie mode, app promises re mutate:
    # cook parm meth form
    #                      
    #  any -   POST  nrmuoi   bug or attack, fail
    #  any -   GET    rmuoi   bug or attack, fail
    #  any any GET     muoi   bug or attack, fail
    #  any t   any   nrmu     bug or attack, fail
    #
    #  -   -   GET         O  "just logged out" page
    #  (any other)         O  bug or attack, fail
    #
    #  a1  a2  POST      o    logout
    #                           if a1 is valid, revoke it
    #                           if a2 is valid, revoke it
    #                           delete cookie
    #                           redirect to "just logged out" page
    #                             (which contains link to login form)
    #
    #  -   t   POST       i   complain about cookies being disabled
    #                           (with link to login form)
    #
    #  t1  t1  POST       i   login (or switch user)
    #                           if bad
    #                             show new login form
    #                           if good
    #                             upgrade t1 to y1 in our db (setting username)
    #                             redirect to GET of remaining params
    #
    #  y1  a2  POST       i   complain about stale login form
    #                           revoke y1
    #                           show new login form
    #                           
    #  (other) POST       i   complain about stale login form
    #                           show new login form
    #
    #  t1  a2  ANY   nrmu     treat as  - a2 ANY
    #
    #  y   -   GET   n        cross-site link
    #                           show data
    #
    #  y   y   GET   nr       fine, show page or send data
    #  y   y   POST  nrmu     mutation is OK, do operation
    #
    #  y1  y2  GET   nr       request from stale page
    #                           do not revoke y2 as not RESTful
    #                           treat as   y1 n GET
    #
    #  y1  y2  POST  nrmu     request from stale page
    #                           revoke y2
    #                           treat as   y1 n POST
    #
    #  y   n   GET   n        intra-site link from stale page,
    #                           treat as cross-site link, show data
    #
    #  y   n   POST  n m      intra-site form submission from stale page
    #                           show "session interrupted"
    #                           with link to main data page
    #
    #  y   n   GET    r       intra-site request from stale page
    #                           fail
    #
    #  y   n   POST   r u     intra-site request from stale page
    #                           fail
    #
    #  -/n y2  GET   nr       intra-site link from cleared session
    #                           do not revoke y2 as not RESTful
    #                           treat as   -/n n GET
    #
    #  -/n y2  POST  nrmu     request from cleared session
    #                           revoke y2
    #                           treat as   -/n n POST
    #
    #  -/n -/n GET   n        cross-site link but user not logged in
    #                           show login form with redirect to orig params
    #                           generate fresh cookie
    #
    #  -/n n   GET    rmu     user not logged in
    #                           fail
    #
    #  -/n n   POST  n m      user not logged in
    #                           show login form
    #
    #  -/n n   POST   r u     user not logged in
    #                           fail

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

    my $srcdump = $r->_rp('srcdump_param_name');
    if ($srcdump) {
	die if $srcdump =~ m/\W/;
	return ({ Kind => 'SRCDUMP-'.uc $srcdump,
		  Message => undef,
		  CookieSecret => undef,
		  Params => { } });
    }

    my $cooks = $r->_ch('get_cookie');

    if ($r->{S}{encrypted_only} && !$r->_ch('check_https')) {
        return ({ Kind => 'REDIRECT-HTTPS',
                  Message => $r->_gt("Redirecting to secure server..."),
                  CookieSecret => undef,
                  Params => { } });
    }

    my $meth = $r->_ch('get_method');
    my $parmh = $r->_rp('assoc_param_name');
    my $cookh = defined $cooks ? $r->hash($cooks) : undef;

    my ($cookt,$cooku) = $r->_identify($cookh, $cooks);
    my $parms = (defined $cooks && defined $parmh && $parmh eq $cookh)
        ? $cooks : undef;
    my ($parmt) = $r->_identify($parmh, $parms);

    $r->_debug("_c_d_c cookt=$cookt parmt=$parmt\n");

    if ($r->_ch('is_logout')) {
	$r->_must_be_post();
	die unless $parmt;
	$r->_db_revoke($cookh);
	$r->_db_revoke($parmh);
	return ({ Kind => 'REDIRECT-LOGGEDOUT',
		  Message => $r->_gt("Logging out..."),
		  CookieSecret => '',
		  Params => { } });
    }
    if ($r->_ch('is_loggedout')) {
	die unless $meth eq 'GET';
	die if $cookt eq 'y';
	die if $parmt;
	return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
		  Message => $r->_gt("You have been logged out."),
		  CookieSecret => '',
		  Params => { } });
    }
    if ($r->_ch('is_login')) {
	$r->_must_be_post();
	die unless $parmt;
        if (!$cookt && $parmt eq 'n') {
            return ({ Kind => 'SMALLPAGE-NOCOOKIE',
                      Message => $r->_gt("You do not seem to have cookies".
                                         " enabled.  You must enable cookies".
                                         " as we use them for login."),
                      CookieSecret => $r->_fresh_secret(),
                      Params => $r->chain_params() })
        }
        if (!$cookt || $cookt eq 'n' || $cookh ne $parmh) {
            $r->_db_revoke($cookh);
            return ({ Kind => 'LOGIN-STALE',
                      Message => $r->_gt("Stale session;".
                                         " you need to log in again."),
                      CookieSecret => $r->_fresh_secret(),
                      Params => { } })
        }
	die unless $parmt eq 't' || $parmt eq 'y';
	my ($username, $login_errormessage) = $r->_ch('login_ok');
        unless (defined $username && length $username) {
            $login_errormessage = $r->_gt("Incorrect username/password.")
                if !$login_errormessage;
            return ({ Kind => 'LOGIN-BAD',
                      Message => $login_errormessage,
                      CookieSecret => $cooks,
                      Params => $r->chain_params() })
        }
	$r->_db_record_login_ok($parmh,$username);
	return ({ Kind => 'REDIRECT-LOGGEDIN',
		  Message => $r->_gt("Logging in..."),
		  CookieSecret => $cooks,
		  Params => $r->chain_params() });
    }
    if ($cookt eq 't') {
	$cookt = '';
    }
    die if $parmt eq 't';

    if ($cookt eq 'y' && $parmt eq 'y' && $cookh ne $parmh) {
	$r->_db_revoke($parmh) if $meth eq 'POST';
	$parmt = 'n';
    }

    if ($cookt ne 'y') {
	die unless !$cookt || $cookt eq 'n';
	die unless !$parmt || $parmt eq 'n' || $parmt eq 'y';
	my $news = $r->_fresh_secret();
	if ($meth eq 'GET') {
	    return ({ Kind => 'LOGIN-INCOMINGLINK',
		      Message => $r->_gt("You need to log in."),
		      CookieSecret => $news,
		      Params => $r->chain_params() });
	} else {
	    $r->_db_revoke($parmh);
	    return ({ Kind => 'LOGIN-FRESH',
                      Message => $r->_gt("You need to log in."),
                      CookieSecret => $news,
                      Params => { } });
	}
    }

    if (!$r->{S}{promise_check_mutate}) {
	if ($meth ne 'POST') {
	    return ({ Kind => 'MAINPAGEONLY',
		      Message => $r->_gt('Entering via cross-site link.'),
		      CookieSecret => $cooks,
		      Params => { } });
	    # NB caller must then ignore params & path!
	    # if this is too hard they can spit out a small form
	    # with a "click to continue"
	}
    }

    die unless $cookt eq 'y';
    unless ($r->{S}{promise_check_mutate} && $meth eq 'GET') {
        die unless $parmt eq 'y';
        die unless $cookh eq $parmh;
    }
    $r->{AssocSecret} = $cooks;
    $r->{UserOK} = $cooku;
#print STDERR "C-D-C OK\n";
    return undef;
}

sub chain_params ($) {
    my ($r) = @_;
    my %p = %{ $r->_ch('get_params') };
    foreach my $pncn (keys %{ $r->{S} }) {
	my $names;
	if ($pncn =~ m/_param_name$/) {
	    my $name = $r->{S}{$pncn};
	    die "$pncn ?" if ref $name;
	    $names = [ $name ];
	} elsif ($pncn =~ m/_param_names$/) {
	    $names = $r->{S}{$pncn};
	} else {
	    next;
	}
	foreach my $name (@$names) {
	    delete $p{$name};
	}
    }
    my $dummy_prefix = $r->{S}{dummy_param_name_prefix};
    foreach my $name (grep /^$dummy_prefix/, keys %p) {
        delete $p{$name};
    }
    die if exists $p{''};
    $p{''} = [ $r->_ch('get_path_info') ];
    return \%p;
}

sub _identify ($$) {
    my ($r,$h,$s) = @_;
    # returns ($t,$username)
    # where $t is one of "t" "y" "n", or "" (for -)
    # either $s must be undef, or $h eq $r->hash($s)

#print STDERR "_identify\n";
    return '' unless defined $h && length $h;
#print STDERR "_identify h=$h s=".(defined $s ? $s : '<undef>')."\n";

    my $dbh = $r->{Dbh};

    $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
             " WHERE last < ?", {},
             time - $r->{S}{login_timeout});

    my $row = $dbh->selectrow_arrayref("SELECT username, last".
			      " FROM $r->{S}{assocdb_table}".
			      " WHERE assochash = ?", {}, $h);
    if (defined $row) {
#print STDERR "_identify h=$h s=$s YES @$row\n";
        my ($nusername, $nlast) = @$row;
        return ('y', $nusername);
    }

    # Well, it's not in the database.  But maybe it's a hash of a
    # temporary secret.

    return 'n' unless defined $s;

    my ($keyt, $signature, $message, $noncet, $nonce) =
        $s =~ m/^(\d+)\.(\w+)\.((\d+)\.(\w+))$/ or die;

    return 'n' if time > $noncet + $r->{S}{login_form_timeout};

#print STDERR "_identify noncet=$noncet ok\n";

    my $keys = $r->_open_keys();
    while (my ($rkeyt, $rkey, $line) = $r->_read_key($keys)) {
#print STDERR "_identify  search rkeyt=$rkeyt rkey=$rkey\n";
        last if $rkeyt < $keyt; # too far down in the file
        my $trysignature = $r->_hmac($rkey, $message);
#print STDERR "_identify  search rkeyt=$rkeyt rkey=$rkey try=$trysignature\n";
        return 't' if $trysignature eq $signature;
    }
    # oh well
#print STDERR "_identify NO\n";

    $keys->error and die $!;
    return 'n';
}

sub _db_revoke ($$) {
    # revokes $h if it's valid; no-op if it's not
    my ($r,$h) = @_;

    my $dbh = $r->{Dbh};

    $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
	     " WHERE assochash = ?", {}, $h);
}

sub _db_record_login_ok ($$$) {
    my ($r,$h,$user) = @_;
    $r->_db_revoke($h);
    my $dbh = $r->{Dbh};
    $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
	     " (assochash, username, last) VALUES (?,?,?)", {},
	     $h, $user, time);
}

sub check_divert ($) {
    my ($r) = @_;
    if (exists $r->{Divert}) {
        return $r->{Divert};
    }
    my $dbh = $r->{Dbh};
    $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); });
    $dbh->commit();
    $r->_debug(Data::Dumper->Dump([$r->{Divert}],[qw(divert)]));
    return $r->{Divert};
}

sub get_divert ($) {
    my ($r) = @_;
    die "unchecked" unless exists $r->{Divert};
    return $r->{Divert};
}

sub get_username ($) {
    my ($r) = @_;
    my $divert = $r->get_divert();
    return undef if $divert;
    return $r->{UserOK};
}

sub url_with_query_params ($$) {
    my ($r, $params) = @_;
#print STDERR "PARAMS ",Dumper($params);
    my $uri = URI->new($r->_ch('get_url'));
    $uri->path($uri->path() . $params->{''}[0]) if $params->{''};
    $uri->query_form(flatten_params($params));
    return $uri->as_string();
}

sub _cgi_header_args ($$@) {
    my ($r, $cookie, @ha) = @_;
    unshift @ha, qw(-type text/html);
    push @ha, (-cookie => $cookie) if defined $cookie;
#print STDERR "_cgi_header_args ",join('|',@ha),".\n";
    return @ha;
}

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

    my ($divert) = $r->check_divert();
    return 1 if !$divert;

    my $handled = $r->_ch('handle_divert',$divert);
    return 0 if $handled;

    my $kind = $divert->{Kind};
    my $cookiesecret = $divert->{CookieSecret};
    my $params = $divert->{Params};
    my $cookie = $r->construct_cookie($cookiesecret);

    if ($kind =~ m/^SRCDUMP-(\w+)$/) {
	$r->_ch('srcdump_dump', (lc $1));
	return 0;
    }

    if ($kind =~ m/^REDIRECT-/) {
	# for redirects, we honour stored NextParams and SetCookie,
	# as we would for non-divert
	if ($kind eq 'REDIRECT-LOGGEDOUT') {
	    $params->{$r->{S}{loggedout_param_names}[0]} = [ 1 ];
	} elsif ($kind eq 'REDIRECT-LOGOUT') {
	    $params->{$r->{S}{logout_param_names}[0]} = [ 1 ];
	} elsif ($kind =~ m/REDIRECT-(?:LOGGEDIN|HTTPS)/) {
	} else {
	    die;
	}
	my $new_url = $r->url_with_query_params($params);
        if ($kind eq 'REDIRECT-HTTPS') {
            my $uri = URI->new($new_url);
            die unless $uri->scheme eq 'http';
            $uri->scheme('https');
            $new_url = $uri->as_string();
        }
	$r->_ch('do_redirect',$new_url, $cookie);
	return 0;
    }

    if (defined $cookiesecret) {
        $params->{$r->{S}{assoc_param_name}} = [ $r->hash($cookiesecret) ];
    }

    my ($title, @body);
    if ($kind =~ m/^LOGIN-/) {
	$title = $r->_gt('Login');
	push @body, $divert->{Message};
	push @body, $r->_ch('gen_login_form', $params);
    } elsif ($kind =~ m/^SMALLPAGE-/) {
	$title = $r->_gt('Not logged in');
	push @body, $divert->{Message};
	push @body, $r->_ch('gen_login_link', $params);
    } elsif ($kind =~ m/^MAINPAGEONLY$/) {
        $title = $r->_gt('Entering secure site.');
        push @body, $divert->{Message};
        push @body, $r->_ch('gen_postmainpage_form', $params);
    } else {
	die $kind;
    }

    $r->_print($r->{Cgi}->header($r->_cgi_header_args($cookie)),
	       $r->_ch('gen_start_html',$title),
	       (join "\n", (@body,
		            $r->_ch('gen_footer_html'),
			    $r->_ch('gen_end_html'))));
    return 0;
}

sub _random ($$) {
    my ($r, $bytes) = @_;
    my $v = $r->{V};
    my $rsf = $v->{RandomHandle};
    my $rsp = $r->{S}{random_source};
    if (!$rsf) {
	$v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!";
#print STDERR "RH $rsf\n";
    }
    my $bin;
    $!=0;
    read($rsf,$bin,$bytes) == $bytes or die "$rsp $!";
    my $out = unpack "H*", $bin;
#print STDERR "_random out $out\n";
    return $out;
}

sub _random_key ($) {
    my ($r) = @_;
#print STDERR "_random_key\n";
    my $bytes = ($r->{S}{secretbits} + 7) >> 3;
    return $r->_random($bytes);
}

sub _read_key ($$) {
    my ($r, $keys) = @_;
    # returns $gen_time_t, $key_value_in_hex, $complete_line
    while (<$keys>) {
        my ($gen, $k) = m/^(\d+) (\S+)$/ or die "$_ ?";
        my $age = time - $gen;
        next if $age > $r->{S}{key_rollover} &&
            $age > $r->{S}{login_form_timeout}*2;
        return ($gen, $k, $_);
    }
    return ();
}

sub _open_keys ($) {
    my ($r) = @_;
    my $spath = $r->_get_path('keys');
    for (;;) {
#print STDERR "_open_keys\n";
        my $keys = new IO::File $spath, 'r+';
        if ($keys) {
#print STDERR "_open_keys open\n";
            stat $keys or die $!; # NB must not disturb stat _
            my $size = (stat _)[7];
            my $age = time - (stat _)[9];
#print STDERR "_open_keys open size=$size age=$age\n";
            return $keys
                if $size && $age <= $r->{S}{key_rollover} / 2;
#print STDERR "_open_keys open bad\n";
        }
        # file doesn't exist, or is empty or too old
        if (!$keys) {
#print STDERR "_open_keys closed\n";
            die "$spath $!" unless $!==&ENOENT;
            # doesn't exist, so create it just so we can lock it
            $keys = new IO::File $spath, 'a+';
            die "$keys $!" unless $keys;
            stat $keys or die $!; # NB must not disturb stat _
            my $size = (stat _)[7];
#print STDERR "_open_keys created size=$size\n";
            next if $size; # oh someone else has done it, reopen and read it
        }
        # file now exists is empty or too old, we must try to replace it
        my $our_inum = (stat _)[1]; # last use of that stat _
        flock $keys, LOCK_EX or die "$spath $!";
        stat $spath or die "$spath $!";
        my $path_inum = (stat _)[1];
#print STDERR "_open_keys locked our=$our_inum path=$path_inum\n";
        next if $our_inum != $path_inum; # someone else has done it
        # We now hold the lock!
#print STDERR "_open_keys creating\n";
        my $newkeys = new IO::Handle;
        sysopen $newkeys, "$spath.new", O_CREAT|O_TRUNC|O_WRONLY, 0600
            or die "$spath.new $!";
        # we add the new key to the front which means it's always sorted
        print $newkeys time, ' ', $r->_random_key(), "\n" or die $!;
        while (my ($gen,$key,$line) = $r->_read_key($keys)) {
#print STDERR "_open_keys copy1\n";
            print $newkeys, $line or die $!;
        }
        $keys->error and die $!;
        close $newkeys or die "$spath.new $!";
        rename "$spath.new", "$spath" or die "$spath: $!";
#print STDERR "_open_keys installed\n";
        # that rename effective unlocks, since it makes the name refer
        #  to the new file which we haven't locked
        # we go round again opening the file at the beginning
        #  so that our caller gets a fresh handle onto the existing key file
    }
}

sub _fresh_secret ($) {
    my ($r) = @_;
#print STDERR "_fresh_secret\n";

    my $keys = $r->_open_keys();
    my ($keyt, $key) = $r->_read_key($keys);
    die unless defined $keyt;

    my $nonce = $r->_random_key();
    my $noncet = time;
    my $message = "$noncet.$nonce";

    my $signature = $r->_hmac($key, $message);
    my $secret = "$keyt.$signature.$message";
#print STDERR "FRESH $secret\n";
    return $secret;
}

sub _hmac ($$$) {
    my ($r, $keyhex, $message) = @_;
    my $keybin = pack "H*", $keyhex;
    my $alg = $r->{S}{hash_algorithm};
#print STDERR "hmac $alg\n";
    my $base = new Digest $alg;
#print STDERR "hmac $alg $base\n";
    my $digest = new Digest::HMAC $keybin, $base;
#print STDERR "hmac $alg $base $digest\n";
    $digest->add($message);
    return $digest->hexdigest();
}

sub hash ($$) {
    my ($r, $message) = @_;
    my $alg = $r->{S}{hash_algorithm};
#print STDERR "hash $alg\n";
    my $digest = new Digest $alg;
    $digest->add($message);
    return $digest->hexdigest();
}

sub _assert_checked ($) {
    my ($r) = @_;
    die "unchecked" unless exists $r->{Divert};
}

sub _is_post ($) {
    my ($r) = @_;
    my $meth = $r->_ch('get_method');
    return $meth eq 'POST';
}

sub _must_be_post ($) {
    my ($r) = @_;
    my $meth = $r->_ch('get_method');
    die "mutating non-POST" if $meth ne 'POST';
}

sub check_mutate ($) {
    my ($r) = @_;
    $r->_assert_checked();
    die if $r->{Divert};
    $r->_must_be_post();
}

sub mutate_ok ($) {
    my ($r) = @_;
    $r->_assert_checked();
    die if $r->{Divert};
    return $r->_is_post();
}

#---------- output ----------

sub secret_cookie_val ($) {
    my ($r) = @_;
    $r->_assert_checked();
    return defined $r->{AssocSecret} ? $r->{AssocSecret} : '';
}

sub secret_hidden_val ($) {
    my ($r) = @_;
    $r->_assert_checked();
    return defined $r->{AssocSecret} ? $r->hash($r->{AssocSecret}) : '';
}

sub secret_hidden_html ($) {
    my ($r) = @_;
    return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name},
                             -default => $r->secret_hidden_val());
}

sub secret_cookie ($) {
    my ($r) = @_;
    my $secret = $r->secret_cookie_val();
    return undef if !defined $secret;
#print STDERR "SC\n";
    my $cookv = $r->construct_cookie($secret); 
#print STDERR "SC=$cookv\n";
    return $cookv;
}

1;

__END__

=head1 NAME

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

=head1 SYNOPSYS

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

 # simple applications
 $authreq->check_ok() or return;

 # sophisticated applications
 my $divert_kind = $authreq->check_divert();
 if ($divert_kind) { ... print diversion page and quit ... }

 # while handling the request
 $user = $authreq->get_username();
 $authreq->check_mutate();

=head1 DESCRIPTION

CGI::Auth::Flexible is a library which you can use to add a
forms/cookie-based login facility to a Perl web application.

CGI::Auth::Flexible doesn't interfere with your application's URL path
namespace and just needs a few (configurable) form parameter and
cookie name(s) for its own use.  It tries to avoid making assumptions
about the implementation structure of your application.

Because CGI::Auth::Flexible is licenced under the AGPLv3, you will
probably need to provide a facility to allow users (even ones not
logged in) to download the source code for your web app.  Conveniently
by default CGI::Auth::Flexible provides (for pure Perl webapps) a
mechanism for users to get the source.

CGI::Auth::Flexible is designed to try to stop you accidentally
granting access by misunderstanding the API.  (Also it, of course,
guards against cross-site scripting.)  You do need to make sure to
call CGI::Auth::Flexible before answering AJAX requests as well as
before generating HTML pages, of course, and to call it in every
entrypoint to your system.

=head2 INITIALISATION

Your application should, on startup (eg, when it is loaded by
mod_perl) do
C<< $verifier = CGI::Auth::Flexible->new_verifier(settings...) >>.
This call can be expensive and is best amortised.

The resulting verifier object can be used to process individual
requests, in each case with
C<< $authreq = CGI::Auth::Flexible->new_request($cgi_query) >>.

=head2 SIMPLE APPLICATIONS

The simplist usage is to call C<< $request->check_ok() >> which will
check the user's authentication.  If the user is not logged in it will
generate a login form (or redirection or other appropriate page) and
return false; your application should not then processing that request
any further.  If the user is logged in it will return true.

After calling C<check_ok> you can use C<< $request->get_username >>
to find out which user the request came from.

=head2 SOPHISTICATED APPLICATIONS

If you want to handle the flow control and to generate login forms,
redirections, etc., yourself, you can say
C<< $divert = $request->check_divert >>.  This returns undef if
the user is logged in, or I<divert spec> if some kind of login
page or diversion should be generated.

=head2 GENERATING (MUTATING) FORMS AND AJAX QUERIES

When you generate a C<POST> form or AJAX request you need to include a
special secret hidden form parameter for the benefit of
CGI::Auth::Generic.  This form parameter will be checked by
C<check_ok>/C<check_divert> and should be ignored by your application.

By default its name is C<caf_assochash>.  After calling C<check_ok> or
C<check_divert> the value to put in your form can be obtained from
C<secret_hidden_val>; C<secret_hidden_html> will generate the whole
HTML C<< <input...> >> element.

Do not put the secret value in URLs for C<GET> requests.

=head2 MUTATING OPERATIONS AND EXTERNAL LINKS INTO YOUR SITE

By default CGI::Auth::Flexible does not permit external links into
your site.  All GET requests give a "click to continue" page which
submits a form.  In this configuration all your application's forms
and AJAX requests should use C<POST>.

This is because the alternative (for complicated reasons relating to
the web security architecture) is to require your application to make
a special and different check when the incoming request is going to do
some kind of action (such as modifying the user's setup, purchasing
goods, or whatever) rather than just display HTML pages.

To support external links, and C<GET> requests, pass C<<
promise_check_mutate => 1 >> in I<settings>, and then call C<<
$authreq->check_mutate() >> before taking any actions.  If the
incoming request is not suitable then C<< $authreq->check_mutate() >>
will call C<die>.  If you do this you must make sure that you have no
mutating C<GET> requests in your application - but you shouldn't have
any of those anyway.

=head2 DATA STORAGE

CGI::Auth::Flexible needs to store various information in plain files;
it does this in the directory specified by the C<dir> parameter.

It also needs to record state relating to user sessions in a database.
There is no particular reason for this 

=head1 SOURCE CODE DOWNLOAD

By default, CGI::Auth::Flexible provides a facility for users to
download the source code for the running version of your web
application.

This facility makes a number of important assumptions which you need
to check.  Note that if the provided facility is not sufficient
because your application is more sophisticated than it copes with (or
if you disable the builtin facility), you may need to implement a
functioning alternative to avoid violating the AGPLv3 licence.

Here are the most important (default) assumptions:

=over

=item *

Your app's source code is available by looking at @INC, $0 and
S<$ENV{'SCRIPT_FILENAME'}> (the B<source items>).  See
C<srcdump_listitems>.  Where these point to files or directories under
revision control, the source item is the whole containing vcs tree.

=item *

Specifically, there are no compiled or autogenerated Perl
files, Javascript resources, etc., which are not contained in one of
the source item directories.  (Files which came with your operating
system install don't need to be shipped as they fall under the system
library exceptio.)

=item *

You have not installed any modified versions of system
libraries (including system-supplied) Perl modules in C</usr> outside
C</usr/local>.  See C<srcdump_system_dir>.

=item *

For each source item in a dvcs, the entire dvcs history does
not contain anything confidential (or libellous).  Also, all files which
contain secrets are in the dvcs's C<.ignore> file.  See
C<srcdump_vcsscript_git> et al.

=item *

For each source item NOT in a dvcs, there are no confidential
files with the world-readable bit set (being in a world-inaccessible
directory is not sufficient).  See C<srcdump_excludes>.

=item *

You have none of your app's source code in C</etc>.

=item *

You don't regard pathnames on your server as secret.

=item *

You don't intentionally load Perl code by virtule of C<.>
being in C<@INC> by default.  (See C<srcdump_filter_cwd>.)

=back

=head1 MAIN FUNCTIONS AND METHODS

=over

=item C<< CGI::Auth::Flexible->new_verifier(setting => value, ...) >>

Initialises an instance and returns a verifier object.
The arguments are setting pairs like a hash initialiser.
See L</SETTINGS> below.

=item C<< $verifier->new_request($cgi_query) >>

Prepares to process a request.  C<$cgi_query> should normally
be the query object from L<CGI(3perl)>.  Most of the default
hook methods assume that it is; however if you replace enough of
the hook methods then you can pass any value you like and it
will be passed to your hooks.

The return value is the authentication request object (C<$authreq>)
which is used to check the incoming request and will contain
information about its credentials.

=item C<< $authreq->check_divert() >>

Checks whether the user is logged in.  Returns undef if the user is
logged in and we should service the request.  Otherwise returns a
divert spec (see L</DIVERT SPEC>) saying what should happen instead.

This method may die if it doesn't like the request, in which case
the request needs to be rejected.

=item C<< $authreq->check_ok() >>

Checks whether the user is logged in.  Returns true if the user is
logged in and we should service the request.

Otherwise it handles the request itself, generating any appropriate
redirect, login form, or continuation page.  It then returns false and
the application should not process the request further.

=item C<< $authreq->disconnect() >>

Disconnects from the 

=back
