chiark / gitweb /
fixes
authorIan Jackson <ian.jackson@eu.citrix.com>
Thu, 10 Jan 2013 19:07:39 +0000 (19:07 +0000)
committerIan Jackson <Ian.Jackson@eu.citrix.com>
Thu, 10 Jan 2013 19:07:39 +0000 (19:07 +0000)
TODO
cgi-auth-hybrid.pm
test.cgi

diff --git a/TODO b/TODO
index b39dff5..8326756 100644 (file)
--- a/TODO
+++ b/TODO
@@ -8,3 +8,5 @@ missing hidden parameter
 form entry has wrong action url
 
 update last in db when we return undef from check_divert
+
+rename to cgi::auth::flexible
index ac41d1e..4c34bc7 100644 (file)
@@ -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 ($$) {
                     '<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">',
@@ -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 ($) {
index 05cc46f..815fa52 100755 (executable)
--- a/test.cgi
+++ b/test.cgi
@@ -9,9 +9,10 @@ use URI;
 my $dump = "$ENV{'CAHTEST_HOME'}/dump";
 
 my $verifier = CGI::Auth::Hybrid->new_verifier(
-   assocdb_path => "$dump/assoc.db",
-   username_password_ok => sub { my ($c,$r,$u,$p)=@_; return $p eq 'sesame'; },
-   encrypted_only => 0,
+    assocdb_path => "$dump/assoc.db",
+    username_password_ok => sub { my ($c,$r,$u,$p)=@_; return $p eq 'sesame'; },
+    encrypted_only => 0,
+    dir => $dump,
 );
 
 END { $verifier->disconnect() if $verifier; }