X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;f=cgi-auth-hybrid.pm;h=af0e08359441601ec4e8e8ec5442607a156e377c;hb=bf40b8616e19346bb283dc19af15b2d603d58ef1;hp=44058fc71cf93e80a7007b2c48396d101e59accb;hpb=e0b5d2156bf63b93189ce95ca70467300059c6e9;p=cgi-auth-flexible.git diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm index 44058fc..af0e083 100644 --- a/cgi-auth-hybrid.pm +++ b/cgi-auth-hybrid.pm @@ -1,5 +1,21 @@ # -*- perl -*- +# This is part of CGI::Auth::Hybrid, a perl CGI authentication module. +# Copyright (C) 2012 Ian Jackson. +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU Affero General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Affero General Public License for more details. +# +# You should have received a copy of the GNU Affero General Public License +# along with this program. If not, see . + BEGIN { use Exporter (); our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); @@ -13,74 +29,366 @@ BEGIN { } our @EXPORT_OK; -our %_s = ( - assocdb_path => 'cah-assocs.db'; - assocdb_dsn => undef, - assocdb_user => '', - assocdb_password => '', - assocdb_table => 'assocs', - random_source => '/dev/urandom', - associdlen => 128, # bits - param_name => 'cah_associd', - cookie_name => 'cah_associd', # make undef to disable cookie - param_get => sub { _c()->param($s_{param_name}) }, - cookie_get => sub { $_s{cookie_name} ? _c()->param($s_{cookie_name}) : '' }, - ); - use DBI; +use CGI; + +#---------- default callbacks ---------- + +sub _def_is_logout ($$) { + my ($c,$r) = @_; + foreach my $pn (@{ $r->{S}{logout_param_names} }) { + return 1 if $r->_cm('get_param')($pn); + } + return 0; +} -our $dbh; +#---------- verifier object methods ---------- -sub new { +sub new_verifier { + my $class = shift; + my $s = { + S => { + assocdb_path => 'cah-assocs.db'; + assocdb_dsn => undef, + assocdb_user => '', + assocdb_password => '', + assocdb_table => 'assocs', + random_source => '/dev/urandom', + associdlen => 128, # bits + login_timeout => 86400, # seconds + assoc_param_name => 'cah_associd', + password_param_name => 'password', + logout_param_names => [qw(logout)], + promise_check_mutate => 0, + get_param => sub { $_[0]->param($_[2]) }, + get_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) }, + get_method => sub { $_[0]->request_method() }, + is_login => sub { defined $_[1]->_rp('password_param_name') }, + login_ok => sub { die }, + is_logout => \&_def_is_logout, + is_page => sub { return 1 }, + }, + Dbh => undef, + }; my ($k,$v); while (($k,$v,@_) = @_) { - die "unknown setting $k" unless %_s{$k}; - $_s{$k} = $v; + die "unknown setting $k" unless exists $s->{S}{$k}; + $s->{S}{$k} = $v; } + bless $s, $class; + $s->_dbopen(); + return $s; } -sub _dbopen () { - return if $dbh; +sub _dbopen ($) { + my ($s) = @_; + my $dbh = $s->{Dbh}; + return $dbh if $dbh; - $_s{assocdb_dsn}="dbi:SQLite:dbname=$s_{assocdb_path}" - if !$_s{assocdb_dsn}; + $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}"; my $u = umask 077; - $dbh = DBI->open($_s{assocdb_dsn}, $s_{assocdb_user}, - $s_{assocdb_password}, { + $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user}, + $s->{S}{assocdb_password}, { AutoCommit => 0, RaiseError => 1, }); die "${assocdb_dsn} $! ?" unless $dbh; + $s->{Dbh} = $dbh; $dbh->do("BEGIN"); eval { - $dbh->do("CREATE TABLE $_s{assocdb_table} (". - " associd VARCHAR PRIMARY KEY,". - " username VARCHAR". + $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (". + " associdh VARCHAR PRIMARY KEY,". + " username VARCHAR,". + " last INTEGER NOT NULL" ")"); }; + return $dbh; +} + +#---------- request object methods ---------- + +sub new_request { + my ($classbase, $cgi, @extra) = @_; + if (!ref $classbase) { + $classbase = $classbase->new_verifier(@extra); + } else { + die if @extra; + } + my $r = { + S => $classbase->{S}, + Dbh => $classbase->{Dbh}, + Cgi => $cgi, + }; + bless $r, ref $classbase; +} + +sub _ch ($$@) { # calls an application hook + my ($r,$methname, @args) = @_; + my $methfunc = $r->{S}{$methname}; + return $methfunc->($r->{Cgi}, $r, @args); +} + +sub _rp ($$@) { + my ($r,$pnvb) = @_; + my $pn = $r->{S}{"${pnvb}_param_name"}; + my $p = $r->_ch('get_param',$pn) } -sub record_login ($) { - my ($nusername) = @_; - my $rs = new IO::File $_s{random_source}, '<' - or die "$_s{random_source} $!"; - my $bytes = ($_s{associdlen} + 7) >> 3; +# pages/param-sets are +# n normal non-mutating page +# r retrieval of information for JS, non-mutating +# m mutating page +# u update of information by JS, mutating +# i login +# o logout + + +# in cook and par, +# a, aN anything including - +# t, tN temporary value (in our db, no logged in user yet) +# y, yN value corresponds to logged-in user +# n, nN value not in our db +# x, xN t or y +# - no value supplied +# if N differs the case applies only when the two values differ +# (eg, a1 y2 does not apply when the logged-in value is supplied twice) + +# "stale session" means request originates from a page from a login +# session which has been revoked (eg by logout); "cleared session" +# means request originates from a browser which has a different (or +# no) cookie. + + # Case analysis, cookie mode, app promises re mutate: + # cook par meth form + # + # any - POST nrmuoi bug or attack, fail + # any - GET rmuoi bug or attack, fail + # any any GET muoi bug or attack, fail + # any t any nrmuo bug or attack, fail + # + # a1 a2 POST o logout + # if a1 is valid, revoke it + # if a2 is valid, revoke it + # delete cookie + # redirect to "just logged out" page + # (which contains link to login form) + # + # - t POST i complain about cookies being disabled + # + # - n POST i complain about stale login form + # show new login form + # + # x1 x2 POST i login (or switch user) + # revoke x1 if it was valid and !=x2 + # upgrade x2 to y2 in our db (setting username) + # set cookie to x2 + # redirect to GET of remaining params + # + # t1 a2 ANY nrmu treat as - a2 ANY + # + # y - GET n cross-site link + # show data + # + # y y GET nr fine, show page or send data + # y y POST nrmu mutation is OK, do operation + # + # y1 y2 GET nr request from stale page + # do not revoke y2 as not RESTful + # treat as y1 n GET + # + # y1 y2 POST nrmu request from stale page + # revoke y2 + # treat as y1 n POST + # + # y n GET n intra-site link from stale page, + # treat as cross-site link, show data + # + # y n POST n m intra-site form submission from stale page + # show "session interrupted" + # with link to main data page + # + # y n GET r intra-site request from stale page + # fail + # + # y n POST r u intra-site request from stale page + # fail + # + # -/n y2 GET nr intra-site link from cleared session + # do not revoke y2 as not RESTful + # treat as -/n n GET + # + # -/n y2 POST nrmu request from cleared session + # revoke y2 + # treat as -/n n POST + # + # -/n n GET n cross-site link but user not logged in + # show login form with redirect to orig params + # + # -/n n GET rmu user not logged in + # fail + # + # -/n n POST nrmu user not logged in + # fail + +sub _check_core ($) { + my ($r) = @_; + my $qassoc = $r->_ch('get_param'); + my ($nassoc,$nmutate); + if (!defined $r->{S}{cookie_name}) { + # authentication is by hidden form parameter only + return undef unless defined $qassoc; + $nassoc = $qassoc; + $nmutate = 1; + } else { + # authentication is by cookie + # the cookie suffices for read-only GET requests + # for mutating and non-GET requests we require hidden param too + my $cassoc = $r->_ch('get_cookie'); + return undef unless defined $cassoc; + $nassoc = $cassoc; + if (defined $qassoc && $qassoc eq $cassoc) { + $nmutate = 1; + } else { + return undef unless $r->{S}{promise_check_mutate}; + return undef unless $r->_ch('get_method') eq 'GET'; + $nmutate = 0; + } + } + +UP TO HERE + + my $dbh = $r->{Dbh}; + my ($nusername, $nlast) = + $dbh->selectrow_array("SELECT username, last". + " FROM $r->{S}{assocdb_table}". + " WHERE associd = ?", {}, $nassoc); + return undef unless defined $nusername; + my $timeout = $r->{S}{login_timeout}; + return undef unless !defined $timeout || time <= $nlast + $timeout; + + # hooray + return ($nusername, $nassoc, $nmutate); +} + +sub record_login ($$) { + my ($r,$nusername) = @_; + my $rsp = $r->{S}{random_source}; + my $rsf = new IO::File $rsp, '<' or die "$rsp $!"; + my $bytes = ($r->{S}{associdlen} + 7) >> 3; my $nassocbin; $!=0; - read($rs,$nassocbin,$bytes) == $bytes or die "$s_{random_source} $!"; + read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!"; + close $rsf; my $nassoc = unpack "H*", $nassocbin; - _dbopen(); - $dbh->do("INSERT INTO $_s{assocdb_table}". - " (associd, username) VALUES (?,?)", {}, - $nassoc, $nusername); + my $dbh = $r->{Dbh}; + $dbh->do("INSERT INTO $r->{S}{assocdb_table}". + " (associd, username, last) VALUES (?,?,?)", {}, + $nassoc, $nusername, time); $dbh->do("COMMIT"); - $username = $nusername; - $assoc = $nassoc; + $r->{U} = $nusername; + $r->{A} = $nassoc; } -sub check () { - my $passocid = $_s{param_get}(); - my $cassocid = $_s{cookie_get}(); - if ( +sub _check ($) { + my ($r) = @_; + + return if exists $r->{Username}; + ($r->{Username}, $r->{Assoc}, $r->{Mutate}) = $r->_check(); + + if (defined $r->{Assoc}) { + $dbh->do("UPDATE $r->{S}{assocdb_table}". + " SET last = ?". + " WHERE associd = ?", {}, time, $nassoc); + $dbh->do("COMMIT"); + } +} + +sub logout ($) { + my ($r) = @_; + + my ($nusername, $nassoc, $nmutate) = $r->_check(); + return undef unless $nmutate; + $dbh->do("DELETE FROM $r->{S}{assocdb_table}". + " WHERE associd = ?", {}, $nassoc); + $dbh->do("COMMIT"); + return $nusername; +} + +sub check ($) { + my ($r) = @_; + $r->_check(); + return !!defined $r->{Username}; +} + +sub check_mutate ($) { + my ($r) = @_; + $r->check(); + return $r->{Mutate}; +} + +sub username ($) { + my ($r) = @_; + $r->check(); + return $r->{Username}; + +sub hidden_val ($) { + my ($r) = @_; + $r->check(); + return defined $r->{Assoc} ? $r->{Assoc} : ''; +} + +#---------- simple wrappers ---------- + +sub hidden_hargs ($) { + my ($r) = @_; + return (-name => $r->{S}{param_name}, + -default => $r->hidden_val()); +} + +sub hidden_html ($) { + my ($r) = @_; + return hidden($r->hidden_hargs()); +} + +sub cookiea_cargs ($) { + my ($r) = @_; + return (-name => $r->{S}{cookie_name}, + -value => hidden_val()); +} + +__END__ + +=head1 NAME + +CGI::Auth::Hybrid - web authentication optionally using cookies + +=head1 SYNOPSYS + + my $verifier = CGI::Auth::Hybrid->new_verifier(setting => value,...); + my $authreq = $verifier->new_request($cgi_request_object); + + my $authreq = CGI::Auth::Hybrid->new_request($cgi_request_object, + setting => value,...); + +=head1 USAGE PATTERN FOR SIMPLE APPLICATIONS + + $authreq->check_ok() or return; + + blah blah blah + $authreq->mutating(); + blah blah blah + +=head1 USAGE PATTERN FOR FANCY APPLICATIONS + + my $divert_kind = $authreq->check_divert(); + if ($divert_kind) { + if ($divert_kind eq 'LOGGEDOUT') { + print "goodbye you are now logged out" and quit + } elsif ($divert_kind eq 'NOCOOKIES') { + print "you need cookies" and quit + ... etc. + } + } +