3 # This is part of CGI::Auth::Hybrid, a perl CGI authentication module.
4 # Copyright (C) 2012 Ian Jackson.
6 # This program is free software: you can redistribute it and/or modify
7 # it under the terms of the GNU Affero General Public License as published by
8 # the Free Software Foundation, either version 3 of the License, or
9 # (at your option) any later version.
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU Affero General Public License for more details.
16 # You should have received a copy of the GNU Affero General Public License
17 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
26 %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
28 @EXPORT_OK = qw(setup);
35 #---------- verifier object methods ----------
41 assocdb_path => 'cah-assocs.db';
44 assocdb_password => '',
45 assocdb_table => 'assocs',
46 random_source => '/dev/urandom',
47 associdlen => 128, # bits
48 login_timeout => 86400, # seconds
49 param_name => 'cah_associd',
50 cookie_name => 'cah_associd', # make undef to disable cookie
51 get_param => sub { $_[0]->param($s->{S}{param_name}) },
52 get_cookie => sub { $s->{S}{cookie_name}
53 ? $_[0]->cookie($s->{S}{cookie_name})
55 get_method => sub { $_[0]->request_method() },
60 while (($k,$v,@_) = @_) {
61 die "unknown setting $k" unless exists $s->{S}{$k};
74 $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
77 $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user},
78 $s->{S}{assocdb_password}, {
79 AutoCommit => 0, RaiseError => 1,
81 die "${assocdb_dsn} $! ?" unless $dbh;
87 $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
88 " associd VARCHAR PRIMARY KEY,".
96 #---------- request object methods ----------
99 my ($classbase, $cgi, @extra) = @_;
100 if (!ref $classbase) {
101 $classbase = $classbase->new_verifier(@extra);
106 S => $classbase->{S},
107 Dbh => $classbase->{Dbh},
110 bless $r, ref $classbase;
114 my ($r,$methname, @args) = @_;
115 my $methfunc = $r->{S}{$methname};
116 return $methfunc->($r->{Cgi}, $r, @args);
119 sub record_login ($$) {
120 my ($r,$nusername) = @_;
121 my $rsp = $r->{S}{random_source};
122 my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
123 my $bytes = ($r->{S}{associdlen} + 7) >> 3;
126 read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
128 my $nassoc = unpack "H*", $nassocbin;
130 $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
131 " (associd, username, last) VALUES (?,?,?)", {},
132 $nassoc, $nusername, time);
134 $r->{U} = $nusername;
140 my $qassoc = $r->_cm('get_param');
141 if (!defined $qassoc) {
142 $qassoc = $r->_cm('get_cookie');
143 return undef unless defined $qassoc;
144 return undef unless $r->_cm('get_method') eq 'GET';
146 my $dbh = $r->_dbopen();
147 my ($nusername, $nlast) =
148 $dbh->selectrow_array("SELECT username, last".
149 " FROM $r->{S}{assocdb_table}".
150 " WHERE associd = ?", {}, $qassoc);
151 return undef unless defined $nusername;
152 my $timeout = $r->{S}{login_timeout};
153 return undef unless !defined $timeout || time <= $nlast + $timeout;
155 return ($nusername, $qassoc);
161 my ($nusername, $qassoc) = $r->_check() or return undef;
164 $dbh->do("UPDATE $r->{S}{assocdb_table}".
166 " WHERE associd = ?", {}, time, $qassoc);
169 $r->{U} = $nusername;
177 if (my ($nusername, $qassoc) = $r->_check()) {
178 $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
179 " WHERE associd = ?", {}, $qassoc);
190 return defined $r->{A} ? $r->{A} : '';
195 return (-name => $r->{param_name},
196 -default => $r->hiddenv());
201 return hidden($r->hiddena());
206 return (-name => $r->{cookie_name},
207 -value => hiddenv());