X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=cgi-auth-flexible.git;a=blobdiff_plain;f=cgi-auth-hybrid.pm;h=c5dd73a83d64fb546196a0c34f3954b15e1a98b2;hp=6f8848972fdda1bdbd913f9a8d4b4d698343ced8;hb=f1de083bcb46992c0565e0875f54a8a1a571e5d1;hpb=947ffd56abe5dfe9f441cf6640a50f5cada1383e diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm index 6f88489..c5dd73a 100644 --- a/cgi-auth-hybrid.pm +++ b/cgi-auth-hybrid.pm @@ -2,6 +2,7 @@ # This is part of CGI::Auth::Hybrid, a perl CGI authentication module. # Copyright (C) 2012 Ian Jackson. +# Copyright (C) 2012 Citrix. # # 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 @@ -16,6 +17,12 @@ # You should have received a copy of the GNU Affero General Public License # along with this program. If not, see . +use strict; +use warnings; + +package CGI::Auth::Hybrid; +require Exporter; + BEGIN { use Exporter (); our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); @@ -30,8 +37,11 @@ BEGIN { our @EXPORT_OK; use DBI; -use CGI; -use Locale::Gettext; +use CGI qw/escapeHTML/; +use Locale::gettext; +use URI; +use IO::File; +use Data::Dumper; #---------- public utilities ---------- @@ -49,16 +59,17 @@ sub flatten_params ($) { #---------- default callbacks ---------- sub has_a_param ($$) { - my ($c,$cn) = @_; + my ($r,$cn) = @_; foreach my $pn (@{ $r->{S}{$cn} }) { - return 1 if $r->_cm('get_param')($pn); + return 1 if $r->_ch('get_param',$pn); } return 0; } -sub get_params ($$) { - my ($c) = @_; +sub get_params ($) { + my ($r) = @_; my %p; + my $c = $r->{Cgi}; foreach my $name ($c->param()) { $p{$name} = [ $c->param($name) ]; } @@ -71,24 +82,20 @@ sub get_cookie_domain ($$$) { 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 login_ok_password ($$) { + my ($c, $r) = @_; + my $username_params = $r->{S}{username_param_names}; + my $username = $r->_ch('get_param',$username_params->[0]); + my $password = $r->_rp('password_param_name'); + return $r->_ch('username_password_ok', $username, $password); } 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->_print($c->header(@ha), - $r->_ch('gen_start_html')($r->_gt('Redirection')), + $r->_print($c->header($r->_cgi_header_args($cookie, + -status => '303 See other', + -location => $new_url)), + $r->_ch('gen_start_html',$r->_gt('Redirection')), '', $r->_gt("If you aren't redirected, click to continue."), "", @@ -99,20 +106,20 @@ sub gen_plain_login_form ($$) { my ($c,$r, $params) = @_; my @form; push @form, ('
'. ''); my $sz = 'size="'.$r->{S}{form_entry_size}.'"'; foreach my $up (@{ $r->{S}{username_param_names}}) { push @form, ('', - ''); + ''); } push @form, ('', ''); push @form, ('', '
',$r->_gt(ucfirst $up),'
'.$r->_gt('Password'),'
', '
'); foreach my $n (keys %$params) { @@ -136,17 +143,18 @@ sub gen_login_link ($$) { sub new_verifier { my $class = shift; - my $s = { + my $verifier = { S => { - assocdb_path => 'cah-assocs.db'; + assocdb_path => 'cah-assocs.db', assocdb_dsn => undef, assocdb_user => '', assocdb_password => '', assocdb_table => 'assocs', random_source => '/dev/urandom', - associdlen => 128, # bits + assocsecretlen => 128, # bits login_timeout => 86400, # seconds - assoc_param_name => 'cah_associd', + assoc_param_name => 'cah_assochash', + cookie_name => "cah_assocsecret", password_param_name => 'password', username_param_names => [qw(username)], form_entry_size => 60, @@ -156,11 +164,12 @@ sub new_verifier { promise_check_mutate => 0, get_param => sub { $_[0]->param($_[2]) }, get_params => sub { $_[1]->get_params() }, - get_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) }, + get_cookie => sub { $_[0]->cookie($_[1]->{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 }, + login_ok => \&login_ok_password, + username_password_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 }, @@ -168,53 +177,97 @@ sub new_verifier { do_redirect => \&do_redirect_cgi, # this hook is allowed to throw cookie_path => "/", get_cookie_domain => \&get_cookie_domain, - encrypted_only => 0, + encrypted_only => 1, gen_start_html => sub { $_[0]->start_html($_[2]); }, gen_end_html => sub { $_[0]->end_html(); }, gen_login_form => \&gen_plain_login_form, gen_login_link => \&gen_plain_login_link, gettext => sub { gettext($_[2]); }, - }; + print => sub { print $_[2] or die $!; }, }, Dbh => undef, }; my ($k,$v); while (($k,$v,@_) = @_) { - die "unknown setting $k" unless exists $s->{S}{$k}; - $s->{S}{$k} = $v; + die "unknown setting $k" unless exists $verifier->{S}{$k}; + $verifier->{S}{$k} = $v; } - bless $s, $class; - $s->_dbopen(); - return $s; + bless $verifier, $class; + $verifier->_dbopen(); + return $verifier; } sub _dbopen ($) { - my ($s) = @_; - my $dbh = $s->{Dbh}; + my ($v) = @_; + my $dbh = $v->{Dbh}; return $dbh if $dbh; - $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}"; + $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$v->{S}{assocdb_path}"; + my $dsn = $v->{S}{assocdb_dsn}; my $u = umask 077; - $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"); + $dbh = DBI->connect($dsn, $v->{S}{assocdb_user}, + $v->{S}{assocdb_password}, { + AutoCommit => 0, + RaiseError => 1, + ShowErrorStatement => 1, + }); + die "$dsn $! ?" unless $dbh; + $v->{Dbh} = $dbh; eval { - $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (". - " associdh VARCHAR PRIMARY KEY,". - " username VARCHAR,". - " last INTEGER NOT NULL" - ")"); + $v->_db_transaction(sub { + local ($dbh->{PrintError}) = 0; + $dbh->do("CREATE TABLE $v->{S}{assocdb_table} (". + " assochash VARCHAR PRIMARY KEY,". + " username VARCHAR,". + " last INTEGER NOT NULL". + ")"); + }); }; return $dbh; } +sub disconnect ($) { + my ($v) = @_; + my $dbh = $v->{Dbh}; + return unless $dbh; + $dbh->disconnect(); +} + +sub _db_transaction ($$) { + my ($v, $fn) = @_; + my $retries = 10; + my $rv; + my $dbh = $v->{Dbh}; +print STDERR "DT entry\n"; + for (;;) { +print STDERR "DT loop\n"; + if (!eval { + $rv = $fn->(); +print STDERR "DT fn ok\n"; + 1; + }) { +print STDERR "DT fn error\n"; + { local ($@); $dbh->rollback(); } +print STDERR "DT fn throwing\n"; + die $@; + } +print STDERR "DT fn eval ok\n"; + if (eval { + $dbh->commit(); +print STDERR "DT commit ok\n"; + 1; + }) { +print STDERR "DT commit eval ok $rv\n"; + return $rv; + } +print STDERR "DT commit throw?\n"; + die $@ if !--$retries; +print STDERR "DT loop again\n"; + } +} + #---------- request object methods ---------- sub new_request { @@ -236,6 +289,7 @@ sub new_request { sub _ch ($$@) { # calls an application hook my ($r,$methname, @args) = @_; my $methfunc = $r->{S}{$methname}; + die "$methname ?" unless $methfunc; return $methfunc->($r->{Cgi}, $r, @args); } @@ -245,8 +299,23 @@ sub _rp ($$@) { my $p = scalar $r->_ch('get_param',$pn) } -sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext')($t); } -sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print')(join '', @t); } +sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); } +sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); } + +sub construct_cookie ($$$) { + my ($r, $cooks) = @_; + return undef unless $cooks; + my $c = $r->{Cgi}; +my @ca = (-name => $r->{S}{cookie_name}, + -value => $cooks, + -path => $r->{S}{cookie_path}, + -domain => $r->_ch('get_cookie_domain'), + -expires => '+'.$r->{S}{login_timeout}.'s', + -secure => $r->{S}{encrypted_only}); + my $cookie = $c->cookie(@ca); +print STDERR "CC $r $c $cooks $cookie (@ca).\n"; + return $cookie; +} # pages/param-sets are # n normal non-mutating page @@ -258,12 +327,13 @@ sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print')(join '', @t); } # O "you have just logged out" page load # in cook and par, -# a, aN anything including - +# - no value supplied (represented in code as $cookt='') +# n, nN value not in our db # 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 +# and, aggregated conditions: +# a, aN anything including - # 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) @@ -293,18 +363,20 @@ sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print')(join '', @t); } # - 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) + # t1 t1 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 + # upgrade t1 to y1 in our db (setting username) # redirect to GET of remaining params # + # y1 a2 POST i complain about stale login form + # revoke y1 + # show new login form + # + # (other) POST i complain about stale login form + # show new login form + # # t1 a2 ANY nrmu treat as - a2 ANY # # y - GET n cross-site link @@ -342,8 +414,9 @@ sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print')(join '', @t); } # revoke y2 # treat as -/n n POST # - # -/n n GET n cross-site link but user not logged in + # -/n -/n GET n cross-site link but user not logged in # show login form with redirect to orig params + # generate fresh cookie # # -/n n GET rmu user not logged in # fail @@ -355,25 +428,26 @@ sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print')(join '', @t); } # fail sub _check_divert_core ($) { -fixme needs wrapping with something to make and commit a transaction -wrapper should also store answers in the $r object for later retrieval my ($r) = @_; my $meth = $r->_ch('get_method'); - my $cookv = $r->_ch('get_cookie'); - my $parmv = $r->_rp('assoc_param_name'); + my $cooks = $r->_ch('get_cookie'); + my $parmh = $r->_rp('assoc_param_name'); + my $cookh = defined $cooks ? $r->hash($cooks) : undef; - my ($cookt,$cooku) = $r->_db_lookup($cookv); - my $parmt = $r->_db_lookup($parmv); + my ($cookt,$cooku) = $r->_db_lookup($cookh); + my $parmt = $r->_db_lookup($parmh); + + print STDERR "_c_d_c cookt=$cookt parmt=$parmt\n"; if ($r->_ch('is_logout')) { $r->_must_be_post(); die unless $parmt; - $r->_db_revoke($cookv); - $r->_db_revoke($parmv); + $r->_db_revoke($cookh); + $r->_db_revoke($parmh); return ({ Kind => 'REDIRECT-LOGGEDOUT', Message => "Logging out...", - Cookie => '', + CookieSecret => '', Params => { } }); } if ($r->_ch('is_loggedout')) { @@ -382,35 +456,38 @@ wrapper should also store answers in the $r object for later retrieval die unless $parmt; return ({ Kind => 'SMALLPAGE-LOGGEDOUT', Message => "You have been logged out.", - Cookie => '', + CookieSecret => '', 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; + if (!$cookt && $parmt eq 't') { + return ({ Kind => 'SMALLPAGE-NOCOOKIE', + Message => "You do not seem to have cookies enabled. ". + "You must enable cookies as we use them for login.", + CookieSecret => $r->_fresh_secret(), + Params => $r->_chain_params() }) + } + if (!$cookt || $cookt eq 'n' || $cookh ne $parmh) { + $r->_db_revoke($cookh); + return ({ Kind => 'LOGIN-STALE', + Message => "Stale session; you need to log in again.", + CookieSecret => $r->_fresh_secret(), + Params => { } }) + } 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'; my $username = $r->_ch('login_ok'); - 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); - $r->_db_record_login_ok($parmv,$username); + unless (defined $username && length $username) { + return ({ Kind => 'LOGIN-BAD', + Message => "Incorrect username/password.", + CookieSecret => $cooks, + Params => $r->_chain_params() }) + } + $r->_db_record_login_ok($parmh,$username); return ({ Kind => 'REDIRECT-LOGGEDIN', Message => "Logging in...", - Cookie => $parmv, + CookieSecret => $cooks, Params => $r->_chain_params() }); } if ($cookt eq 't') { @@ -418,24 +495,26 @@ wrapper should also store answers in the $r object for later retrieval } die if $parmt eq 't'; - if ($cookt eq 'y' && $parmt eq 'y' && $cookv ne $parmv) { - $r->_db_revoke($parmv) if $meth eq 'POST'; + if ($cookt eq 'y' && $parmt eq 'y' && $cookh ne $parmh) { + $r->_db_revoke($parmh) 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'; + my $news = $r->_fresh_secret(); if ($meth eq 'GET') { return ({ Kind => 'LOGIN-INCOMINGLINK', Message => "You need to log in again.", - Cookie => $parmv, + CookieSecret => $news, Params => $r->_chain_params() }); } else { - return ((Kind => 'LOGIN-FRESH', - Message => "You need to log in again.", - Cookie => $parmv, - Params => { }); + $r->_db_revoke($parmh); + return ({ Kind => 'LOGIN-FRESH', + Message => "You need to log in again.", + CookieSecret => $news, + Params => { } }); } } @@ -443,7 +522,7 @@ wrapper should also store answers in the $r object for later retrieval if ($meth ne 'POST') { return ({ Kind => 'MAINPAGEONLY', Message => 'Entering via cross-site link.', - Cookie => $cookv, + CookieSecret => $cooks, Params => { } }); # NB caller must then ignore params & path! # if this is too hard they can spit out a small form @@ -453,8 +532,10 @@ wrapper should also store answers in the $r object for later retrieval die unless $cookt eq 'y'; die unless $parmt eq 'y'; - die unless $cookv eq $parmv; + die unless $cookh eq $parmh; + $r->{AssocSecret} = $cooks; $r->{UserOK} = $cooku; + print STDERR "C-D-C OK\n"; return undef; } @@ -462,6 +543,7 @@ sub _chain_params ($) { my ($r) = @_; my %p = %{ $r->_ch('get_params') }; foreach my $pncn (keys %{ $r->{S} }) { + my $names; if ($pncn =~ m/_param_name$/) { my $name = $r->{S}{$pncn}; die "$pncn ?" if ref $name; @@ -471,7 +553,7 @@ sub _chain_params ($) { } else { next; } - foreach my $param (@$names) { + foreach my $name (@$names) { delete $p{$name}; } } @@ -479,17 +561,18 @@ sub _chain_params ($) { } sub _db_lookup ($$) { + my ($r,$h) = @_; # 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". + my $row = $dbh->selectrow_arrayref("SELECT username, last". " FROM $r->{S}{assocdb_table}". - " WHERE associd = ?", {}, $nassoc); - return ('') unless defined $nusername; + " WHERE assochash = ?", {}, $h); + return ('') unless defined $row; + + my ($nusername, $nlast) = @$row; my $timeout = $r->{S}{login_timeout}; return ('n') unless !defined $timeout || time <= $nlast + $timeout; @@ -501,21 +584,47 @@ sub _db_lookup ($$) { } sub _db_revoke ($$) { - # revokes $v if it's valid; no-op if it's not - my ($r,$v) = @_; + # revokes $h if it's valid; no-op if it's not + my ($r,$h) = @_; my $dbh = $r->{Dbh}; $dbh->do("DELETE FROM $r->{S}{assocdb_table}". - " WHERE associd = ?", {}, $v); + " WHERE assochash = ?", {}, $h); } sub _db_record_login_ok ($$$) { - my ($r,$v,$user) = @_; - $r->_db_revoke($v); + my ($r,$h,$user) = @_; + $r->_db_revoke($h); + my $dbh = $r->{Dbh}; $dbh->do("INSERT INTO $r->{S}{assocdb_table}". " (associd, username, last) VALUES (?,?,?)", {}, - $v, $user, time); + $h, $user, time); +} + +sub check_divert ($) { + my ($r) = @_; + if (exists $r->{Divert}) { + return $r->{Divert}; + } + my $dbh = $r->{Dbh}; + $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); }); + $dbh->commit(); + print STDERR Dumper($r->{Divert}); + return $r->{Divert}; +} + +sub get_divert ($) { + my ($r) = @_; + die "unchecked" unless exists $r->{Divert}; + return $r->{Divert}; +} + +sub get_username ($) { + my ($r) = @_; + my $divert = $r->get_divert(); + return undef if $divert; + return $r->{UserOK}; } sub url_with_query_params ($$) { @@ -525,32 +634,41 @@ sub url_with_query_params ($$) { return $uri->as_string(); } +sub _cgi_header_args ($$@) { + my ($r, $cookie, @ha) = @_; + unshift @ha, qw(-type text/html); + push @ha, (-cookie => $cookie) if defined $cookie; + print STDERR "_cgi_header_args ",join('|',@ha),".\n"; + return @ha; +} + sub check_ok ($) { my ($r) = @_; - my ($divert) = $authreq->check_divert(); - return 1 if $divert; + my ($divert) = $r->check_divert(); + return 1 if !$divert; - my $handled = $r->_ch('handle_divert')($divert); + my $handled = $r->_ch('handle_divert',$divert); return 0 if $handled; my $kind = $divert->{Kind}; - my $cookie = $divert->{Cookie}; + my $cookiesecret = $divert->{CookieSecret}; my $params = $divert->{Params}; + my $cookie = $r->construct_cookie($cookiesecret); if ($kind =~ m/^REDIRECT-/) { # for redirects, we honour stored NextParams and SetCookie, # as we would for non-divert - if ($divert_kind eq 'REDIRECT-LOGGEDOUT') { - $params{$r->{S}{loggedout_param_names}[0]} = 1; - } elsif ($divert_kind eq 'REDIRECT-LOGOUT') { - $params{$r->{S}{logout_param_names}[0]} = 1; - } elsif ($divert_kind eq 'REDIRECT-LOGGEDIN') { + if ($kind eq 'REDIRECT-LOGGEDOUT') { + $params->{$r->{S}{loggedout_param_names}[0]} = 1; + } elsif ($kind eq 'REDIRECT-LOGOUT') { + $params->{$r->{S}{logout_param_names}[0]} = 1; + } elsif ($kind eq 'REDIRECT-LOGGEDIN') { } else { die; } my $new_url = $r->url_with_query_params($params); - $r->_ch('do_redirect')($new_url, $cookie); + $r->_ch('do_redirect',$new_url, $cookie); return 0; } @@ -567,113 +685,78 @@ sub check_ok ($) { die $kind; } - $r->_print($r->_ch('start_html')($title), - @body, - $r->_ch('end_html')); + $r->_print($r->{Cgi}->header($r->_cgi_header_args($cookie)), + $r->_ch('gen_start_html',$title), + (join "\n", @body), + $r->_ch('gen_end_html')); return 0; } sub _random ($$) { my ($r, $bytes) = @_; my $v = $r->{V}; - if (!$v->{RandomHandle}) { - my $rsp = $r->{S}{random_source}; - my $rsf = new IO::File $rsp, '<' or die "$rsp $!"; - $v->{RandomHandle} = $rsf; + my $rsf = $v->{RandomHandle}; + my $rsp = $r->{S}{random_source}; + if (!$rsf) { + $v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!"; } my $bin; $!=0; read($rsf,$bin,$bytes) == $bytes or die "$rsp $!"; close $rsf; - return unpack "H*", $bin; + my $out = unpack "H*", $bin; + print STDERR "_random out $out\n"; + return $out; } -sub _fresh_cookie ($) { +sub _fresh_secret ($) { my ($r) = @_; + print STDERR "_fresh_secret\n"; my $bytes = ($r->{S}{associdlen} + 7) >> 3; return $r->_random($bytes); } -UP TO HERE - -sub record_login ($$) { - my ($r,$nusername) = @_; - - - - my $dbh = $r->{Dbh}; - - $r->{U} = $nusername; - $r->{A} = $nassoc; - - $dbh->do("COMMIT"); -} - -sub _check ($) { +sub _assert_checked ($) { 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}; + die "unchecked" unless exists $r->{Divert}; } sub check_mutate ($) { my ($r) = @_; - $r->check(); - return $r->{Mutate}; + $r->_assert_checked(); + die if $r->{Divert}; + my $meth = $r->_ch('get_method'); + die "mutating non-POST" if $meth ne 'POST'; } -sub username ($) { - my ($r) = @_; - $r->check(); - return $r->{Username}; +#---------- output ---------- -sub hidden_val ($) { +sub secret_cookie_val ($) { my ($r) = @_; - $r->check(); - return defined $r->{Assoc} ? $r->{Assoc} : ''; + $r->_assert_checked(); + return defined $r->{AssocSecret} ? $r->{AssocSecret} : ''; } -#---------- simple wrappers ---------- - -sub hidden_hargs ($) { +sub secret_hidden_val ($) { my ($r) = @_; - return (-name => $r->{S}{param_name}, - -default => $r->hidden_val()); + $r->_assert_checked(); + return defined $r->{AssocSecret} ? $r->hash($r->{AssocSecret}) : ''; } -sub hidden_html ($) { +sub secret_hidden_html ($) { my ($r) = @_; - return hidden($r->hidden_hargs()); + return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name}, + -default => $r->secret_hidden_val()); } -sub cookiea_cargs ($) { +sub secret_cookie ($) { my ($r) = @_; - return (-name => $r->{S}{cookie_name}, - -value => hidden_val()); + my $secret = $r->secret_cookie_val(); + return undef if !defined $secret; +#print STDERR "SC\n"; + my $cookv = $r->construct_cookie($secret); +#print STDERR "SC=$cookv\n"; + return $cookv; } __END__ @@ -695,7 +778,7 @@ CGI::Auth::Hybrid - web authentication optionally using cookies $authreq->check_ok() or return; blah blah blah - $authreq->mutating(); + $authreq->check_mutate(); blah blah blah =head1 USAGE PATTERN FOR FANCY APPLICATIONS @@ -710,3 +793,6 @@ CGI::Auth::Hybrid - web authentication optionally using cookies } } + blah blah blah + $authreq->check_mutate(); + blah blah blah