X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;f=cgi-auth-hybrid.pm;h=f8c74ae63789b83927451bd939d761ed0c01a16c;hb=21e5e43683e3b969da7fd68669852634f43d34d5;hp=a5630428b13d3551cab3b0ba2ad39432829f3dac;hpb=5ada8633da1b049cc7339b065abe55462e7e1ab1;p=cgi-auth-flexible.git diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm index a563042..f8c74ae 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); @@ -14,8 +30,61 @@ BEGIN { our @EXPORT_OK; use DBI; +use CGI; + +#---------- default callbacks ---------- + +sub has_a_param ($$) { + my ($c,$cn) = @_; + foreach my $pn (@{ $r->{S}{$cn} }) { + return 1 if $r->_cm('get_param')($pn); + } + return 0; +} + +sub get_param_list ($$) { + my ($c) = @_; + my @p = ( ); + foreach my $name ($c->param()) { + foreach my $val ($c->param($name)) { + push @p, $name, $val; + } + } + return @p; +} + +sub get_cookie_domain ($$$) { + my ($c,$r) = @_; + my $uri = new URI $r->_ch('get_url'); + return $uri->host(); +} + +sub construct_cookie ($$$) { + my ($c, $r, $cookv) = @_; + return $c->cookie(-name => $r->{S}{cookie_name}, + -value => $cookv, + -path => $r->{S}{cookie_path}, + -domain => $r->_ch('get_cookie_domain'), + -expires => '+'.$r->{S}{login_timeout}.'s', + -secure => $r->{S}{encrypted_only}); +} + +sub do_redirect_cgi ($$$$) { + my ($c, $r, $new_url, $cookie) = @_; + my @ha = ('text/html', + -status => '303 See other', + -location => $new_url); + push @ha, (-cookie => $cookie) if defined $cookie; + $r->_ch('print')($c->header(@ha). + $c->start_html('Redirection'). + $c->a({href=>$new_url}, + "If you aren't redirected, click to continue."). + $c->end_html()); +} + +#---------- verifier object methods ---------- -sub new { +sub new_verifier { my $class = shift; my $s = { S => { @@ -26,16 +95,30 @@ sub new { assocdb_table => 'assocs', random_source => '/dev/urandom', associdlen => 128, # bits - param_name => 'cah_associd', - cookie_name => 'cah_associd', # make undef to disable cookie - cgi => undef, - get_param => sub { $s->_c()->param($s->{S}{param_name}) }, - get_cookie => sub { $s->{S}{cookie_name} - ? $s->_c()->cookie($s->{S}{cookie_name}) - : '' }, - get_method => sub { $s->_c()->request_method() }, + login_timeout => 86400, # seconds + assoc_param_name => 'cah_associd', + password_param_name => 'password', + logout_param_names => [qw(cah_logout)], + loggedout_param_names => [qw(cah_loggedout)], + promise_check_mutate => 0, + get_param => sub { $_[0]->param($_[2]) }, + get_param_list => sub { $_[1]->get_param_list() }, + get_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) }, + get_method => sub { $_[0]->request_method() }, + get_url => sub { $_[0]->url(); }, + is_login => sub { defined $_[1]->_rp('password_param_name') }, + login_ok => sub { die }, + is_logout => sub { $_[1]->has_a_param('logout_param_names') }, + is_loggedout => sub { $_[1]->has_a_param('loggedout_param_names') }, + is_page => sub { return 1 }, + handle_divert => sub { return 0 }, + do_redirect => \&do_redirect_cgi, # this hook is allowed to throw + cookie_path => "/", + get_cookie_domain => \&get_cookie_domain, + encrypted_only => 0, + }; }, - D => undef, + Dbh => undef, }; my ($k,$v); while (($k,$v,@_) = @_) { @@ -43,17 +126,13 @@ sub new { $s->{S}{$k} = $v; } bless $s, $class; + $s->_dbopen(); return $s; } -sub _c ($) { - my ($s) = @_; - return $s->{S}{cgi}; -} - sub _dbopen ($) { my ($s) = @_; - my $dbh = $s->{D}; + my $dbh = $s->{Dbh}; return $dbh if $dbh; $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}"; @@ -64,43 +143,486 @@ sub _dbopen ($) { AutoCommit => 0, RaiseError => 1, }); die "${assocdb_dsn} $! ?" unless $dbh; - $s->{D} = $dbh; + $s->{Dbh} = $dbh; $dbh->do("BEGIN"); eval { $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (". - " associd VARCHAR PRIMARY KEY,". - " username VARCHAR". + " 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}; + my $p = scalar $r->_ch('get_param',$pn) +} + +# 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 +# O "you have just logged out" page load + +# 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 parm 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 nrmu bug or attack, fail + # + # - - GET O "just logged out" page + # (any other) O 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 + # (with link to login form) + # + # any n POST i complain about stale login form + # show new login form + # + # x1 t2 POST i login (or switch user) + # if bad + # show new login form + # if good + # revoke x1 if it was valid and !=t2 + # upgrade t2 to y2 in our db (setting username) + # set cookie to t2 + # 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 n m user not logged in + # show login form + # + # -/n n POST r u user not logged in + # fail + +sub _check_divert_core ($) { +fixme needs wrapping with something to make and commit a transaction + my ($r) = @_; + + my $meth = $r->_ch('get_method'); + my $cookv = $r->_ch('get_cookie'); + my $parmv = $r->_rp('assoc_param_name'); + + my ($cookt,$cooku) = $r->_db_lookup($cookv); + my $parmt = $r->_db_lookup($parmv); + + if ($r->_ch('is_logout')) { + $r->_must_be_post(); + die unless $parmt; + $r->_db_revoke($cookv); + $r->_db_revoke($parmv); + return ({ Kind => 'REDIRECT/LOGGEDOUT', + Message => "Logging out...", + Cookie => '', + Params => [ ] }); + } + if ($r->_ch('is_loggedout')) { + die unless $meth eq 'GET'; + die unless $cookt; + die unless $parmt; + return ({ Kind => 'SMALLPAGE/LOGGEDOUT', + Message => "You have been logged out.", + Cookie => '', + Params => [ ] }); + } + if ($r->_ch('is_login')) { + $r->_must_be_post(); + return ({ Kind => 'LOGIN-STALE', + Message => "Stale session; you need to log in again.", + Cookie => $r->_fresh_cookie(), + Params => [ ] }) + if $parmt eq 'n'; + die unless $parmt eq 't' || $parmt eq 'y'; + return ({ Kind => 'SMALLPAGE-NOCOOKIE', + Message => "You do not seem to have cookies enabled. ". + "You must enable cookies as we use them for login.", + Cookie => $r->_fresh_cookie(), + Params => $r->_chain_params() }) + if !$cookt && $parmt eq 't'; + return ({ Kind => 'LOGIN-BAD', + Message => "Incorrect username/password.", + Cookie => $cookv, + Params => $r->_chain_params() }) + unless defined $username && length $username; + $r->_db_revoke($cookv) + if defined $cookv && !(defined $parmv && $cookv eq $parmv); + my $username = $r->_ch('login_ok'); + $r->_db_record_login_ok($parmv,$username); + return ({ Kind => 'REDIRECT-LOGGEDIN', + Message => "Logging in...", + Cookie => $parmv, + Params => $r->_chain_params() }); + } + if ($cookt eq 't') { + $cookt = ''; + } + die if $parmt eq 't'; + + if ($cookt eq 'y' && $parmt eq 'y' && $cookv ne $parmv) { + $r->_db_revoke($parmv) if $meth eq 'POST'; + $parmt = 'n'; + } + + if ($cookt ne 'y') { + die unless !$cookt || $cookt eq 'n'; + die unless !$parmt || $parmt eq 'n' || $parmt eq 'y'; + if ($meth eq 'GET') { + return ({ Kind => 'LOGIN-INCOMINGLINK', + Message => "You need to log in again.", + Cookie => $parmv, + Params => $r->_chain_params() }); + } else { + return ((Kind => 'LOGIN-FRESH', + Message => "You need to log in again.", + Cookie => $parmv, + Params => [ ]); + } + } + + if (!$r->{S}{promise_check_mutate}) { + if ($meth ne 'POST') { + return ({ Kind => 'MAINPAGEONLY', + Message => 'Entering via cross-site link.', + Cookie => $cookv, + Params => [ ] }); + # NB caller must then ignore params & path! + # if this is too hard they can spit out a small form + # with a "click to continue" + } + } + + die unless $cookt eq 'y'; + die unless $parmt eq 'y'; + die unless $cookv eq $parmv; + $r->{UserOK} = $cooku; + return undef; +} + +sub _chain_params ($) { + my ($r) = @_; + my %elim = { }; + foreach my $pncn (keys %{ $r->{S} }) { + if ($pncn =~ m/_param_name$/) { + my $name = $r->{S}{$pncn}; + die "$pncn ?" if ref $name; + $names = [ $name ]; + } elsif ($pncn =~ m/_param_names$/) { + $names = $r->{S}{$pncn}; + } else { + next; + } + foreach my $param (@$names) { + $elim{$name} = 1; + } + } + my @p = $r->_ch('get_param_list'); + my ($name,$val); + my @q = (); + while (@p) { + ($name,$val,@p) = @p; + next if $elim{$name}; + push @q, $name, $val; + } + return @q; +} + +sub _db_lookup ($$) { + # returns ($t,$username) + # where $t is one of "t" "y" "n", or "" (for -) + my ($r,$v) = @_; + + my $dbh = $r->{Dbh}; + + my ($nusername, $nlast) = + $dbh->selectrow_array("SELECT username, last". + " FROM $r->{S}{assocdb_table}". + " WHERE associd = ?", {}, $nassoc); + return ('') unless defined $nusername; + + my $timeout = $r->{S}{login_timeout}; + return ('n') unless !defined $timeout || time <= $nlast + $timeout; + + return ('t') unless defined $nusername; + + # hooray + return ('y', $nusername); +} + +sub _db_revoke ($$) { + # revokes $v if it's valid; no-op if it's not + my ($r,$v) = @_; + + my $dbh = $r->{Dbh}; + + $dbh->do("DELETE FROM $r->{S}{assocdb_table}". + " WHERE associd = ?", {}, $v); +} + +sub _db_record_login_ok ($$$) { + my ($r,$v,$user) = @_; + $r->_db_revoke($v); + $dbh->do("INSERT INTO $r->{S}{assocdb_table}". + " (associd, username, last) VALUES (?,?,?)", {}, + $v, $user, time); +} + +sub url_with_query_params ($@) { + my ($r, @params) = @_; + my $uri = URI->new($r->_ch('get_url')); + $uri->query_form(\@params); + return $uri->as_string(); +} + +sub check_ok ($) { + my ($r) = @_; + + my ($divert) = $authreq->check_divert(); + return 1 if $divert; + + my $handled = $r->_ch('handle_divert')($divert); + return 0 if $handled; + + my $kind = $divert->{Kind}; + my $cookie = $divert->{Cookie}; + my $params = $divert->{Params}; + + if ($kind =~ m#^REDIRECT/#) { + # for redirects, we honour stored NextParams and SetCookie, + # as we would for non-divert + if ($divert_kind eq 'REDIRECT-LOGGEDOUT') { + push @$params, $r->{S}{cah_loggedout}[0], 1; + } elsif ($divert_kind eq 'REDIRECT-LOGOUT') { + push @$params, $r->{S}{cah_logout}[0], 1; + } elsif ($divert_kind eq 'REDIRECT-LOGGEDIN') { + } else { + die; + } + my $new_url = $r->url_with_query_params(@$params); + $r->_ch('do_redirect')($new_url, $cookie); + return 0; + } + + +if (defined $cookie) { + $r->_ch('header_out')($cookie); + } + +UP TO HERE + sub record_login ($$) { - my ($s,$nusername) = @_; - my $rsp = $s->{S}{random_source}; + my ($r,$nusername) = @_; + my $rsp = $r->{S}{random_source}; my $rsf = new IO::File $rsp, '<' or die "$rsp $!"; - my $bytes = ($s->{S}{associdlen} + 7) >> 3; + my $bytes = ($r->{S}{associdlen} + 7) >> 3; my $nassocbin; $!=0; read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!"; close $rsf; my $nassoc = unpack "H*", $nassocbin; - my $dbh = $s->_dbopen(); - $dbh->do("INSERT INTO $s->{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 $qassocid = $s->{S}{param_get}(); - if (!defined $qassocid) { - $qassocid = $s->{S}{cookie_get}(); - return 0 unless defined $qassocid; - return 0 unless $s->{S}{get_method}() eq 'GET'; +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. + } + } +