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(setup);
  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
  51 #---------- public utilities ----------
  52
  53 sub flatten_params ($) {
  54     my ($p) = @_;
  55     my @p;
  56     foreach my $k (keys %$p) {
  57         foreach my $v (@{ $p->{$k} }) {
  58             push @p, $k, $v;
  59         }
  60     }
  61     return @p;
  62 }
  63
  64 #---------- default callbacks ----------
  65
  66 sub has_a_param ($$) {
  67     my ($r,$cn) = @_;
  68     foreach my $pn (@{ $r->{S}{$cn} }) {
  69         return 1 if $r->_ch('get_param',$pn);
  70     }
  71     return 0;
  72 }
  73
  74 sub get_params ($) {
  75     my ($r) = @_;
  76     my %p;
  77     my $c = $r->{Cgi};
  78     foreach my $name ($c->param()) {
  79         $p{$name} = [ $c->param($name) ];
  80     }
  81     return \%p;
  82 }
  83
  84 sub get_cookie_domain ($$$) {
  85     my ($c,$r) = @_;
  86     my $uri = new URI $r->_ch('get_url');
  87     return $uri->host();
  88 }
  89
  90 sub login_ok_password ($$) {
  91     my ($c, $r) = @_;
  92     my $username_params = $r->{S}{username_param_names};
  93     my $username = $r->_ch('get_param',$username_params->[0]);
  94     my $password = $r->_rp('password_param_name');
  95     return undef unless $r->_ch('username_password_ok', $username, $password);
  96     return $username;
  97 }
  98
  99 sub do_redirect_cgi ($$$$) {
 100     my ($c, $r, $new_url, $cookie) = @_;
 101     $r->_print($c->header($r->_cgi_header_args($cookie,
 102                                                -status => '303 See other',
 103                                                -location => $new_url)),
 104                $r->_ch('gen_start_html',$r->_gt('Redirection')),
 105                '<a href="'.escapeHTML($new_url).'">',
 106                $r->_gt("If you aren't redirected, click to continue."),
 107                "</a>",
 108                $r->_ch('gen_end_html'));
 109 }
 110
 111 sub gen_some_form ($$) {
 112     my ($r, $params, $bodyfn) = @_;
 113     # Calls $bodyfn->($c,$r) which returns @formbits
 114     my $c = $r->{Cgi};
 115     my @form;
 116     push @form, ('<form method="POST" action="'.
 117                  escapeHTML($r->_ch('get_url')).'">');
 118     push @form, $bodyfn->($c,$r);
 119     foreach my $n (keys %$params) {
 120         foreach my $val (@{ $params->{$n} }) {
 121             push @form, ('<input type="hidden"'.
 122                          ' name="'.escapeHTML($n).'"'.
 123                          ' value="'.escapeHTML($val).'">');
 124         }
 125     }
 126     push @form, ('</form>');
 127     return join "\n", @form;
 128 }
 129
 130 sub gen_plain_login_form ($$) {
 131     my ($c,$r, $params) = @_;
 132     return $r->gen_some_form($params, sub {
 133         my @form;
 134         push @form, ('<table>');
 135         my $sz = 'size="'.$r->{S}{form_entry_size}.'"';
 136         foreach my $up (@{ $r->{S}{username_param_names}}) {
 137             push @form, ('<tr><td>',$r->_gt(ucfirst $up),'</td>',
 138                          '<td><input type="text" '.$sz.
 139                          ' name='.$up.'></td></tr>');
 140         }
 141         push @form, ('<tr><td>'.$r->_gt('Password').'</td>',
 142                      '<td><input type="password" '.$sz.
 143                      ' name="'.$r->{S}{password_param_name}.'"></td></tr>');
 144         push @form, ('<tr><td colspan="2">',
 145                      '<input type="submit"'.
 146                      ' name="'.$r->{S}{login_submit_name}[0].'"'.
 147                      ' value="'.$r->_gt('Login').'"></td></tr>',
 148                      '</table>');
 149         return @form;
 150     });
 151 }
 152
 153 sub gen_postmainpage_form ($$$) {
 154     my ($c,$r, $params) = @_;
 155     return $r->gen_some_form($params, sub {
 156         my @form;
 157         push @form, ('<input type="submit"',
 158                      ' name="'.$r->{S}{dummy_param_name}.'_submit"'.
 159                      ' value="'.$r->_gt('Continue').'">');
 160         return @form;
 161     });
 162 }
 163
 164 sub gen_plain_login_link ($$) {
 165     my ($c,$r, $params) = @_;
 166     my $url = $r->url_with_query_params($params);
 167     return ('<a href="'.escapeHTML($url).'">'.
 168             $r->_gt('Log in again to continue.').
 169             '</a>');
 170 }
 171
 172 #---------- verifier object methods ----------
 173
 174 sub new_verifier {
 175     my $class = shift;
 176     my $verifier = {
 177         S => {
 178             dir => undef,
 179             assocdb_path => 'caf-assocs.db',
 180             keys_path => 'caf-keys',
 181             assocdb_dsn => undef,
 182             assocdb_user => '',
 183             assocdb_password => '',
 184             assocdb_table => 'caf_assocs',
 185             random_source => '/dev/urandom',
 186             secretbits => 128, # bits
 187             hash_algorithm => "SHA-256",
 188             login_timeout => 86400, # seconds
 189             login_form_timeout => 3600, # seconds
 190             key_rollover => 86400, # seconds
 191             assoc_param_name => 'caf_assochash',
 192             dummy_param_name => 'caf_dummy',
 193             cookie_name => "caf_assocsecret",
 194             password_param_name => 'password',
 195             username_param_names => [qw(username)],
 196             form_entry_size => 60,
 197             logout_param_names => [qw(caf_logout)],
 198             login_submit_name => [qw(caf_login)],
 199             loggedout_param_names => [qw(caf_loggedout)],
 200             promise_check_mutate => 0,
 201             get_param => sub { $_[0]->param($_[2]) },
 202             get_params => sub { $_[1]->get_params() },
 203             get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) },
 204             get_method => sub { $_[0]->request_method() },
 205             get_url => sub { $_[0]->url(); },
 206             is_login => sub { defined $_[1]->_rp('password_param_name') },
 207             login_ok => \&login_ok_password,
 208             username_password_ok => sub { die },
 209             is_logout => sub { $_[1]->has_a_param('logout_param_names') },
 210             is_loggedout => sub { $_[1]->has_a_param('loggedout_param_names') },
 211             is_page => sub { return 1 },
 212             handle_divert => sub { return 0 },
 213             do_redirect => \&do_redirect_cgi, # this hook is allowed to throw
 214             cookie_path => "/",
 215             get_cookie_domain => \&get_cookie_domain,
 216             encrypted_only => 1,
 217             gen_start_html => sub { $_[0]->start_html($_[2]); },
 218             gen_end_html => sub { $_[0]->end_html(); },
 219             gen_login_form => \&gen_plain_login_form,
 220             gen_login_link => \&gen_plain_login_link,
 221             gen_postmainpage_form => \&gen_postmainpage_form,
 222             gettext => sub { gettext($_[2]); },
 223             print => sub { print $_[2] or die $!; },
 224         },
 225         Dbh => undef,
 226     };
 227     my ($k,$v);
 228     while (($k,$v,@_) = @_) {
 229         die "unknown setting $k" unless exists $verifier->{S}{$k};
 230         $verifier->{S}{$k} = $v;
 231     }
 232     bless $verifier, $class;
 233     $verifier->_dbopen();
 234     return $verifier;
 235 }
 236
 237 sub _db_setup_do ($$) {
 238     my ($v, $sql) = @_;
 239     my $dbh = $v->{Dbh};
 240     eval {
 241         $v->_db_transaction(sub {
 242             local ($dbh->{PrintError}) = 0;
 243             $dbh->do($sql);
 244         });
 245     };
 246 }
 247
 248 sub _dbopen ($) {
 249     my ($v) = @_;
 250     my $dbh = $v->{Dbh};
 251     return $dbh if $dbh;
 252
 253     $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb');
 254     my $dsn = $v->{S}{assocdb_dsn};
 255
 256     my $u = umask 077;
 257     $dbh = DBI->connect($dsn, $v->{S}{assocdb_user},
 258                         $v->{S}{assocdb_password}, {
 259                             AutoCommit => 0,
 260                             RaiseError => 1,
 261                             ShowErrorStatement => 1,
 262                         });
 263     die "$dsn $! ?" unless $dbh;
 264     $v->{Dbh} = $dbh;
 265
 266     $v->_db_setup_do("CREATE TABLE $v->{S}{assocdb_table} (".
 267                      " assochash VARCHAR PRIMARY KEY,".
 268                      " username VARCHAR NOT NULL,".
 269                      " last INTEGER NOT NULL".
 270                      ")");
 271     $v->_db_setup_do("CREATE INDEX $v->{S}{assocdb_table}_timeout_index".
 272                      " ON $v->{S}{assocdb_table}".
 273                      " (last)");
 274     return $dbh;
 275 }
 276
 277 sub disconnect ($) {
 278     my ($v) = @_;
 279     my $dbh = $v->{Dbh};
 280     return unless $dbh;
 281     $dbh->disconnect();
 282 }
 283
 284 sub _db_transaction ($$) {
 285     my ($v, $fn) = @_;
 286     my $retries = 10;
 287     my $rv;
 288     my $dbh = $v->{Dbh};
 289 print STDERR "DT entry\n";
 290     for (;;) {
 291 print STDERR "DT loop\n";
 292         if (!eval {
 293             $rv = $fn->();
 294 print STDERR "DT fn ok\n";
 295             1;
 296         }) {
 297 print STDERR "DT fn error\n";
 298             { local ($@); $dbh->rollback(); }
 299 print STDERR "DT fn throwing\n";
 300             die $@;
 301         }
 302 print STDERR "DT fn eval ok\n";
 303         if (eval {
 304             $dbh->commit();
 305 print STDERR "DT commit ok\n";
 306             1;
 307         }) {
 308 print STDERR "DT commit eval ok ",Dumper($rv);
 309             return $rv;
 310         }
 311 print STDERR "DT commit throw?\n";
 312         die $@ if !--$retries;
 313 print STDERR "DT loop again\n";
 314     }
 315 }
 316
 317 #---------- request object methods ----------
 318
 319 sub new_request {
 320     my ($classbase, $cgi, @extra) = @_;
 321     if (!ref $classbase) {
 322         $classbase = $classbase->new_verifier(@extra);
 323     } else {
 324         die if @extra;
 325     }
 326     my $r = {
 327         V => $classbase,
 328         S => $classbase->{S},
 329         Dbh => $classbase->{Dbh},
 330         Cgi => $cgi,
 331     };
 332     bless $r, ref $classbase;
 333 }
 334
 335 sub _ch ($$@) { # calls an application hook
 336     my ($r,$methname, @args) = @_;
 337     my $methfunc = $r->{S}{$methname};
 338     die "$methname ?" unless $methfunc;
 339     return $methfunc->($r->{Cgi}, $r, @args);
 340 }
 341
 342 sub _rp ($$@) {
 343     my ($r,$pnvb) = @_;
 344     my $pn = $r->{S}{$pnvb};
 345     my $p = scalar $r->_ch('get_param',$pn)
 346 }
 347
 348 sub _get_path ($$) {
 349     my ($v,$keybase) = @_;
 350     my $leaf = $v->{S}{"${keybase}_path"};
 351     my $dir = $v->{S}{dir};
 352     return $leaf if $leaf =~ m,^/,;
 353     die "relying on cwd by default ?!  set dir" unless defined $dir;
 354     return "$dir/$leaf";
 355 }
 356
 357 sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); }
 358 sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); }
 359
 360 sub construct_cookie ($$$) {
 361     my ($r, $cooks) = @_;
 362     return undef unless $cooks;
 363     my $c = $r->{Cgi};
 364 my @ca = (-name => $r->{S}{cookie_name},
 365                              -value => $cooks,
 366                              -path => $r->{S}{cookie_path},
 367                              -domain => $r->_ch('get_cookie_domain'),
 368                              -expires => '+'.$r->{S}{login_timeout}.'s',
 369                              -secure => $r->{S}{encrypted_only});
 370     my $cookie = $c->cookie(@ca);
 371 print STDERR "CC $r $c $cooks $cookie (@ca).\n";
 372     return $cookie;
 373 }
 374
 375 # pages/param-sets are
 376 #   n normal non-mutating page
 377 #   r retrieval of information for JS, non-mutating
 378 #   m mutating page
 379 #   u update of information by JS, mutating
 380 #   i login
 381 #   o logout
 382 #   O "you have just logged out" page load
 383
 384 # in cook and par,
 385 #    -         no value supplied (represented in code as $cookt='')
 386 #    n, nN     value not in our db
 387 #    t, tN     temporary value (in our db, no logged in user yet)
 388 #    y, yN     value corresponds to logged-in user
 389 # and, aggregated conditions:
 390 #    a, aN     anything including -
 391 #    x, xN     t or y
 392 # if N differs the case applies only when the two values differ
 393 # (eg,   a1 y2   does not apply when the logged-in value is supplied twice)
 394
 395 # "stale session" means request originates from a page from a login
 396 # session which has been revoked (eg by logout); "cleared session"
 397 # means request originates from a browser which has a different (or
 398 # no) cookie.
 399
 400     # Case analysis, cookie mode, app promises re mutate:
 401     # cook parm meth form
 402     #
 403     #  any -   POST  nrmuoi   bug or attack, fail
 404     #  any -   GET    rmuoi   bug or attack, fail
 405     #  any any GET     muoi   bug or attack, fail
 406     #  any t   any   nrmu     bug or attack, fail
 407     #
 408     #  -   -   GET         O  "just logged out" page
 409     #  (any other)         O  bug or attack, fail
 410     #
 411     #  a1  a2  POST      o    logout
 412     #                           if a1 is valid, revoke it
 413     #                           if a2 is valid, revoke it
 414     #                           delete cookie
 415     #                           redirect to "just logged out" page
 416     #                             (which contains link to login form)
 417     #
 418     #  -   t   POST       i   complain about cookies being disabled
 419     #                           (with link to login form)
 420     #
 421     #  t1  t1  POST       i   login (or switch user)
 422     #                           if bad
 423     #                             show new login form
 424     #                           if good
 425     #                             upgrade t1 to y1 in our db (setting username)
 426     #                             redirect to GET of remaining params
 427     #
 428     #  y1  a2  POST       i   complain about stale login form
 429     #                           revoke y1
 430     #                           show new login form
 431     #
 432     #  (other) POST       i   complain about stale login form
 433     #                           show new login form
 434     #
 435     #  t1  a2  ANY   nrmu     treat as  - a2 ANY
 436     #
 437     #  y   -   GET   n        cross-site link
 438     #                           show data
 439     #
 440     #  y   y   GET   nr       fine, show page or send data
 441     #  y   y   POST  nrmu     mutation is OK, do operation
 442     #
 443     #  y1  y2  GET   nr       request from stale page
 444     #                           do not revoke y2 as not RESTful
 445     #                           treat as   y1 n GET
 446     #
 447     #  y1  y2  POST  nrmu     request from stale page
 448     #                           revoke y2
 449     #                           treat as   y1 n POST
 450     #
 451     #  y   n   GET   n        intra-site link from stale page,
 452     #                           treat as cross-site link, show data
 453     #
 454     #  y   n   POST  n m      intra-site form submission from stale page
 455     #                           show "session interrupted"
 456     #                           with link to main data page
 457     #
 458     #  y   n   GET    r       intra-site request from stale page
 459     #                           fail
 460     #
 461     #  y   n   POST   r u     intra-site request from stale page
 462     #                           fail
 463     #
 464     #  -/n y2  GET   nr       intra-site link from cleared session
 465     #                           do not revoke y2 as not RESTful
 466     #                           treat as   -/n n GET
 467     #
 468     #  -/n y2  POST  nrmu     request from cleared session
 469     #                           revoke y2
 470     #                           treat as   -/n n POST
 471     #
 472     #  -/n -/n GET   n        cross-site link but user not logged in
 473     #                           show login form with redirect to orig params
 474     #                           generate fresh cookie
 475     #
 476     #  -/n n   GET    rmu     user not logged in
 477     #                           fail
 478     #
 479     #  -/n n   POST  n m      user not logged in
 480     #                           show login form
 481     #
 482     #  -/n n   POST   r u     user not logged in
 483     #                           fail
 484
 485 sub _check_divert_core ($) {
 486     my ($r) = @_;
 487
 488     my $meth = $r->_ch('get_method');
 489     my $cooks = $r->_ch('get_cookie');
 490     my $parmh = $r->_rp('assoc_param_name');
 491     my $cookh = defined $cooks ? $r->hash($cooks) : undef;
 492
 493     my ($cookt,$cooku) = $r->_identify($cookh, $cooks);
 494     my $parms = (defined $cooks && defined $parmh && $parmh eq $cookh)
 495         ? $cooks : undef;
 496     my ($parmt) = $r->_identify($parmh, $parms);
 497
 498     print STDERR "_c_d_c cookt=$cookt parmt=$parmt\n";
 499
 500     if ($r->_ch('is_logout')) {
 501         $r->_must_be_post();
 502         die unless $parmt;
 503         $r->_db_revoke($cookh);
 504         $r->_db_revoke($parmh);
 505         return ({ Kind => 'REDIRECT-LOGGEDOUT',
 506                   Message => "Logging out...",
 507                   CookieSecret => '',
 508                   Params => { } });
 509     }
 510     if ($r->_ch('is_loggedout')) {
 511         die unless $meth eq 'GET';
 512         die unless $cookt;
 513         die unless $parmt;
 514         return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
 515                   Message => "You have been logged out.",
 516                   CookieSecret => '',
 517                   Params => { } });
 518     }
 519     if ($r->_ch('is_login')) {
 520         $r->_must_be_post();
 521         die unless $parmt;
 522         if (!$cookt && $parmt eq 't') {
 523             return ({ Kind => 'SMALLPAGE-NOCOOKIE',
 524                       Message => "You do not seem to have cookies enabled.  ".
 525                           "You must enable cookies as we use them for login.",
 526                           CookieSecret => $r->_fresh_secret(),
 527                           Params => $r->_chain_params() })
 528         }
 529         if (!$cookt || $cookt eq 'n' || $cookh ne $parmh) {
 530             $r->_db_revoke($cookh);
 531             return ({ Kind => 'LOGIN-STALE',
 532                       Message => "Stale session; you need to log in again.",
 533                       CookieSecret => $r->_fresh_secret(),
 534                       Params => { } })
 535         }
 536         die unless $parmt eq 't' || $parmt eq 'y';
 537         my $username = $r->_ch('login_ok');
 538         unless (defined $username && length $username) {
 539             return ({ Kind => 'LOGIN-BAD',
 540                       Message => "Incorrect username/password.",
 541                       CookieSecret => $cooks,
 542                       Params => $r->_chain_params() })
 543         }
 544         $r->_db_record_login_ok($parmh,$username);
 545         return ({ Kind => 'REDIRECT-LOGGEDIN',
 546                   Message => "Logging in...",
 547                   CookieSecret => $cooks,
 548                   Params => $r->_chain_params() });
 549     }
 550     if ($cookt eq 't') {
 551         $cookt = '';
 552     }
 553     die if $parmt eq 't';
 554
 555     if ($cookt eq 'y' && $parmt eq 'y' && $cookh ne $parmh) {
 556         $r->_db_revoke($parmh) if $meth eq 'POST';
 557         $parmt = 'n';
 558     }
 559
 560     if ($cookt ne 'y') {
 561         die unless !$cookt || $cookt eq 'n';
 562         die unless !$parmt || $parmt eq 'n' || $parmt eq 'y';
 563         my $news = $r->_fresh_secret();
 564         if ($meth eq 'GET') {
 565             return ({ Kind => 'LOGIN-INCOMINGLINK',
 566                       Message => "You need to log in.",
 567                       CookieSecret => $news,
 568                       Params => $r->_chain_params() });
 569         } else {
 570             $r->_db_revoke($parmh);
 571             return ({ Kind => 'LOGIN-FRESH',
 572                       Message => "You need to log in.",
 573                       CookieSecret => $news,
 574                       Params => { } });
 575         }
 576     }
 577
 578     if (!$r->{S}{promise_check_mutate}) {
 579         if ($meth ne 'POST') {
 580             return ({ Kind => 'MAINPAGEONLY',
 581                       Message => 'Entering via cross-site link.',
 582                       CookieSecret => $cooks,
 583                       Params => { } });
 584             # NB caller must then ignore params & path!
 585             # if this is too hard they can spit out a small form
 586             # with a "click to continue"
 587         }
 588     }
 589
 590     die unless $cookt eq 'y';
 591     die unless $parmt eq 'y';
 592     die unless $cookh eq $parmh;
 593     $r->{AssocSecret} = $cooks;
 594     $r->{UserOK} = $cooku;
 595     print STDERR "C-D-C OK\n";
 596     return undef;
 597 }
 598
 599 sub _chain_params ($) {
 600     my ($r) = @_;
 601     my %p = %{ $r->_ch('get_params') };
 602     foreach my $pncn (keys %{ $r->{S} }) {
 603         my $names;
 604         if ($pncn =~ m/_param_name$/) {
 605             my $name = $r->{S}{$pncn};
 606             die "$pncn ?" if ref $name;
 607             $names = [ $name ];
 608         } elsif ($pncn =~ m/_param_names$/) {
 609             $names = $r->{S}{$pncn};
 610         } else {
 611             next;
 612         }
 613         foreach my $name (@$names) {
 614             delete $p{$name};
 615         }
 616     }
 617     return \%p;
 618 }
 619
 620 sub _identify ($$) {
 621     my ($r,$h,$s) = @_;
 622     # returns ($t,$username)
 623     # where $t is one of "t" "y" "n", or "" (for -)
 624     # either $s must be undef, or $h eq $r->hash($s)
 625
 626 print STDERR "_identify\n";
 627     return '' unless defined $h && length $h;
 628 print STDERR "_identify h=$h s=".(defined $s ? $s : '<undef>')."\n";
 629
 630     my $dbh = $r->{Dbh};
 631
 632     $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
 633              " WHERE last < ?", {},
 634              time - $r->{S}{login_timeout});
 635
 636     my $row = $dbh->selectrow_arrayref("SELECT username, last".
 637                               " FROM $r->{S}{assocdb_table}".
 638                               " WHERE assochash = ?", {}, $h);
 639     if (defined $row) {
 640 print STDERR "_identify h=$h s=$s YES @$row\n";
 641         my ($nusername, $nlast) = @$row;
 642         return ('y', $nusername);
 643     }
 644
 645     # Well, it's not in the database.  But maybe it's a hash of a
 646     # temporary secret.
 647
 648     return 'n' unless defined $s;
 649
 650     my ($keyt, $signature, $message, $noncet, $nonce) =
 651         $s =~ m/^(\d+)\.(\w+)\.((\d+)\.(\w+))$/ or die;
 652
 653     return 'n' if time > $noncet + $r->{S}{login_form_timeout};
 654
 655 print STDERR "_identify noncet=$noncet ok\n";
 656
 657     my $keys = $r->_open_keys();
 658     while (my ($rkeyt, $rkey, $line) = $r->_read_key($keys)) {
 659 print STDERR "_identify  search rkeyt=$rkeyt rkey=$rkey\n";
 660         last if $rkeyt < $keyt; # too far down in the file
 661         my $trysignature = $r->_hmac($rkey, $message);
 662 print STDERR "_identify  search rkeyt=$rkeyt rkey=$rkey trysig=$trysignature\n";
 663         return 't' if $trysignature eq $signature;
 664     }
 665     # oh well
 666 print STDERR "_identify NO\n";
 667
 668     $keys->error and die $!;
 669     return 'n';
 670 }
 671
 672 sub _db_revoke ($$) {
 673     # revokes $h if it's valid; no-op if it's not
 674     my ($r,$h) = @_;
 675
 676     my $dbh = $r->{Dbh};
 677
 678     $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
 679              " WHERE assochash = ?", {}, $h);
 680 }
 681
 682 sub _db_record_login_ok ($$$) {
 683     my ($r,$h,$user) = @_;
 684     $r->_db_revoke($h);
 685     my $dbh = $r->{Dbh};
 686     $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
 687              " (assochash, username, last) VALUES (?,?,?)", {},
 688              $h, $user, time);
 689 }
 690
 691 sub check_divert ($) {
 692     my ($r) = @_;
 693     if (exists $r->{Divert}) {
 694         return $r->{Divert};
 695     }
 696     my $dbh = $r->{Dbh};
 697     $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); });
 698     $dbh->commit();
 699     print STDERR Dumper($r->{Divert});
 700     return $r->{Divert};
 701 }
 702
 703 sub get_divert ($) {
 704     my ($r) = @_;
 705     die "unchecked" unless exists $r->{Divert};
 706     return $r->{Divert};
 707 }
 708
 709 sub get_username ($) {
 710     my ($r) = @_;
 711     my $divert = $r->get_divert();
 712     return undef if $divert;
 713     return $r->{UserOK};
 714 }
 715
 716 sub url_with_query_params ($$) {
 717     my ($r, $params) = @_;
 718 print STDERR "PARAMS ",Dumper($params);
 719     my $uri = URI->new($r->_ch('get_url'));
 720     $uri->query_form(flatten_params($params));
 721     return $uri->as_string();
 722 }
 723
 724 sub _cgi_header_args ($$@) {
 725     my ($r, $cookie, @ha) = @_;
 726     unshift @ha, qw(-type text/html);
 727     push @ha, (-cookie => $cookie) if defined $cookie;
 728     print STDERR "_cgi_header_args ",join('|',@ha),".\n";
 729     return @ha;
 730 }
 731
 732 sub check_ok ($) {
 733     my ($r) = @_;
 734
 735     my ($divert) = $r->check_divert();
 736     return 1 if !$divert;
 737
 738     my $handled = $r->_ch('handle_divert',$divert);
 739     return 0 if $handled;
 740
 741     my $kind = $divert->{Kind};
 742     my $cookiesecret = $divert->{CookieSecret};
 743     my $params = $divert->{Params};
 744     my $cookie = $r->construct_cookie($cookiesecret);
 745
 746     if (defined $cookiesecret) {
 747         $params->{$r->{S}{assoc_param_name}} = [ $r->hash($cookiesecret) ];
 748     }
 749
 750     if ($kind =~ m/^REDIRECT-/) {
 751         # for redirects, we honour stored NextParams and SetCookie,
 752         # as we would for non-divert
 753         if ($kind eq 'REDIRECT-LOGGEDOUT') {
 754             $params->{$r->{S}{loggedout_param_names}[0]} = [ 1 ];
 755         } elsif ($kind eq 'REDIRECT-LOGOUT') {
 756             $params->{$r->{S}{logout_param_names}[0]} = [ 1 ];
 757         } elsif ($kind eq 'REDIRECT-LOGGEDIN') {
 758         } else {
 759             die;
 760         }
 761         my $new_url = $r->url_with_query_params($params);
 762         $r->_ch('do_redirect',$new_url, $cookie);
 763         return 0;
 764     }
 765
 766     my ($title, @body);
 767     if ($kind =~ m/^LOGIN-/) {
 768         $title = $r->_gt('Login');
 769         push @body, $r->_gt($divert->{Message});
 770         push @body, $r->_ch('gen_login_form', $params);
 771     } elsif ($kind =~ m/^SMALLPAGE-/) {
 772         $title = $r->_gt('Not logged in');
 773         push @body, $r->_gt($divert->{Message});
 774         push @body, $r->_ch('gen_login_link', $params);
 775     } elsif ($kind =~ m/^MAINPAGEONLY$/) {
 776         $title = $r->_gt('Entering secure site.');
 777         push @body, $r->_gt($divert->{Message});
 778         push @body, $r->_ch('gen_postmainpage_form', $params);
 779     } else {
 780         die $kind;
 781     }
 782
 783     $r->_print($r->{Cgi}->header($r->_cgi_header_args($cookie)),
 784                $r->_ch('gen_start_html',$title),
 785                (join "\n", @body),
 786                $r->_ch('gen_end_html'));
 787     return 0;
 788 }
 789
 790 sub _random ($$) {
 791     my ($r, $bytes) = @_;
 792     my $v = $r->{V};
 793     my $rsf = $v->{RandomHandle};
 794     my $rsp = $r->{S}{random_source};
 795     if (!$rsf) {
 796         $v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!";
 797 print STDERR "RH $rsf\n";
 798     }
 799     my $bin;
 800     $!=0;
 801     read($rsf,$bin,$bytes) == $bytes or die "$rsp $!";
 802     my $out = unpack "H*", $bin;
 803     print STDERR "_random out $out\n";
 804     return $out;
 805 }
 806
 807 sub _random_key ($) {
 808     my ($r) = @_;
 809     print STDERR "_random_key\n";
 810     my $bytes = ($r->{S}{secretbits} + 7) >> 3;
 811     return $r->_random($bytes);
 812 }
 813
 814 sub _read_key ($$) {
 815     my ($r, $keys) = @_;
 816     # returns $gen_time_t, $key_value_in_hex, $complete_line
 817     while (<$keys>) {
 818         my ($gen, $k) = m/^(\d+) (\S+)$/ or die "$_ ?";
 819         my $age = time - $gen;
 820         next if $age > $r->{S}{key_rollover} &&
 821             $age > $r->{S}{login_form_timeout}*2;
 822         return ($gen, $k, $_);
 823     }
 824     return ();
 825 }
 826
 827 sub _open_keys ($) {
 828     my ($r) = @_;
 829     my $spath = $r->_get_path('keys');
 830     for (;;) {
 831  print STDERR "_open_keys\n";
 832         my $keys = new IO::File $spath, 'r+';
 833         if ($keys) {
 834  print STDERR "_open_keys open\n";
 835             stat $keys or die $!; # NB must not disturb stat _
 836             my $size = (stat _)[7];
 837             my $age = time - (stat _)[9];
 838  print STDERR "_open_keys open size=$size age=$age\n";
 839             return $keys
 840                 if $size && $age <= $r->{S}{key_rollover} / 2;
 841  print STDERR "_open_keys open bad\n";
 842         }
 843         # file doesn't exist, or is empty or too old
 844         if (!$keys) {
 845  print STDERR "_open_keys closed\n";
 846             die "$spath $!" unless $!==&ENOENT;
 847             # doesn't exist, so create it just so we can lock it
 848             $keys = new IO::File $spath, 'a+';
 849             die "$keys $!" unless $keys;
 850             stat $keys or die $!; # NB must not disturb stat _
 851             my $size = (stat _)[7];
 852  print STDERR "_open_keys created size=$size\n";
 853             next if $size; # oh someone else has done it, reopen and read it
 854         }
 855         # file now exists is empty or too old, we must try to replace it
 856         my $our_inum = (stat _)[1]; # last use of that stat _
 857         flock $keys, LOCK_EX or die "$spath $!";
 858         stat $spath or die "$spath $!";
 859         my $path_inum = (stat _)[1];
 860  print STDERR "_open_keys locked our=$our_inum path=$path_inum\n";
 861         next if $our_inum != $path_inum; # someone else has done it
 862         # We now hold the lock!
 863  print STDERR "_open_keys creating\n";
 864         my $newkeys = new IO::Handle;
 865         sysopen $newkeys, "$spath.new", O_CREAT|O_TRUNC|O_WRONLY, 0600
 866             or die "$spath.new $!";
 867         # we add the new key to the front which means it's always sorted
 868         print $newkeys time, ' ', $r->_random_key(), "\n" or die $!;
 869         while (my ($gen,$key,$line) = $r->_read_key($keys)) {
 870  print STDERR "_open_keys copy1\n";
 871             print $newkeys, $line or die $!;
 872         }
 873         $keys->error and die $!;
 874         close $newkeys or die "$spath.new $!";
 875         rename "$spath.new", "$spath" or die "$spath: $!";
 876  print STDERR "_open_keys installed\n";
 877         # that rename effective unlocks, since it makes the name refer
 878         #  to the new file which we haven't locked
 879         # we go round again opening the file at the beginning
 880         #  so that our caller gets a fresh handle onto the existing key file
 881     }
 882 }
 883
 884 sub _fresh_secret ($) {
 885     my ($r) = @_;
 886     print STDERR "_fresh_secret\n";
 887
 888     my $keys = $r->_open_keys();
 889     my ($keyt, $key) = $r->_read_key($keys);
 890     die unless defined $keyt;
 891
 892     my $nonce = $r->_random_key();
 893     my $noncet = time;
 894     my $message = "$noncet.$nonce";
 895
 896     my $signature = $r->_hmac($key, $message);
 897     my $secret = "$keyt.$signature.$message";
 898     print STDERR "FRESH $secret\n";
 899     return $secret;
 900 }
 901
 902 sub _hmac ($$$) {
 903     my ($r, $keyhex, $message) = @_;
 904     my $keybin = pack "H*", $keyhex;
 905     my $alg = $r->{S}{hash_algorithm};
 906 print STDERR "hmac $alg\n";
 907     my $base = new Digest $alg;
 908 print STDERR "hmac $alg $base\n";
 909     my $digest = new Digest::HMAC $keybin, $base;
 910 print STDERR "hmac $alg $base $digest\n";
 911     $digest->add($message);
 912     return $digest->hexdigest();
 913 }
 914
 915 sub hash ($$) {
 916     my ($r, $message) = @_;
 917     my $alg = $r->{S}{hash_algorithm};
 918 print STDERR "hash $alg\n";
 919     my $digest = new Digest $alg;
 920     $digest->add($message);
 921     return $digest->hexdigest();
 922 }
 923
 924 sub _assert_checked ($) {
 925     my ($r) = @_;
 926     die "unchecked" unless exists $r->{Divert};
 927 }
 928
 929 sub _must_be_post ($) {
 930     my ($r) = @_;
 931     my $meth = $r->_ch('get_method');
 932     die "mutating non-POST" if $meth ne 'POST';
 933 }
 934
 935 sub check_mutate ($) {
 936     my ($r) = @_;
 937     $r->_assert_checked();
 938     die if $r->{Divert};
 939     $r->_must_be_post();
 940 }
 941
 942 #---------- output ----------
 943
 944 sub secret_cookie_val ($) {
 945     my ($r) = @_;
 946     $r->_assert_checked();
 947     return defined $r->{AssocSecret} ? $r->{AssocSecret} : '';
 948 }
 949
 950 sub secret_hidden_val ($) {
 951     my ($r) = @_;
 952     $r->_assert_checked();
 953     return defined $r->{AssocSecret} ? $r->hash($r->{AssocSecret}) : '';
 954 }
 955
 956 sub secret_hidden_html ($) {
 957     my ($r) = @_;
 958     return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name},
 959                              -default => $r->secret_hidden_val());
 960 }
 961
 962 sub secret_cookie ($) {
 963     my ($r) = @_;
 964     my $secret = $r->secret_cookie_val();
 965     return undef if !defined $secret;
 966 #print STDERR "SC\n";
 967     my $cookv = $r->construct_cookie($secret);
 968 #print STDERR "SC=$cookv\n";
 969     return $cookv;
 970 }
 971
 972 __END__
 973
 974 =head1 NAME
 975
 976 CGI::Auth::Flexible - web authentication optionally using cookies
 977
 978 =head1 SYNOPSYS
 979
 980  my $verifier = CGI::Auth::Flexible->new_verifier(setting => value,...);
 981  my $authreq = $verifier->new_request($cgi_request_object);
 982
 983  my $authreq = CGI::Auth::Flexible->new_request($cgi_request_object,
 984                                               setting => value,...);
 985
 986 =head1 USAGE PATTERN FOR SIMPLE APPLICATIONS
 987
 988  $authreq->check_ok() or return;
 989
 990  blah blah blah
 991  $authreq->check_mutate();
 992  blah blah blah
 993
 994 =head1 USAGE PATTERN FOR FANCY APPLICATIONS
 995
 996  my $divert_kind = $authreq->check_divert();
 997  if ($divert_kind) {
 998      if ($divert_kind eq 'LOGGEDOUT') {
 999          print "goodbye you are now logged out" and quit
1000      } elsif ($divert_kind eq 'NOCOOKIES') {
1001          print "you need cookies" and quit
1002      ... etc.
1003      }
1004  }
1005
1006  blah blah blah
1007  $authreq->check_mutate();
1008  blah blah blah