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;h=bf2bdd65bb73f9f3edd82d0e8ffdba00e0824298;hp=a5630428b13d3551cab3b0ba2ad39432829f3dac;hb=33bc626134e855b61dedc97513f81ee33e738e6a;hpb=5ada8633da1b049cc7339b065abe55462e7e1ab1

diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index a563042..bf2bdd6 100644
--- a/cgi-auth-hybrid.pm
+++ b/cgi-auth-hybrid.pm
@@ -1,5 +1,21 @@
 # -*- perl -*-
 
+# This is part of CGI::Auth::Hybrid, a perl CGI authentication module.
+# Copyright (C) 2012 Ian Jackson.
+# 
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU Affero General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+# 
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU Affero General Public License for more details.
+# 
+# You should have received a copy of the GNU Affero General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
 BEGIN {
     use Exporter   ();
     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
@@ -14,6 +30,7 @@ BEGIN {
 our @EXPORT_OK;
 
 use DBI;
+use CGI;
 
 sub new {
     my $class = shift;
@@ -26,6 +43,7 @@ sub new {
 	    assocdb_table => 'assocs',
 	    random_source => '/dev/urandom',
 	    associdlen => 128, # bits
+	    login_timeout => 86400, # seconds
 	    param_name => 'cah_associd',
 	    cookie_name => 'cah_associd', # make undef to disable cookie
 	    cgi => undef,
@@ -71,7 +89,8 @@ sub _dbopen ($) {
     eval {
 	$dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
 		 " associd VARCHAR PRIMARY KEY,".
-                 " username VARCHAR".
+                 " username VARCHAR,".
+		 " last INTEGER"
 		 ")");
     };
     return $dbh;
@@ -89,18 +108,81 @@ sub record_login ($$) {
     my $nassoc = unpack "H*", $nassocbin;
     my $dbh = $s->_dbopen();
     $dbh->do("INSERT INTO $s->{S}{assocdb_table}".
-	     " (associd, username) VALUES (?,?)", {},
-	     $nassoc, $nusername);
+	     " (associd, username, last) VALUES (?,?,?)", {},
+	     $nassoc, $nusername, time);
     $dbh->do("COMMIT");
-    $username = $nusername;
-    $assoc =    $nassoc;
+    $s->{U} = $nusername;
+    $s->{A} = $nassoc;
+}
+
+sub _check ($) {
+    my ($s) = @_;
+    my $qassoc = $s->{S}{param_get}();
+    if (!defined $qassoc) {
+	$qassoc = $s->{S}{cookie_get}();
+	return undef unless defined $qassoc;
+	return undef unless $s->{S}{get_method}() eq 'GET';
+    }
+    my $dbh = $s->_dbopen();
+    my ($nusername, $nlast) =
+	$dbh->selectrow_array("SELECT username, last".
+			      " FROM $s->{S}{assocdb_table}".
+			      " WHERE associd = ?", {}, $qassoc);
+    return undef unless defined $nusername;
+    my $timeout = $s->{S}{login_timeout};
+    return undef unless !defined $timeout || time <= $nlast + $timeout;
+
+    return ($nusername, $qassoc);
 }
 
-sub check () {
-    my $qassocid = $s->{S}{param_get}();
-    if (!defined $qassocid) {
-	$qassocid = $s->{S}{cookie_get}();
-	return 0 unless defined $qassocid;
-	return 0 unless $s->{S}{get_method}() eq 'GET';
+sub check ($) {
+    my ($s) = @_;
+
+    my ($nusername, $qassoc) = $s->_check() or return undef;
+
+    # hooray
+    $dbh->do("UPDATE $s->{S}{assocdb_table}".
+	     " SET last = ?".
+	     " WHERE associd = ?", {}, time, $qassoc);
+    $dbh->do("COMMIT");
+
+    $s->{U} = $nusername;
+    $s->{A} = $qassoc;
+    return $username;
+}
+
+sub logout ($) {
+    my ($s) = @_;
+
+    if (my ($nusername, $qassoc) = $s->_check()) {
+	$dbh->do("DELETE FROM $s->{S}{assocdb_table}".
+		 " WHERE associd = ?", {}, $qassoc);
+	$dbh->do("COMMIT");
     }
-    
+}
+
+sub username ($) {
+    my ($s) = @_;
+    return $s->{U};
+
+sub hiddenv ($) {
+    my ($s) = @_;
+    return defined $s->{A} ? $s->{A} : '';
+}
+
+sub hiddena ($) {
+    my ($s) = @_;
+    return (-name => $s->{param_name},
+	    -default => $s->hiddenv());
+}
+
+sub hiddenh ($) {
+    my ($s) = @_;
+    return hidden($s->hiddena());
+}
+
+sub cookieac ($) {
+    my ($s) = @_;
+    return (-name => $s->{cookie_name},
+	    -value => hiddenv());
+