wip, check_ok finished

[cgi-auth-flexible.git] / cgi-auth-hybrid.pm

diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index 35739b035ef967ba07023f1192bd6dc6a95b8f05..4b413671798f845206dad619fd2796f8501b0a69 100644 (file)
--- a/cgi-auth-hybrid.pm
+++ b/cgi-auth-hybrid.pm
@@ -33,6 +33,19 @@ use DBI;
 use CGI;
 use Locale::Gettext;
 
+#---------- 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 has_a_param ($$) {
@@ -43,15 +56,13 @@ sub has_a_param ($$) {
     return 0;
 }
 
-sub get_param_list ($$) {
+sub get_params ($$) {
     my ($c) = @_;
-    my @p = ( );
+    my %p;
     foreach my $name ($c->param()) {
-       foreach my $val ($c->param($name)) {
-           push @p, $name, $val;
-       }
+       $p{$name} = [ $c->param($name) ];
     }
-    return @p;
+    return \%p;
 }
 
 sub get_cookie_domain ($$$) {
@@ -87,24 +98,39 @@ sub do_redirect_cgi ($$$$) {
 sub gen_plain_login_form ($$) {
     my ($c,$r, $params) = @_;
     my @form;
-    push @form, ('<form method="POST" action="',
-                escapeHTML($r->_ch('get_url')).'>',
+    push @form, ('<form method="POST" action="'.
+                escapeHTML($r->_ch('get_url')).'>'.
                 '<table>');
     my $sz = 'size="'.$r->{S}{form_entry_size}.'"';
     foreach my $up (@{ $r->{S}{username_param_names}}) {
        push @form, ('<tr><td>',$r->_gt(ucfirst $up),'</td>',
-                    '<td><input type="text" ',$sz,
+                    '<td><input type="text" ',$sz.
                     ' name=',$up,'></td></tr>');
     }
     push @form, ('<tr><td>'.$r->_gt('Password'),'</td>',
-                '<td><input type="password" ',$sz,
+                '<td><input type="password" '.$sz.
                 ' name="'.$r->{S}{password_param_name}.'"></td></tr>');
     push @form, ('<tr><td colspan="2">',
                 '<input type="submit"'.
-                ' name="'.$r->{S}{login_submit_name}.'"',
-                ' value="'.$r->_gt('Login').'"></td></tr></table>');
-    foreach my $p (@$params) {
-       
+                ' name="'.$r->{S}{login_submit_name}.'"'.
+                ' value="'.$r->_gt('Login').'"></td></tr>',
+                '</table>');
+    foreach my $n (keys %$params) {
+       push @form, ('<input type="hidden"'.
+                    ' name="'.$n.'"'.
+                    ' value="'.$params->{$n}.'">');
+    }
+    push @form, ('</form>');
+    return join "\n", @form;
+}
+
+sub gen_login_link ($$) {
+    my ($c,$r, $params) = @_;
+    my $url = $r->url_with_query_params($params);
+    return ('<a href="'.escapeHTML($url).'">'.
+           $r->_gt('Log in again to continue.').
+           '</a>');
+}
 
 #---------- verifier object methods ----------
 
@@ -129,7 +155,7 @@ sub new_verifier {
            loggedout_param_names => [qw(cah_loggedout)],
            promise_check_mutate => 0,
            get_param => sub { $_[0]->param($_[2]) },
-           get_param_list => sub { $_[1]->get_param_list() },
+           get_params => sub { $_[1]->get_params() },
            get_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) },
            get_method => sub { $_[0]->request_method() },
            get_url => sub { $_[0]->url(); },
@@ -146,6 +172,7 @@ sub new_verifier {
            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]); },
            };
        },
