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=06625631bcf4ece5ab4ee41fd97d71b80474fed2;hp=00b766aec90bf5a416ecdbe73ff640efc6777173;hb=835fb7c01a795a36ff8a24daa8e3896c208dcca3;hpb=1a02b976452bf546a1d225361b3e7c27566a6696 diff --git a/cgi-auth-flexible.pm b/cgi-auth-flexible.pm index 00b766a..0662563 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, (''); } +sub gen_special_link_html ($$$$) { + my ($c,$r,$anchor,$specval) = @_; + my %params = ($r->{S}{special_param_name} => [ $specval ]); + return ''. + $anchor.""; +} +sub gen_plain_licence_link_html ($$) { + my ($c,$r) = @_; + gen_special_link_html($c,$r, 'GNU Affero GPL', 'licence'); +} +sub gen_plain_source_link_html ($$) { + my ($c,$r) = @_; + gen_special_link_html($c,$r, 'Source available', 'source'); +} + +sub gen_plain_footer_html ($$) { + my ($c,$r) = @_; + return ('
', + ("Powered by Free / Libre / Open Source Software". + " according to the ".$r->_ch('gen_licence_link_html')."."), + $r->_ch('gen_source_link_html').".", + '
'); +} + #---------- verifier object methods ---------- sub new_verifier { @@ -176,6 +204,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, @@ -192,6 +221,7 @@ sub new_verifier { dummy_param_name_prefix => 'caf__', cookie_name => "caf_assocsecret", password_param_name => 'password', + special_param_name => 'caf_special', username_param_names => [qw(username)], form_entry_size => 60, logout_param_names => [qw(caf_logout)], @@ -199,12 +229,14 @@ sub new_verifier { 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 }, @@ -214,12 +246,16 @@ sub new_verifier { get_cookie_domain => \&get_cookie_domain, encrypted_only => 1, gen_start_html => sub { $_[0]->start_html($_[2]); }, + gen_footer_html => \&gen_plain_footer_html, + gen_licence_link_html => \&gen_plain_licence_link_html, + gen_source_link_html => \&gen_plain_source_link_html, gen_end_html => sub { $_[0]->end_html(); }, gen_login_form => \&gen_plain_login_form, gen_login_link => \&gen_plain_login_link, 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, }; @@ -249,17 +285,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} (". @@ -285,31 +328,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"; } } @@ -344,6 +387,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"}; @@ -367,7 +415,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; } @@ -484,8 +532,25 @@ print STDERR "CC $r $c $cooks $cookie (@ca).\n"; sub _check_divert_core ($) { my ($r) = @_; - my $meth = $r->_ch('get_method'); + my $special = $r->_rp('special_param_name'); + if ($special) { + die if $special =~ m/\W/; + return ({ Kind => 'SPECIAL-'.uc $special, + Message => undef, + CookieSecret => undef, + Params => { } }); + } + my $cooks = $r->_ch('get_cookie'); + + if ($r->{S}{encrypted_only} && !$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; @@ -494,7 +559,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(); @@ -502,47 +567,51 @@ 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 => { } }); } if ($r->_ch('is_loggedout')) { die unless $meth eq 'GET'; - die unless $cookt; - die unless $parmt; + die if $cookt eq 'y'; + die if $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.", + 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() }) } $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() }); } @@ -562,13 +631,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() }); } 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 => { } }); } @@ -577,7 +646,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! @@ -593,7 +662,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; } @@ -619,6 +688,8 @@ sub chain_params ($) { foreach my $name (grep /^$dummy_prefix/, keys %p) { delete $p{$name}; } + die if exists $p{''}; + $p{''} = [ $r->_ch('get_path_info') ]; return \%p; } @@ -628,9 +699,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}; @@ -642,7 +713,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); } @@ -657,18 +728,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'; @@ -701,7 +772,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}; } @@ -720,8 +791,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(); } @@ -730,7 +802,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; } @@ -748,10 +820,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 @@ -759,27 +827,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; @@ -787,8 +865,9 @@ sub check_ok ($) { $r->_print($r->{Cgi}->header($r->_cgi_header_args($cookie)), $r->_ch('gen_start_html',$title), - (join "\n", @body), - $r->_ch('gen_end_html')); + (join "\n", (@body, + $r->_ch('gen_footer_html'), + $r->_ch('gen_end_html')))); return 0; } @@ -799,19 +878,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); } @@ -833,28 +912,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 @@ -862,23 +941,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 @@ -888,7 +967,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); @@ -900,7 +979,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; } @@ -908,11 +987,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(); } @@ -920,7 +999,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(); @@ -987,6 +1066,8 @@ sub secret_cookie ($) { return $cookv; } +1; + __END__ =head1 NAME