cgi-auth-flexible.pm

   1 # -*- perl -*-
   2
   3 # This is part of CGI::Auth::Flexible, a perl CGI authentication module.
   4 # Copyright (C) 2012 Ian Jackson.
   5 # Copyright (C) 2012 Citrix.
   6 #
   7 # This program is free software: you can redistribute it and/or modify
   8 # it under the terms of the GNU Affero General Public License as published by
   9 # the Free Software Foundation, either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU Affero General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU Affero General Public License
  18 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 use strict;
  21 use warnings FATAL => 'all';
  22
  23 package CGI::Auth::Flexible;
  24 require Exporter;
  25
  26 BEGIN {
  27     use Exporter   ();
  28     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  29
  30     $VERSION     = 1.00;
  31     @ISA         = qw(Exporter);
  32     @EXPORT      = qw();
  33     %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
  34
  35     @EXPORT_OK   = qw();
  36 }
  37 our @EXPORT_OK;
  38
  39 use DBI;
  40 use CGI qw/escapeHTML/;
  41 use Locale::gettext;
  42 use URI;
  43 use IO::File;
  44 use Fcntl qw(:flock);
  45 use POSIX;
  46 use Digest;
  47 use Digest::HMAC;
  48 use Digest::SHA;
  49 use Data::Dumper;
  50 use File::Copy;
  51 use Cwd qw/realpath/;
  52
  53
  54 #---------- public utilities ----------
  55
  56 sub flatten_params ($) {
  57     my ($p) = @_;
  58     my @p;
  59     foreach my $k (keys %$p) {
  60         next if $k eq '';
  61         foreach my $v (@{ $p->{$k} }) {
  62             push @p, $k, $v;
  63         }
  64     }
  65     return @p;
  66 }
  67
  68 #---------- default callbacks ----------
  69
  70 sub has_a_param ($$) {
  71     my ($r,$cn) = @_;
  72     foreach my $pn (@{ $r->{S}{$cn} }) {
  73         return 1 if $r->_ch('get_param',$pn);
  74     }
  75     return 0;
  76 }
  77
  78 sub get_params ($) {
  79     my ($r) = @_;
  80     my %p;
  81     my $c = $r->{Cgi};
  82     foreach my $name ($c->param()) {
  83         $p{$name} = [ $c->param($name) ];
  84     }
  85     return \%p;
  86 }
  87
  88 sub get_cookie_domain ($$$) {
  89     my ($c,$r) = @_;
  90     my $uri = new URI $r->_ch('get_url');
  91     return $uri->host();
  92 }
  93
  94 sub login_ok_password ($$) {
  95     my ($c, $r) = @_;
  96     my $username_params = $r->{S}{username_param_names};
  97     my $username = $r->_ch('get_param',$username_params->[0]);
  98     my $password = $r->_rp('password_param_name');
  99     my $error = $r->_ch('username_password_error', $username, $password);
 100     return defined($error) ? (undef,$error) : ($username,undef);
 101 }
 102
 103 sub do_redirect_cgi ($$$$) {
 104     my ($c, $r, $new_url, $cookie) = @_;
 105     $r->_print($c->header($r->_cgi_header_args($cookie,
 106                                                -status => '303 See other',
 107                                                -location => $new_url)),
 108                $r->_ch('gen_start_html',$r->_gt('Redirection')),
 109                '<a href="'.escapeHTML($new_url).'">',
 110                $r->_gt("If you aren't redirected, click to continue."),
 111                "</a>",
 112                $r->_ch('gen_end_html'));
 113 }
 114
 115 sub gen_some_form ($$) {
 116     my ($r, $params, $bodyfn) = @_;
 117     # Calls $bodyfn->($c,$r) which returns @formbits
 118     my $c = $r->{Cgi};
 119     my @form;
 120     my $pathinfo = '';
 121     $pathinfo .= $params->{''}[0] if $params->{''};
 122     push @form, ('<form method="POST" action="'.
 123                  escapeHTML($r->_ch('get_url').$pathinfo).'">');
 124     push @form, $bodyfn->($c,$r);
 125     foreach my $n (keys %$params) {
 126         next if $n eq '';
 127         foreach my $val (@{ $params->{$n} }) {
 128             push @form, ('<input type="hidden"'.
 129                          ' name="'.escapeHTML($n).'"'.
 130                          ' value="'.escapeHTML($val).'">');
 131         }
 132     }
 133     push @form, ('</form>');
 134     return join "\n", @form;
 135 }
 136
 137 sub gen_plain_login_form ($$) {
 138     my ($c,$r, $params) = @_;
 139     return $r->gen_some_form($params, sub {
 140         my @form;
 141         push @form, ('<table>');
 142         my $sz = 'size="'.$r->{S}{form_entry_size}.'"';
 143         foreach my $up (@{ $r->{S}{username_param_names}}) {
 144             push @form, ('<tr><td>',$r->_gt(ucfirst $up),'</td>',
 145                          '<td><input type="text" '.$sz.
 146                          ' name='.$up.'></td></tr>');
 147         }
 148         push @form, ('<tr><td>'.$r->_gt('Password').'</td>',
 149                      '<td><input type="password" '.$sz.
 150                      ' name="'.$r->{S}{password_param_name}.'"></td></tr>');
 151         push @form, ('<tr><td colspan="2">',
 152                      '<input type="submit"'.
 153                      ' name="'.$r->{S}{dummy_param_name_prefix}.'login"'.
 154                      ' value="'.$r->_gt('Login').'"></td></tr>',
 155                      '</table>');
 156         return @form;
 157     });
 158 }
 159
 160 sub gen_postmainpage_form ($$$) {
 161     my ($c,$r, $params) = @_;
 162     return $r->gen_some_form($params, sub {
 163         my @form;
 164         push @form, ('<input type="submit"',
 165                      ' name="'.$r->{S}{dummy_param_name_prefix}.'submit"'.
 166                      ' value="'.$r->_gt('Continue').'">');
 167         return @form;
 168     });
 169 }
 170
 171 sub gen_plain_login_link ($$) {
 172     my ($c,$r, $params) = @_;
 173     my $url = $r->url_with_query_params($params);
 174     return ('<a href="'.escapeHTML($url).'">'.
 175             $r->_gt('Log in again to continue.').
 176             '</a>');
 177 }
 178
 179 sub gen_srcdump_link_html ($$$$) {
 180     my ($c,$r,$anchor,$specval) = @_;
 181     my %params = ($r->{S}{srcdump_param_name} => [ $specval ]);
 182     return '<a href="'.escapeHTML($r->url_with_query_params(\%params)).'">'.
 183         $anchor."</a>";
 184 }
 185 sub gen_plain_licence_link_html ($$) {
 186     my ($c,$r) = @_;
 187     gen_srcdump_link_html($c,$r, 'GNU Affero GPL', 'licence');
 188 }
 189 sub gen_plain_source_link_html ($$) {
 190     my ($c,$r) = @_;
 191     gen_srcdump_link_html($c,$r, 'Source available', 'source');
 192 }
 193
 194 sub gen_plain_footer_html ($$) {
 195     my ($c,$r) = @_;
 196     return ('<hr><address>',
 197             ("Powered by Free / Libre / Open Source Software".
 198              " according to the ".$r->_ch('gen_licence_link_html')."."),
 199             $r->_ch('gen_source_link_html').".",
 200             '</address>');
 201 }
 202
 203 #---------- licence and source code ----------
 204
 205 sub srcdump_dump ($$$) {
 206     my ($c,$r, $thing) = @_;
 207     die if $thing =~ m/\W/ || $thing !~ m/\w/;
 208     my $path = $r->_get_path('srcdump');
 209     my $ctf = new IO::File "$path/$thing.ctype", 'r'
 210         or die "$path/$thing.ctype $!";
 211     my $ct = <$ctf>;
 212     chomp $ct or die "$path/$thing ?";
 213     $ctf->close or die "$path/$thing $!";
 214     my $df = new IO::File "$path/$thing.data", 'r'
 215         or die "$path/$thing.data $!";
 216     $r->_ch('dump', $ct, $df);
 217 }
 218
 219 sub dump_plain ($$$$) {
 220     my ($c, $r, $ct, $df) = @_;
 221     $r->_print($c->header('-type' => $ct));
 222     my $buffer;
 223     for (;;) {
 224         my $got = read $df, $buffer, 65536;
 225         die $! unless defined $got;
 226         return if !$got;
 227         $r->_print($buffer);
 228     }
 229 }
 230
 231 sub srcdump_process_item ($$$$$$) {
 232     my ($c, $v, $dumpdir, $item, $outfn, $needlicence, $dirsdone) = @_;
 233     if ($v->_ch('srcdump_system_dir', $item)) {
 234         $outfn->("srcdump_process_item: srcdump_system_dir, skipping $item");
 235         return;
 236     }
 237     my $upwards = $item;
 238     for (;;) {
 239         $upwards =~ s#/+$##;
 240         $upwards =~ s#/+\.$##;
 241         last unless $upwards =~ m#[^/]#;
 242         foreach my $try (@{ $v->{S}{srcdump_vcs_dirs} }) {
 243 #print STDERR "TRY $item $upwards $try\n";
 244             if (!stat "$upwards/$try") {
 245                 $!==&ENOENT or $!==&ENOTDIR or die "check $upwards/$try $!";
 246                 next;
 247             }
 248 #print STDERR "VCS $item $upwards $try\n";
 249             if ($dirsdone->{$upwards}++) {
 250                 $outfn->("srcdump_process_item: did $upwards,".
 251                          " skipping $item");
 252                 return;
 253             }
 254 #print STDERR "VCS $item $upwards $try GO\n";
 255             $try =~ m/\w+/ or die;
 256             return $v->_ch('srcdump_byvcs', $dumpdir, $upwards, $outfn, lc $&);
 257         }
 258         $upwards =~ s#/*[^/]+$##;
 259     }
 260     return $v->_ch('srcdump_novcs', $dumpdir, $item, $outfn);
 261 }
 262
 263 sub srcdump_novcs ($$$$$) {
 264     my ($c, $v, $dumpdir, $item, $outfn) = @_;
 265     stat $item or die "$item $!";
 266     if (-d _) {
 267         my $script = 'find -type f -perm +004';
 268         foreach my $excl (@{ $v->{S}{srcdump_excludes} }) {
 269             $script .= " \\! -name '$excl'";
 270         }
 271         $script .= " -print0";
 272         return srcdump_dir_cpio($c,$v,$dumpdir,$item,$outfn,'novcs',$script);
 273     } elsif (-f _) {
 274         return srcdump_file($c,$v,$dumpdir,$item,$outfn);
 275     } else {
 276         die "$item not file or directory";
 277     }
 278 }
 279
 280 sub srcdump_byvcs ($$$$$$) {
 281     my ($c, $v, $dumpdir, $dir, $outfn, $vcs) = @_;
 282 #print STDERR "BYVCS GIT $dir\n";
 283     return srcdump_dir_cpio($c,$v,$dumpdir,$dir,$outfn,$vcs,
 284                             $v->{S}{"srcdump_vcsscript_$vcs"});
 285 }
 286
 287 sub srcdump_file ($$$$) {
 288     my ($c,$v,$dumpdir,$file,$outfn) = @_;
 289     my $outfile = $outfn->("srcdump_file saved $file", "src");
 290     copy($file,$outfile) or die "$file $outfile $!";
 291 }
 292
 293 sub srcdump_dir_cpio ($$$$$$$) {
 294     my ($c,$v,$dumpdir,$dir,$outfn,$how,$script) = @_;
 295     my $outfile = $outfn->("srcdump_dir_cpio $how saved $dir", "tar");
 296 #print STDERR "CPIO $dir >$script<\n";
 297     my $pid = fork();
 298     defined $pid or die $!;
 299     if (!$pid) {
 300         $SIG{__DIE__} = sub {
 301             print STDERR "CGI::Auth::Flexible srcdump error: $@\n";
 302             exit 127;
 303         };
 304         open STDOUT, ">", $outfile or die "$outfile $!";
 305         chdir $dir or die "chdir $dir: $!";
 306         exec '/bin/bash','-ec',"
 307             set -o pipefail
 308             (
 309              $script
 310             ) | (
 311              cpio -Hustar -o --quiet -0 -R 1000:1000 || \
 312              cpio -Hustar -o --quiet -0
 313             )
 314             ";
 315         die $!;
 316     }
 317     $!=0; (waitpid $pid, 0) == $pid or die "$!";
 318     die "$dir ($how $script) $outfile $?" if $?;
 319 }
 320
 321 sub srcdump_dirscan_prepare ($$) {
 322     my ($c, $v) = @_;
 323     my $dumpdir = $v->_get_path('srcdump');
 324     mkdir $dumpdir or $!==&EEXIST or die "mkdir $dumpdir $!";
 325     my $lockf = new IO::File "$dumpdir/generate.lock", 'w+'
 326         or die "$dumpdir/generate.lock $!";
 327     flock $lockf, LOCK_EX or die "$dumpdir/generate.lock $!";
 328     my $needlicence = "$dumpdir/licence.tmp";
 329     unlink $needlicence or $!==&ENOENT or die "rm $needlicence $!";
 330     if (defined $v->{S}{srcdump_licence_path}) {
 331         copy($v->{S}{srcdump_licence_path}, $needlicence)
 332             or die "$v->{S}{srcdump_licence_path} $!";
 333         $needlicence = undef;
 334     }
 335     unlink <"$dumpdir/s.[a-z][a-z][a-z].*">;
 336     my @srcfiles = qw(licence.data manifest.txt);
 337     my $srcoutcounter = 'aaa';
 338
 339     my $reportfh = new IO::File "$dumpdir/manifest.txt", 'w' or die $!;
 340     my $outfn = sub {
 341         my ($message, $extension) = @_;
 342         if (defined $extension) {
 343             my $leaf = "s.$srcoutcounter.$extension";
 344             $srcoutcounter++;
 345             push @srcfiles, $leaf;
 346             print $reportfh "$leaf: $message\n" or die $!;
 347             return "$dumpdir/$leaf";
 348         } else {
 349             print $reportfh "none: $message\n" or die $!;
 350             return undef;
 351         }
 352     };
 353     my %dirsdone;
 354     foreach my $item ($v->_ch('srcdump_listitems')) {
 355         if ($item eq '.' && $v->{S}{srcdump_filter_cwd}) {
 356             my @bad = grep { !m#^/# } values %INC;
 357             die "filtering . from srcdump items and \@INC but already".
 358                 " included @bad " if @bad;
 359             @INC = grep { $_ ne '.' } @INC;
 360             next;
 361         }
 362         if (!lstat "$item") {
 363             die "stat $item $!" unless $!==&ENOENT;
 364             $outfn->("srcdump_dirscan_prepare stat ENOENT, skipping $item");
 365             next;
 366         };
 367         if (-l _) {
 368             $item = realpath($item);
 369             if (!defined $item) {
 370                 die "realpath $item $!" unless $!==&ENOENT;
 371                 $outfn->("srcdump_dirscan_prepare realpath ENOENT,".
 372                          " skipping $item");
 373             }
 374         }
 375         if (defined $needlicence) {
 376             foreach my $try (@{ $v->{S}{srcdump_licence_files} }) {
 377                 last if copy("$item/$try", $needlicence);
 378                 $!==&ENOENT or $!==&ENOTDIR or die "copy $item/$try $!";
 379             }
 380         }
 381         $v->_ch('srcdump_process_item', $dumpdir, $item,
 382                 $outfn, \$needlicence, \%dirsdone);
 383         $dirsdone{$item}++;
 384     }
 385     close $reportfh or die $!;
 386     srcdump_install($c,$v, $dumpdir, 'licence', 'text/plain');
 387     $!=0;
 388     my @cmd = (qw(tar -zvvcf), "$dumpdir/source.tmp",
 389                "-C", $dumpdir, qw(  --), @srcfiles);
 390     my $r = system(@cmd);
 391     if ($r) {
 392         print STDERR "CGI::Auth::Flexible tar failed ($r $!) @cmd\n";
 393         die "tar failed";
 394     }
 395     die "licence file not found" unless defined $needlicence;
 396     srcdump_install($c,$v, $dumpdir, 'source', 'application/octet-stream');
 397     close $lockf or die $!;
 398 }
 399
 400 sub srcdump_install ($$$$$) {
 401     my ($c,$v, $dumpdir, $which, $ctype) = @_;
 402     rename "$dumpdir/$which.tmp", "$dumpdir/$which.data"
 403         or die "$dumpdir/$which.data $!";
 404     my $ctf = new IO::File "$dumpdir/$which.tmp", 'w'
 405         or die "$dumpdir/$which.tmp $!";
 406     print $ctf $ctype, "\n" or die $!;
 407     close $ctf or die $!;
 408     rename "$dumpdir/$which.tmp", "$dumpdir/$which.ctype"
 409         or die "$dumpdir/$which.ctype $!";
 410 }
 411
 412 #---------- verifier object methods ----------
 413
 414 sub new_verifier {
 415     my $class = shift;
 416     my $verifier = {
 417         S => {
 418             dir => undef,
 419             assocdb_dbh => undef, # must have AutoCommit=0, RaiseError=1
 420             assocdb_path => 'caf-assocs.db',
 421             keys_path => 'caf-keys',
 422             srcdump_path => 'caf-srcdump',
 423             assocdb_dsn => undef,
 424             assocdb_user => '',
 425             assocdb_password => '',
 426             assocdb_table => 'caf_assocs',
 427             random_source => '/dev/urandom',
 428             secretbits => 128, # bits
 429             hash_algorithm => "SHA-256",
 430             login_timeout => 86400, # seconds
 431             login_form_timeout => 3600, # seconds
 432             key_rollover => 86400, # seconds
 433             assoc_param_name => 'caf_assochash',
 434             dummy_param_name_prefix => 'caf__',
 435             cookie_name => "caf_assocsecret",
 436             password_param_name => 'password',
 437             srcdump_param_name => 'caf_srcdump',
 438             username_param_names => [qw(username)],
 439             form_entry_size => 60,
 440             logout_param_names => [qw(caf_logout)],
 441             loggedout_param_names => [qw(caf_loggedout)],
 442             promise_check_mutate => 0,
 443             get_param => sub { $_[0]->param($_[2]) },
 444             get_params => sub { $_[1]->get_params() },
 445             get_path_info => sub { $_[0]->path_info() },
 446             get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) },
 447             get_method => sub { $_[0]->request_method() },
 448             check_https => sub { !!$_[0]->https() },
 449             get_url => sub { $_[0]->url(); },
 450             is_login => sub { defined $_[1]->_rp('password_param_name') },
 451             login_ok => \&login_ok_password,
 452             username_password_error => sub { die },
 453             is_logout => sub { $_[1]->has_a_param('logout_param_names') },
 454             is_loggedout => sub { $_[1]->has_a_param('loggedout_param_names') },
 455             is_page => sub { return 1 },
 456             handle_divert => sub { return 0 },
 457             do_redirect => \&do_redirect_cgi, # this hook is allowed to throw
 458             cookie_path => "/",
 459             get_cookie_domain => \&get_cookie_domain,
 460             encrypted_only => 1,
 461             gen_start_html => sub { $_[0]->start_html($_[2]); },
 462             gen_footer_html => \&gen_plain_footer_html,
 463             gen_licence_link_html => \&gen_plain_licence_link_html,
 464             gen_source_link_html => \&gen_plain_source_link_html,
 465             gen_end_html => sub { $_[0]->end_html(); },
 466             gen_login_form => \&gen_plain_login_form,
 467             gen_login_link => \&gen_plain_login_link,
 468             gen_postmainpage_form => \&gen_postmainpage_form,
 469             srcdump_dump => \&srcdump_dump,
 470             srcdump_prepare => \&srcdump_dirscan_prepare,
 471             srcdump_licence_path => undef,
 472             srcdump_licence_files => [qw(AGPLv3 CGI/Auth/Flexible/AGPLv3)],
 473             srcdump_listitems => sub { (@INC, $ENV{'SCRIPT_FILENAME'}, $0); },
 474             srcdump_filter_cwd => 1,
 475             srcdump_system_dir => sub {
 476                 $_[2] =~ m#^/etc/|^/usr/(?!local/)(?!lib/cgi)#;
 477             },
 478             srcdump_process_item => \&srcdump_process_item,
 479             srcdump_vcs_dirs => [qw(.git .hg .bzr .svn CVS)],
 480             srcdump_vcsscript_git => "
 481                  git ls-files -z
 482                  git ls-files -z --others --exclude-from=.gitignore
 483                  find .git -print0
 484                             ",
 485             srcdump_vcsscript_hg => "false hg",
 486             srcdump_vcsscript_bzr => "false bzr",
 487             srcdump_vcsscript_svn => "false svn",
 488             srcdump_vcsscript_cvs => "false cvs",
 489             srcdump_byvcs => \&srcdump_byvcs,
 490             srcdump_novcs => \&srcdump_novcs,
 491             srcdump_excludes => [qw(*~ *.bak *.tmp), '#*#'],
 492             dump => \&dump_plain,
 493             gettext => sub { gettext($_[2]); },
 494             print => sub { print $_[2] or die $!; },
 495             debug => sub { }, # like print; msgs contain trailing \n
 496         },
 497         Dbh => undef,
 498     };
 499     my ($k,$v);
 500     while (($k,$v,@_) = @_) {
 501         die "unknown setting $k" unless exists $verifier->{S}{$k};
 502         $verifier->{S}{$k} = $v;
 503     }
 504     bless $verifier, $class;
 505     $verifier->_dbopen();
 506     $verifier->_ch('srcdump_prepare');
 507     return $verifier;
 508 }
 509
 510 sub _db_setup_do ($$) {
 511     my ($v, $sql) = @_;
 512     my $dbh = $v->{Dbh};
 513     eval {
 514         $v->_db_transaction(sub {
 515             local ($dbh->{PrintError}) = 0;
 516             $dbh->do($sql);
 517         });
 518     };
 519 }
 520
 521 sub _dbopen ($) {
 522     my ($v) = @_;
 523     my $dbh = $v->{Dbh};
 524     return $dbh if $dbh;
 525
 526     $dbh = $v->{S}{assocdb_dbh};
 527     if ($dbh) {
 528         die if $dbh->{AutoCommit};
 529         die unless $dbh->{RaiseError};
 530     } else {
 531         $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb');
 532         my $dsn = $v->{S}{assocdb_dsn};
 533
 534         my $u = umask 077;
 535         $dbh = DBI->connect($dsn, $v->{S}{assocdb_user},
 536                             $v->{S}{assocdb_password}, {
 537                                 AutoCommit => 0,
 538                                 RaiseError => 1,
 539                                 ShowErrorStatement => 1,
 540                             });
 541         umask $u;
 542         die "$dsn $! ?" unless $dbh;
 543     }
 544     $v->{Dbh} = $dbh;
 545
 546     $v->_db_setup_do("CREATE TABLE $v->{S}{assocdb_table} (".
 547                      " assochash VARCHAR PRIMARY KEY,".
 548                      " username VARCHAR NOT NULL,".
 549                      " last INTEGER NOT NULL".
 550                      ")");
 551     $v->_db_setup_do("CREATE INDEX $v->{S}{assocdb_table}_timeout_index".
 552                      " ON $v->{S}{assocdb_table}".
 553                      " (last)");
 554     return $dbh;
 555 }
 556
 557 sub disconnect ($) {
 558     my ($v) = @_;
 559     my $dbh = $v->{Dbh};
 560     return unless $dbh;
 561     $dbh->disconnect();
 562 }
 563
 564 sub _db_transaction ($$) {
 565     my ($v, $fn) = @_;
 566     my $retries = 10;
 567     my $rv;
 568     my $dbh = $v->{Dbh};
 569 #print STDERR "DT entry\n";
 570     for (;;) {
 571 #print STDERR "DT loop\n";
 572         if (!eval {
 573             $rv = $fn->();
 574 #print STDERR "DT fn ok\n";
 575             1;
 576         }) {
 577 #print STDERR "DT fn error\n";
 578             { local ($@); $dbh->rollback(); }
 579 #print STDERR "DT fn throwing\n";
 580             die $@;
 581         }
 582 #print STDERR "DT fn eval ok\n";
 583         if (eval {
 584             $dbh->commit();
 585 #print STDERR "DT commit ok\n";
 586             1;
 587         }) {
 588 #print STDERR "DT commit eval ok ",Dumper($rv);
 589             return $rv;
 590         }
 591 #print STDERR "DT commit throw?\n";
 592         die $@ if !--$retries;
 593 #print STDERR "DT loop again\n";
 594     }
 595 }
 596
 597 #---------- request object methods ----------
 598
 599 sub new_request {
 600     my ($classbase, $cgi, @extra) = @_;
 601     if (!ref $classbase) {
 602         $classbase = $classbase->new_verifier(@extra);
 603     } else {
 604         die if @extra;
 605     }
 606     my $r = {
 607         V => $classbase,
 608         S => $classbase->{S},
 609         Dbh => $classbase->{Dbh},
 610         Cgi => $cgi,
 611     };
 612     bless $r, ref $classbase;
 613 }
 614
 615 sub _ch ($$@) { # calls an application hook
 616     my ($r,$methname, @args) = @_;
 617     my $methfunc = $r->{S}{$methname};
 618     die "$methname ?" unless $methfunc;
 619     return $methfunc->($r->{Cgi}, $r, @args);
 620 }
 621
 622 sub _rp ($$@) {
 623     my ($r,$pnvb) = @_;
 624     my $pn = $r->{S}{$pnvb};
 625     my $p = scalar $r->_ch('get_param',$pn)
 626 }
 627
 628 sub _debug ($@) {
 629     my ($r,@args) = @_;
 630     $r->_ch('debug',@args);
 631 }
 632
 633 sub _get_path ($$) {
 634     my ($r,$keybase) = @_;
 635     my $leaf = $r->{S}{"${keybase}_path"};
 636     return $r->_absify_path($leaf);
 637 }
 638
 639 sub _absify_path ($$) {
 640     my ($v,$leaf) = @_;
 641     return $leaf if $leaf =~ m,^/,;
 642     my $dir = $v->{S}{dir};
 643     die "relying on cwd by default ?!  set dir" unless defined $dir;
 644     return "$dir/$leaf";
 645 }
 646
 647 sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); }
 648 sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); }
 649
 650 sub construct_cookie ($$$) {
 651     my ($r, $cooks) = @_;
 652     return undef unless $cooks;
 653     my $c = $r->{Cgi};
 654 my @ca = (-name => $r->{S}{cookie_name},
 655                              -value => $cooks,
 656                              -path => $r->{S}{cookie_path},
 657                              -domain => $r->_ch('get_cookie_domain'),
 658                              -expires => '+'.$r->{S}{login_timeout}.'s',
 659                              -secure => $r->{S}{encrypted_only});
 660     my $cookie = $c->cookie(@ca);
 661 #print STDERR "CC $r $c $cooks $cookie (@ca).\n";
 662     return $cookie;
 663 }
 664
 665 # pages/param-sets are
 666 #   n normal non-mutating page
 667 #   r retrieval of information for JS, non-mutating
 668 #   m mutating page
 669 #   u update of information by JS, mutating
 670 #   i login
 671 #   o logout
 672 #   O "you have just logged out" page load
 673
 674 # in cook and par,
 675 #    -         no value supplied (represented in code as $cookt='')
 676 #    n, nN     value not in our db
 677 #    t, tN     temporary value (in our db, no logged in user yet)
 678 #    y, yN     value corresponds to logged-in user
 679 # and, aggregated conditions:
 680 #    a, aN     anything including -
 681 #    x, xN     t or y
 682 # if N differs the case applies only when the two values differ
 683 # (eg,   a1 y2   does not apply when the logged-in value is supplied twice)
 684
 685 # "stale session" means request originates from a page from a login
 686 # session which has been revoked (eg by logout); "cleared session"
 687 # means request originates from a browser which has a different (or
 688 # no) cookie.
 689
 690     # Case analysis, cookie mode, app promises re mutate:
 691     # cook parm meth form
 692     #
 693     #  any -   POST  nrmuoi   bug or attack, fail
 694     #  any -   GET    rmuoi   bug or attack, fail
 695     #  any any GET     muoi   bug or attack, fail
 696     #  any t   any   nrmu     bug or attack, fail
 697     #
 698     #  -   -   GET         O  "just logged out" page
 699     #  (any other)         O  bug or attack, fail
 700     #
 701     #  a1  a2  POST      o    logout
 702     #                           if a1 is valid, revoke it
 703     #                           if a2 is valid, revoke it
 704     #                           delete cookie
 705     #                           redirect to "just logged out" page
 706     #                             (which contains link to login form)
 707     #
 708     #  -   t   POST       i   complain about cookies being disabled
 709     #                           (with link to login form)
 710     #
 711     #  t1  t1  POST       i   login (or switch user)
 712     #                           if bad
 713     #                             show new login form
 714     #                           if good
 715     #                             upgrade t1 to y1 in our db (setting username)
 716     #                             redirect to GET of remaining params
 717     #
 718     #  y1  a2  POST       i   complain about stale login form
 719     #                           revoke y1
 720     #                           show new login form
 721     #
 722     #  (other) POST       i   complain about stale login form
 723     #                           show new login form
 724     #
 725     #  t1  a2  ANY   nrmu     treat as  - a2 ANY
 726     #
 727     #  y   -   GET   n        cross-site link
 728     #                           show data
 729     #
 730     #  y   y   GET   nr       fine, show page or send data
 731     #  y   y   POST  nrmu     mutation is OK, do operation
 732     #
 733     #  y1  y2  GET   nr       request from stale page
 734     #                           do not revoke y2 as not RESTful
 735     #                           treat as   y1 n GET
 736     #
 737     #  y1  y2  POST  nrmu     request from stale page
 738     #                           revoke y2
 739     #                           treat as   y1 n POST
 740     #
 741     #  y   n   GET   n        intra-site link from stale page,
 742     #                           treat as cross-site link, show data
 743     #
 744     #  y   n   POST  n m      intra-site form submission from stale page
 745     #                           show "session interrupted"
 746     #                           with link to main data page
 747     #
 748     #  y   n   GET    r       intra-site request from stale page
 749     #                           fail
 750     #
 751     #  y   n   POST   r u     intra-site request from stale page
 752     #                           fail
 753     #
 754     #  -/n y2  GET   nr       intra-site link from cleared session
 755     #                           do not revoke y2 as not RESTful
 756     #                           treat as   -/n n GET
 757     #
 758     #  -/n y2  POST  nrmu     request from cleared session
 759     #                           revoke y2
 760     #                           treat as   -/n n POST
 761     #
 762     #  -/n -/n GET   n        cross-site link but user not logged in
 763     #                           show login form with redirect to orig params
 764     #                           generate fresh cookie
 765     #
 766     #  -/n n   GET    rmu     user not logged in
 767     #                           fail
 768     #
 769     #  -/n n   POST  n m      user not logged in
 770     #                           show login form
 771     #
 772     #  -/n n   POST   r u     user not logged in
 773     #                           fail
 774
 775 sub _check_divert_core ($) {
 776     my ($r) = @_;
 777
 778     my $srcdump = $r->_rp('srcdump_param_name');
 779     if ($srcdump) {
 780         die if $srcdump =~ m/\W/;
 781         return ({ Kind => 'SRCDUMP-'.uc $srcdump,
 782                   Message => undef,
 783                   CookieSecret => undef,
 784                   Params => { } });
 785     }
 786
 787     my $cooks = $r->_ch('get_cookie');
 788
 789     if ($r->{S}{encrypted_only} && !$r->_ch('check_https')) {
 790         return ({ Kind => 'REDIRECT-HTTPS',
 791                   Message => $r->_gt("Redirecting to secure server..."),
 792                   CookieSecret => undef,
 793                   Params => { } });
 794     }
 795
 796     my $meth = $r->_ch('get_method');
 797     my $parmh = $r->_rp('assoc_param_name');
 798     my $cookh = defined $cooks ? $r->hash($cooks) : undef;
 799
 800     my ($cookt,$cooku) = $r->_identify($cookh, $cooks);
 801     my $parms = (defined $cooks && defined $parmh && $parmh eq $cookh)
 802         ? $cooks : undef;
 803     my ($parmt) = $r->_identify($parmh, $parms);
 804
 805     $r->_debug("_c_d_c cookt=$cookt parmt=$parmt\n");
 806
 807     if ($r->_ch('is_logout')) {
 808         $r->_must_be_post();
 809         die unless $parmt;
 810         $r->_db_revoke($cookh);
 811         $r->_db_revoke($parmh);
 812         return ({ Kind => 'REDIRECT-LOGGEDOUT',
 813                   Message => $r->_gt("Logging out..."),
 814                   CookieSecret => '',
 815                   Params => { } });
 816     }
 817     if ($r->_ch('is_loggedout')) {
 818         die unless $meth eq 'GET';
 819         die if $cookt eq 'y';
 820         die if $parmt;
 821         return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
 822                   Message => $r->_gt("You have been logged out."),
 823                   CookieSecret => '',
 824                   Params => { } });
 825     }
 826     if ($r->_ch('is_login')) {
 827         $r->_must_be_post();
 828         die unless $parmt;
 829         if (!$cookt && $parmt eq 'n') {
 830             return ({ Kind => 'SMALLPAGE-NOCOOKIE',
 831                       Message => $r->_gt("You do not seem to have cookies".
 832                                          " enabled.  You must enable cookies".
 833                                          " as we use them for login."),
 834                       CookieSecret => $r->_fresh_secret(),
 835                       Params => $r->chain_params() })
 836         }
 837         if (!$cookt || $cookt eq 'n' || $cookh ne $parmh) {
 838             $r->_db_revoke($cookh);
 839             return ({ Kind => 'LOGIN-STALE',
 840                       Message => $r->_gt("Stale session;".
 841                                          " you need to log in again."),
 842                       CookieSecret => $r->_fresh_secret(),
 843                       Params => { } })
 844         }
 845         die unless $parmt eq 't' || $parmt eq 'y';
 846         my ($username, $login_errormessage) = $r->_ch('login_ok');
 847         unless (defined $username && length $username) {
 848             $login_errormessage = $r->_gt("Incorrect username/password.")
 849                 if !$login_errormessage;
 850             return ({ Kind => 'LOGIN-BAD',
 851                       Message => $login_errormessage,
 852                       CookieSecret => $cooks,
 853                       Params => $r->chain_params() })
 854         }
 855         $r->_db_record_login_ok($parmh,$username);
 856         return ({ Kind => 'REDIRECT-LOGGEDIN',
 857                   Message => $r->_gt("Logging in..."),
 858                   CookieSecret => $cooks,
 859                   Params => $r->chain_params() });
 860     }
 861     if ($cookt eq 't') {
 862         $cookt = '';
 863     }
 864     die if $parmt eq 't';
 865
 866     if ($cookt eq 'y' && $parmt eq 'y' && $cookh ne $parmh) {
 867         $r->_db_revoke($parmh) if $meth eq 'POST';
 868         $parmt = 'n';
 869     }
 870
 871     if ($cookt ne 'y') {
 872         die unless !$cookt || $cookt eq 'n';
 873         die unless !$parmt || $parmt eq 'n' || $parmt eq 'y';
 874         my $news = $r->_fresh_secret();
 875         if ($meth eq 'GET') {
 876             return ({ Kind => 'LOGIN-INCOMINGLINK',
 877                       Message => $r->_gt("You need to log in."),
 878                       CookieSecret => $news,
 879                       Params => $r->chain_params() });
 880         } else {
 881             $r->_db_revoke($parmh);
 882             return ({ Kind => 'LOGIN-FRESH',
 883                       Message => $r->_gt("You need to log in."),
 884                       CookieSecret => $news,
 885                       Params => { } });
 886         }
 887     }
 888
 889     if (!$r->{S}{promise_check_mutate}) {
 890         if ($meth ne 'POST') {
 891             return ({ Kind => 'MAINPAGEONLY',
 892                       Message => $r->_gt('Entering via cross-site link.'),
 893                       CookieSecret => $cooks,
 894                       Params => { } });
 895             # NB caller must then ignore params & path!
 896             # if this is too hard they can spit out a small form
 897             # with a "click to continue"
 898         }
 899     }
 900
 901     die unless $cookt eq 'y';
 902     unless ($r->{S}{promise_check_mutate} && $meth eq 'GET') {
 903         die unless $parmt eq 'y';
 904         die unless $cookh eq $parmh;
 905     }
 906     $r->{AssocSecret} = $cooks;
 907     $r->{UserOK} = $cooku;
 908 #print STDERR "C-D-C OK\n";
 909     return undef;
 910 }
 911
 912 sub chain_params ($) {
 913     my ($r) = @_;
 914     my %p = %{ $r->_ch('get_params') };
 915     foreach my $pncn (keys %{ $r->{S} }) {
 916         my $names;
 917         if ($pncn =~ m/_param_name$/) {
 918             my $name = $r->{S}{$pncn};
 919             die "$pncn ?" if ref $name;
 920             $names = [ $name ];
 921         } elsif ($pncn =~ m/_param_names$/) {
 922             $names = $r->{S}{$pncn};
 923         } else {
 924             next;
 925         }
 926         foreach my $name (@$names) {
 927             delete $p{$name};
 928         }
 929     }
 930     my $dummy_prefix = $r->{S}{dummy_param_name_prefix};
 931     foreach my $name (grep /^$dummy_prefix/, keys %p) {
 932         delete $p{$name};
 933     }
 934     die if exists $p{''};
 935     $p{''} = [ $r->_ch('get_path_info') ];
 936     return \%p;
 937 }
 938
 939 sub _identify ($$) {
 940     my ($r,$h,$s) = @_;
 941     # returns ($t,$username)
 942     # where $t is one of "t" "y" "n", or "" (for -)
 943     # either $s must be undef, or $h eq $r->hash($s)
 944
 945 #print STDERR "_identify\n";
 946     return '' unless defined $h && length $h;
 947 #print STDERR "_identify h=$h s=".(defined $s ? $s : '<undef>')."\n";
 948
 949     my $dbh = $r->{Dbh};
 950
 951     $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
 952              " WHERE last < ?", {},
 953              time - $r->{S}{login_timeout});
 954
 955     my $row = $dbh->selectrow_arrayref("SELECT username, last".
 956                               " FROM $r->{S}{assocdb_table}".
 957                               " WHERE assochash = ?", {}, $h);
 958     if (defined $row) {
 959 #print STDERR "_identify h=$h s=$s YES @$row\n";
 960         my ($nusername, $nlast) = @$row;
 961         return ('y', $nusername);
 962     }
 963
 964     # Well, it's not in the database.  But maybe it's a hash of a
 965     # temporary secret.
 966
 967     return 'n' unless defined $s;
 968
 969     my ($keyt, $signature, $message, $noncet, $nonce) =
 970         $s =~ m/^(\d+)\.(\w+)\.((\d+)\.(\w+))$/ or die;
 971
 972     return 'n' if time > $noncet + $r->{S}{login_form_timeout};
 973
 974 #print STDERR "_identify noncet=$noncet ok\n";
 975
 976     my $keys = $r->_open_keys();
 977     while (my ($rkeyt, $rkey, $line) = $r->_read_key($keys)) {
 978 #print STDERR "_identify  search rkeyt=$rkeyt rkey=$rkey\n";
 979         last if $rkeyt < $keyt; # too far down in the file
 980         my $trysignature = $r->_hmac($rkey, $message);
 981 #print STDERR "_identify  search rkeyt=$rkeyt rkey=$rkey try=$trysignature\n";
 982         return 't' if $trysignature eq $signature;
 983     }
 984     # oh well
 985 #print STDERR "_identify NO\n";
 986
 987     $keys->error and die $!;
 988     return 'n';
 989 }
 990
 991 sub _db_revoke ($$) {
 992     # revokes $h if it's valid; no-op if it's not
 993     my ($r,$h) = @_;
 994
 995     my $dbh = $r->{Dbh};
 996
 997     $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
 998              " WHERE assochash = ?", {}, $h);
 999 }
