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
172 # Case analysis, cookie mode, app promises re mutate:
175 # y y GET nr fine, show page or send data
177 # y - GET n cross-site link
179 # y1 y2 GET n intra-site link
180 # from session no longer known to browser
181 # do not revoke y2 as not a POST so not RESTful
182 # treat as cross-site link, show data
183 # y n GET n intra-site link from stale session,
184 # treat as cross-site link, show data
186 # y - GET r bug or attack, fail
187 # y1 y2 GET r intra-site data request
188 # from session no longer known to browser
189 # do not revoke y2 as not a POST so not RESTful
191 # y n GET r intra-site data request from stale session
194 # - y GET n CLEAR COOKIES TO LOGOUT OPTION
196 # -/n any GET n cross-site link but user not logged in
199 # -/n any GET r data request from stale session
202 # any any GET muoi bug or attack, fail
204 # y y POST nrmu mutation is OK, do operation
206 # y y POST i login, redirect to GET of remaining params
208 # any - POST bug or xsrf attack, fail
210 # n/y1 y2 POST r intra-site form submission
211 # from session no longer known to browser
213 # show "session interrupted"
214 # n/y1 y2 POST m intra-site js operation
215 # from session no longer known to browser
218 # y n POST r intra-site form submission from stale session
219 # show "session interrupted"
220 # y n POST m intra-site form submission from stale session
223 # - y2 GET intra-site link or data request
224 # from session no longer known to browser
227 # - y2 any req from old session y2, del y2, show login
228 # y1 y2 any req from old session y2, del y2, show y1 main
230 # y1 any GET non-mut cross-site link
231 # y1 any GET non-mut no mutation, show page providing new par
233 # A B any page from old session or cross-site request
234 # any y2 POST logout do logout y2
237 # any any GET mutate bug or attack, forbidden, call die
240 my ($nusername, $nlast) =
241 $dbh->selectrow_array("SELECT username, last".
242 " FROM $r->{S}{assocdb_table}".
243 " WHERE associd = ?", {}, $nassoc);
244 return undef unless defined $nusername;
245 my $timeout = $r->{S}{login_timeout};
246 return undef unless !defined $timeout || time <= $nlast + $timeout;
249 return ($nusername, $nassoc, $nmutate);
255 return if exists $r->{Username};
256 ($r->{Username}, $r->{Assoc}, $r->{Mutate}) = $r->_check();
258 if (defined $r->{Assoc}) {
259 $dbh->do("UPDATE $r->{S}{assocdb_table}".
261 " WHERE associd = ?", {}, time, $nassoc);
269 my ($nusername, $nassoc, $nmutate) = $r->_check();
270 return undef unless $nmutate;
271 $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
272 " WHERE associd = ?", {}, $nassoc);
280 return !!defined $r->{Username};
283 sub check_mutate ($) {
292 return $r->{Username};
297 return defined $r->{Assoc} ? $r->{Assoc} : '';
300 #---------- simple wrappers ----------
302 sub hidden_hargs ($) {
304 return (-name => $r->{S}{param_name},
305 -default => $r->hidden_val());
308 sub hidden_html ($) {
310 return hidden($r->hidden_hargs());
313 sub cookiea_cargs ($) {
315 return (-name => $r->{S}{cookie_name},
316 -value => hidden_val());
323 CGI::Auth::Hybrid - web authentication optionally using cookies
327 my $verifier = CGI::Auth::Hybrid->new_verifier(setting => value,...);
328 my $authreq = $verifier->new_request($cgi_request_object);
330 my $authreq = CGI::Auth::Hybrid->new_request($cgi_request_object,
331 setting => value,...);
333 =head1 USAGE PATTERN FOR SIMPLE APPLICATIONS
335 if ( form submission is login request ) {
336 check login details, if wrong print error and quit
337 $authreq->record_login(...username...);
339 if ( form submission is logout request ) {
340 my $logged_out_user = $authreq->logout();
341 if (!defined $logged_out_user) {
342 print "you are not logged in" error and quit
344 print "goodbye $username you are now logged out" and quit
347 if ( !$authreq->check() ) {
348 display login form, quit
351 =head1 USAGE PATTERN FOR FANCY APPLICATIONS
353 if ( form submission is login request ) {
354 check login details, if wrong print error and quit
355 $authreq->record_login(...username...);
357 if ( !$authreq->check() ) {
358 display login form, quit
359 if ( form submission is logout request ) {
360 die unless $authreq->mutate();
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
371 - user can sort of log out by clearing cookies
372 - sophisticated applications can have get-requests