X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=cgi-auth-flexible.git;a=blobdiff_plain;f=cgi-auth-flexible.pm;h=4ab430d5f989affb6b080e1efe8401dedd5e518b;hp=61955c90fe26ec497af1bedf19fdb91b2dcaa5ee;hb=6ca44cd905b9d2c8d83bc10d95428f3da8ed7e45;hpb=99ad03d323ee579b8901615cd18f80c39d610b55;ds=sidebyside diff --git a/cgi-auth-flexible.pm b/cgi-auth-flexible.pm index 61955c9..4ab430d 100644 --- a/cgi-auth-flexible.pm +++ b/cgi-auth-flexible.pm @@ -93,8 +93,8 @@ sub login_ok_password ($$) { 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 undef unless $r->_ch('username_password_ok', $username, $password); - return $username; + my $error = $r->_ch('username_password_error', $username, $password); + return defined($error) ? (undef,$error) : ($username,undef); } sub do_redirect_cgi ($$$$) { @@ -180,6 +180,7 @@ sub new_verifier { my $verifier = { S => { dir => undef, + assocdb_dbh => undef, # must have AutoCommit=0, RaiseError=1 assocdb_path => 'caf-assocs.db', keys_path => 'caf-keys', assocdb_dsn => undef, @@ -206,10 +207,11 @@ sub new_verifier { get_path_info => sub { $_[0]->path_info() }, get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) }, get_method => sub { $_[0]->request_method() }, + check_https => sub { !!$_[0]->https() }, get_url => sub { $_[0]->url(); }, is_login => sub { defined $_[1]->_rp('password_param_name') }, login_ok => \&login_ok_password, - username_password_ok => sub { die }, + username_password_error => 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 }, @@ -225,6 +227,7 @@ sub new_verifier { gen_postmainpage_form => \&gen_postmainpage_form, gettext => sub { gettext($_[2]); }, print => sub { print $_[2] or die $!; }, + debug => sub { }, # like print; msgs contain trailing \n }, Dbh => undef, }; @@ -254,17 +257,24 @@ sub _dbopen ($) { my $dbh = $v->{Dbh}; return $dbh if $dbh; - $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb'); - my $dsn = $v->{S}{assocdb_dsn}; - - my $u = umask 077; - $dbh = DBI->connect($dsn, $v->{S}{assocdb_user}, - $v->{S}{assocdb_password}, { - AutoCommit => 0, - RaiseError => 1, - ShowErrorStatement => 1, - }); - die "$dsn $! ?" unless $dbh; + $dbh = $v->{S}{assocdb_dbh}; + if ($dbh) { + die if $dbh->{AutoCommit}; + die unless $dbh->{RaiseError}; + } else { + $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=".$v->_get_path('assocdb'); + my $dsn = $v->{S}{assocdb_dsn}; + + my $u = umask 077; + $dbh = DBI->connect($dsn, $v->{S}{assocdb_user}, + $v->{S}{assocdb_password}, { + AutoCommit => 0, + RaiseError => 1, + ShowErrorStatement => 1, + }); + umask $u; + die "$dsn $! ?" unless $dbh; + } $v->{Dbh} = $dbh; $v->_db_setup_do("CREATE TABLE $v->{S}{assocdb_table} (". @@ -290,31 +300,31 @@ sub _db_transaction ($$) { my $retries = 10; my $rv; my $dbh = $v->{Dbh}; -print STDERR "DT entry\n"; +#print STDERR "DT entry\n"; for (;;) { -print STDERR "DT loop\n"; +#print STDERR "DT loop\n"; if (!eval { $rv = $fn->(); -print STDERR "DT fn ok\n"; +#print STDERR "DT fn ok\n"; 1; }) { -print STDERR "DT fn error\n"; +#print STDERR "DT fn error\n"; { local ($@); $dbh->rollback(); } -print STDERR "DT fn throwing\n"; +#print STDERR "DT fn throwing\n"; die $@; } -print STDERR "DT fn eval ok\n"; +#print STDERR "DT fn eval ok\n"; if (eval { $dbh->commit(); -print STDERR "DT commit ok\n"; +#print STDERR "DT commit ok\n"; 1; }) { -print STDERR "DT commit eval ok ",Dumper($rv); +#print STDERR "DT commit eval ok ",Dumper($rv); return $rv; } -print STDERR "DT commit throw?\n"; +#print STDERR "DT commit throw?\n"; die $@ if !--$retries; -print STDERR "DT loop again\n"; +#print STDERR "DT loop again\n"; } } @@ -349,6 +359,11 @@ sub _rp ($$@) { my $p = scalar $r->_ch('get_param',$pn) } +sub _debug ($@) { + my ($r,@args) = @_; + $r->_ch('debug',@args); +} + sub _get_path ($$) { my ($v,$keybase) = @_; my $leaf = $v->{S}{"${keybase}_path"}; @@ -372,7 +387,7 @@ my @ca = (-name => $r->{S}{cookie_name}, -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"; +#print STDERR "CC $r $c $cooks $cookie (@ca).\n"; return $cookie; } @@ -489,8 +504,16 @@ print STDERR "CC $r $c $cooks $cookie (@ca).\n"; sub _check_divert_core ($) { my ($r) = @_; - my $meth = $r->_ch('get_method'); my $cooks = $r->_ch('get_cookie'); + + if (!$r->_ch('check_https')) { + return ({ Kind => 'REDIRECT-HTTPS', + Message => $r->_gt("Redirecting to secure server..."), + CookieSecret => undef, + Params => { } }); + } + + my $meth = $r->_ch('get_method'); my $parmh = $r->_rp('assoc_param_name'); my $cookh = defined $cooks ? $r->hash($cooks) : undef; @@ -499,7 +522,7 @@ sub _check_divert_core ($) { ? $cooks : undef; my ($parmt) = $r->_identify($parmh, $parms); - print STDERR "_c_d_c cookt=$cookt parmt=$parmt\n"; + $r->_debug("_c_d_c cookt=$cookt parmt=$parmt\n"); if ($r->_ch('is_logout')) { $r->_must_be_post(); @@ -523,7 +546,7 @@ sub _check_divert_core ($) { if ($r->_ch('is_login')) { $r->_must_be_post(); die unless $parmt; - if (!$cookt && $parmt eq 't') { + if (!$cookt && $parmt eq 'n') { return ({ Kind => 'SMALLPAGE-NOCOOKIE', Message => $r->_gt("You do not seem to have cookies". " enabled. You must enable cookies". @@ -540,10 +563,12 @@ sub _check_divert_core ($) { Params => { } }) } die unless $parmt eq 't' || $parmt eq 'y'; - my $username = $r->_ch('login_ok'); + my ($username, $login_errormessage) = $r->_ch('login_ok'); unless (defined $username && length $username) { + $login_errormessage = $r->_gt("Incorrect username/password.") + if !$login_errormessage; return ({ Kind => 'LOGIN-BAD', - Message => $r->_gt("Incorrect username/password."), + Message => $login_errormessage, CookieSecret => $cooks, Params => $r->chain_params() }) } @@ -600,7 +625,7 @@ sub _check_divert_core ($) { } $r->{AssocSecret} = $cooks; $r->{UserOK} = $cooku; - print STDERR "C-D-C OK\n"; +#print STDERR "C-D-C OK\n"; return undef; } @@ -637,9 +662,9 @@ sub _identify ($$) { # where $t is one of "t" "y" "n", or "" (for -) # either $s must be undef, or $h eq $r->hash($s) -print STDERR "_identify\n"; +#print STDERR "_identify\n"; return '' unless defined $h && length $h; -print STDERR "_identify h=$h s=".(defined $s ? $s : '')."\n"; +#print STDERR "_identify h=$h s=".(defined $s ? $s : '')."\n"; my $dbh = $r->{Dbh}; @@ -651,7 +676,7 @@ print STDERR "_identify h=$h s=".(defined $s ? $s : '')."\n"; " FROM $r->{S}{assocdb_table}". " WHERE assochash = ?", {}, $h); if (defined $row) { -print STDERR "_identify h=$h s=$s YES @$row\n"; +#print STDERR "_identify h=$h s=$s YES @$row\n"; my ($nusername, $nlast) = @$row; return ('y', $nusername); } @@ -666,18 +691,18 @@ print STDERR "_identify h=$h s=$s YES @$row\n"; return 'n' if time > $noncet + $r->{S}{login_form_timeout}; -print STDERR "_identify noncet=$noncet ok\n"; +#print STDERR "_identify noncet=$noncet ok\n"; my $keys = $r->_open_keys(); while (my ($rkeyt, $rkey, $line) = $r->_read_key($keys)) { -print STDERR "_identify search rkeyt=$rkeyt rkey=$rkey\n"; +#print STDERR "_identify search rkeyt=$rkeyt rkey=$rkey\n"; last if $rkeyt < $keyt; # too far down in the file my $trysignature = $r->_hmac($rkey, $message); -print STDERR "_identify search rkeyt=$rkeyt rkey=$rkey trysig=$trysignature\n"; +#print STDERR "_identify search rkeyt=$rkeyt rkey=$rkey try=$trysignature\n"; return 't' if $trysignature eq $signature; } # oh well -print STDERR "_identify NO\n"; +#print STDERR "_identify NO\n"; $keys->error and die $!; return 'n'; @@ -710,7 +735,7 @@ sub check_divert ($) { my $dbh = $r->{Dbh}; $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); }); $dbh->commit(); - print STDERR Dumper($r->{Divert}); + $r->_debug(Data::Dumper->Dump([$r->{Divert}],[qw(divert)])); return $r->{Divert}; } @@ -729,7 +754,7 @@ sub get_username ($) { sub url_with_query_params ($$) { my ($r, $params) = @_; -print STDERR "PARAMS ",Dumper($params); +#print STDERR "PARAMS ",Dumper($params); my $uri = URI->new($r->_ch('get_url')); $uri->path($uri->path() . $params->{''}[0]) if $params->{''}; $uri->query_form(flatten_params($params)); @@ -740,7 +765,7 @@ 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"; +#print STDERR "_cgi_header_args ",join('|',@ha),".\n"; return @ha; } @@ -765,11 +790,17 @@ sub check_ok ($) { $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') { + } elsif ($kind =~ m/REDIRECT-(?:LOGGEDIN|HTTPS)/) { } else { die; } my $new_url = $r->url_with_query_params($params); + if ($kind eq 'REDIRECT-HTTPS') { + my $uri = URI->new($new_url); + die unless $uri->scheme eq 'http'; + $uri->scheme('https'); + $new_url = $uri->as_string(); + } $r->_ch('do_redirect',$new_url, $cookie); return 0; } @@ -809,19 +840,19 @@ sub _random ($$) { my $rsp = $r->{S}{random_source}; if (!$rsf) { $v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!"; -print STDERR "RH $rsf\n"; +#print STDERR "RH $rsf\n"; } my $bin; $!=0; read($rsf,$bin,$bytes) == $bytes or die "$rsp $!"; my $out = unpack "H*", $bin; - print STDERR "_random out $out\n"; +#print STDERR "_random out $out\n"; return $out; } sub _random_key ($) { my ($r) = @_; - print STDERR "_random_key\n"; +#print STDERR "_random_key\n"; my $bytes = ($r->{S}{secretbits} + 7) >> 3; return $r->_random($bytes); } @@ -843,28 +874,28 @@ sub _open_keys ($) { my ($r) = @_; my $spath = $r->_get_path('keys'); for (;;) { - print STDERR "_open_keys\n"; +#print STDERR "_open_keys\n"; my $keys = new IO::File $spath, 'r+'; if ($keys) { - print STDERR "_open_keys open\n"; +#print STDERR "_open_keys open\n"; stat $keys or die $!; # NB must not disturb stat _ my $size = (stat _)[7]; my $age = time - (stat _)[9]; - print STDERR "_open_keys open size=$size age=$age\n"; +#print STDERR "_open_keys open size=$size age=$age\n"; return $keys if $size && $age <= $r->{S}{key_rollover} / 2; - print STDERR "_open_keys open bad\n"; +#print STDERR "_open_keys open bad\n"; } # file doesn't exist, or is empty or too old if (!$keys) { - print STDERR "_open_keys closed\n"; +#print STDERR "_open_keys closed\n"; 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]; - print STDERR "_open_keys created size=$size\n"; +#print STDERR "_open_keys created size=$size\n"; 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 @@ -872,23 +903,23 @@ sub _open_keys ($) { flock $keys, LOCK_EX or die "$spath $!"; stat $spath or die "$spath $!"; my $path_inum = (stat _)[1]; - print STDERR "_open_keys locked our=$our_inum path=$path_inum\n"; +#print STDERR "_open_keys locked our=$our_inum path=$path_inum\n"; next if $our_inum != $path_inum; # someone else has done it # We now hold the lock! - print STDERR "_open_keys creating\n"; +#print STDERR "_open_keys creating\n"; 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 STDERR "_open_keys copy1\n"; +#print STDERR "_open_keys copy1\n"; print $newkeys, $line or die $!; } $keys->error and die $!; close $newkeys or die "$spath.new $!"; rename "$spath.new", "$spath" or die "$spath: $!"; - print STDERR "_open_keys installed\n"; +#print STDERR "_open_keys installed\n"; # 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 @@ -898,7 +929,7 @@ sub _open_keys ($) { sub _fresh_secret ($) { my ($r) = @_; - print STDERR "_fresh_secret\n"; +#print STDERR "_fresh_secret\n"; my $keys = $r->_open_keys(); my ($keyt, $key) = $r->_read_key($keys); @@ -910,7 +941,7 @@ sub _fresh_secret ($) { my $signature = $r->_hmac($key, $message); my $secret = "$keyt.$signature.$message"; - print STDERR "FRESH $secret\n"; +#print STDERR "FRESH $secret\n"; return $secret; } @@ -918,11 +949,11 @@ sub _hmac ($$$) { my ($r, $keyhex, $message) = @_; my $keybin = pack "H*", $keyhex; my $alg = $r->{S}{hash_algorithm}; -print STDERR "hmac $alg\n"; +#print STDERR "hmac $alg\n"; my $base = new Digest $alg; -print STDERR "hmac $alg $base\n"; +#print STDERR "hmac $alg $base\n"; my $digest = new Digest::HMAC $keybin, $base; -print STDERR "hmac $alg $base $digest\n"; +#print STDERR "hmac $alg $base $digest\n"; $digest->add($message); return $digest->hexdigest(); } @@ -930,7 +961,7 @@ print STDERR "hmac $alg $base $digest\n"; sub hash ($$) { my ($r, $message) = @_; my $alg = $r->{S}{hash_algorithm}; -print STDERR "hash $alg\n"; +#print STDERR "hash $alg\n"; my $digest = new Digest $alg; $digest->add($message); return $digest->hexdigest(); @@ -997,6 +1028,8 @@ sub secret_cookie ($) { return $cookv; } +1; + __END__ =head1 NAME