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 promise_check_mutate => 0,
51 cookie_name => 'cah_associd', # make undef to disable cookie
52 get_param => sub { $_[0]->param($s->{S}{param_name}) },
53 get_cookie => sub { $s->{S}{cookie_name}
54 ? $_[0]->cookie($s->{S}{cookie_name})
56 get_method => sub { $_[0]->request_method() },
61 while (($k,$v,@_) = @_) {
62 die "unknown setting $k" unless exists $s->{S}{$k};
75 $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
78 $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user},
79 $s->{S}{assocdb_password}, {
80 AutoCommit => 0, RaiseError => 1,
82 die "${assocdb_dsn} $! ?" unless $dbh;
88 $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
89 " associd VARCHAR PRIMARY KEY,".
97 #---------- request object methods ----------
100 my ($classbase, $cgi, @extra) = @_;
101 if (!ref $classbase) {
102 $classbase = $classbase->new_verifier(@extra);
107 S => $classbase->{S},
108 Dbh => $classbase->{Dbh},
111 bless $r, ref $classbase;
115 my ($r,$methname, @args) = @_;
116 my $methfunc = $r->{S}{$methname};
117 return $methfunc->($r->{Cgi}, $r, @args);
120 sub record_login ($$) {
121 my ($r,$nusername) = @_;
122 my $rsp = $r->{S}{random_source};
123 my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
124 my $bytes = ($r->{S}{associdlen} + 7) >> 3;
127 read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
129 my $nassoc = unpack "H*", $nassocbin;
131 $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
132 " (associd, username, last) VALUES (?,?,?)", {},
133 $nassoc, $nusername, time);
135 $r->{U} = $nusername;
141 my $qassoc = $r->_cm('get_param');
142 my ($nassoc,$nmutate);
143 if (!defined $r->{S}{cookie_name}) {
144 # authentication is by hidden form parameter only
145 return undef unless defined $qassoc;
149 # authentication is by cookie
150 # the cookie suffices for read-only GET requests
151 # for mutating and non-GET requests we require hidden param too
152 my $cassoc = $r->_cm('get_cookie');
153 return undef unless defined $cassoc;
155 if (defined $qassoc && $qassoc eq $cassoc) {
158 return undef unless $r->{S}{promise_check_mutate};
159 return undef unless $r->_cm('get_method') eq 'GET';
164 my ($nusername, $nlast) =
165 $dbh->selectrow_array("SELECT username, last".
166 " FROM $r->{S}{assocdb_table}".
167 " WHERE associd = ?", {}, $nassoc);
168 return undef unless defined $nusername;
169 my $timeout = $r->{S}{login_timeout};
170 return undef unless !defined $timeout || time <= $nlast + $timeout;
173 return ($nusername, $nassoc, $nmutate);
179 my ($nusername, $nassoc, $nmutate) = $r->_check() or return undef;
181 $dbh->do("UPDATE $r->{S}{assocdb_table}".
183 " WHERE associd = ?", {}, time, $nassoc);
186 $r->{Username} = $nusername;
187 $r->{Assoc} = $nassoc;
188 $r->{Mutate} = $nmutate;
192 sub check_mutate ($) {
199 my ($nusername, $nassoc, $nmutate) = $r->_check();
200 return undef unless $nmutate;
201 $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
202 " WHERE associd = ?", {}, $nassoc);
209 return $r->{Username};
213 return defined $r->{A} ? $r->{A} : '';
218 return (-name => $r->{param_name},
219 -default => $r->hiddenv());
224 return hidden($r->hiddena());
229 return (-name => $r->{cookie_name},
230 -value => hiddenv());