wip, rename __ to _gt

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

diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index 68a73809bdfebfd9fe88b1d2bdb5dfb3472041ed..27cf367d64cbb8f17359e755f0cd818cc8555eae 100644 (file)
--- a/cgi-auth-hybrid.pm
+++ b/cgi-auth-hybrid.pm
@@ -31,6 +31,7 @@ our @EXPORT_OK;
 
 use DBI;
 use CGI;
+use Locale::Gettext;
 
 #---------- default callbacks ----------
 
@@ -53,6 +54,50 @@ sub get_param_list ($$) {
     return @p;
 }
 
+sub get_cookie_domain ($$$) {
+    my ($c,$r) = @_;
+    my $uri = new URI $r->_ch('get_url');
+    return $uri->host();
+}
+
+sub construct_cookie ($$$) {
+    my ($c, $r, $cookv) = @_;
+    return $c->cookie(-name => $r->{S}{cookie_name},
+                     -value => $cookv,
+                     -path => $r->{S}{cookie_path},
+                     -domain => $r->_ch('get_cookie_domain'),
+                     -expires => '+'.$r->{S}{login_timeout}.'s',
+                     -secure => $r->{S}{encrypted_only});
+}
+
+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->_ch('gen_start_html')($r->_gt('Redirection')),
+              '<a href="'.escapeHTML($new_url).'">',
+              $r->_gt("If you aren't redirected, click to continue."),
+              "</a>",
+              $c->_ch('gen_end_html'));
+}
+
+sub gen_plain_login_form ($$) {
+    my ($c,$r) = @_;
+    my @form;
+    push @form, ('<form method="POST" action="',
+                escapeHTML($r->_ch('get_url')).'>',
+                '<table>');
+    foreach my $up (@{ $r->{S}{username_param_names}}) {
+       push @form, '<tr><td>'.$r->
+    push @form
+       '<table>'.
+       '<tr>'
+       '<input type="text" name="'
+       '<input type="text" name="'.$r->{S}{password_param_name}.'">'.
+
 #---------- verifier object methods ----------
 
 sub new_verifier {
@@ -69,12 +114,14 @@ sub new_verifier {
            login_timeout => 86400, # seconds
            assoc_param_name => 'cah_associd',
            password_param_name => 'password',
+           username_param_names => [qw(username)],
+           form_entry_size => 60,
            logout_param_names => [qw(cah_logout)],
            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_cah_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) },
+           get_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) },
            get_method => sub { $_[0]->request_method() },
            get_url => sub { $_[0]->url(); },
             is_login => sub { defined $_[1]->_rp('password_param_name') },
@@ -82,6 +129,16 @@ sub new_verifier {
            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 },
+           handle_divert => sub { return 0 },
+           do_redirect => \&do_redirect_cgi, # this hook is allowed to throw
+           cookie_path => "/",
+           get_cookie_domain => \&get_cookie_domain,
+           encrypted_only => 0,
+           gen_start_html => sub { $_[0]->start_html($_[2]); },
+           gen_end_html => sub { $_[0]->end_html(); },
+           gen_login_form => \&gen_plain_login_form,
+           gettext => sub { gettext($_[2]); },
+           };
        },
        Dbh => undef,
     };
@@ -151,6 +208,9 @@ sub _rp ($$@) {
     my $p = scalar $r->_ch('get_param',$pn)
 }
 
+sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext')($t); }
+sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print')(join '', @t); }
+
 # pages/param-sets are
 #   n normal non-mutating page
 #   r retrieval of information for JS, non-mutating
@@ -262,7 +322,7 @@ fixme needs wrapping with something to make and commit a transaction
     my ($r) = @_;
 
     my $meth = $r->_ch('get_method');
-    my $cookv = $r->_ch('get_cah_cookie');
+    my $cookv = $r->_ch('get_cookie');
     my $parmv = $r->_rp('assoc_param_name');
 
     my ($cookt,$cooku) = $r->_db_lookup($cookv);
@@ -273,7 +333,7 @@ fixme needs wrapping with something to make and commit a transaction
        die unless $parmt;
        $r->_db_revoke($cookv);
        $r->_db_revoke($parmv);
-       return ({ Kind => 'REDIRECT/LOGGEDOUT',
+       return ({ Kind => 'REDIRECT-LOGGEDOUT',
                  Message => "Logging out...",
                  Cookie => '',
                  Params => [ ] });
@@ -282,7 +342,7 @@ fixme needs wrapping with something to make and commit a transaction
        die unless $meth eq 'GET';
        die unless $cookt;
        die unless $parmt;
-       return ({ Kind => 'SMALLPAGE/LOGGEDOUT',
+       return ({ Kind => 'SMALLPAGE-LOGGEDOUT',
                  Message => "You have been logged out.",
                  Cookie => '',
                  Params => [ ] });
@@ -441,24 +501,48 @@ sub check_ok ($) {
     my ($divert) = $authreq->check_divert();
     return 1 if $divert;
 
+    my $handled = $r->_ch('handle_divert')($divert);
+    return 0 if $handled;
+
     my $kind = $divert->{Kind};
     my $cookie = $divert->{Cookie};
     my $params = $divert->{Params};
 
-    if (defined $cookie) {
-        $r->_ch('header_out')($cookie);
-    }
     if ($kind =~ m/^REDIRECT-/) {
        # for redirects, we honour stored NextParams and SetCookie,
        # as we would for non-divert
-       my $new_url = $r->_ch('get_url');
        if ($divert_kind eq 'REDIRECT-LOGGEDOUT') {
            push @$params, $r->{S}{cah_loggedout}[0], 1;
        } elsif ($divert_kind eq 'REDIRECT-LOGOUT') {
            push @$params, $r->{S}{cah_logout}[0], 1;
        } elsif ($divert_kind eq 'REDIRECT-LOGGEDIN') {
+       } else {
+           die;
        }
+       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');
+       $body .= $r->_ch(
 
+       $r->_print(
+                  $r->_ch('start_html')($title),
+                  
+                  
+
+    if ($kind =~ m/^SMALLPAGE
+
+if (defined $cookie) {
+        $r->_ch('header_out')($cookie);
+    }
+    
 UP TO HERE
 
 sub record_login ($$) {