fixes

diff --git a/TODO b/TODO
index b39dff53969e2b7813a434ff85e9ceb21c324e7f..832675646b5270180fe388656ff1b354952a1930 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
 form entry has wrong action url
 
 update last in db when we return undef from check_divert

+
+rename to cgi::auth::flexible

diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index ac41d1e58b284046db95b9b7a164e32e0753576e..4c34bc7966393dbc025f15bba82336454300ccd6 100644 (file)
--- 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 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 ----------
 use Data::Dumper;
 
 #---------- public utilities ----------


@@ -115,7 +119,7 @@ sub gen_plain_login_form ($$) {
                     '<td><input type="text" '.$sz.
                     ' name='.$up.'></td></tr>');
     }
                     '<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">',
                 '<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 => {
     my $class = shift;
     my $verifier = {
        S => {

+            dir => undef,

            assocdb_path => 'cah-assocs.db',
            keys_path => 'cah-keys',
            assocdb_dsn => 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; 
 
     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 $dsn = $v->{S}{assocdb_dsn};
 
     my $u = umask 077;


@@ -313,6 +318,15 @@ sub _rp ($$@) {
     my $p = scalar $r->_ch('get_param',$pn)
 }
 
     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); }
 
 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 $!";
     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 $!";
     }
     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 $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>) {
     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;
         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) = @_;
 
 sub _open_keys ($) {
     my ($r) = @_;

-    my $spath = $r->{S}{secrets_path};
+    my $spath = $r->_get_path('keys');

     for (;;) {
     for (;;) {

+ print STDERR "_open_keys\n";

         my $keys = new IO::File $spath, 'r+';
         if ($keys) {
         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];
             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) {
         }
         # 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];
             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
             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];
         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!
         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
         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)) {
         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 $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
         # 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";
     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;
 }
 
 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) = @_;
     $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();
 }
     $digest->add($message);
     return $digest->hexdigest();
 }


@@ -867,7 +899,7 @@ sub secret_cookie_val ($) {
 sub secret_hidden_val ($) {
     my ($r) = @_;
     $r->_assert_checked();
 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 ($) {
 }
 
 sub secret_hidden_html ($) {

diff --git a/test.cgi b/test.cgi
index 05cc46ffa219425f27ccc3d87968e094079652e6..815fa524c47539c26f361e3b21fbeeb917bacc79 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(
 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; }
 );
 
 END { $verifier->disconnect() if $verifier; }