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=ac41d1e58b284046db95b9b7a164e32e0753576e;hp=070603dd685096f5e182fdeaeb28689302b286f4;hb=0ff77901e5e258423b2e24ad7e91fc912726a694;hpb=5a9d1753dfffd178c9b3c5170eec31408ec09b8d diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm index 070603d..ac41d1e 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,81 +37,249 @@ BEGIN { our @EXPORT_OK; use DBI; -use CGI; +use CGI qw/escapeHTML/; +use Locale::gettext; +use URI; +use IO::File; +use Fctnl qw(:flock); +use Data::Dumper; + +#---------- public utilities ---------- + +sub flatten_params ($) { + my ($p) = @_; + my @p; + foreach my $k (keys %$p) { + foreach my $v (@{ $p->{$k} }) { + push @p, $k, $v; + } + } + return @p; +} #---------- 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); +sub has_a_param ($$) { + my ($r,$cn) = @_; + foreach my $pn (@{ $r->{S}{$cn} }) { + return 1 if $r->_ch('get_param',$pn); } return 0; } +sub get_params ($) { + my ($r) = @_; + my %p; + my $c = $r->{Cgi}; + foreach my $name ($c->param()) { + $p{$name} = [ $c->param($name) ]; + } + return \%p; +} + +sub get_cookie_domain ($$$) { + my ($c,$r) = @_; + my $uri = new URI $r->_ch('get_url'); + return $uri->host(); +} + +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) = @_; + $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."), + "", + $c->_ch('gen_end_html')); +} + +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) { + push @form, (''); + } + push @form, ('
'); + return join "\n", @form; +} + +sub gen_login_link ($$) { + my ($c,$r, $params) = @_; + my $url = $r->url_with_query_params($params); + return (''. + $r->_gt('Log in again to continue.'). + ''); +} + #---------- verifier object methods ---------- sub new_verifier { my $class = shift; - my $s = { + my $verifier = { S => { - assocdb_path => 'cah-assocs.db'; + assocdb_path => 'cah-assocs.db', + keys_path => 'cah-keys', assocdb_dsn => undef, assocdb_user => '', assocdb_password => '', assocdb_table => 'assocs', random_source => '/dev/urandom', - associdlen => 128, # bits + secretbits => 128, # bits + hash_algorithm => "SHA-256", login_timeout => 86400, # seconds - assoc_param_name => 'cah_associd', + login_form_timeout => 3600, # seconds + key_rollover => 86400, # seconds + assoc_param_name => 'cah_assochash', + cookie_name => "cah_assocsecret", password_param_name => 'password', - logout_param_names => [qw(logout)], + username_param_names => [qw(username)], + form_entry_size => 60, + logout_param_names => [qw(cah_logout)], + login_submit_name => [qw(cah_login)], + loggedout_param_names => [qw(cah_loggedout)], promise_check_mutate => 0, get_param => sub { $_[0]->param($_[2]) }, - get_cah_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) }, + get_params => sub { $_[1]->get_params() }, + 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 }, - is_logout => \&_def_is_logout, + 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 }, + 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 => 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 _db_setup_do ($$) { + my ($v, $sql) = @_; + my $dbh = $v->{Dbh}; + eval { + $v->_db_transaction(sub { + local ($dbh->{PrintError}) = 0; + $dbh->do($sql); + }); + }; } 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 = DBI->connect($dsn, $v->{S}{assocdb_user}, + $v->{S}{assocdb_password}, { + AutoCommit => 0, + RaiseError => 1, + ShowErrorStatement => 1, + }); + die "$dsn $! ?" unless $dbh; + $v->{Dbh} = $dbh; + + $v->_db_setup_do("CREATE TABLE $v->{S}{assocdb_table} (". + " assochash VARCHAR PRIMARY KEY,". + " username VARCHAR NOT NULL,". + " last INTEGER NOT NULL". + ")"); + $v->_db_setup_do("CREATE INDEX $v->{S}{assocdb_table}_timeout_index". + " ON $v->{S}{assocdb_table}". + " (last)"); + return $dbh; +} - $dbh->do("BEGIN"); +sub disconnect ($) { + my ($v) = @_; + my $dbh = $v->{Dbh}; + return unless $dbh; + $dbh->disconnect(); +} - eval { - $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (". - " associdh VARCHAR PRIMARY KEY,". - " username VARCHAR,". - " last INTEGER NOT NULL" - ")"); - }; - return $dbh; +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 ---------- @@ -117,6 +292,7 @@ sub new_request { die if @extra; } my $r = { + V => $classbase, S => $classbase->{S}, Dbh => $classbase->{Dbh}, Cgi => $cgi, @@ -127,13 +303,32 @@ 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); } sub _rp ($$@) { my ($r,$pnvb) = @_; my $pn = $r->{S}{$pnvb}; - my $p = $r->_ch('get_param',$pn) + 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 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 @@ -143,15 +338,16 @@ sub _rp ($$@) { # 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 - +# - 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) @@ -166,7 +362,10 @@ sub _rp ($$@) { # 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 + # 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 @@ -176,15 +375,21 @@ sub _rp ($$@) { # (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 + # t1 t1 POST i login (or switch user) + # if bad + # show new login form + # if good + # upgrade t1 to y1 in our db (setting username) + # redirect to GET of remaining params # - # x1 t2 POST i login (or switch user) - # 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 + # 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 # @@ -223,173 +428,462 @@ sub _rp ($$@) { # 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 # - # -/n n POST nrmu user not logged in + # -/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 ($) { +sub _check_divert_core ($) { my ($r) = @_; - my $cookv = $r->_ch('get_cah_cookie'); - my $parmv = $r->_rp('assoc_param_name'); + my $meth = $r->_ch('get_method'); + my $cooks = $r->_ch('get_cookie'); + my $parmh = $r->_rp('assoc_param_name'); + my $cookh = defined $cooks ? $r->hash($cooks) : undef; - my $cookt = $r->_db_lookup($cookv); - my $parmt = $r->_db_lookup($parmv); + my ($cookt,$cooku) = $r->_identify($cookh, $cooks); + my $parmt = $r->_identify($parmh, undef); + + print STDERR "_c_d_c cookt=$cookt parmt=$parmt\n"; if ($r->_ch('is_logout')) { $r->_must_be_post(); die unless $parmt; - $r->_db_perhaps_revoke($cookv); - $r->_db_perhaps_revoke($parmv); - $r->_queue_set_cookie(''); - return 'REDIRECT-LOGGEDOUT'; + $r->_db_revoke($cookh); + $r->_db_revoke($parmh); + return ({ Kind => 'REDIRECT-LOGGEDOUT', + Message => "Logging out...", + CookieSecret => '', + 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.", + CookieSecret => '', + Params => { } }); } if ($r->_ch('is_login')) { - return 'NOCOOKIE' if !$cookt && $parmt eq 't'; - return 'LOGIN-STALE' if $parmt eq 'n'; - $r->_db_perhaps_revoke($cookv) - if defined $cookv && !(defined $parmv && $cookv eq $parmv); - $r->_queue_set_cookie($parmv); + $r->_must_be_post(); + 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'; my $username = $r->_ch('login_ok'); - return 'LOGIN-BAD' unless defined $username && length $username; - $r->_db_record_login_ok($parmv,$username); - return 'REDIRECT-LOGGEDIN'; + 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...", + CookieSecret => $cooks, + Params => $r->_chain_params() }); } + if ($cookt eq 't') { + $cookt = ''; + } + die if $parmt eq 't'; + + 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.", + CookieSecret => $news, + Params => $r->_chain_params() }); + } else { + $r->_db_revoke($parmh); + return ({ Kind => 'LOGIN-FRESH', + Message => "You need to log in again.", + CookieSecret => $news, + Params => { } }); + } + } + if (!$r->{S}{promise_check_mutate}) { - something with method get, check parameter, etc. - return 'FRONTPAGE'; + if ($meth ne 'POST') { + return ({ Kind => 'MAINPAGEONLY', + Message => 'Entering via cross-site link.', + CookieSecret => $cooks, + 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" + } } - -UP TO HERE + die unless $cookt eq 'y'; + die unless $parmt eq 'y'; + die unless $cookh eq $parmh; + $r->{AssocSecret} = $cooks; + $r->{UserOK} = $cooku; + print STDERR "C-D-C OK\n"; + return undef; +} -sub _check_core ($) { +sub _chain_params ($) { 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; + 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; + $names = [ $name ]; + } elsif ($pncn =~ m/_param_names$/) { + $names = $r->{S}{$pncn}; } else { - return undef unless $r->{S}{promise_check_mutate}; - return undef unless $r->_ch('get_method') eq 'GET'; - $nmutate = 0; + next; + } + foreach my $name (@$names) { + delete $p{$name}; } } + return \%p; +} + +sub _identify ($$) { + my ($r,$h,$s) = @_; + # returns ($t,$username) + # where $t is one of "t" "y" "n", or "" (for -) + # either $s must be undef, or $h eq $r->hash($s) + + return '' unless defined $h && length $h; my $dbh = $r->{Dbh}; - my ($nusername, $nlast) = - $dbh->selectrow_array("SELECT username, last". + + $dbh->do("DELETE FROM $r->{S}{assocdb_table}". + " WHERE last < ?", {}, + time - $r->{S}{login_timeout}); + + my $row = $dbh->selectrow_arrayref("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; + " WHERE assochash = ?", {}, $h); + if (defined $row) { + my ($nusername, $nlast) = @$row; + return ('y', $nusername); + } + + # Well, it's not in the database. But maybe it's a hash of a + # temporary secret. + + return 'n' unless defined $s; + + my ($keyt, $signature, $message, $noncet, $nonce) = + $s =~ m/^(\d+)\.(\w+)\.((\d+)\.(\w+))$/ or die; + + return 'n' if time > $noncet + $r->{S}{form_timeout}; - # hooray - return ($nusername, $nassoc, $nmutate); + my $keys = $r->_open_keys(); + while (my ($rkeyt, $rkey, $line) = $r->_read_key($keys)) { + last if $rkeyt < $keyt; # too far down in the file + my $trysignature = $r->_hmac($rkey, $message); + return 't' if $trysignature eq $signature; + } + # oh well + + $keys->error and die $!; + return 'n'; } -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($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!"; - close $rsf; - my $nassoc = unpack "H*", $nassocbin; +sub _db_revoke ($$) { + # 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 assochash = ?", {}, $h); +} + +sub _db_record_login_ok ($$$) { + my ($r,$h,$user) = @_; + $r->_db_revoke($h); my $dbh = $r->{Dbh}; $dbh->do("INSERT INTO $r->{S}{assocdb_table}". " (associd, username, last) VALUES (?,?,?)", {}, - $nassoc, $nusername, time); - $dbh->do("COMMIT"); - $r->{U} = $nusername; - $r->{A} = $nassoc; + $h, $user, time); } -sub _check ($) { +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}; +} - return if exists $r->{Username}; - ($r->{Username}, $r->{Assoc}, $r->{Mutate}) = $r->_check(); +sub get_divert ($) { + my ($r) = @_; + die "unchecked" unless exists $r->{Divert}; + return $r->{Divert}; +} - if (defined $r->{Assoc}) { - $dbh->do("UPDATE $r->{S}{assocdb_table}". - " SET last = ?". - " WHERE associd = ?", {}, time, $nassoc); - $dbh->do("COMMIT"); +sub get_username ($) { + my ($r) = @_; + my $divert = $r->get_divert(); + return undef if $divert; + return $r->{UserOK}; +} + +sub url_with_query_params ($$) { + my ($r, $params) = @_; + my $uri = URI->new($r->_ch('get_url')); + $uri->query_form(flatten_params($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) = $r->check_divert(); + return 1 if !$divert; + + my $handled = $r->_ch('handle_divert',$divert); + return 0 if $handled; + + my $kind = $divert->{Kind}; + 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 ($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); + return 0; } + + my ($title, @body); + if ($kind =~ m/^LOGIN-/) { + $title = $r->_gt('Login'); + push @body, $r->_gt($divert->{Message}); + push @body, $r->_ch('gen_login_form', $params); + } elsif ($kind =~ m/^SMALLPAGE-/) { + $title = $r->_gt('Not logged in'); + push @body, $r->_gt($divert->{Message}); + push @body, $r->_ch('gen_login_link'); + } else { + die $kind; + } + + $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 logout ($) { +sub _random ($$) { + my ($r, $bytes) = @_; + my $v = $r->{V}; + 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; + my $out = unpack "H*", $bin; + print STDERR "_random out $out\n"; + return $out; +} + +sub _random_key ($) { my ($r) = @_; + print STDERR "_random_key\n"; + my $bytes = ($r->{S}{secretbits} + 7) >> 3; + return $r->_random($bytes); +} - 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 _read_key ($$) { + my ($r, $keys) = @_; + # returns $gen_time_t, $key_value_in_hex, $complete_line + while (<$keys>) { + m/^(\d+) (\S+)$/ or die "$_ ?"; + my ($gen, $k) = @_; + my $age = time - $gen; + next if $age > $r->{S}{key_rollover} && + $age > $r->{S}{login_form_timeout}*2; + return ($gen, $k, $_); + } + return (); } -sub check ($) { +sub _open_keys ($) { my ($r) = @_; - $r->_check(); - return !!defined $r->{Username}; + my $spath = $r->{S}{secrets_path}; + for (;;) { + my $keys = new IO::File $spath, 'r+'; + if ($keys) { + stat $keys or die $!; # NB must not disturb stat _ + my $size = (stat _)[7]; + my $age = time - (stat _)[9]; + return $keys if $size && $age <= $r->{S}{key_rollover} / 2; + } + # file doesn't exist, or is empty or too old + if (!$keys) { + die "$spath $!" unless $!==&ENOENT; + # doesn't exist, so create it just so we can lock it + $keys = new IO::File $spath, 'a+'; + die "$keys $!" unless $keys; + stat $keys or die $!; # NB must not disturb stat _ + my $size = (stat _)[7]; + next if $size; # oh someone else has done it, reopen and read it + } + # file now exists is empty or too old, we must try to replace it + my $our_inum = (stat _)[1]; # last use of that stat _ + flock $keys, LOCK_EX or die "$spath $!"; + stat $spath or die "$spath $!"; + my $path_inum = (stat _)[1]; + next if $our_inum != $path_inum; # someone else has done it + # We now hold the lock! + my $newkeys = new IO::Handle; + sysopen $newkeys, "$spath.new", O_CREAT|O_TRUNC|O_WRONLY, 0600 + or die "$spath.new $!"; + # we add the new key to the front which means it's always sorted + print $newkeys, time, ' ', $r->_random_key(), "\n" or die $!; + while (my ($gen,$key,$line) = $r->_read_key($keys)) { + print $newkeys, $line or die $!; + } + $keys->error and die $!; + close $newkeys or die "$spath.new $!"; + rename "$spath.new", "$spath" or die "$spath: $!"; + # that rename effective unlocks, since it makes the name refer + # to the new file which we haven't locked + # we go round again opening the file at the beginning + # so that our caller gets a fresh handle onto the existing key file + } } -sub check_mutate ($) { +sub _fresh_secret ($) { my ($r) = @_; - $r->check(); - return $r->{Mutate}; + print STDERR "_fresh_secret\n"; + + my $keys = $r->_open_keys(); + my ($keyt, $key) = $r->_read_key($keys); + die unless defined $keyt; + + my $nonce = $r->_random_key(); + my $noncet = time; + my $message = "$noncet.$nonce"; + + my $signature = $r->_hmac($key, $message); + my $secret = "$keyt.$signature.$message"; + print STDERR "FRESH $secret\n"; +} + +sub _hmac ($$$) { + my ($r, $keyhex, $message) = @_; + my $keybin = pack "H*", $keyhex; + my $digest = Digest::HMAC->new($keybin, $r->{S}{hash_algorithm}); + $digest->add($message); + return $digest->hexdigest(); +} + +sub hash ($$) { + my ($r, $message) = @_; + my $digest = Digest->new($r->{S}{hash_algorithm}); + $digest->add($message); + return $digest->hexdigest(); } -sub username ($) { +sub _assert_checked ($) { my ($r) = @_; - $r->check(); - return $r->{Username}; + die "unchecked" unless exists $r->{Divert}; +} -sub hidden_val ($) { +sub check_mutate ($) { my ($r) = @_; - $r->check(); - return defined $r->{Assoc} ? $r->{Assoc} : ''; + $r->_assert_checked(); + die if $r->{Divert}; + my $meth = $r->_ch('get_method'); + die "mutating non-POST" if $meth ne 'POST'; } -#---------- simple wrappers ---------- +#---------- output ---------- + +sub secret_cookie_val ($) { + my ($r) = @_; + $r->_assert_checked(); + return defined $r->{AssocSecret} ? $r->{AssocSecret} : ''; +} -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} ? 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__ @@ -411,7 +905,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 @@ -426,3 +920,6 @@ CGI::Auth::Hybrid - web authentication optionally using cookies } } + blah blah blah + $authreq->check_mutate(); + blah blah blah