new generators

[cgi-auth-flexible.git] / cgi-auth-hybrid.pm

diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index 76342e4aef319d4f4cc465b22661ae43ff1762f2..2993bc239c54ddb0a4cb78731a726bc52e9702cc 100644 (file)
--- a/cgi-auth-hybrid.pm
+++ b/cgi-auth-hybrid.pm
@@ -47,6 +47,7 @@ sub new_verifier {
            associdlen => 128, # bits
            login_timeout => 86400, # seconds
            param_name => 'cah_associd',
+           promise_check_mutate => 0,
            cookie_name => 'cah_associd', # make undef to disable cookie
            get_param => sub { $_[0]->param($s->{S}{param_name}) },
            get_cookie => sub { $s->{S}{cookie_name}
@@ -54,7 +55,7 @@ sub new_verifier {
                                : '' },
            get_method => sub { $_[0]->request_method() },
        },
-       D => undef,
+       Dbh => undef,
     };
     my ($k,$v);
     while (($k,$v,@_) = @_) {
@@ -68,7 +69,7 @@ sub new_verifier {
 
 sub _dbopen ($) {
     my ($s) = @_;
-    my $dbh = $s->{D};
+    my $dbh = $s->{Dbh};
     return $dbh if $dbh; 
 
     $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
@@ -79,7 +80,7 @@ sub _dbopen ($) {
                         AutoCommit => 0, RaiseError => 1,
                     });
     die "${assocdb_dsn} $! ?" unless $dbh;
-    $s->{D} = $dbh;
+    $s->{Dbh} = $dbh;
 
     $dbh->do("BEGIN");
 
@@ -104,8 +105,8 @@ sub new_request {
     }
     my $r = {
        S => $classbase->{S},
-       D => $classbase->{D},
-       C => $cgi,
+       Dbh => $classbase->{Dbh},
+       Cgi => $cgi,
     };
     bless $r, ref $classbase;
 }
@@ -113,7 +114,7 @@ sub new_request {
 sub _cm ($$@) {
     my ($r,$methname, @args) = @_;
     my $methfunc = $r->{S}{$methname};
-    return $methfunc->($r->{C}, $r, @args);
+    return $methfunc->($r->{Cgi}, $r, @args);
 }
 
 sub record_login ($$) {
@@ -126,7 +127,7 @@ sub record_login ($$) {
     read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
     close $rsf;
     my $nassoc = unpack "H*", $nassocbin;
-    my $dbh = $r->{D};
+    my $dbh = $r->{Dbh};
     $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
             " (associd, username, last) VALUES (?,?,?)", {},
             $nassoc, $nusername, time);
@@ -138,71 +139,93 @@ sub record_login ($$) {
 sub _check ($) {
     my ($r) = @_;
     my $qassoc = $r->_cm('get_param');
-    if (!defined $qassoc) {
-       $qassoc = $r->_cm('get_cookie');
+    my ($nassoc,$nmutate);
+    if (!defined $r->{S}{cookie_name}) {
+       # authentication is by hidden form parameter only
        return undef unless defined $qassoc;
-       return undef unless $r->_cm('get_method') eq 'GET';
+       $nassoc = $qassoc;
+       $nmutate = 1;
+    } else {
+       # authentication is by cookie
+       # the cookie suffices for read-only GET requests
+       # for mutating and non-GET requests we require hidden param too
+       my $cassoc = $r->_cm('get_cookie');
+       return undef unless defined $cassoc;
+       $nassoc = $cassoc;
+       if (defined $qassoc && $qassoc eq $cassoc) {
+           $nmutate = 1;
+       } else {
+           return undef unless $r->{S}{promise_check_mutate};
+           return undef unless $r->_cm('get_method') eq 'GET';
+           $nmutate = 0;
+       }
     }
-    my $dbh = $r->_dbopen();
+    my $dbh = $r->{Dbh};
     my ($nusername, $nlast) =
        $dbh->selectrow_array("SELECT username, last".
                              " FROM $r->{S}{assocdb_table}".
-                             " WHERE associd = ?", {}, $qassoc);
+                             " WHERE associd = ?", {}, $nassoc);
     return undef unless defined $nusername;
     my $timeout = $r->{S}{login_timeout};
     return undef unless !defined $timeout || time <= $nlast + $timeout;
 
-    return ($nusername, $qassoc);
+    # hooray
+    return ($nusername, $nassoc, $nmutate);
 }
 
 sub check ($) {
     my ($r) = @_;
 
-    my ($nusername, $qassoc) = $r->_check() or return undef;
+    my ($nusername, $nassoc, $nmutate) = $r->_check() or return undef;
 
-    # hooray
     $dbh->do("UPDATE $r->{S}{assocdb_table}".
             " SET last = ?".
-            " WHERE associd = ?", {}, time, $qassoc);
+            " WHERE associd = ?", {}, time, $nassoc);
     $dbh->do("COMMIT");
 
-    $r->{U} = $nusername;
-    $r->{A} = $qassoc;
-    return $username;
+    $r->{Username} = $nusername;
+    $r->{Assoc} = $nassoc;
+    $r->{Mutate} = $nmutate;
+    return $nusername;
+}
+
+sub check_mutate ($) {
+    my ($r) = @_;
 }
 
 sub logout ($) {
     my ($r) = @_;
 
-    if (my ($nusername, $qassoc) = $r->_check()) {
-       $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
-                " WHERE associd = ?", {}, $qassoc);
-       $dbh->do("COMMIT");
-    }
+    my ($nusername, $nassoc, $nmutate) = $r->_check();
+    return undef unless $nmutate;
+    $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
+            " WHERE associd = ?", {}, $nassoc);
+    $dbh->do("COMMIT");
+    return $nusername;
 }
 
 sub username ($) {
     my ($r) = @_;
-    return $r->{U};
+    return $r->{Username};
 
-sub hiddenv ($) {
+sub hidden_val ($) {
     my ($r) = @_;
-    return defined $r->{A} ? $r->{A} : '';
+    return defined $r->{Assoc} ? $r->{Assoc} : '';
 }
 
-sub hiddena ($) {
+sub hidden_hargs ($) {
     my ($r) = @_;
-    return (-name => $r->{param_name},
-           -default => $r->hiddenv());
+    return (-name => $r->{S}{param_name},
+           -default => $r->hidden_val());
 }
 
-sub hiddenh ($) {
+sub hidden_html ($) {
     my ($r) = @_;
-    return hidden($r->hiddena());
+    return hidden($r->hidden_hargs());
 }
 
-sub cookieac ($) {
+sub cookiea_cargs ($) {
     my ($r) = @_;
-    return (-name => $r->{cookie_name},
-           -value => hiddenv());
-           
+    return (-name => $r->{S}{cookie_name},
+           -value => hidden_val());
+}