chiark / gitweb /
wip
[cgi-auth-flexible.git] / cgi-auth-hybrid.pm
1 # -*- perl -*-
2
3 # This is part of CGI::Auth::Hybrid, a perl CGI authentication module.
4 # Copyright (C) 2012 Ian Jackson.
5
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.
10
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.
15
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/>.
18
19 BEGIN {
20     use Exporter   ();
21     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
22
23     $VERSION     = 1.00;
24     @ISA         = qw(Exporter);
25     @EXPORT      = qw();
26     %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
27
28     @EXPORT_OK   = qw(setup);
29 }
30 our @EXPORT_OK;
31
32 use DBI;
33 use CGI;
34
35 #---------- default callbacks ----------
36
37 sub _def_is_logout ($$) {
38     my ($c,$r) = @_;
39     foreach my $pn (@{ $r->{S}{logout_param_names} }) {
40         return 1 if $r->_cm('get_param')($pn);
41     }
42     return 0;
43 }
44
45 #---------- verifier object methods ----------
46
47 sub new_verifier {
48     my $class = shift;
49     my $s = {
50         S => {
51             assocdb_path => 'cah-assocs.db';
52             assocdb_dsn => undef,
53             assocdb_user => '',
54             assocdb_password => '',
55             assocdb_table => 'assocs',
56             random_source => '/dev/urandom',
57             associdlen => 128, # bits
58             login_timeout => 86400, # seconds
59             assoc_param_name => 'cah_associd',
60             password_param_name => 'password',
61             logout_param_names => [qw(logout)],
62             promise_check_mutate => 0,
63             get_param => sub { $_[0]->param($_[2]) },
64             get_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) },
65             get_method => sub { $_[0]->request_method() },
66             is_login => sub { defined $_[1]->_rp('password_param_name') },
67             login_ok => sub { die },
68             is_logout => \&_def_is_logout,
69             is_page => sub { return 1 },
70         },
71         Dbh => undef,
72     };
73     my ($k,$v);
74     while (($k,$v,@_) = @_) {
75         die "unknown setting $k" unless exists $s->{S}{$k};
76         $s->{S}{$k} = $v;
77     }
78     bless $s, $class;
79     $s->_dbopen();
80     return $s;
81 }
82
83 sub _dbopen ($) {
84     my ($s) = @_;
85     my $dbh = $s->{Dbh};
86     return $dbh if $dbh; 
87
88     $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
89
90     my $u = umask 077;
91     $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user}, 
92                      $s->{S}{assocdb_password}, { 
93                          AutoCommit => 0, RaiseError => 1,
94                      });
95     die "${assocdb_dsn} $! ?" unless $dbh;
96     $s->{Dbh} = $dbh;
97
98     $dbh->do("BEGIN");
99
100     eval {
101         $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
102                  " associdh VARCHAR PRIMARY KEY,".
103                  " username VARCHAR,".
104                  " last INTEGER NOT NULL"
105                  ")");
106     };
107     return $dbh;
108 }
109
110 #---------- request object methods ----------
111
112 sub new_request {
113     my ($classbase, $cgi, @extra) = @_;
114     if (!ref $classbase) {
115         $classbase = $classbase->new_verifier(@extra);
116     } else {
117         die if @extra;
118     }
119     my $r = {
120         S => $classbase->{S},
121         Dbh => $classbase->{Dbh},
122         Cgi => $cgi,
123     };
124     bless $r, ref $classbase;
125 }
126
127 sub _ch ($$@) { # calls an application hook
128     my ($r,$methname, @args) = @_;
129     my $methfunc = $r->{S}{$methname};
130     return $methfunc->($r->{Cgi}, $r, @args);
131 }
132
133 sub _rp ($$@) {
134     my ($r,$pnvb) = @_;
135     my $pn = $r->{S}{"${pnvb}_param_name"};
136     my $p = $r->_ch('get_param',$pn)
137 }
138
139 sub _check_core ($) {
140     my ($r) = @_;
141     my $qassoc = $r->_ch('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;
146         $nassoc = $qassoc;
147         $nmutate = 1;
148     } else {
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->_ch('get_cookie');
153         return undef unless defined $cassoc;
154         $nassoc = $cassoc;
155         if (defined $qassoc && $qassoc eq $cassoc) {
156             $nmutate = 1;
157         } else {
158             return undef unless $r->{S}{promise_check_mutate};
159             return undef unless $r->_ch('get_method') eq 'GET';
160             $nmutate = 0;
161         }
162     }
163
164 UP TO HERE
165
166 sub record_login ($$) {
167     my ($r,$nusername) = @_;
168     my $rsp = $r->{S}{random_source};
169     my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
170     my $bytes = ($r->{S}{associdlen} + 7) >> 3;
171     my $nassocbin;
172     $!=0;
173     read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
174     close $rsf;
175     my $nassoc = unpack "H*", $nassocbin;
176     my $dbh = $r->{Dbh};
177     $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
178              " (associd, username, last) VALUES (?,?,?)", {},
179              $nassoc, $nusername, time);
180     $dbh->do("COMMIT");
181     $r->{U} = $nusername;
182     $r->{A} = $nassoc;
183 }
184
185 # pages/param-sets are
186 #   n normal non-mutating page
187 #   r retrieval of information for JS, non-mutating
188 #   m mutating page
189 #   u update of information by JS, mutating
190 #   i login
191 #   o logout
192
193
194 # in cook and par,
195 #    a, aN     anything including -
196 #    t, tN     temporary value (in our db, no logged in user yet)
197 #    y, yN     value corresponds to logged-in user
198 #    n, nN     value not in our db
199 #    x, xN     t or y
200 #    -         no value supplied
201 # if N differs the case applies only when the two values differ
202 # (eg,   a1 y2   does not apply when the logged-in value is supplied twice)
203
204 # "stale session" means request originates from a page from a login
205 # session which has been revoked (eg by logout); "cleared session"
206 # means request originates from a browser which has a different (or
207 # no) cookie.
208
209     # Case analysis, cookie mode, app promises re mutate:
210     # cook par meth  form
211     #                      
212     #  any -   POST  nrmuoi   bug or attack, fail
213     #  any -   GET    rmuoi   bug or attack, fail
214     #  any any GET     muoi   bug or attack, fail
215     #  any t   any   nrmuo    bug or attack, fail
216     #
217     #  a1  a2  POST      o    logout
218     #                           if a1 is valid, revoke it
219     #                           if a2 is valid, revoke it
220     #                           delete cookie
221     #                           redirect to "just logged out" page
222     #                             (which contains link to login form)
223     #
224     #  -   t   POST       i   complain about cookies being disabled
225     #
226     #  -   n   POST       i   complain about stale login form
227     #                           show new login form
228     #
229     #  x1  x2  POST       i   login (or switch user)
230     #                           revoke x1 if it was valid and !=x2
231     #                           upgrade x2 to y2 in our db (setting username)
232     #                           set cookie to x2
233     #                           redirect to GET of remaining params
234     #
235     #  t1  a2  ANY   nrmu     treat as  - a2 ANY
236     #
237     #  y   -   GET   n        cross-site link
238     #                           show data
239     #
240     #  y   y   GET   nr       fine, show page or send data
241     #  y   y   POST  nrmu     mutation is OK, do operation
242     #
243     #  y1  y2  GET   nr       request from stale page
244     #                           do not revoke y2 as not RESTful
245     #                           treat as   y1 n GET
246     #
247     #  y1  y2  POST  nrmu     request from stale page
248     #                           revoke y2
249     #                           treat as   y1 n POST
250     #
251     #  y   n   GET   n        intra-site link from stale page,
252     #                           treat as cross-site link, show data
253     #
254     #  y   n   POST  n m      intra-site form submission from stale page
255     #                           show "session interrupted"
256     #                           with link to main data page
257     #
258     #  y   n   GET    r       intra-site request from stale page
259     #                           fail
260     #
261     #  y   n   POST   r u     intra-site request from stale page
262     #                           fail
263     #
264     #  -/n y2  GET   nr       intra-site link from cleared session
265     #                           do not revoke y2 as not RESTful
266     #                           treat as   -/n n GET
267     #
268     #  -/n y2  POST  nrmu     request from cleared session
269     #                           revoke y2
270     #                           treat as   -/n n POST
271     #
272     #  -/n n   GET   n        cross-site link but user not logged in
273     #                           show login form with redirect to orig params
274     #
275     #  -/n n   GET    rmu     user not logged in
276     #                           fail
277     #
278     #  -/n n   POST  nrmu     user not logged in
279     #                           fail
280
281     my $dbh = $r->{Dbh};
282     my ($nusername, $nlast) =
283         $dbh->selectrow_array("SELECT username, last".
284                               " FROM $r->{S}{assocdb_table}".
285                               " WHERE associd = ?", {}, $nassoc);
286     return undef unless defined $nusername;
287     my $timeout = $r->{S}{login_timeout};
288     return undef unless !defined $timeout || time <= $nlast + $timeout;
289
290     # hooray
291     return ($nusername, $nassoc, $nmutate);
292 }
293
294 sub _check ($) {
295     my ($r) = @_;
296
297     return if exists $r->{Username};
298     ($r->{Username}, $r->{Assoc}, $r->{Mutate}) = $r->_check();
299
300     if (defined $r->{Assoc}) {
301         $dbh->do("UPDATE $r->{S}{assocdb_table}".
302                  " SET last = ?".
303                  " WHERE associd = ?", {}, time, $nassoc);
304         $dbh->do("COMMIT");
305     }
306 }
307
308 sub logout ($) {
309     my ($r) = @_;
310
311     my ($nusername, $nassoc, $nmutate) = $r->_check();
312     return undef unless $nmutate;
313     $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
314              " WHERE associd = ?", {}, $nassoc);
315     $dbh->do("COMMIT");
316     return $nusername;
317 }
318
319 sub check ($) {
320     my ($r) = @_;
321     $r->_check();
322     return !!defined $r->{Username};
323 }
324
325 sub check_mutate ($) {
326     my ($r) = @_;
327     $r->check();
328     return $r->{Mutate};
329 }
330
331 sub username ($) {
332     my ($r) = @_;
333     $r->check();
334     return $r->{Username};
335
336 sub hidden_val ($) {
337     my ($r) = @_;
338     $r->check();
339     return defined $r->{Assoc} ? $r->{Assoc} : '';
340 }
341
342 #---------- simple wrappers ----------
343
344 sub hidden_hargs ($) {
345     my ($r) = @_;
346     return (-name => $r->{S}{param_name},
347             -default => $r->hidden_val());
348 }
349
350 sub hidden_html ($) {
351     my ($r) = @_;
352     return hidden($r->hidden_hargs());
353 }
354
355 sub cookiea_cargs ($) {
356     my ($r) = @_;
357     return (-name => $r->{S}{cookie_name},
358             -value => hidden_val());
359 }
360
361 __END__
362
363 =head1 NAME
364
365 CGI::Auth::Hybrid - web authentication optionally using cookies
366
367 =head1 SYNOPSYS
368
369  my $verifier = CGI::Auth::Hybrid->new_verifier(setting => value,...);
370  my $authreq = $verifier->new_request($cgi_request_object);
371
372  my $authreq = CGI::Auth::Hybrid->new_request($cgi_request_object,
373                                               setting => value,...);
374
375 =head1 USAGE PATTERN FOR SIMPLE APPLICATIONS
376
377  $authreq->check_ok() or return;
378
379  blah blah blah
380  $authreq->mutating();
381  blah blah blah
382
383 =head1 USAGE PATTERN FOR FANCY APPLICATIONS
384
385  my $divert_kind = $authreq->check_divert();
386  if ($divert_kind) {
387      if ($divert_kind eq 'LOGGEDOUT') {
388          print "goodbye you are now logged out" and quit
389      } elsif ($divert_kind eq 'NOCOOKIES') {
390          print "you need cookies" and quit
391      ... etc.
392      }
393  }
394