3 # This is part of CGI::Auth::Flexible, a perl CGI authentication module.
4 # Copyright (C) 2012 Ian Jackson.
5 # Copyright (C) 2012 Citrix.
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.
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.
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/>.
21 use warnings FATAL => 'all';
23 package CGI::Auth::Flexible;
28 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
33 %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
40 use CGI qw/escapeHTML/;
54 #---------- public utilities ----------
56 sub flatten_params ($) {
59 foreach my $k (keys %$p) {
61 foreach my $v (@{ $p->{$k} }) {
68 #---------- default callbacks ----------
70 sub has_a_param ($$) {
72 foreach my $pn (@{ $r->{S}{$cn} }) {
73 return 1 if $r->_ch('get_param',$pn);
82 foreach my $name ($c->param()) {
83 $p{$name} = [ $c->param($name) ];
88 sub get_cookie_domain ($$$) {
90 my $uri = new URI $r->_ch('get_url');
94 sub login_ok_password ($$) {
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);
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."),
112 $r->_ch('gen_end_html'));
115 sub gen_some_form ($$) {
116 my ($r, $params, $bodyfn) = @_;
117 # Calls $bodyfn->($c,$r) which returns @formbits
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) {
127 foreach my $val (@{ $params->{$n} }) {
128 push @form, ('<input type="hidden"'.
129 ' name="'.escapeHTML($n).'"'.
130 ' value="'.escapeHTML($val).'">');
133 push @form, ('</form>');
134 return join "\n", @form;
137 sub gen_plain_login_form ($$) {
138 my ($c,$r, $params) = @_;
139 return $r->gen_some_form($params, sub {
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>');
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>',
160 sub gen_postmainpage_form ($$$) {
161 my ($c,$r, $params) = @_;
162 return $r->gen_some_form($params, sub {
164 push @form, ('<input type="submit"',
165 ' name="'.$r->{S}{dummy_param_name_prefix}.'submit"'.
166 ' value="'.$r->_gt('Continue').'">');
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.').
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)).'">'.
185 sub gen_plain_licence_link_html ($$) {
187 gen_srcdump_link_html($c,$r, 'GNU Affero GPL', 'licence');
189 sub gen_plain_source_link_html ($$) {
191 gen_srcdump_link_html($c,$r, 'Source available', 'source');
194 sub gen_plain_footer_html ($$) {
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').".",
203 #---------- licence and source code ----------
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 $!";
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);
219 sub dump_plain ($$$$) {
220 my ($c, $r, $ct, $df) = @_;
221 $r->_print($c->header('-type' => $ct));
224 my $got = read $df, $buffer, 65536;
225 die $! unless defined $got;
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");
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 $!";
248 #print STDERR "VCS $item $upwards $try\n";
249 if ($dirsdone->{$upwards}++) {
250 $outfn->("srcdump_process_item: did $upwards,".
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 $&);
258 $upwards =~ s#/*[^/]+$##;
260 return $v->_ch('srcdump_novcs', $dumpdir, $item, $outfn);
263 sub srcdump_novcs ($$$$$) {
264 my ($c, $v, $dumpdir, $item, $outfn) = @_;
265 stat $item or die "$item $!";
267 my $script = 'find -type f -perm +004';
268 foreach my $excl (@{ $v->{S}{srcdump_excludes} }) {
269 $script .= " \\! -name '$excl'";
271 $script .= " -print0";
272 return srcdump_dir_cpio($c,$v,$dumpdir,$item,$outfn,'novcs',$script);
274 return srcdump_file($c,$v,$dumpdir,$item,$outfn);
276 die "$item not file or directory";
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"});
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 $!";
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";
298 defined $pid or die $!;
300 $SIG{__DIE__} = sub {
301 print STDERR "CGI::Auth::Flexible srcdump error: $@\n";
304 open STDOUT, ">", $outfile or die "$outfile $!";
305 chdir $dir or die "chdir $dir: $!";
306 exec '/bin/bash','-ec',"
311 cpio -Hustar -o --quiet -0 -R 1000:1000 || \
312 cpio -Hustar -o --quiet -0
317 $!=0; (waitpid $pid, 0) == $pid or die "$!";
318 die "$dir ($how $script) $outfile $?" if $?;
321 sub srcdump_dirscan_prepare ($$) {
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;
335 unlink <"$dumpdir/s.[a-z][a-z][a-z].*">;
336 my @srcfiles = qw(licence.data manifest.txt);
337 my $srcoutcounter = 'aaa';
339 my $reportfh = new IO::File "$dumpdir/manifest.txt", 'w' or die $!;
341 my ($message, $extension) = @_;
342 if (defined $extension) {
343 my $leaf = "s.$srcoutcounter.$extension";
345 push @srcfiles, $leaf;
346 print $reportfh "$leaf: $message\n" or die $!;
347 return "$dumpdir/$leaf";
349 print $reportfh "none: $message\n" or die $!;
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;
362 if (!lstat "$item") {
363 die "stat $item $!" unless $!==&ENOENT;
364 $outfn->("srcdump_dirscan_prepare stat ENOENT, skipping $item");
368 $item = realpath($item);
369 if (!defined $item) {
370 die "realpath $item $!" unless $!==&ENOENT;
371 $outfn->("srcdump_dirscan_prepare realpath ENOENT,".
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 $!";
381 $v->_ch('srcdump_process_item', $dumpdir, $item,
382 $outfn, \$needlicence, \%dirsdone);
385 close $reportfh or die $!;
386 srcdump_install($c,$v, $dumpdir, 'licence', 'text/plain');
388 my @cmd = (qw(tar -zvvcf), "$dumpdir/source.tmp",
389 "-C", $dumpdir, qw( --), @srcfiles);
390 my $r = system(@cmd);
392 print STDERR "CGI::Auth::Flexible tar failed ($r $!) @cmd\n";
395 die "licence file not found" unless defined $needlicence;
396 srcdump_install($c,$v, $dumpdir, 'source', 'application/octet-stream');
397 close $lockf or die $!;
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 $!";
412 #---------- verifier object methods ----------
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,
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
459 get_cookie_domain => \&get_cookie_domain,
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)#;
478 srcdump_process_item => \&srcdump_process_item,
479 srcdump_vcs_dirs => [qw(.git .hg .bzr .svn CVS)],
480 srcdump_vcsscript_git => "
482 git ls-files -z --others --exclude-from=.gitignore
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
500 while (($k,$v,@_) = @_) {
501 die "unknown setting $k" unless exists $verifier->{S}{$k};
502 $verifier->{S}{$k} = $v;
504 bless $verifier, $class;
505 $verifier->_dbopen();
506 $verifier->_ch('srcdump_prepare');
510 sub _db_setup_do ($$) {
514 $v->_db_transaction(sub {
515 local ($dbh->{PrintError}) = 0;
526 $dbh = $v->{S}{assocdb_dbh};
528 die if $dbh->{AutoCommit};
529 die unless $dbh->{RaiseError};
531 $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb');
532 my $dsn = $v->{S}{assocdb_dsn};
535 $dbh = DBI->connect($dsn, $v->{S}{assocdb_user},
536 $v->{S}{assocdb_password}, {
539 ShowErrorStatement => 1,
542 die "$dsn $! ?" unless $dbh;
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".
551 $v->_db_setup_do("CREATE INDEX $v->{S}{assocdb_table}_timeout_index".
552 " ON $v->{S}{assocdb_table}".
564 sub _db_transaction ($$) {
569 #print STDERR "DT entry\n";
571 #print STDERR "DT loop\n";
574 #print STDERR "DT fn ok\n";
577 #print STDERR "DT fn error\n";
578 { local ($@); $dbh->rollback(); }
579 #print STDERR "DT fn throwing\n";
582 #print STDERR "DT fn eval ok\n";
585 #print STDERR "DT commit ok\n";
588 #print STDERR "DT commit eval ok ",Dumper($rv);
591 #print STDERR "DT commit throw?\n";
592 die $@ if !--$retries;
593 #print STDERR "DT loop again\n";
597 #---------- request object methods ----------
600 my ($classbase, $cgi, @extra) = @_;
601 if (!ref $classbase) {
602 $classbase = $classbase->new_verifier(@extra);
608 S => $classbase->{S},
609 Dbh => $classbase->{Dbh},
612 bless $r, ref $classbase;
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);
624 my $pn = $r->{S}{$pnvb};
625 my $p = scalar $r->_ch('get_param',$pn)
630 $r->_ch('debug',@args);
634 my ($r,$keybase) = @_;
635 my $leaf = $r->{S}{"${keybase}_path"};
636 return $r->_absify_path($leaf);
639 sub _absify_path ($$) {
641 return $leaf if $leaf =~ m,^/,;
642 my $dir = $v->{S}{dir};
643 die "relying on cwd by default ?! set dir" unless defined $dir;
647 sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); }
648 sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); }
650 sub construct_cookie ($$$) {
651 my ($r, $cooks) = @_;
652 return undef unless $cooks;
654 my @ca = (-name => $r->{S}{cookie_name},
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";
665 # pages/param-sets are
666 # n normal non-mutating page
667 # r retrieval of information for JS, non-mutating
669 # u update of information by JS, mutating
672 # O "you have just logged out" page load
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 -
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)
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
690 # Case analysis, cookie mode, app promises re mutate:
691 # cook parm meth form
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
698 # - - GET O "just logged out" page
699 # (any other) O bug or attack, fail
701 # a1 a2 POST o logout
702 # if a1 is valid, revoke it
703 # if a2 is valid, revoke it
705 # redirect to "just logged out" page
706 # (which contains link to login form)
708 # - t POST i complain about cookies being disabled
709 # (with link to login form)
711 # t1 t1 POST i login (or switch user)
713 # show new login form
715 # upgrade t1 to y1 in our db (setting username)
716 # redirect to GET of remaining params
718 # y1 a2 POST i complain about stale login form
720 # show new login form
722 # (other) POST i complain about stale login form
723 # show new login form
725 # t1 a2 ANY nrmu treat as - a2 ANY
727 # y - GET n cross-site link
730 # y y GET nr fine, show page or send data
731 # y y POST nrmu mutation is OK, do operation
733 # y1 y2 GET nr request from stale page
734 # do not revoke y2 as not RESTful
737 # y1 y2 POST nrmu request from stale page
741 # y n GET n intra-site link from stale page,
742 # treat as cross-site link, show data
744 # y n POST n m intra-site form submission from stale page
745 # show "session interrupted"
746 # with link to main data page
748 # y n GET r intra-site request from stale page
751 # y n POST r u intra-site request from stale page
754 # -/n y2 GET nr intra-site link from cleared session
755 # do not revoke y2 as not RESTful
758 # -/n y2 POST nrmu request from cleared session
760 # treat as -/n n POST
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
766 # -/n n GET rmu user not logged in
769 # -/n n POST n m user not logged in
772 # -/n n POST r u user not logged in
775 sub _check_divert_core ($) {
778 my $srcdump = $r->_rp('srcdump_param_name');
780 die if $srcdump =~ m/\W/;
781 return ({ Kind => 'SRCDUMP-'.uc $srcdump,
783 CookieSecret => undef,
787 my $cooks = $r->_ch('get_cookie');
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,
796 my $meth = $r->_ch('get_method');
797 my $parmh = $r->_rp('assoc_param_name');
798 my $cookh = defined $cooks ? $r->hash($cooks) : undef;
800 my ($cookt,$cooku) = $r->_identify($cookh, $cooks);
801 my $parms = (defined $cooks && defined $parmh && $parmh eq $cookh)
803 my ($parmt) = $r->_identify($parmh, $parms);
805 $r->_debug("_c_d_c cookt=$cookt parmt=$parmt\n");
807 if ($r->_ch('is_logout')) {
810 $r->_db_revoke($cookh);
811 $r->_db_revoke($parmh);
812 return ({ Kind => 'REDIRECT-LOGGEDOUT',
813 Message => $r->_gt("Logging out..."),
817 if ($r->_ch('is_loggedout')) {
818 die unless $meth eq 'GET';
819 die if $cookt eq 'y';
821 return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
822 Message => $r->_gt("You have been logged out."),
826 if ($r->_ch('is_login')) {
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() })
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(),
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() })
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() });
864 die if $parmt eq 't';
866 if ($cookt eq 'y' && $parmt eq 'y' && $cookh ne $parmh) {
867 $r->_db_revoke($parmh) if $meth eq 'POST';
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() });
881 $r->_db_revoke($parmh);
882 return ({ Kind => 'LOGIN-FRESH',
883 Message => $r->_gt("You need to log in."),
884 CookieSecret => $news,
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,
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"
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;
906 $r->{AssocSecret} = $cooks;
907 $r->{UserOK} = $cooku;
908 #print STDERR "C-D-C OK\n";
912 sub chain_params ($) {
914 my %p = %{ $r->_ch('get_params') };
915 foreach my $pncn (keys %{ $r->{S} }) {
917 if ($pncn =~ m/_param_name$/) {
918 my $name = $r->{S}{$pncn};
919 die "$pncn ?" if ref $name;
921 } elsif ($pncn =~ m/_param_names$/) {
922 $names = $r->{S}{$pncn};
926 foreach my $name (@$names) {
930 my $dummy_prefix = $r->{S}{dummy_param_name_prefix};
931 foreach my $name (grep /^$dummy_prefix/, keys %p) {
934 die if exists $p{''};
935 $p{''} = [ $r->_ch('get_path_info') ];
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)
945 #print STDERR "_identify\n";
946 return '' unless defined $h && length $h;
947 #print STDERR "_identify h=$h s=".(defined $s ? $s : '<undef>')."\n";
951 $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
952 " WHERE last < ?", {},
953 time - $r->{S}{login_timeout});
955 my $row = $dbh->selectrow_arrayref("SELECT username, last".
956 " FROM $r->{S}{assocdb_table}".
957 " WHERE assochash = ?", {}, $h);
959 #print STDERR "_identify h=$h s=$s YES @$row\n";
960 my ($nusername, $nlast) = @$row;
961 return ('y', $nusername);
964 # Well, it's not in the database. But maybe it's a hash of a
967 return 'n' unless defined $s;
969 my ($keyt, $signature, $message, $noncet, $nonce) =
970 $s =~ m/^(\d+)\.(\w+)\.((\d+)\.(\w+))$/ or die;
972 return 'n' if time > $noncet + $r->{S}{login_form_timeout};
974 #print STDERR "_identify noncet=$noncet ok\n";
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;
985 #print STDERR "_identify NO\n";
987 $keys->error and die $!;
991 sub _db_revoke ($$) {
992 # revokes $h if it's valid; no-op if it's not
997 $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
998 " WHERE assochash = ?", {}, $h);
1001 sub _db_record_login_ok ($$$) {
1002 my ($r,$h,$user) = @_;
1004 my $dbh = $r->{Dbh};
1005 $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
1006 " (assochash, username, last) VALUES (?,?,?)", {},
1010 sub check_divert ($) {
1012 if (exists $r->{Divert}) {
1013 return $r->{Divert};
1015 my $dbh = $r->{Dbh};
1016 $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); });
1018 $r->_debug(Data::Dumper->Dump([$r->{Divert}],[qw(divert)]));
1019 return $r->{Divert};
1022 sub get_divert ($) {
1024 die "unchecked" unless exists $r->{Divert};
1025 return $r->{Divert};
1028 sub get_username ($) {
1030 my $divert = $r->get_divert();
1031 return undef if $divert;
1032 return $r->{UserOK};
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();
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";
1055 my ($divert) = $r->check_divert();
1056 return 1 if !$divert;
1058 my $handled = $r->_ch('handle_divert',$divert);
1059 return 0 if $handled;
1061 my $kind = $divert->{Kind};
1062 my $cookiesecret = $divert->{CookieSecret};
1063 my $params = $divert->{Params};
1064 my $cookie = $r->construct_cookie($cookiesecret);
1066 if ($kind =~ m/^SRCDUMP-(\w+)$/) {
1067 $r->_ch('srcdump_dump', (lc $1));
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)/) {
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();
1089 $r->_ch('do_redirect',$new_url, $cookie);
1093 if (defined $cookiesecret) {
1094 $params->{$r->{S}{assoc_param_name}} = [ $r->hash($cookiesecret) ];
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);
1114 $r->_print($r->{Cgi}->header($r->_cgi_header_args($cookie)),
1115 $r->_ch('gen_start_html',$title),
1117 $r->_ch('gen_footer_html'),
1118 $r->_ch('gen_end_html'))));
1123 my ($r, $bytes) = @_;
1125 my $rsf = $v->{RandomHandle};
1126 my $rsp = $r->{S}{random_source};
1128 $v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!";
1129 #print STDERR "RH $rsf\n";
1133 read($rsf,$bin,$bytes) == $bytes or die "$rsp $!";
1134 my $out = unpack "H*", $bin;
1135 #print STDERR "_random out $out\n";
1139 sub _random_key ($) {
1141 #print STDERR "_random_key\n";
1142 my $bytes = ($r->{S}{secretbits} + 7) >> 3;
1143 return $r->_random($bytes);
1146 sub _read_key ($$) {
1147 my ($r, $keys) = @_;
1148 # returns $gen_time_t, $key_value_in_hex, $complete_line
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, $_);
1159 sub _open_keys ($) {
1161 my $spath = $r->_get_path('keys');
1163 #print STDERR "_open_keys\n";
1164 my $keys = new IO::File $spath, 'r+';
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";
1172 if $size && $age <= $r->{S}{key_rollover} / 2;
1173 #print STDERR "_open_keys open bad\n";
1175 # file doesn't exist, or is empty or too old
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
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 $!;
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
1216 sub _fresh_secret ($) {
1218 #print STDERR "_fresh_secret\n";
1220 my $keys = $r->_open_keys();
1221 my ($keyt, $key) = $r->_read_key($keys);
1222 die unless defined $keyt;
1224 my $nonce = $r->_random_key();
1226 my $message = "$noncet.$nonce";
1228 my $signature = $r->_hmac($key, $message);
1229 my $secret = "$keyt.$signature.$message";
1230 #print STDERR "FRESH $secret\n";
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();
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();
1256 sub _assert_checked ($) {
1258 die "unchecked" unless exists $r->{Divert};
1263 my $meth = $r->_ch('get_method');
1264 return $meth eq 'POST';
1267 sub _must_be_post ($) {
1269 my $meth = $r->_ch('get_method');
1270 die "mutating non-POST" if $meth ne 'POST';
1273 sub check_mutate ($) {
1275 $r->_assert_checked();
1276 die if $r->{Divert};
1277 $r->_must_be_post();
1282 $r->_assert_checked();
1283 die if $r->{Divert};
1284 return $r->_is_post();
1287 #---------- output ----------
1289 sub secret_cookie_val ($) {
1291 $r->_assert_checked();
1292 return defined $r->{AssocSecret} ? $r->{AssocSecret} : '';
1295 sub secret_hidden_val ($) {
1297 $r->_assert_checked();
1298 return defined $r->{AssocSecret} ? $r->hash($r->{AssocSecret}) : '';
1301 sub secret_hidden_html ($) {
1303 return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name},
1304 -default => $r->secret_hidden_val());
1307 sub secret_cookie ($) {
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";
1323 CGI::Auth::Flexible - web authentication optionally using cookies
1327 my $verifier = CGI::Auth::Flexible->new_verifier(setting => value,...);
1328 my $authreq = $verifier->new_request($cgi_query_object);
1330 # simple applications
1331 $authreq->check_ok() or return;
1333 # sophisticated applications
1334 my $divert_kind = $authreq->check_divert();
1335 if ($divert_kind) { ... print diversion page and quit ... }
1337 # while handling the request
1338 $user = $authreq->get_username();
1339 $authreq->check_mutate();
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.
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.
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.
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.
1364 =head1 INITIALISATION
1366 Your application should, on startup (eg, when it is loaded by
1368 C<< $verifier = CGI::Auth::Flexible->new_verifier(settings...) >>.
1369 This call can be expensive and is best amortised.
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) >>.
1375 =head1 SIMPLE APPLICATIONS
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.
1383 After calling C<check_ok> you can use C<< $request->get_username >>
1384 to find out which user the request came from.
1386 =head1 SOPHISTICATED APPLICATIONS
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.
1394 =head1 MUTATING OPERATIONS AND EXTERNAL LINKS INTO YOUR SITE
1396 By default CGI::Auth::Flexible does not permit external links into
1397 your site. All GET requests give a "click to continue" page which
1400 This is because the alternative (for complicated reasons relating to
1401 the web security architecture) is to require your application to make
1402 a special and different check when the incoming request is going to do
1403 some kind of action (such as modifying the user's setup, purchasing
1404 goods, or whatever) rather than just display HTML pages.
1406 To support external links, pass C<< promise_check_mutate => 1 >> in
1407 I<settings>, and then call C<< $authreq->check_mutate() >> before
1408 taking any actions. If the incoming request is not suitable then
1409 C<< $authreq->check_mutate() >> will call C<die>. If you do this you
1410 must make sure that you have no mutating C<GET> requests in your
1411 application - but you shouldn't have any of those anyway.
1413 =head1 SOURCE CODE DOWNLOAD
1415 By default, CGI::Auth::Flexible provides a facility for users to
1416 download the source code for the running version of your web
1419 This facility makes a number of important assumptions which you need
1420 to check. Note that if the provided facility is not sufficient
1421 because your application is more sophisticated than it copes with (or
1422 if you disable the builtin facility), you may need to implement a
1423 functioning alternative to avoid violating the AGPLv3 licence.
1425 Here are the most important (default) assumptions:
1431 Your app's source code is available by looking at @INC, $0 and
1432 S<$ENV{'SCRIPT_FILENAME'}> (the B<source items>). See
1433 C<srcdump_listitems>. Where these point to files or directories under
1434 revision control, the source item is the whole containing vcs tree.
1438 Specifically, there are no compiled or autogenerated Perl
1439 files, Javascript resources, etc., which are not contained in one of
1440 the source item directories. (Files which came with your operating
1441 system install don't need to be shipped as they fall under the system
1446 You have not installed any modified versions of system
1447 libraries (including system-supplied) Perl modules in C</usr> outside
1448 C</usr/local>. See C<srcdump_system_dir>.
1452 For each source item in a dvcs, the entire dvcs history does
1453 not contain anything confidential (or libellous). Also, all files which
1454 contain secrets are in the dvcs's C<.ignore> file. See
1455 C<srcdump_vcsscript_git> et al.
1459 For each source item NOT in a dvcs, there are no confidential
1460 files with the world-readable bit set (being in a world-inaccessible
1461 directory is not sufficient). See C<srcdump_excludes>.
1465 You have none of your app's source code in C</etc>.
1469 You don't regard pathnames on your server as secret.
1473 You don't intentionally load Perl code by virtule of C<.>
1474 being in C<@INC> by default. (See C<srcdump_filter_cwd>.)
1478 =head1 FUNCTIONS AND METHODS
1482 =item C<< CGI::Auth::Flexible::new_verifier(setting => value, ...) >>
1484 Initialises an instance and returns a verifier object.
1485 The arguments are setting pairs like a hash initialiser.
1486 See L</SETTINGS> below.
1488 =item C<< $verifier->new_request($cgi_query) >>
1490 Prepares to process a request. C<$cgi_query> should normally
1491 be the query object from L<CGI(3perl)>. Most of the default
1492 hook methods assume that it is; however if you replace enough of
1493 the hook methods then you can pass any value you like and it
1494 will be passed to your hooks.
1496 The return value is the authentication request object (C<$authreq>)
1497 which is used to check the incoming request and will contain
1498 information about its credentials.
1500 =item C<< $authreq->check_divert() >>
1502 Checks whether the user is logged in. Returns undef if the user is
1503 logged in and we should service the request. Otherwise returns a
1504 divert spec (see L</DIVERT SPEC>) saying what should happen instead.