@@ -345,7 +372,7 @@ fixme needs wrapping with something to make and commit a transaction
        return ({ Kind => 'REDIRECT-LOGGEDOUT',
                  Message => "Logging out...",
                  Cookie => '',
-                 Params => [ ] });
+                 Params => { } });
     }
     if ($r->_ch('is_loggedout')) {
        die unless $meth eq 'GET';
@@ -354,14 +381,14 @@ fixme needs wrapping with something to make and commit a transaction
        return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
                  Message => "You have been logged out.",
                  Cookie => '',
-                 Params => [ ] });
+                 Params => { } });
     }
     if ($r->_ch('is_login')) {
        $r->_must_be_post();
        return ({ Kind => 'LOGIN-STALE',
                  Message => "Stale session; you need to log in again.",
                  Cookie => $r->_fresh_cookie(),
-                 Params => [ ] })
+                 Params => { } })
            if $parmt eq 'n';
        die unless $parmt eq 't' || $parmt eq 'y';
        return ({ Kind => 'SMALLPAGE-NOCOOKIE',
@@ -406,7 +433,7 @@ fixme needs wrapping with something to make and commit a transaction
            return ((Kind => 'LOGIN-FRESH',
                     Message => "You need to log in again.",
                     Cookie => $parmv,
-                    Params => [ ]);
+                    Params => { });
        }
     }
 
@@ -415,7 +442,7 @@ fixme needs wrapping with something to make and commit a transaction
            return ({ Kind => 'MAINPAGEONLY',
                      Message => 'Entering via cross-site link.',
                      Cookie => $cookv,
-                     Params => [ ] });
+                     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"
@@ -431,7 +458,7 @@ fixme needs wrapping with something to make and commit a transaction
 
 sub _chain_params ($) {
     my ($r) = @_;
-    my %elim = { };
+    my %p = %{ $r->_ch('get_params') };
     foreach my $pncn (keys %{ $r->{S} }) {
        if ($pncn =~ m/_param_name$/) {
            my $name = $r->{S}{$pncn};
@@ -443,18 +470,10 @@ sub _chain_params ($) {
            next;
        }
        foreach my $param (@$names) {
-           $elim{$name} = 1;
+           delete $p{$name};
        }
     }
-    my @p = $r->_ch('get_param_list');
-    my ($name,$val);
-    my @q = ();
-    while (@p) {
-       ($name,$val,@p) = @p;
-       next if $elim{$name};
-       push @q, $name, $val;
-    }
-    return @q;
+    return \%p;
 }
 
 sub _db_lookup ($$) {
@@ -497,10 +516,10 @@ sub _db_record_login_ok ($$$) {
             $v, $user, time);
 }
 
-sub url_with_query_params ($@) {
-    my ($r, @params) = @_;
+sub url_with_query_params ($$) {
+    my ($r, $params) = @_;
     my $uri = URI->new($r->_ch('get_url'));
-    $uri->query_form(\@params);
+    $uri->query_form(flatten_params($params));
     return $uri->as_string();
 }
 
@@ -521,36 +540,36 @@ sub check_ok ($) {
        # for redirects, we honour stored NextParams and SetCookie,
        # as we would for non-divert
        if ($divert_kind eq 'REDIRECT-LOGGEDOUT') {
-           push @$params, $r->{S}{cah_loggedout}[0], 1;
+           $params{$r->{S}{loggedout_param_names}[0]} = 1;
        } elsif ($divert_kind eq 'REDIRECT-LOGOUT') {
-           push @$params, $r->{S}{cah_logout}[0], 1;
+           $params{$r->{S}{logout_param_names}[0]} = 1;
        } elsif ($divert_kind eq 'REDIRECT-LOGGEDIN') {
        } else {
            die;
        }
-       my $new_url = $r->url_with_query_params(@$params);
+       my $new_url = $r->url_with_query_params($params);
        $r->_ch('do_redirect')($new_url, $cookie);
        return 0;
     }
-    $kind =~ m/^SMALLPAGE|^LOGIN/ or die;
 
     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);
-       $body .= $r->_ch(
-
-       $r->_print(
-                  $r->_ch('start_html')($title),
-                  
-                  
-
-    if ($kind =~ m/^SMALLPAGE
-
-if (defined $cookie) {
-        $r->_ch('header_out')($cookie);
+    } 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->_ch('start_html')($title),
+              @body,
+              $r->_ch('end_html'));
+    return 0;
+}
     
 UP TO HERE