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;
139 sub _check_core ($) {
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 # pages/param-sets are
165 # n normal non-mutating page
166 # r retrieval of information for JS, non-mutating
168 # u update of information by JS, mutating
174 # a, aN anything including -
175 # t, tN temporary value (in our db, no logged in user yet)
176 # y, yN value corresponds to logged-in user
177 # n, nN value not in our db
179 # - no value supplied
180 # if N differs the case applies only when the two values differ
181 # (eg, a1 y2 does not apply when the logged-in value is supplied twice)
183 # "stale session" means request originates from a page from a login
184 # session which has been revoked (eg by logout); "cleared session"
185 # means request originates from a browser which has a different (or
188 # Case analysis, cookie mode, app promises re mutate:
191 # any - POST nrmuoi bug or attack, fail
192 # any - GET rmuoi bug or attack, fail
193 # any any GET muoi bug or attack, fail
194 # any t any nrmuo bug or attack, fail
196 # a1 a2 POST o logout
197 # if a1 is valid, revoke it
198 # if a2 is valid, revoke it
200 # redirect to "just logged out" page
201 # (which contains link to login form)
203 # - t POST i complain about cookies being disabled
205 # - n POST i complain about stale login form
206 # show new login form
208 # x1 x2 POST i login (or switch user)
209 # revoke x1 if it was valid and !=x2
210 # upgrade x2 to y2 in our db (setting username)
212 # redirect to GET of remaining params
214 # t1 a2 ANY nrmu treat as - a2 ANY
216 # y - GET n cross-site link
219 # y y GET nr fine, show page or send data
220 # y y POST nrmu mutation is OK, do operation
222 # y1 y2 GET nr request from stale page
223 # do not revoke y2 as not RESTful
226 # y1 y2 POST nrmu request from stale page
230 # y n GET n intra-site link from stale page,
231 # treat as cross-site link, show data
233 # y n POST n m intra-site form submission from stale page
234 # show "session interrupted"
235 # with link to main data page
237 # y n GET r intra-site request from stale page
240 # y n POST r u intra-site request from stale page
243 # -/n y2 GET nr intra-site link from cleared session
244 # do not revoke y2 as not RESTful
247 # -/n y2 POST nrmu request from cleared session
249 # treat as -/n n POST
251 # -/n n GET n cross-site link but user not logged in
252 # show login form with redirect to orig params
254 # -/n n GET rmu user not logged in
257 # -/n n POST nrmu user not logged in
261 my ($nusername, $nlast) =
262 $dbh->selectrow_array("SELECT username, last".
263 " FROM $r->{S}{assocdb_table}".
264 " WHERE associd = ?", {}, $nassoc);
265 return undef unless defined $nusername;
266 my $timeout = $r->{S}{login_timeout};
267 return undef unless !defined $timeout || time <= $nlast + $timeout;
270 return ($nusername, $nassoc, $nmutate);
276 return if exists $r->{Username};
277 ($r->{Username}, $r->{Assoc}, $r->{Mutate}) = $r->_check();
279 if (defined $r->{Assoc}) {
280 $dbh->do("UPDATE $r->{S}{assocdb_table}".
282 " WHERE associd = ?", {}, time, $nassoc);
290 my ($nusername, $nassoc, $nmutate) = $r->_check();
291 return undef unless $nmutate;
292 $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
293 " WHERE associd = ?", {}, $nassoc);
301 return !!defined $r->{Username};
304 sub check_mutate ($) {
313 return $r->{Username};
318 return defined $r->{Assoc} ? $r->{Assoc} : '';
321 #---------- simple wrappers ----------
323 sub hidden_hargs ($) {
325 return (-name => $r->{S}{param_name},
326 -default => $r->hidden_val());
329 sub hidden_html ($) {
331 return hidden($r->hidden_hargs());
334 sub cookiea_cargs ($) {
336 return (-name => $r->{S}{cookie_name},
337 -value => hidden_val());
344 CGI::Auth::Hybrid - web authentication optionally using cookies
348 my $verifier = CGI::Auth::Hybrid->new_verifier(setting => value,...);
349 my $authreq = $verifier->new_request($cgi_request_object);
351 my $authreq = CGI::Auth::Hybrid->new_request($cgi_request_object,
352 setting => value,...);
354 =head1 USAGE PATTERN FOR SIMPLE APPLICATIONS
356 if ( form submission is login request ) {
357 check login details, if wrong print error and quit
358 $authreq->record_login(...username...);
360 if ( form submission is logout request ) {
361 my $logged_out_user = $authreq->logout();
362 if (!defined $logged_out_user) {
363 print "you are not logged in" error and quit
365 print "goodbye $username you are now logged out" and quit
368 if ( !$authreq->check() ) {
369 display login form, quit
372 =head1 USAGE PATTERN FOR FANCY APPLICATIONS
374 if ( form submission is login request ) {
375 check login details, if wrong print error and quit
376 $authreq->record_login(...username...);
378 if ( !$authreq->check() ) {
379 display login form, quit
380 if ( form submission is logout request ) {
381 die unless $authreq->mutate();
382 my $logged_out_user = $authreq->logout();
383 if (!defined $logged_out_user) {
384 print "you are not logged in" error and quit
386 print "goodbye $username you are now logged out" and quit
392 - user can sort of log out by clearing cookies
393 - sophisticated applications can have get-requests