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=7f2f979c6e8846048a8255ec33b9015bf718cfb4;hb=6ca44cd905b9d2c8d83bc10d95428f3da8ed7e45;hpb=589da9ecc81d68dd4c78ff4c29c291e894f2b460 diff --git a/cgi-auth-flexible.pm b/cgi-auth-flexible.pm index 7f2f979..4ab430d 100644 --- a/cgi-auth-flexible.pm +++ b/cgi-auth-flexible.pm @@ -32,7 +32,7 @@ BEGIN { @EXPORT = qw(); %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], - @EXPORT_OK = qw(setup); + @EXPORT_OK = qw(); } our @EXPORT_OK; @@ -54,6 +54,7 @@ sub flatten_params ($) { my ($p) = @_; my @p; foreach my $k (keys %$p) { + next if $k eq ''; foreach my $v (@{ $p->{$k} }) { push @p, $k, $v; } @@ -92,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 ($$$$) { @@ -113,10 +114,13 @@ sub gen_some_form ($$) { # Calls $bodyfn->($c,$r) which returns @formbits my $c = $r->{Cgi}; my @form; + my $pathinfo = ''; + $pathinfo .= $params->{''}[0] if $params->{''}; push @form, ('
'); + escapeHTML($r->_ch('get_url').$pathinfo).'">'); push @form, $bodyfn->($c,$r); foreach my $n (keys %$params) { + next if $n eq ''; foreach my $val (@{ $params->{$n} }) { push @form, (''); push @form, ('', '', ''); return @form; @@ -155,7 +159,7 @@ sub gen_postmainpage_form ($$$) { return $r->gen_some_form($params, sub { my @form; push @form, (''); return @form; }); @@ -176,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, @@ -189,23 +194,24 @@ sub new_verifier { login_form_timeout => 3600, # seconds key_rollover => 86400, # seconds assoc_param_name => 'caf_assochash', - dummy_param_name => 'caf_dummy', + dummy_param_name_prefix => 'caf__', cookie_name => "caf_assocsecret", password_param_name => 'password', username_param_names => [qw(username)], form_entry_size => 60, logout_param_names => [qw(caf_logout)], - login_submit_name => [qw(caf_login)], loggedout_param_names => [qw(caf_loggedout)], promise_check_mutate => 0, get_param => sub { $_[0]->param($_[2]) }, get_params => sub { $_[1]->get_params() }, + 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 }, @@ -221,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, }; @@ -250,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} (". @@ -286,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"; } } @@ -345,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"}; @@ -368,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; } @@ -485,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; @@ -495,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(); @@ -503,7 +530,7 @@ sub _check_divert_core ($) { $r->_db_revoke($cookh); $r->_db_revoke($parmh); return ({ Kind => 'REDIRECT-LOGGEDOUT', - Message => "Logging out...", + Message => $r->_gt("Logging out..."), CookieSecret => '', Params => { } }); } @@ -512,40 +539,44 @@ sub _check_divert_core ($) { die unless $cookt; die unless $parmt; return ({ Kind => 'SMALLPAGE-LOGGEDOUT', - Message => "You have been logged out.", + Message => $r->_gt("You have been logged out."), CookieSecret => '', Params => { } }); } 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 => "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() }) + Message => $r->_gt("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.", + Message => $r->_gt("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'); + 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 => "Incorrect username/password.", + Message => $login_errormessage, CookieSecret => $cooks, - Params => $r->_chain_params() }) + Params => $r->chain_params() }) } $r->_db_record_login_ok($parmh,$username); return ({ Kind => 'REDIRECT-LOGGEDIN', - Message => "Logging in...", + Message => $r->_gt("Logging in..."), CookieSecret => $cooks, - Params => $r->_chain_params() }); + Params => $r->chain_params() }); } if ($cookt eq 't') { $cookt = ''; @@ -563,13 +594,13 @@ sub _check_divert_core ($) { my $news = $r->_fresh_secret(); if ($meth eq 'GET') { return ({ Kind => 'LOGIN-INCOMINGLINK', - Message => "You need to log in.", + Message => $r->_gt("You need to log in."), CookieSecret => $news, - Params => $r->_chain_params() }); + Params => $r->chain_params() }); } else { $r->_db_revoke($parmh); return ({ Kind => 'LOGIN-FRESH', - Message => "You need to log in.", + Message => $r->_gt("You need to log in."), CookieSecret => $news, Params => { } }); } @@ -578,7 +609,7 @@ sub _check_divert_core ($) { if (!$r->{S}{promise_check_mutate}) { if ($meth ne 'POST') { return ({ Kind => 'MAINPAGEONLY', - Message => 'Entering via cross-site link.', + Message => $r->_gt('Entering via cross-site link.'), CookieSecret => $cooks, Params => { } }); # NB caller must then ignore params & path! @@ -594,11 +625,11 @@ 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; } -sub _chain_params ($) { +sub chain_params ($) { my ($r) = @_; my %p = %{ $r->_ch('get_params') }; foreach my $pncn (keys %{ $r->{S} }) { @@ -616,6 +647,12 @@ sub _chain_params ($) { delete $p{$name}; } } + my $dummy_prefix = $r->{S}{dummy_param_name_prefix}; + foreach my $name (grep /^$dummy_prefix/, keys %p) { + delete $p{$name}; + } + die if exists $p{''}; + $p{''} = [ $r->_ch('get_path_info') ]; return \%p; } @@ -625,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}; @@ -639,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); } @@ -654,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'; @@ -698,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}; } @@ -717,8 +754,9 @@ 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)); return $uri->as_string(); } @@ -727,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; } @@ -745,10 +783,6 @@ sub check_ok ($) { my $params = $divert->{Params}; my $cookie = $r->construct_cookie($cookiesecret); - if (defined $cookiesecret) { - $params->{$r->{S}{assoc_param_name}} = [ $r->hash($cookiesecret) ]; - } - if ($kind =~ m/^REDIRECT-/) { # for redirects, we honour stored NextParams and SetCookie, # as we would for non-divert @@ -756,27 +790,37 @@ 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; } + if (defined $cookiesecret) { + $params->{$r->{S}{assoc_param_name}} = [ $r->hash($cookiesecret) ]; + } + my ($title, @body); if ($kind =~ m/^LOGIN-/) { $title = $r->_gt('Login'); - push @body, $r->_gt($divert->{Message}); + push @body, $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, $divert->{Message}; push @body, $r->_ch('gen_login_link', $params); } elsif ($kind =~ m/^MAINPAGEONLY$/) { $title = $r->_gt('Entering secure site.'); - push @body, $r->_gt($divert->{Message}); + push @body, $divert->{Message}; push @body, $r->_ch('gen_postmainpage_form', $params); } else { die $kind; @@ -796,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); } @@ -830,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 @@ -859,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 @@ -885,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); @@ -897,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; } @@ -905,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(); } @@ -917,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(); @@ -984,6 +1028,8 @@ sub secret_cookie ($) { return $cookv; } +1; + __END__ =head1 NAME