# -*- 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;

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(setup);
}
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;

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

sub flatten_params ($) {
    my ($p) = @_;
    my @p;
    foreach my $k (keys %$p) {
	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');
    return $r->_ch('username_password_ok', $username, $password);
}

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>",
	       $c->_ch('gen_end_html'));
}

sub gen_plain_login_form ($$) {
    my ($c,$r, $params) = @_;
    my @form;
    push @form, ('<form method="POST" action="'.
		 escapeHTML($r->_ch('get_url')).'">'.
		 '<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}{login_submit_name}[0].'"'.
		 ' value="'.$r->_gt('Login').'"></td></tr>',
		 '</table>');
    foreach my $n (keys %$params) {
	push @form, ('<input type="hidden"'.
		     ' name="'.$n.'"'.
		     ' value="'.$params->{$n}.'">');
    }
    push @form, ('</form>');
    return join "\n", @form;
}

sub gen_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>');
}

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

sub new_verifier {
    my $class = shift;
    my $verifier = {
	S => {
            dir => undef,
	    assocdb_path => 'caf-assocs.db',
	    keys_path => 'caf-keys',
	    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',
	    cookie_name => "caf_assocsecret",
	    password_param_name => 'password',
	    username_param_names => [qw(username)],
	    form_entry_size => 60,
	    logout_param_names => [qw(caf_logout)],
	    login_submit_name => [qw(caf_login)],
	    loggedout_param_names => [qw(caf_loggedout)],
	    promise_check_mutate => 0,
	    get_param => sub { $_[0]->param($_[2]) },
	    get_params => sub { $_[1]->get_params() },
	    get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) },
	    get_method => sub { $_[0]->request_method() },
	    get_url => sub { $_[0]->url(); },
            is_login => sub { defined $_[1]->_rp('password_param_name') },
            login_ok => \&login_ok_password,
            username_password_ok => 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_end_html => sub { $_[0]->end_html(); },
	    gen_login_form => \&gen_plain_login_form,
	    gen_login_link => \&gen_plain_login_link,
	    gettext => sub { gettext($_[2]); },
	    print => sub { print $_[2] or die $!; },
	},
	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();
    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; 

    $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,
                        });
    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 $rv\n";
	    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 _get_path ($$) {
    my ($v,$keybase) = @_;
    my $leaf = $v->{S}{"${keybase}_path"};
    my $dir = $v->{S}{dir};
    return $leaf if $leaf =~ m,^/,;
    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 $meth = $r->_ch('get_method');
    my $cooks = $r->_ch('get_cookie');
    my $parmh = $r->_rp('assoc_param_name');
    my $cookh = defined $cooks ? $r->hash($cooks) : undef;

    my ($cookt,$cooku) = $r->_identify($cookh, $cooks);
    my $parmt = $r->_identify($parmh, undef);

    print STDERR "_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 => "Logging out...",
		  CookieSecret => '',
		  Params => { } });
    }
    if ($r->_ch('is_loggedout')) {
	die unless $meth eq 'GET';
	die unless $cookt;
	die unless $parmt;
	return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
		  Message => "You have been logged out.",
		  CookieSecret => '',
		  Params => { } });
    }
    if ($r->_ch('is_login')) {
	$r->_must_be_post();
	die unless $parmt;
        if (!$cookt && $parmt eq 't') {
            return ({ Kind => 'SMALLPAGE-NOCOOKIE',
                      Message => "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 => "Stale session; you need to log in again.",
                      CookieSecret => $r->_fresh_secret(),
                      Params => { } })
        }
	die unless $parmt eq 't' || $parmt eq 'y';
	my $username = $r->_ch('login_ok');
        unless (defined $username && length $username) {
            return ({ Kind => 'LOGIN-BAD',
                      Message => "Incorrect username/password.",
                      CookieSecret => $cooks,
                      Params => $r->_chain_params() })
        }
	$r->_db_record_login_ok($parmh,$username);
	return ({ Kind => 'REDIRECT-LOGGEDIN',
		  Message => "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 => "You need to log in again.",
		      CookieSecret => $news,
		      Params => $r->_chain_params() });
	} else {
	    $r->_db_revoke($parmh);
	    return ({ Kind => 'LOGIN-FRESH',
                      Message => "You need to log in again.",
                      CookieSecret => $news,
                      Params => { } });
	}
    }

    if (!$r->{S}{promise_check_mutate}) {
	if ($meth ne 'POST') {
	    return ({ Kind => 'MAINPAGEONLY',
		      Message => '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';
    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};
	}
    }
    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)

    return '' unless defined $h && length $h;

    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) {
        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}{form_timeout};

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

    $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}".
	     " (associd, 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();
    print STDERR Dumper($r->{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) = @_;
    my $uri = URI->new($r->_ch('get_url'));
    $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 (defined $cookiesecret) {
        $params->{$r->{S}{assoc_param_name}} = $r->hash($cookiesecret);
    }

    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 eq 'REDIRECT-LOGGEDIN') {
	} else {
	    die;
	}
	my $new_url = $r->url_with_query_params($params);
	$r->_ch('do_redirect',$new_url, $cookie);
	return 0;
    }

    my ($title, @body);
    if ($kind =~ m/^LOGIN-/) {
	$title = $r->_gt('Login');
	push @body, $r->_gt($divert->{Message});
	push @body, $r->_ch('gen_login_form', $params);
    } elsif ($kind =~ m/^SMALLPAGE-/) {
	$title = $r->_gt('Not logged in');
	push @body, $r->_gt($divert->{Message});
	push @body, $r->_ch('gen_login_link');
    } 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_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";
    my $digest = new Digest $alg;
    $digest->add($message);
    return $digest->hexdigest();
}

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

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

#---------- 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;
}

__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_request_object);

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

=head1 USAGE PATTERN FOR SIMPLE APPLICATIONS

 $authreq->check_ok() or return;

 blah blah blah
 $authreq->check_mutate();
 blah blah blah

=head1 USAGE PATTERN FOR FANCY APPLICATIONS

 my $divert_kind = $authreq->check_divert();
 if ($divert_kind) {
     if ($divert_kind eq 'LOGGEDOUT') {
	 print "goodbye you are now logged out" and quit
     } elsif ($divert_kind eq 'NOCOOKIES') {
	 print "you need cookies" and quit
     ... etc.
     }
 }

 blah blah blah
 $authreq->check_mutate();
 blah blah blah