1000
1001 sub _db_record_login_ok ($$$) {
1002     my ($r,$h,$user) = @_;
1003     $r->_db_revoke($h);
1004     my $dbh = $r->{Dbh};
1005     $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
1006              " (assochash, username, last) VALUES (?,?,?)", {},
1007              $h, $user, time);
1008 }
1009
1010 sub check_divert ($) {
1011     my ($r) = @_;
1012     if (exists $r->{Divert}) {
1013         return $r->{Divert};
1014     }
1015     my $dbh = $r->{Dbh};
1016     $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); });
1017     $dbh->commit();
1018     $r->_debug(Data::Dumper->Dump([$r->{Divert}],[qw(divert)]));
1019     return $r->{Divert};
1020 }
1021
1022 sub get_divert ($) {
1023     my ($r) = @_;
1024     die "unchecked" unless exists $r->{Divert};
1025     return $r->{Divert};
1026 }
1027
1028 sub get_username ($) {
1029     my ($r) = @_;
1030     my $divert = $r->get_divert();
1031     return undef if $divert;
1032     return $r->{UserOK};
1033 }
1034
1035 sub url_with_query_params ($$) {
1036     my ($r, $params) = @_;
1037 #print STDERR "PARAMS ",Dumper($params);
1038     my $uri = URI->new($r->_ch('get_url'));
1039     $uri->path($uri->path() . $params->{''}[0]) if $params->{''};
1040     $uri->query_form(flatten_params($params));
1041     return $uri->as_string();
1042 }
1043
1044 sub _cgi_header_args ($$@) {
1045     my ($r, $cookie, @ha) = @_;
1046     unshift @ha, qw(-type text/html);
1047     push @ha, (-cookie => $cookie) if defined $cookie;
1048 #print STDERR "_cgi_header_args ",join('|',@ha),".\n";
1049     return @ha;
1050 }
1051
1052 sub check_ok ($) {
1053     my ($r) = @_;
1054
1055     my ($divert) = $r->check_divert();
1056     return 1 if !$divert;
1057
1058     my $handled = $r->_ch('handle_divert',$divert);
1059     return 0 if $handled;
1060
1061     my $kind = $divert->{Kind};
1062     my $cookiesecret = $divert->{CookieSecret};
1063     my $params = $divert->{Params};
1064     my $cookie = $r->construct_cookie($cookiesecret);
1065
1066     if ($kind =~ m/^SRCDUMP-(\w+)$/) {
1067         $r->_ch('srcdump_dump', (lc $1));
1068         return 0;
1069     }
1070
1071     if ($kind =~ m/^REDIRECT-/) {
1072         # for redirects, we honour stored NextParams and SetCookie,
1073         # as we would for non-divert
1074         if ($kind eq 'REDIRECT-LOGGEDOUT') {
1075             $params->{$r->{S}{loggedout_param_names}[0]} = [ 1 ];
1076         } elsif ($kind eq 'REDIRECT-LOGOUT') {
1077             $params->{$r->{S}{logout_param_names}[0]} = [ 1 ];
1078         } elsif ($kind =~ m/REDIRECT-(?:LOGGEDIN|HTTPS)/) {
1079         } else {
1080             die;
1081         }
1082         my $new_url = $r->url_with_query_params($params);
1083         if ($kind eq 'REDIRECT-HTTPS') {
1084             my $uri = URI->new($new_url);
1085             die unless $uri->scheme eq 'http';
1086             $uri->scheme('https');
1087             $new_url = $uri->as_string();
1088         }
1089         $r->_ch('do_redirect',$new_url, $cookie);
1090         return 0;
1091     }
1092
1093     if (defined $cookiesecret) {
1094         $params->{$r->{S}{assoc_param_name}} = [ $r->hash($cookiesecret) ];
1095     }
1096
1097     my ($title, @body);
1098     if ($kind =~ m/^LOGIN-/) {
1099         $title = $r->_gt('Login');
1100         push @body, $divert->{Message};
1101         push @body, $r->_ch('gen_login_form', $params);
1102     } elsif ($kind =~ m/^SMALLPAGE-/) {
1103         $title = $r->_gt('Not logged in');
1104         push @body, $divert->{Message};
1105         push @body, $r->_ch('gen_login_link', $params);
1106     } elsif ($kind =~ m/^MAINPAGEONLY$/) {
1107         $title = $r->_gt('Entering secure site.');
1108         push @body, $divert->{Message};
1109         push @body, $r->_ch('gen_postmainpage_form', $params);
1110     } else {
1111         die $kind;
1112     }
1113
1114     $r->_print($r->{Cgi}->header($r->_cgi_header_args($cookie)),
1115                $r->_ch('gen_start_html',$title),
1116                (join "\n", (@body,
1117                             $r->_ch('gen_footer_html'),
1118                             $r->_ch('gen_end_html'))));
1119     return 0;
1120 }
1121
1122 sub _random ($$) {
1123     my ($r, $bytes) = @_;
1124     my $v = $r->{V};
1125     my $rsf = $v->{RandomHandle};
1126     my $rsp = $r->{S}{random_source};
1127     if (!$rsf) {
1128         $v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!";
1129 #print STDERR "RH $rsf\n";
1130     }
1131     my $bin;
1132     $!=0;
1133     read($rsf,$bin,$bytes) == $bytes or die "$rsp $!";
1134     my $out = unpack "H*", $bin;
1135 #print STDERR "_random out $out\n";
1136     return $out;
1137 }
1138
1139 sub _random_key ($) {
1140     my ($r) = @_;
1141 #print STDERR "_random_key\n";
1142     my $bytes = ($r->{S}{secretbits} + 7) >> 3;
1143     return $r->_random($bytes);
1144 }
1145
1146 sub _read_key ($$) {
1147     my ($r, $keys) = @_;
1148     # returns $gen_time_t, $key_value_in_hex, $complete_line
1149     while (<$keys>) {
1150         my ($gen, $k) = m/^(\d+) (\S+)$/ or die "$_ ?";
1151         my $age = time - $gen;
1152         next if $age > $r->{S}{key_rollover} &&
1153             $age > $r->{S}{login_form_timeout}*2;
1154         return ($gen, $k, $_);
1155     }
1156     return ();
1157 }
1158
1159 sub _open_keys ($) {
1160     my ($r) = @_;
1161     my $spath = $r->_get_path('keys');
1162     for (;;) {
1163 #print STDERR "_open_keys\n";
1164         my $keys = new IO::File $spath, 'r+';
1165         if ($keys) {
1166 #print STDERR "_open_keys open\n";
1167             stat $keys or die $!; # NB must not disturb stat _
1168             my $size = (stat _)[7];
1169             my $age = time - (stat _)[9];
1170 #print STDERR "_open_keys open size=$size age=$age\n";
1171             return $keys
1172                 if $size && $age <= $r->{S}{key_rollover} / 2;
1173 #print STDERR "_open_keys open bad\n";
1174         }
1175         # file doesn't exist, or is empty or too old
1176         if (!$keys) {
1177 #print STDERR "_open_keys closed\n";
1178             die "$spath $!" unless $!==&ENOENT;
1179             # doesn't exist, so create it just so we can lock it
1180             $keys = new IO::File $spath, 'a+';
1181             die "$keys $!" unless $keys;
1182             stat $keys or die $!; # NB must not disturb stat _
1183             my $size = (stat _)[7];
1184 #print STDERR "_open_keys created size=$size\n";
1185             next if $size; # oh someone else has done it, reopen and read it
1186         }
1187         # file now exists is empty or too old, we must try to replace it
1188         my $our_inum = (stat _)[1]; # last use of that stat _
1189         flock $keys, LOCK_EX or die "$spath $!";
1190         stat $spath or die "$spath $!";
1191         my $path_inum = (stat _)[1];
1192 #print STDERR "_open_keys locked our=$our_inum path=$path_inum\n";
1193         next if $our_inum != $path_inum; # someone else has done it
1194         # We now hold the lock!
1195 #print STDERR "_open_keys creating\n";
1196         my $newkeys = new IO::Handle;
1197         sysopen $newkeys, "$spath.new", O_CREAT|O_TRUNC|O_WRONLY, 0600
1198             or die "$spath.new $!";
1199         # we add the new key to the front which means it's always sorted
1200         print $newkeys time, ' ', $r->_random_key(), "\n" or die $!;
1201         while (my ($gen,$key,$line) = $r->_read_key($keys)) {
1202 #print STDERR "_open_keys copy1\n";
1203             print $newkeys, $line or die $!;
1204         }
1205         $keys->error and die $!;
1206         close $newkeys or die "$spath.new $!";
1207         rename "$spath.new", "$spath" or die "$spath: $!";
1208 #print STDERR "_open_keys installed\n";
1209         # that rename effective unlocks, since it makes the name refer
1210         #  to the new file which we haven't locked
1211         # we go round again opening the file at the beginning
1212         #  so that our caller gets a fresh handle onto the existing key file
1213     }
1214 }
1215
1216 sub _fresh_secret ($) {
1217     my ($r) = @_;
1218 #print STDERR "_fresh_secret\n";
1219
1220     my $keys = $r->_open_keys();
1221     my ($keyt, $key) = $r->_read_key($keys);
1222     die unless defined $keyt;
1223
1224     my $nonce = $r->_random_key();
1225     my $noncet = time;
1226     my $message = "$noncet.$nonce";
1227
1228     my $signature = $r->_hmac($key, $message);
1229     my $secret = "$keyt.$signature.$message";
1230 #print STDERR "FRESH $secret\n";
1231     return $secret;
1232 }
1233
1234 sub _hmac ($$$) {
1235     my ($r, $keyhex, $message) = @_;
1236     my $keybin = pack "H*", $keyhex;
1237     my $alg = $r->{S}{hash_algorithm};
1238 #print STDERR "hmac $alg\n";
1239     my $base = new Digest $alg;
1240 #print STDERR "hmac $alg $base\n";
1241     my $digest = new Digest::HMAC $keybin, $base;
1242 #print STDERR "hmac $alg $base $digest\n";
1243     $digest->add($message);
1244     return $digest->hexdigest();
1245 }
1246
1247 sub hash ($$) {
1248     my ($r, $message) = @_;
1249     my $alg = $r->{S}{hash_algorithm};
1250 #print STDERR "hash $alg\n";
1251     my $digest = new Digest $alg;
1252     $digest->add($message);
1253     return $digest->hexdigest();
1254 }
1255
1256 sub _assert_checked ($) {
1257     my ($r) = @_;
1258     die "unchecked" unless exists $r->{Divert};
1259 }
1260
1261 sub _is_post ($) {
1262     my ($r) = @_;
1263     my $meth = $r->_ch('get_method');
1264     return $meth eq 'POST';
1265 }
1266
1267 sub _must_be_post ($) {
1268     my ($r) = @_;
1269     my $meth = $r->_ch('get_method');
1270     die "mutating non-POST" if $meth ne 'POST';
1271 }
1272
1273 sub check_mutate ($) {
1274     my ($r) = @_;
1275     $r->_assert_checked();
1276     die if $r->{Divert};
1277     $r->_must_be_post();
1278 }
1279
1280 sub mutate_ok ($) {
1281     my ($r) = @_;
1282     $r->_assert_checked();
1283     die if $r->{Divert};
1284     return $r->_is_post();
1285 }
1286
1287 #---------- output ----------
1288
1289 sub secret_cookie_val ($) {
1290     my ($r) = @_;
1291     $r->_assert_checked();
1292     return defined $r->{AssocSecret} ? $r->{AssocSecret} : '';
1293 }
1294
1295 sub secret_hidden_val ($) {
1296     my ($r) = @_;
1297     $r->_assert_checked();
1298     return defined $r->{AssocSecret} ? $r->hash($r->{AssocSecret}) : '';
1299 }
1300
1301 sub secret_hidden_html ($) {
1302     my ($r) = @_;
1303     return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name},
1304                              -default => $r->secret_hidden_val());
1305 }
1306
1307 sub secret_cookie ($) {
1308     my ($r) = @_;
1309     my $secret = $r->secret_cookie_val();
1310     return undef if !defined $secret;
1311 #print STDERR "SC\n";
1312     my $cookv = $r->construct_cookie($secret);
1313 #print STDERR "SC=$cookv\n";
1314     return $cookv;
1315 }
1316
1317 1;
1318
1319 __END__
1320
1321 =head1 NAME
1322
1323 CGI::Auth::Flexible - web authentication optionally using cookies
1324
1325 =head1 SYNOPSYS
1326
1327  my $verifier = CGI::Auth::Flexible->new_verifier(setting => value,...);
1328  my $authreq = $verifier->new_request($cgi_query_object);
1329
1330  # simple applications
1331  $authreq->check_ok() or return;
1332
1333  # sophisticated applications
1334  my $divert_kind = $authreq->check_divert();
1335  if ($divert_kind) { ... print diversion page and quit ... }
1336
1337  # while handling the request
1338  $user = $authreq->get_username();
1339  $authreq->check_mutate();
1340
1341 =head1 DESCRIPTION
1342
1343 CGI::Auth::Flexible is a library which you can use to add a
1344 forms/cookie-based login facility to a Perl web application.
1345
1346 CGI::Auth::Flexible doesn't interfere with your application's URL path
1347 namespace and just needs a few (configurable) form parameter and
1348 cookie name(s) for its own use.  It tries to avoid making assumptions
1349 about the implementation structure of your application.
1350
1351 Because CGI::Auth::Flexible is licenced under the AGPLv3, you will
1352 probably need to provide a facility to allow users (even ones not
1353 logged in) to download the source code for your web app.  Conveniently
1354 by default CGI::Auth::Flexible provides (for pure Perl webapps) a
1355 mechanism for users to get the source.
1356
1357 CGI::Auth::Flexible is designed to try to stop you accidentally
1358 granting access by misunderstanding the API.  (Also it, of course,
1359 guards against cross-site scripting.)  You do need to make sure to
1360 call CGI::Auth::Flexible before answering AJAX requests as well as
1361 before generating HTML pages, of course, and to call it in every
1362 entrypoint to your system.
1363
1364 =head2 INITIALISATION
1365
1366 Your application should, on startup (eg, when it is loaded by
1367 mod_perl) do
1368 C<< $verifier = CGI::Auth::Flexible->new_verifier(settings...) >>.
1369 This call can be expensive and is best amortised.
1370
1371 The resulting verifier object can be used to process individual
1372 requests, in each case with
1373 C<< $authreq = CGI::Auth::Flexible->new_request($cgi_query) >>.
1374
1375 =head2 SIMPLE APPLICATIONS
1376
1377 The simplist usage is to call C<< $request->check_ok() >> which will
1378 check the user's authentication.  If the user is not logged in it will
1379 generate a login form (or redirection or other appropriate page) and
1380 return false; your application should not then processing that request
1381 any further.  If the user is logged in it will return true.
1382
1383 After calling C<check_ok> you can use C<< $request->get_username >>
1384 to find out which user the request came from.
1385
1386 =head2 SOPHISTICATED APPLICATIONS
1387
1388 If you want to handle the flow control and to generate login forms,
1389 redirections, etc., yourself, you can say
1390 C<< $divert = $request->check_divert >>.  This returns undef if
1391 the user is logged in, or I<divert spec> if some kind of login
1392 page or diversion should be generated.
1393
1394 =head2 GENERATING (MUTATING) FORMS AND AJAX QUERIES
1395
1396 When you generate a C<POST> form or AJAX request you need to include a
1397 special secret hidden form parameter for the benefit of
1398 CGI::Auth::Generic.  This form parameter will be checked by
1399 C<check_ok>/C<check_divert> and should be ignored by your application.
1400
1401 By default its name is C<caf_assochash>.  After calling C<check_ok> or
1402 C<check_divert> the value to put in your form can be obtained from
1403 C<secret_hidden_val>; C<secret_hidden_html> will generate the whole
1404 HTML C<< <input...> >> element.
1405
1406 Do not put the secret value in URLs for C<GET> requests.
1407
1408 =head2 MUTATING OPERATIONS AND EXTERNAL LINKS INTO YOUR SITE
1409
1410 By default CGI::Auth::Flexible does not permit external links into
1411 your site.  All GET requests give a "click to continue" page which
1412 submits a form.  In this configuration all your application's forms
1413 and AJAX requests should use C<POST>.
1414
1415 This is because the alternative (for complicated reasons relating to
1416 the web security architecture) is to require your application to make
1417 a special and different check when the incoming request is going to do
1418 some kind of action (such as modifying the user's setup, purchasing
1419 goods, or whatever) rather than just display HTML pages.
1420
1421 To support external links, and C<GET> requests, pass C<<
1422 promise_check_mutate => 1 >> in I<settings>, and then call C<<
1423 $authreq->check_mutate() >> before taking any actions.  If the
1424 incoming request is not suitable then C<< $authreq->check_mutate() >>
1425 will call C<die>.  If you do this you must make sure that you have no
1426 mutating C<GET> requests in your application - but you shouldn't have
1427 any of those anyway.
1428
1429 =head2 DATA STORAGE
1430
1431 CGI::Auth::Flexible needs to store various information in plain files;
1432 it does this in the directory specified by the C<dir> parameter.
1433
1434 It also needs to record state relating to user sessions in a database.
1435 There is no particular reason for this
1436
1437 =head1 SOURCE CODE DOWNLOAD
1438
1439 By default, CGI::Auth::Flexible provides a facility for users to
1440 download the source code for the running version of your web
1441 application.
1442
1443 This facility makes a number of important assumptions which you need
1444 to check.  Note that if the provided facility is not sufficient
1445 because your application is more sophisticated than it copes with (or
1446 if you disable the builtin facility), you may need to implement a
1447 functioning alternative to avoid violating the AGPLv3 licence.
1448
1449 Here are the most important (default) assumptions:
1450
1451 =over
1452
1453 =item *
1454
1455 Your app's source code is available by looking at @INC, $0 and
1456 S<$ENV{'SCRIPT_FILENAME'}> (the B<source items>).  See
1457 C<srcdump_listitems>.  Where these point to files or directories under
1458 revision control, the source item is the whole containing vcs tree.
1459
1460 =item *
1461
1462 Specifically, there are no compiled or autogenerated Perl
1463 files, Javascript resources, etc., which are not contained in one of
1464 the source item directories.  (Files which came with your operating
1465 system install don't need to be shipped as they fall under the system
1466 library exceptio.)
1467
1468 =item *
1469
1470 You have not installed any modified versions of system
1471 libraries (including system-supplied) Perl modules in C</usr> outside
1472 C</usr/local>.  See C<srcdump_system_dir>.
1473
1474 =item *
1475
1476 For each source item in a dvcs, the entire dvcs history does
1477 not contain anything confidential (or libellous).  Also, all files which
1478 contain secrets are in the dvcs's C<.ignore> file.  See
1479 C<srcdump_vcsscript_git> et al.
1480
1481 =item *
1482
1483 For each source item NOT in a dvcs, there are no confidential
1484 files with the world-readable bit set (being in a world-inaccessible
1485 directory is not sufficient).  See C<srcdump_excludes>.
1486
1487 =item *
1488
1489 You have none of your app's source code in C</etc>.
1490
1491 =item *
1492
1493 You don't regard pathnames on your server as secret.
1494
1495 =item *
1496
1497 You don't intentionally load Perl code by virtule of C<.>
1498 being in C<@INC> by default.  (See C<srcdump_filter_cwd>.)
1499
1500 =back
1501
1502 =head1 MAIN FUNCTIONS AND METHODS
1503
1504 =over
1505
1506 =item C<< CGI::Auth::Flexible->new_verifier(setting => value, ...) >>
1507
1508 Initialises an instance and returns a verifier object.
1509 The arguments are setting pairs like a hash initialiser.
1510 See L</SETTINGS> below.
1511
1512 =item C<< $verifier->new_request($cgi_query) >>
1513
1514 Prepares to process a request.  C<$cgi_query> should normally
1515 be the query object from L<CGI(3perl)>.  Most of the default
1516 hook methods assume that it is; however if you replace enough of
1517 the hook methods then you can pass any value you like and it
1518 will be passed to your hooks.
1519
1520 The return value is the authentication request object (C<$authreq>)
1521 which is used to check the incoming request and will contain
1522 information about its credentials.
1523
1524 =item C<< $authreq->check_divert() >>
1525
1526 Checks whether the user is logged in.  Returns undef if the user is
1527 logged in and we should service the request.  Otherwise returns a
1528 divert spec (see L</DIVERT SPEC>) saying what should happen instead.
1529
1530 This method may die if it doesn't like the request, in which case
1531 the request needs to be rejected.
1532
1533 =item C<< $authreq->check_ok() >>
1534
1535 Checks whether the user is logged in.  Returns true if the user is
1536 logged in and we should service the request.
1537
1538 Otherwise it handles the request itself, generating any appropriate
1539 redirect, login form, or continuation page.  It then returns false and
1540 the application should not process the request further.
1541
1542 =item C<< $authreq->disconnect() >>
1543
1544 Disconnects from the
1545
1546 =back