X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=cgi-auth-flexible.git;a=blobdiff_plain;f=cgi-auth-hybrid.pm;fp=cgi-auth-hybrid.pm;h=4c34bc7966393dbc025f15bba82336454300ccd6;hp=ac41d1e58b284046db95b9b7a164e32e0753576e;hb=0816d8bf9664c72da4216b4b3c5eb19b70bbe464;hpb=0ff77901e5e258423b2e24ad7e91fc912726a694
diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index ac41d1e..4c34bc7 100644
--- a/cgi-auth-hybrid.pm
+++ b/cgi-auth-hybrid.pm
@@ -41,7 +41,11 @@ use CGI qw/escapeHTML/;
use Locale::gettext;
use URI;
use IO::File;
-use Fctnl qw(:flock);
+use Fcntl qw(:flock);
+use POSIX;
+use Digest;
+use Digest::HMAC;
+use Digest::SHA;
use Data::Dumper;
#---------- public utilities ----------
@@ -115,7 +119,7 @@ sub gen_plain_login_form ($$) {
'
',
@@ -146,6 +150,7 @@ sub new_verifier {
my $class = shift;
my $verifier = {
S => {
+ dir => undef,
assocdb_path => 'cah-assocs.db',
keys_path => 'cah-keys',
assocdb_dsn => undef,
@@ -218,7 +223,7 @@ sub _dbopen ($) {
my $dbh = $v->{Dbh};
return $dbh if $dbh;
- $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$v->{S}{assocdb_path}";
+ $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb');
my $dsn = $v->{S}{assocdb_dsn};
my $u = umask 077;
@@ -313,6 +318,15 @@ sub _rp ($$@) {
my $p = scalar $r->_ch('get_param',$pn)
}
+sub _get_path ($$) {
+ my ($v,$keybase) = @_;
+ my $leaf = $v->{S}{"${keybase}_path"};
+ my $dir = $v->{S}{dir};
+ return $leaf if $leaf =~ m,^/,;
+ die "relying on cwd by default ?! set dir" unless defined $dir;
+ return "$dir/$leaf";
+}
+
sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); }
sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); }
@@ -734,11 +748,11 @@ sub _random ($$) {
my $rsp = $r->{S}{random_source};
if (!$rsf) {
$v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!";
+print STDERR "RH $rsf\n";
}
my $bin;
$!=0;
read($rsf,$bin,$bytes) == $bytes or die "$rsp $!";
- close $rsf;
my $out = unpack "H*", $bin;
print STDERR "_random out $out\n";
return $out;
@@ -755,8 +769,7 @@ sub _read_key ($$) {
my ($r, $keys) = @_;
# returns $gen_time_t, $key_value_in_hex, $complete_line
while (<$keys>) {
- m/^(\d+) (\S+)$/ or die "$_ ?";
- my ($gen, $k) = @_;
+ my ($gen, $k) = m/^(\d+) (\S+)$/ or die "$_ ?";
my $age = time - $gen;
next if $age > $r->{S}{key_rollover} &&
$age > $r->{S}{login_form_timeout}*2;
@@ -767,23 +780,30 @@ sub _read_key ($$) {
sub _open_keys ($) {
my ($r) = @_;
- my $spath = $r->{S}{secrets_path};
+ my $spath = $r->_get_path('keys');
for (;;) {
+ print STDERR "_open_keys\n";
my $keys = new IO::File $spath, 'r+';
if ($keys) {
+ print STDERR "_open_keys open\n";
stat $keys or die $!; # NB must not disturb stat _
my $size = (stat _)[7];
my $age = time - (stat _)[9];
- return $keys if $size && $age <= $r->{S}{key_rollover} / 2;
+ print STDERR "_open_keys open size=$size age=$age\n";
+ return $keys
+ if $size && $age <= $r->{S}{key_rollover} / 2;
+ print STDERR "_open_keys open bad\n";
}
# file doesn't exist, or is empty or too old
if (!$keys) {
+ print STDERR "_open_keys closed\n";
die "$spath $!" unless $!==&ENOENT;
# doesn't exist, so create it just so we can lock it
$keys = new IO::File $spath, 'a+';
die "$keys $!" unless $keys;
stat $keys or die $!; # NB must not disturb stat _
my $size = (stat _)[7];
+ print STDERR "_open_keys created size=$size\n";
next if $size; # oh someone else has done it, reopen and read it
}
# file now exists is empty or too old, we must try to replace it
@@ -791,19 +811,23 @@ sub _open_keys ($) {
flock $keys, LOCK_EX or die "$spath $!";
stat $spath or die "$spath $!";
my $path_inum = (stat _)[1];
+ print STDERR "_open_keys locked our=$our_inum path=$path_inum\n";
next if $our_inum != $path_inum; # someone else has done it
# We now hold the lock!
+ print STDERR "_open_keys creating\n";
my $newkeys = new IO::Handle;
sysopen $newkeys, "$spath.new", O_CREAT|O_TRUNC|O_WRONLY, 0600
or die "$spath.new $!";
# we add the new key to the front which means it's always sorted
- print $newkeys, time, ' ', $r->_random_key(), "\n" or die $!;
+ print $newkeys time, ' ', $r->_random_key(), "\n" or die $!;
while (my ($gen,$key,$line) = $r->_read_key($keys)) {
+ print STDERR "_open_keys copy1\n";
print $newkeys, $line or die $!;
}
$keys->error and die $!;
close $newkeys or die "$spath.new $!";
rename "$spath.new", "$spath" or die "$spath: $!";
+ print STDERR "_open_keys installed\n";
# that rename effective unlocks, since it makes the name refer
# to the new file which we haven't locked
# we go round again opening the file at the beginning
@@ -826,19 +850,27 @@ sub _fresh_secret ($) {
my $signature = $r->_hmac($key, $message);
my $secret = "$keyt.$signature.$message";
print STDERR "FRESH $secret\n";
+ return $secret;
}
sub _hmac ($$$) {
my ($r, $keyhex, $message) = @_;
my $keybin = pack "H*", $keyhex;
- my $digest = Digest::HMAC->new($keybin, $r->{S}{hash_algorithm});
+ my $alg = $r->{S}{hash_algorithm};
+print STDERR "hmac $alg\n";
+ my $base = new Digest $alg;
+print STDERR "hmac $alg $base\n";
+ my $digest = new Digest::HMAC $keybin, $base;
+print STDERR "hmac $alg $base $digest\n";
$digest->add($message);
return $digest->hexdigest();
}
sub hash ($$) {
my ($r, $message) = @_;
- my $digest = Digest->new($r->{S}{hash_algorithm});
+ my $alg = $r->{S}{hash_algorithm};
+print STDERR "hash $alg";
+ my $digest = new Digest $alg;
$digest->add($message);
return $digest->hexdigest();
}
@@ -867,7 +899,7 @@ sub secret_cookie_val ($) {
sub secret_hidden_val ($) {
my ($r) = @_;
$r->_assert_checked();
- return defined $r->{AssocSecret} ? hash($r->{AssocSecret}) : '';
+ return defined $r->{AssocSecret} ? r->hash($r->{AssocSecret}) : '';
}
sub secret_hidden_html ($) {
|