@ISA = qw(Exporter);
@EXPORT = qw();
%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
-
- @EXPORT_OK = qw();
}
our @EXPORT_OK;
use Digest::SHA;
use Data::Dumper;
use File::Copy;
+use Cwd qw/realpath/;
+
#---------- public utilities ----------
sub get_params ($) {
my ($r) = @_;
- my %p;
my $c = $r->{Cgi};
- foreach my $name ($c->param()) {
- $p{$name} = [ $c->param($name) ];
+ my $vars = $c->Vars();
+ my %p;
+ foreach my $name (keys %$vars) {
+ $p{$name} = [ split "\0", $vars->{$name} ];
}
return \%p;
}
sub gen_srcdump_link_html ($$$$) {
my ($c,$r,$anchor,$specval) = @_;
my %params = ($r->{S}{srcdump_param_name} => [ $specval ]);
- return '<a href="'.escapeHTML($r->url_with_query_params(\%params)).'">'.
- $anchor."</a>";
+ return '<a href="'.
+ escapeHTML($r->url_with_query_params(\%params,'SRCDUMP')).
+ '">'.$anchor."</a>";
}
sub gen_plain_licence_link_html ($$) {
my ($c,$r) = @_;
#---------- licence and source code ----------
-#sub dump_licence ($$$) {
-#
-# my ($c,$r, $fh) = @_;
-# foreach my $incdir ($r->_ch('getsource_includedirs')) {
-#
-# }
-#}
-
-sub srcdump_dump_thing ($$$) {
- my ($c,$r, $thing, $outfn) = @_;
+sub srcdump_dump ($$$) {
+ my ($c,$r, $thing) = @_;
die if $thing =~ m/\W/ || $thing !~ m/\w/;
my $path = $r->_get_path('srcdump');
my $ctf = new IO::File "$path/$thing.ctype", 'r'
or die "$path/$thing.ctype $!";
my $ct = <$ctf>;
chomp $ct or die "$path/$thing ?";
- $ct->close or die "$path/$thing $!";
+ $ctf->close or die "$path/$thing $!";
my $df = new IO::File "$path/$thing.data", 'r'
or die "$path/$thing.data $!";
$r->_ch('dump', $ct, $df);
sub dump_plain ($$$$) {
my ($c, $r, $ct, $df) = @_;
- $r->_print($c->header(-type $ct));
+ $r->_print($c->header('-type' => $ct));
my $buffer;
for (;;) {
my $got = read $df, $buffer, 65536;
}
}
+sub srcdump_process_item ($$$$$$) {
+ my ($c, $v, $dumpdir, $item, $outfn, $needlicence, $dirsdone) = @_;
+ if ($v->_ch('srcdump_system_dir', $item)) {
+ $outfn->("srcdump_process_item: srcdump_system_dir, skipping $item");
+ return;
+ }
+ my $upwards = $item;
+ for (;;) {
+ $upwards =~ s#/+$##;
+ $upwards =~ s#/+\.$##;
+ last unless $upwards =~ m#[^/]#;
+ foreach my $try (@{ $v->{S}{srcdump_vcs_dirs} }) {
+#print STDERR "TRY $item $upwards $try\n";
+ if (!stat "$upwards/$try") {
+ $!==&ENOENT or $!==&ENOTDIR or die "check $upwards/$try $!";
+ next;
+ }
+#print STDERR "VCS $item $upwards $try\n";
+ if ($dirsdone->{$upwards}++) {
+ $outfn->("srcdump_process_item: did $upwards,".
+ " skipping $item");
+ return;
+ }
+#print STDERR "VCS $item $upwards $try GO\n";
+ $try =~ m/\w+/ or die;
+ return $v->_ch('srcdump_byvcs', $dumpdir, $upwards, $outfn, lc $&);
+ }
+ $upwards =~ s#/*[^/]+$##;
+ }
+ return $v->_ch('srcdump_novcs', $dumpdir, $item, $outfn);
+}
+
+sub srcdump_novcs ($$$$$) {
+ my ($c, $v, $dumpdir, $item, $outfn) = @_;
+ stat $item or die "$item $!";
+ if (-d _) {
+ my $script = 'find -type f -perm +004';
+ foreach my $excl (@{ $v->{S}{srcdump_excludes} }) {
+ $script .= " \\! -name '$excl'";
+ }
+ $script .= " -print0";
+ return srcdump_dir_cpio($c,$v,$dumpdir,$item,$outfn,'novcs',$script);
+ } elsif (-f _) {
+ return srcdump_file($c,$v,$dumpdir,$item,$outfn);
+ } else {
+ die "$item not file or directory";
+ }
+}
+
+sub srcdump_byvcs ($$$$$$) {
+ my ($c, $v, $dumpdir, $dir, $outfn, $vcs) = @_;
+#print STDERR "BYVCS GIT $dir\n";
+ my $script = $v->{S}{"srcdump_vcsscript"}{$vcs};
+ die "no script for vcs $vcs" unless defined $script;
+ return srcdump_dir_cpio($c,$v,$dumpdir,$dir,$outfn,$vcs,$script);
+}
+
+sub srcdump_file ($$$$) {
+ my ($c,$v,$dumpdir,$file,$outfn) = @_;
+ my $outfile = $outfn->("srcdump_file saved $file", "src");
+ copy($file,$outfile) or die "$file $outfile $!";
+}
+
+sub srcdump_dir_cpio ($$$$$$$) {
+ my ($c,$v,$dumpdir,$dir,$outfn,$how,$script) = @_;
+ my $outfile = $outfn->("srcdump_dir_cpio $how saved $dir", "tar");
+#print STDERR "CPIO $dir >$script<\n";
+ my $pid = fork();
+ defined $pid or die $!;
+ if (!$pid) {
+ $SIG{__DIE__} = sub {
+ print STDERR "CGI::Auth::Flexible srcdump error: $@\n";
+ exit 127;
+ };
+ open STDOUT, ">", $outfile or die "$outfile $!";
+ chdir $dir or die "chdir $dir: $!";
+ exec '/bin/bash','-ec',"
+ set -o pipefail
+ (
+ $script
+ ) | (
+ cpio -Hustar -o --quiet -0 -R 1000:1000 || \
+ cpio -Hustar -o --quiet -0
+ )
+ ";
+ die $!;
+ }
+ $!=0; (waitpid $pid, 0) == $pid or die "$!";
+ die "$dir ($how $script) $outfile $?" if $?;
+}
+
+sub srcdump_dirscan_prepare ($$) {
+ my ($c, $v) = @_;
+ my $dumpdir = $v->_get_path('srcdump');
+ mkdir $dumpdir or $!==&EEXIST or die "mkdir $dumpdir $!";
+ my $lockf = new IO::File "$dumpdir/generate.lock", 'w+'
+ or die "$dumpdir/generate.lock $!";
+ flock $lockf, LOCK_EX or die "$dumpdir/generate.lock $!";
+ my $needlicence = "$dumpdir/licence.tmp";
+ unlink $needlicence or $!==&ENOENT or die "rm $needlicence $!";
+ if (defined $v->{S}{srcdump_licence_path}) {
+ copy($v->{S}{srcdump_licence_path}, $needlicence)
+ or die "$v->{S}{srcdump_licence_path} $!";
+ $needlicence = undef;
+ }
+ unlink <"$dumpdir/s.[a-z][a-z][a-z].*">;
+ my @srcfiles = qw(licence.data manifest.txt);
+ my $srcoutcounter = 'aaa';
+
+ my $reportfh = new IO::File "$dumpdir/manifest.txt", 'w' or die $!;
+ my $outfn = sub {
+ my ($message, $extension) = @_;
+ if (defined $extension) {
+ my $leaf = "s.$srcoutcounter.$extension";
+ $srcoutcounter++;
+ push @srcfiles, $leaf;
+ print $reportfh "$leaf: $message\n" or die $!;
+ return "$dumpdir/$leaf";
+ } else {
+ print $reportfh "none: $message\n" or die $!;
+ return undef;
+ }
+ };
+ my %dirsdone;
+ foreach my $item ($v->_ch('srcdump_listitems')) {
+ next unless defined $item;
+ if ($item eq '.' && $v->{S}{srcdump_filter_cwd}) {
+ my @bad = grep { !m#^/# } values %INC;
+ die "filtering . from srcdump items and \@INC but already".
+ " included @bad " if @bad;
+ @INC = grep { $_ ne '.' } @INC;
+ next;
+ }
+ if (!lstat "$item") {
+ die "stat $item $!" unless $!==&ENOENT;
+ $outfn->("srcdump_dirscan_prepare stat ENOENT, skipping $item");
+ next;
+ };
+ if (-l _) {
+ $item = realpath($item);
+ if (!defined $item) {
+ die "realpath $item $!" unless $!==&ENOENT;
+ $outfn->("srcdump_dirscan_prepare realpath ENOENT,".
+ " skipping $item");
+ }
+ }
+ if (defined $needlicence) {
+ foreach my $try (@{ $v->{S}{srcdump_licence_files} }) {
+ last if copy("$item/$try", $needlicence);
+ $!==&ENOENT or $!==&ENOTDIR or die "copy $item/$try $!";
+ }
+ }
+ $v->_ch('srcdump_process_item', $dumpdir, $item,
+ $outfn, \$needlicence, \%dirsdone);
+ $dirsdone{$item}++;
+ }
+ close $reportfh or die $!;
+ srcdump_install($c,$v, $dumpdir, 'licence', 'text/plain');
+ $!=0;
+ my @cmd = (qw(sh -ec), 'exec >&2 "$@"', qw(x),
+ qw(tar -zvvcf), "$dumpdir/source.tmp",
+ "-C", $dumpdir, qw( --), @srcfiles);
+ my $r = system(@cmd);
+ if ($r) {
+ print STDERR "CGI::Auth::Flexible tar failed ($r $!) @cmd\n";
+ die "tar failed";
+ }
+ die "licence file not found" unless defined $needlicence;
+ srcdump_install($c,$v, $dumpdir, 'source', 'application/octet-stream');
+ close $lockf or die $!;
+}
+
+sub srcdump_install ($$$$$) {
+ my ($c,$v, $dumpdir, $which, $ctype) = @_;
+ rename "$dumpdir/$which.tmp", "$dumpdir/$which.data"
+ or die "$dumpdir/$which.data $!";
+ my $ctf = new IO::File "$dumpdir/$which.tmp", 'w'
+ or die "$dumpdir/$which.tmp $!";
+ print $ctf $ctype, "\n" or die $!;
+ close $ctf or die $!;
+ rename "$dumpdir/$which.tmp", "$dumpdir/$which.ctype"
+ or die "$dumpdir/$which.ctype $!";
+}
+
#---------- verifier object methods ----------
sub new_verifier {
my $verifier = {
S => {
dir => undef,
- assocdb_dbh => undef, # must have AutoCommit=0, RaiseError=1
- assocdb_path => 'caf-assocs.db',
+ db_dbh => undef, # must have AutoCommit=0, RaiseError=1
+ db_path => 'caf.db',
keys_path => 'caf-keys',
srcdump_path => 'caf-srcdump',
- assocdb_dsn => undef,
- assocdb_user => '',
- assocdb_password => '',
- assocdb_table => 'caf_assocs',
+ db_dsn => undef,
+ db_user => '',
+ db_password => '',
+ db_prefix => 'caf',
random_source => '/dev/urandom',
secretbits => 128, # bits
hash_algorithm => "SHA-256",
get_path_info => sub { $_[0]->path_info() },
get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) },
get_method => sub { $_[0]->request_method() },
- check_https => sub { !!$_[0]->https() },
+ is_https => sub { !!$_[0]->https() },
get_url => sub { $_[0]->url(); },
is_login => sub { defined $_[1]->_rp('password_param_name') },
login_ok => \&login_ok_password,
username_password_error => sub { die },
is_logout => sub { $_[1]->has_a_param('logout_param_names') },
is_loggedout => sub { $_[1]->has_a_param('loggedout_param_names') },
- is_page => sub { return 1 },
handle_divert => sub { return 0 },
do_redirect => \&do_redirect_cgi, # this hook is allowed to throw
cookie_path => "/",
gen_login_form => \&gen_plain_login_form,
gen_login_link => \&gen_plain_login_link,
gen_postmainpage_form => \&gen_postmainpage_form,
- srcdump_dump_thing => \&srcdump_dump_thing,
- source_includedirs => sub { grep { !m#^/etc/# } @INC; },
+ srcdump_dump => \&srcdump_dump,
+ srcdump_prepare => \&srcdump_dirscan_prepare,
+ srcdump_licence_path => undef,
+ srcdump_licence_files => [qw(AGPLv3 CGI/Auth/Flexible/AGPLv3)],
+ srcdump_listitems => sub { (@INC, $ENV{'SCRIPT_FILENAME'}, $0); },
+ srcdump_filter_cwd => 1,
+ srcdump_system_dir => sub {
+ $_[2] =~ m#^/etc/|^/usr/(?!local/)(?!lib/cgi)#;
+ },
+ srcdump_process_item => \&srcdump_process_item,
+ srcdump_vcs_dirs => [qw(.git .hg .bzr .svn)],
+ srcdump_vcsscript => {git => "
+ git ls-files -z
+ git ls-files -z --others --exclude-from=.gitignore
+ find .git -print0
+ "},
+ srcdump_byvcs => \&srcdump_byvcs,
+ srcdump_novcs => \&srcdump_novcs,
+ srcdump_excludes => [qw(*~ *.bak *.tmp), '#*#'],
+ dump => \&dump_plain,
gettext => sub { gettext($_[2]); },
print => sub { print $_[2] or die $!; },
debug => sub { }, # like print; msgs contain trailing \n
};
my ($k,$v);
while (($k,$v,@_) = @_) {
- die "unknown setting $k" unless exists $verifier->{S}{$k};
+ die "unknown setting $k" unless
+ $k =~ m/^promise_/ or
+ exists $verifier->{S}{$k};
$verifier->{S}{$k} = $v;
}
+ $verifier->{S}{db_setup_stmts} //=
+ ["CREATE TABLE $verifier->{S}{db_prefix}_assocs (".
+ " assochash VARCHAR PRIMARY KEY,".
+ " username VARCHAR NOT NULL,".
+ " last INTEGER NOT NULL".
+ ")"
+ ,
+ "CREATE INDEX $verifier->{S}{db_prefix}_assocs_timeout_index".
+ " ON $verifier->{S}{db_prefix}_assocs".
+ " (last)"
+ ];
bless $verifier, $class;
$verifier->_dbopen();
+ $verifier->_ch('srcdump_prepare');
return $verifier;
}
my $dbh = $v->{Dbh};
return $dbh if $dbh;
- $dbh = $v->{S}{assocdb_dbh};
+ $dbh = $v->{S}{db_dbh};
if ($dbh) {
die if $dbh->{AutoCommit};
die unless $dbh->{RaiseError};
} else {
- $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb');
- my $dsn = $v->{S}{assocdb_dsn};
+ $v->{S}{db_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('db');
+ my $dsn = $v->{S}{db_dsn};
my $u = umask 077;
- $dbh = DBI->connect($dsn, $v->{S}{assocdb_user},
- $v->{S}{assocdb_password}, {
+ $dbh = DBI->connect($dsn, $v->{S}{db_user},
+ $v->{S}{db_password}, {
AutoCommit => 0,
RaiseError => 1,
ShowErrorStatement => 1,
}
$v->{Dbh} = $dbh;
- $v->_db_setup_do("CREATE TABLE $v->{S}{assocdb_table} (".
- " assochash VARCHAR PRIMARY KEY,".
- " username VARCHAR NOT NULL,".
- " last INTEGER NOT NULL".
- ")");
- $v->_db_setup_do("CREATE INDEX $v->{S}{assocdb_table}_timeout_index".
- " ON $v->{S}{assocdb_table}".
- " (last)");
+ foreach my $stmt (@{ $v->{S}{db_setup_stmts} }) {
+ $v->_db_setup_do($stmt);
+ }
return $dbh;
}
my ($r, $cooks) = @_;
return undef unless $cooks;
my $c = $r->{Cgi};
-my @ca = (-name => $r->{S}{cookie_name},
- -value => $cooks,
- -path => $r->{S}{cookie_path},
- -domain => $r->_ch('get_cookie_domain'),
- -expires => '+'.$r->{S}{login_timeout}.'s',
- -secure => $r->{S}{encrypted_only});
+ my @ca = (
+ -name => $r->{S}{cookie_name},
+ -value => $cooks,
+ -path => $r->{S}{cookie_path},
+ -domain => $r->_ch('get_cookie_domain'),
+ -expires => '+'.$r->{S}{login_timeout}.'s',
+ -secure => $r->{S}{encrypted_only}
+ );
my $cookie = $c->cookie(@ca);
#print STDERR "CC $r $c $cooks $cookie (@ca).\n";
return $cookie;
# pages/param-sets are
# n normal non-mutating page
-# r retrieval of information for JS, non-mutating
+# r retrieval of information for JS etc., non-mutating
# m mutating page
-# u update of information by JS, mutating
+# u update of information by JS etc., mutating
# i login
# o logout
# O "you have just logged out" page load
die if $srcdump =~ m/\W/;
return ({ Kind => 'SRCDUMP-'.uc $srcdump,
Message => undef,
- CookieSecret => undef,
+ _CookieRaw => undef,
Params => { } });
}
- my $cooks = $r->_ch('get_cookie');
+ my $cooksraw = $r->_ch('get_cookie');
+ my $cooks = $r->_unblind($cooksraw);
- if ($r->{S}{encrypted_only} && !$r->_ch('check_https')) {
+ if ($r->{S}{encrypted_only} && !$r->_ch('is_https')) {
return ({ Kind => 'REDIRECT-HTTPS',
Message => $r->_gt("Redirecting to secure server..."),
- CookieSecret => undef,
+ _CookieRaw => undef,
Params => { } });
}
my $meth = $r->_ch('get_method');
- my $parmh = $r->_rp('assoc_param_name');
+ my $parmhraw = $r->_rp('assoc_param_name');
+ my $parmh = $r->_unblind($parmhraw);
my $cookh = defined $cooks ? $r->hash($cooks) : undef;
my ($cookt,$cooku) = $r->_identify($cookh, $cooks);
$r->_db_revoke($parmh);
return ({ Kind => 'REDIRECT-LOGGEDOUT',
Message => $r->_gt("Logging out..."),
- CookieSecret => '',
- Params => { } });
+ _CookieRaw => '',
+ Params => {
+ $r->{S}{loggedout_param_names}[0] => [ 1 ],
+ } });
}
if ($r->_ch('is_loggedout')) {
die unless $meth eq 'GET';
die if $parmt;
return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
Message => $r->_gt("You have been logged out."),
- CookieSecret => '',
+ _CookieRaw => '',
Params => { } });
}
if ($r->_ch('is_login')) {
Message => $r->_gt("You do not seem to have cookies".
" enabled. You must enable cookies".
" as we use them for login."),
- CookieSecret => $r->_fresh_secret(),
- Params => $r->chain_params() })
+ _CookieRaw => $r->_fresh_secret(),
+ Params => $r->_chain_params() })
}
if (!$cookt || $cookt eq 'n' || $cookh ne $parmh) {
$r->_db_revoke($cookh);
return ({ Kind => 'LOGIN-STALE',
Message => $r->_gt("Stale session;".
" you need to log in again."),
- CookieSecret => $r->_fresh_secret(),
+ _CookieRaw => $r->_fresh_secret(),
Params => { } })
}
die unless $parmt eq 't' || $parmt eq 'y';
if !$login_errormessage;
return ({ Kind => 'LOGIN-BAD',
Message => $login_errormessage,
- CookieSecret => $cooks,
- Params => $r->chain_params() })
+ _CookieRaw => $cooks,
+ Params => $r->_chain_params() })
}
$r->_db_record_login_ok($parmh,$username);
return ({ Kind => 'REDIRECT-LOGGEDIN',
Message => $r->_gt("Logging in..."),
- CookieSecret => $cooks,
- Params => $r->chain_params() });
+ _CookieRaw => $cooks,
+ Params => $r->_chain_params() });
}
if ($cookt eq 't') {
$cookt = '';
if ($meth eq 'GET') {
return ({ Kind => 'LOGIN-INCOMINGLINK',
Message => $r->_gt("You need to log in."),
- CookieSecret => $news,
- Params => $r->chain_params() });
+ _CookieRaw => $news,
+ Params => $r->_chain_params() });
} else {
$r->_db_revoke($parmh);
return ({ Kind => 'LOGIN-FRESH',
Message => $r->_gt("You need to log in."),
- CookieSecret => $news,
+ _CookieRaw => $news,
Params => { } });
}
}
if ($meth ne 'POST') {
return ({ Kind => 'MAINPAGEONLY',
Message => $r->_gt('Entering via cross-site link.'),
- CookieSecret => $cooks,
+ _CookieRaw => $cooks,
Params => { } });
# NB caller must then ignore params & path!
# if this is too hard they can spit out a small form
die unless $parmt eq 'y';
die unless $cookh eq $parmh;
}
- $r->{AssocSecret} = $cooks;
+ $r->{ParmT} = $parmt;
+ $r->{AssocRaw} = $cooks;
$r->{UserOK} = $cooku;
#print STDERR "C-D-C OK\n";
return undef;
}
-sub chain_params ($) {
+sub _chain_params ($) {
+# =item C<< $authreq->_chain_params() >>
+#
+# Returns a hash of the "relevant" parameters to this request, in a form
+# used by C<url_with_query_params>. This is all of the query parameters
+# which are not related to CGI::Auth::Flexible. The PATH_INFO from the
+# request is returned as the parameter C<< '' >>.
+
my ($r) = @_;
my %p = %{ $r->_ch('get_params') };
foreach my $pncn (keys %{ $r->{S} }) {
my $dbh = $r->{Dbh};
- $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
+ $dbh->do("DELETE FROM $r->{S}{db_prefix}_assocs".
" WHERE last < ?", {},
time - $r->{S}{login_timeout});
my $row = $dbh->selectrow_arrayref("SELECT username, last".
- " FROM $r->{S}{assocdb_table}".
+ " FROM $r->{S}{db_prefix}_assocs".
" WHERE assochash = ?", {}, $h);
if (defined $row) {
#print STDERR "_identify h=$h s=$s YES @$row\n";
my $dbh = $r->{Dbh};
- $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
+ $dbh->do("DELETE FROM $r->{S}{db_prefix}_assocs".
" WHERE assochash = ?", {}, $h);
}
my ($r,$h,$user) = @_;
$r->_db_revoke($h);
my $dbh = $r->{Dbh};
- $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
+ $dbh->do("INSERT INTO $r->{S}{db_prefix}_assocs".
" (assochash, username, last) VALUES (?,?,?)", {},
$h, $user, time);
}
my $dbh = $r->{Dbh};
$r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); });
$dbh->commit();
- $r->_debug(Data::Dumper->Dump([$r->{Divert}],[qw(divert)]));
- return $r->{Divert};
+
+ my $divert = $r->{Divert};
+ my $cookraw = $divert->{_CookieRaw};
+ $divert->{CookieSecret} = $r->_blind($cookraw);
+ if ($cookraw) {
+ $divert->{Params}{$r->{S}{assoc_param_name}} = [
+ $r->_blind($r->hash($cookraw))
+ ];
+ }
+
+ $r->_debug(Data::Dumper->Dump([$divert],[qw(divert)]));
+ return $divert;
}
sub get_divert ($) {
return $r->{UserOK};
}
-sub url_with_query_params ($$) {
- my ($r, $params) = @_;
+sub url_with_query_params ($$;$) {
+ my ($r, $params, $nonpagetype) = @_;
#print STDERR "PARAMS ",Dumper($params);
my $uri = URI->new($r->_ch('get_url'));
$uri->path($uri->path() . $params->{''}[0]) if $params->{''};
- $uri->query_form(flatten_params($params));
+ my @flatparams = flatten_params($params);
+ if (defined $nonpagetype && $r->need_add_hidden('GET',$nonpagetype)) {
+ push @flatparams, $r->{S}{assoc_param_name}, $r->secret_hidden_val();
+ }
+ $uri->query_form(@flatparams);
return $uri->as_string();
}
my $cookie = $r->construct_cookie($cookiesecret);
if ($kind =~ m/^SRCDUMP-(\w+)$/) {
- $r->_ch('srcdump_dump_thing', (lc $1));
+ $r->_ch('srcdump_dump', (lc $1));
return 0;
}
if ($kind =~ m/^REDIRECT-/) {
- # for redirects, we honour stored NextParams and SetCookie,
+ # for redirects, we honour stored Params and Cookie,
# as we would for non-divert
if ($kind eq 'REDIRECT-LOGGEDOUT') {
- $params->{$r->{S}{loggedout_param_names}[0]} = [ 1 ];
- } elsif ($kind eq 'REDIRECT-LOGOUT') {
- $params->{$r->{S}{logout_param_names}[0]} = [ 1 ];
} elsif ($kind =~ m/REDIRECT-(?:LOGGEDIN|HTTPS)/) {
} else {
die;
return 0;
}
- if (defined $cookiesecret) {
- $params->{$r->{S}{assoc_param_name}} = [ $r->hash($cookiesecret) ];
- }
-
my ($title, @body);
if ($kind =~ m/^LOGIN-/) {
$title = $r->_gt('Login');
return $out;
}
+sub _blind_len ($$) {
+ my ($r, $str) = @_;
+ return length($str =~ y/0-9a-f//cdr);
+}
+
+sub _blind_combine ($$$) {
+ my ($r, $in, $mask) = @_;
+ my @mask = split //, $mask;
+ $in =~ s{[0-9a-f]}{
+ my $m = shift @mask;
+ sprintf "%x", hex($m) ^ hex($&);
+ }ge;
+ return $in;
+}
+
+sub _blind ($$) {
+ my ($r, $in) = @_;
+ return $in unless $in;
+ my $l = $r->_blind_len($in);
+ my $mask = $r->_random(($l+1)>>1);
+ $mask = substr $mask, 0, $l;
+ my $blound = $r->_blind_combine($in, $mask);
+ return "$blound.$mask";
+}
+
+sub _unblind ($$) {
+ my ($r, $in) = @_;
+ return $in unless $in;
+ my ($blound,$mask) = ($in =~ m#^(.*)\.([0-9a-f]+)$#) or die "$in ?";
+ my $l = $r->_blind_len($blound);
+ $l == length($mask) or die "$in ?";
+ return $r->_blind_combine($blound, $mask);
+}
+
sub _random_key ($) {
my ($r) = @_;
#print STDERR "_random_key\n";
$r->_must_be_post();
}
-sub mutate_ok ($) {
- my ($r) = @_;
+our %_resource_get_needs_secret_hidden =
+ (map { $_ => 0 } qw(PAGE FRAME IFRAME SRCDUMP STYLESHEET FAVICON ROBOTS),
+ map { $_ => 1 } qw(IMAGE SCRIPT AJAX-XML AJAX-JSON AJAX-OTHER));
+
+sub update_get_need_add_hidden ($$;$) {
+ my ($r, $reqtype, $value, $force) = @_;
+ my $hash = ref $r
+ ? ($r->{GetNeedsSecretHidden} ||= { })
+ : \%_resource_get_needs_secret_hidden;
+ return if !$force &&
+ (exists $_resource_get_needs_secret_hidden{$reqtype} ||
+ exists $hash->{$reqtype});
+ $hash->{$reqtype} = $value;
+}
+
+sub need_add_hidden ($$) {
+ my ($r, $method, $reqtype) = @_;
+ return 1 if $method ne 'GET';
+ if (ref $r) {
+ my $ent = $r->{GetNeedsSecretHidden}{$reqtype};
+ return $ent if defined $ent;
+ }
+ my $ent = $_resource_get_needs_secret_hidden{$reqtype};
+ return $ent if defined $ent;
+ die "unsupported nonpage GET type $reqtype";
+}
+
+sub check_nonpage ($$) {
+ my ($r, $reqtype) = @_;
$r->_assert_checked();
- die if $r->{Divert};
- return $r->_is_post();
+ return unless $r->resource_get_needs_secret_hidden($reqtype);
+ return if $r->{ParmT};
+ die "missing hidden secret parameter on nonpage request $reqtype";
}
#---------- output ----------
sub secret_cookie_val ($) {
my ($r) = @_;
$r->_assert_checked();
- return defined $r->{AssocSecret} ? $r->{AssocSecret} : '';
+ return defined $r->{AssocRaw} ? $r->_blind($r->{AssocRaw}) : '';
}
sub secret_hidden_val ($) {
my ($r) = @_;
$r->_assert_checked();
- return defined $r->{AssocSecret} ? $r->hash($r->{AssocSecret}) : '';
+ return defined $r->{AssocRaw} ? $r->_blind($r->hash($r->{AssocRaw})) : '';
}
sub secret_hidden_html ($) {
}
1;
-
-__END__
-
-=head1 NAME
-
-CGI::Auth::Flexible - web authentication optionally using cookies
-
-=head1 SYNOPSYS
-
- my $verifier = CGI::Auth::Flexible->new_verifier(setting => value,...);
- my $authreq = $verifier->new_request($cgi_request_object);
-
- my $authreq = CGI::Auth::Flexible->new_request($cgi_request_object,
- setting => value,...);
-
-=head1 USAGE PATTERN FOR SIMPLE APPLICATIONS
-
- $authreq->check_ok() or return;
-
- blah blah blah
- $authreq->check_mutate();
- blah blah blah
-
-=head1 USAGE PATTERN FOR FANCY APPLICATIONS
-
- my $divert_kind = $authreq->check_divert();
- if ($divert_kind) {
- if ($divert_kind eq 'LOGGEDOUT') {
- print "goodbye you are now logged out" and quit
- } elsif ($divert_kind eq 'NOCOOKIES') {
- print "you need cookies" and quit
- ... etc.
- }
- }
-
- blah blah blah
- $authreq->check_mutate();
- blah blah blah
~ian / cgi-auth-flexible.git / blobdiff