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=81a12aae47667b72774703947d772ee932c8add6;hp=dd44e2250f3ef133ab8f6b2f2b39eeba21e9c643;hb=2509e7aad65f50030f7bbe8886a66e06870d843e;hpb=b3e02a198778248d14b912abc0d45d2becc93e71

diff --git a/cgi-auth-flexible.pm b/cgi-auth-flexible.pm
index dd44e22..81a12aa 100644
--- a/cgi-auth-flexible.pm
+++ b/cgi-auth-flexible.pm
@@ -47,6 +47,7 @@ use Digest;
 use Digest::HMAC;
 use Digest::SHA;
 use Data::Dumper;
+use File::Copy;
 
 #---------- public utilities ----------
 
@@ -173,30 +174,66 @@ sub gen_plain_login_link ($$) {
 	    '</a>');
 }
 
-sub gen_special_link_html ($$$$) {
+sub gen_srcdump_link_html ($$$$) {
     my ($c,$r,$anchor,$specval) = @_;
-    my %params = ($r->{S}{special_param_name} => [ $specval ]);
+    my %params = ($r->{S}{srcdump_param_name} => [ $specval ]);
     return '<a href="'.escapeHTML($r->url_with_query_params(\%params)).'">'.
 	$anchor."</a>";
 }
-sub gen_plain_agpl_link_html ($$) {
+sub gen_plain_licence_link_html ($$) {
     my ($c,$r) = @_;
-    gen_special_link_html($c,$r, 'GNU Affero GPL', 'licence');
+    gen_srcdump_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');
+    gen_srcdump_link_html($c,$r, 'Source available', 'source');
 }
 
 sub gen_plain_footer_html ($$) {
     my ($c,$r) = @_;
     return ('<hr><address>',
 	    ("Powered by Free / Libre / Open Source Software".
-	     " according to the ".$r->_ch('gen_agpl_link_html')."."),
+	     " according to the ".$r->_ch('gen_licence_link_html')."."),
 	    $r->_ch('gen_source_link_html').".",
 	    '</address>');
 }
 
+#---------- licence and source code ----------
+
+#sub dump_licence ($$$) {
+#    
+#    my ($c,$r, $fh) = @_;
+#    foreach my $incdir ($r->_ch('getsource_includedirs')) {
+#	
+#    }
+#}
+
+sub srcdump_dump_thing ($$$) {
+    my ($c,$r, $thing, $outfn) = @_;
+    die if $thing =~ m/\W/ || $thing !~ m/\w/;
+    my $path = $r->_get_path('srcdump');
+    my $ctf = new IO::File "$path/$thing.ctype", 'r'
+	or die "$path/$thing.ctype $!";
+    my $ct = <$ctf>;
+    chomp $ct or die "$path/$thing ?";
+    $ct->close or die "$path/$thing $!";
+    my $df = new IO::File "$path/$thing.data", 'r'
+	or die "$path/$thing.data $!";
+    $r->_ch('dump', $ct, $df);
+}
+
+sub dump_plain ($$$$) {
+    my ($c, $r, $ct, $df) = @_;
+    $r->_print($c->header(-type $ct));
+    my $buffer;
+    for (;;) {
+	my $got = read $df, $buffer, 65536;
+	die $! unless defined $got;
+	return if !$got;
+	$r->_print($buffer);
+    }
+}
+
 #---------- verifier object methods ----------
 
 sub new_verifier {
@@ -207,6 +244,7 @@ sub new_verifier {
 	    assocdb_dbh => undef, # must have AutoCommit=0, RaiseError=1
 	    assocdb_path => 'caf-assocs.db',
 	    keys_path => 'caf-keys',
+	    srcdump_path => 'caf-srcdump',
 	    assocdb_dsn => undef,
 	    assocdb_user => '',
 	    assocdb_password => '',
@@ -221,7 +259,7 @@ sub new_verifier {
 	    dummy_param_name_prefix => 'caf__',
 	    cookie_name => "caf_assocsecret",
 	    password_param_name => 'password',
-	    special_param_name => 'caf_special',
+	    srcdump_param_name => 'caf_srcdump',
 	    username_param_names => [qw(username)],
 	    form_entry_size => 60,
 	    logout_param_names => [qw(caf_logout)],
@@ -247,12 +285,14 @@ sub new_verifier {
 	    encrypted_only => 1,
 	    gen_start_html => sub { $_[0]->start_html($_[2]); },
 	    gen_footer_html => \&gen_plain_footer_html,
-	    gen_agpl_link_html => \&gen_plain_agpl_link_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,
+	    srcdump_dump_thing => \&srcdump_dump_thing,
+	    source_includedirs => sub { grep { !m#^/etc/# } @INC; },
 	    gettext => sub { gettext($_[2]); },
 	    print => sub { print $_[2] or die $!; },
             debug => sub { }, # like print; msgs contain trailing \n
@@ -393,10 +433,15 @@ sub _debug ($@) {
 }
 
 sub _get_path ($$) {
-    my ($v,$keybase) = @_;
-    my $leaf = $v->{S}{"${keybase}_path"};
-    my $dir = $v->{S}{dir};
+    my ($r,$keybase) = @_;
+    my $leaf = $r->{S}{"${keybase}_path"};
+    return $r->_absify_path($leaf);
+}
+
+sub _absify_path ($$) {
+    my ($v,$leaf) = @_;
     return $leaf if $leaf =~ m,^/,;
+    my $dir = $v->{S}{dir};
     die "relying on cwd by default ?!  set dir" unless defined $dir;
     return "$dir/$leaf";
 }
@@ -532,6 +577,15 @@ my @ca = (-name => $r->{S}{cookie_name},
 sub _check_divert_core ($) {
     my ($r) = @_;
 
+    my $srcdump = $r->_rp('srcdump_param_name');
+    if ($srcdump) {
+	die if $srcdump =~ m/\W/;
+	return ({ Kind => 'SRCDUMP-'.uc $srcdump,
+		  Message => undef,
+		  CookieSecret => undef,
+		  Params => { } });
+    }
+
     my $cooks = $r->_ch('get_cookie');
 
     if ($r->{S}{encrypted_only} && !$r->_ch('check_https')) {
@@ -811,6 +865,11 @@ sub check_ok ($) {
     my $params = $divert->{Params};
     my $cookie = $r->construct_cookie($cookiesecret);
 
+    if ($kind =~ m/^SRCDUMP-(\w+)$/) {
+	$r->_ch('srcdump_dump_thing', (lc $1));
+	return 0;
+    }
+
     if ($kind =~ m/^REDIRECT-/) {
 	# for redirects, we honour stored NextParams and SetCookie,
 	# as we would for non-divert