X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;ds=sidebyside;f=cgi-auth-hybrid.pm;h=ac41d1e58b284046db95b9b7a164e32e0753576e;hb=0ff77901e5e258423b2e24ad7e91fc912726a694;hp=a5499a33b4517129df489a5f7af90a6180bba190;hpb=576fe12d72d1dad68a2161df0c211097b9062f4c;p=cgi-auth-flexible.git diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm index a5499a3..ac41d1e 100644 --- a/cgi-auth-hybrid.pm +++ b/cgi-auth-hybrid.pm @@ -37,8 +37,12 @@ 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 ---------- @@ -58,7 +62,7 @@ sub flatten_params ($) { sub has_a_param ($$) { 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; } @@ -89,11 +93,9 @@ sub login_ok_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->_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."), @@ -105,20 +107,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) { @@ -145,14 +147,19 @@ sub new_verifier { my $verifier = { S => { 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', username_param_names => [qw(username)], form_entry_size => 60, @@ -175,12 +182,13 @@ 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, }; @@ -194,6 +202,17 @@ sub new_verifier { 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 ($v) = @_; my $dbh = $v->{Dbh}; @@ -205,20 +224,21 @@ sub _dbopen ($) { my $u = umask 077; $dbh = DBI->connect($dsn, $v->{S}{assocdb_user}, $v->{S}{assocdb_password}, { - AutoCommit => 0, RaiseError => 1, + AutoCommit => 0, + RaiseError => 1, + ShowErrorStatement => 1, }); die "$dsn $! ?" unless $dbh; $v->{Dbh} = $dbh; - eval { - $v->_db_transaction(sub { - $dbh->do("CREATE TABLE $v->{S}{assocdb_table} (". - " associd VARCHAR PRIMARY KEY,". - " username VARCHAR,". + $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; } @@ -234,21 +254,31 @@ sub _db_transaction ($$) { 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"; } } @@ -273,6 +303,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); } @@ -286,13 +317,18 @@ 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, $cookv) = @_; - return $r->{Cgi}->cookie(-name => $r->{S}{cookie_name}, - -value => $cookv, + 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 @@ -305,12 +341,13 @@ sub construct_cookie ($$$) { # 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) @@ -340,18 +377,20 @@ sub construct_cookie ($$$) { # - 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 @@ -389,8 +428,9 @@ sub construct_cookie ($$$) { # 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 @@ -405,20 +445,23 @@ sub _check_divert_core ($) { 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->_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_revoke($cookv); - $r->_db_revoke($parmv); + $r->_db_revoke($cookh); + $r->_db_revoke($parmh); return ({ Kind => 'REDIRECT-LOGGEDOUT', Message => "Logging out...", - CookieVal => '', + CookieSecret => '', Params => { } }); } if ($r->_ch('is_loggedout')) { @@ -427,35 +470,38 @@ sub _check_divert_core ($) { die unless $parmt; return ({ Kind => 'SMALLPAGE-LOGGEDOUT', Message => "You have been logged out.", - CookieVal => '', + CookieSecret => '', Params => { } }); } if ($r->_ch('is_login')) { $r->_must_be_post(); - return ({ Kind => 'LOGIN-STALE', - Message => "Stale session; you need to log in again.", - CookieVal => $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.", - CookieVal => $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.", - CookieVal => $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...", - CookieVal => $parmv, + CookieSecret => $cooks, Params => $r->_chain_params() }); } if ($cookt eq 't') { @@ -463,23 +509,25 @@ sub _check_divert_core ($) { } 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.", - CookieVal => $parmv, + CookieSecret => $news, Params => $r->_chain_params() }); } else { + $r->_db_revoke($parmh); return ({ Kind => 'LOGIN-FRESH', Message => "You need to log in again.", - CookieVal => $parmv, + CookieSecret => $news, Params => { } }); } } @@ -488,7 +536,7 @@ sub _check_divert_core ($) { if ($meth ne 'POST') { return ({ Kind => 'MAINPAGEONLY', Message => 'Entering via cross-site link.', - CookieVal => $cookv, + CookieSecret => $cooks, Params => { } }); # NB caller must then ignore params & path! # if this is too hard they can spit out a small form @@ -498,9 +546,10 @@ sub _check_divert_core ($) { die unless $cookt eq 'y'; die unless $parmt eq 'y'; - die unless $cookv eq $parmv; - $r->{Assoc} = $cookv; + die unless $cookh eq $parmh; + $r->{AssocSecret} = $cooks; $r->{UserOK} = $cooku; + print STDERR "C-D-C OK\n"; return undef; } @@ -525,58 +574,79 @@ sub _chain_params ($) { return \%p; } -sub _db_lookup ($$) { - my ($r,$v) = @_; +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}; + $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 = ?", {}, $v); - return ('') unless defined $row; + " WHERE assochash = ?", {}, $h); + if (defined $row) { + my ($nusername, $nlast) = @$row; + return ('y', $nusername); + } - my ($nusername, $nlast) = @$row; + # Well, it's not in the database. But maybe it's a hash of a + # temporary secret. - my $timeout = $r->{S}{login_timeout}; - return ('n') unless !defined $timeout || time <= $nlast + $timeout; + return 'n' unless defined $s; - return ('t') unless defined $nusername; + my ($keyt, $signature, $message, $noncet, $nonce) = + $s =~ m/^(\d+)\.(\w+)\.((\d+)\.(\w+))$/ or die; + + return 'n' if time > $noncet + $r->{S}{form_timeout}; + + 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 - # hooray - return ('y', $nusername); + $keys->error and die $!; + return 'n'; } 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) = @_; - my $divert; if (exists $r->{Divert}) { return $r->{Divert}; } my $dbh = $r->{Dbh}; $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); }); $dbh->commit(); - return $divert; + print STDERR Dumper($r->{Divert}); + return $r->{Divert}; } sub get_divert ($) { @@ -599,18 +669,27 @@ 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) = $r->check_divert(); - return 1 if $divert; + return 1 if !$divert; my $handled = $r->_ch('handle_divert',$divert); return 0 if $handled; my $kind = $divert->{Kind}; - my $cookieval = $divert->{CookieVal}; + 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, @@ -624,7 +703,6 @@ sub check_ok ($) { die; } my $new_url = $r->url_with_query_params($params); - my $cookie = $r->construct_cookie($r, $cookieval); $r->_ch('do_redirect',$new_url, $cookie); return 0; } @@ -642,9 +720,10 @@ 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; } @@ -660,18 +739,118 @@ sub _random ($$) { $!=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 _random_key ($) { my ($r) = @_; - my $bytes = ($r->{S}{associdlen} + 7) >> 3; + print STDERR "_random_key\n"; + my $bytes = ($r->{S}{secretbits} + 7) >> 3; return $r->_random($bytes); } -sub check_mutate ($) { +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 _open_keys ($) { + my ($r) = @_; + 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 _fresh_secret ($) { + my ($r) = @_; + 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 _assert_checked ($) { my ($r) = @_; die "unchecked" unless exists $r->{Divert}; +} + +sub check_mutate ($) { + my ($r) = @_; + $r->_assert_checked(); die if $r->{Divert}; my $meth = $r->_ch('get_method'); die "mutating non-POST" if $meth ne 'POST'; @@ -679,21 +858,32 @@ sub check_mutate ($) { #---------- output ---------- -sub secret_val ($) { +sub secret_cookie_val ($) { + my ($r) = @_; + $r->_assert_checked(); + return defined $r->{AssocSecret} ? $r->{AssocSecret} : ''; +} + +sub secret_hidden_val ($) { my ($r) = @_; - $r->check(); - return defined $r->{Assoc} ? $r->{Assoc} : ''; + $r->_assert_checked(); + return defined $r->{AssocSecret} ? hash($r->{AssocSecret}) : ''; } sub secret_hidden_html ($) { my ($r) = @_; return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name}, - -default => $r->secret_val()); + -default => $r->secret_hidden_val()); } sub secret_cookie ($) { my ($r) = @_; - return $r->construct_cookie($r->secret_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__