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 ----------
'<td><input type="text" '.$sz.
' name='.$up.'></td></tr>');
}
- push @form, ('<tr><td>'.$r->_gt('Password'),'</td>',
+ push @form, ('<tr><td>'.$r->_gt('Password').'</td>',
'<td><input type="password" '.$sz.
' name="'.$r->{S}{password_param_name}.'"></td></tr>');
push @form, ('<tr><td colspan="2">',
my $class = shift;
my $verifier = {
S => {
+ dir => undef,
assocdb_path => 'cah-assocs.db',
keys_path => 'cah-keys',
assocdb_dsn => undef,
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;
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); }
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;
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;
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
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
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();
}
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 ($) {