X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;f=cgi-auth-flexible.pm;h=a462bf8434f79f2e0f0190565ebfed908ff2e4af;hb=7474e250f15af4708e7576c759e3941fa56e9080;hp=2be63b4a242926ff1ef9c9a88dcec34dc6c4acf0;hpb=8f2a5fab109a38c7ad841637fab0859eae7beb5f;p=cgi-auth-flexible.git diff --git a/cgi-auth-flexible.pm b/cgi-auth-flexible.pm index 2be63b4..a462bf8 100644 --- a/cgi-auth-flexible.pm +++ b/cgi-auth-flexible.pm @@ -174,19 +174,19 @@ sub gen_plain_login_link ($$) { ''); } -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 ''. $anchor.""; } 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 ($$) { @@ -200,26 +200,143 @@ sub gen_plain_footer_html ($$) { #---------- licence and source code ---------- -sub dump_licence ($$$) { - - my ($c,$r, $fh) = @_; - foreach my $incdir ($r->_ch('getsource_includedirs')) { - +sub srcdump_dump ($$$) { + my ($c,$r, $thing) = @_; + 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 ?"; + $ctf->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); } } -sub source_dump_get_path ($$$) { - my ($c,$r, $thing) = @_; - die if $thing =~ m/\W/; - my $pat = $r->{S}('source_dump_path_pat'); - my $leaf = sprintf $pat, $thing; - return $r->_absify_path($leaf); +sub srcdump_process_dir ($$$$$$) { + my ($c, $v, $dumpdir, $incdir, $tarballcounter, + $needlicence, $dirsdone) = @_; + return () if $v->_ch('srcdump_system_dir', $incdir); + my $upwards = $incdir; + for (;;) { + $upwards =~ s#/+##; + last unless $upwards =~ m#[^/]#; + foreach my $try (@{ $v->{S}{srcdump_vcs_dirs} }) { + if (!stat "$upwards/$try") { + $!==&ENOENT or die "check $upwards/$try $!"; + next; + } + $try =~ m/\w+/ or die; + return if $dirsdone->{$upwards}++; + return $v->_ch(('srcdump_byvcs_'.lc $try), + $dumpdir, $upwards, $tarballcounter); + } + $upwards =~ s#/*[^/]+##; + } + return $v->_ch('srcdump_novcs', $dumpdir, $incdir, $tarballcounter); +} + +sub srcdump_novcs ($$$$$) { + my ($c, $v, $dumpdir, $dir, $tarballcounter) = @_; + my $script = 'find -type f -perm +004'; + foreach my $excl (@{ $v->{S}{srcdump_excludes} }) { + $script .= " \\! -name '$excl'"; + } + $script .= " -print0"; + return srcdump_dir_cpio($c,$v,$dumpdir,$dir,$tarballcounter,$script); } -sub source_dump_thing ($$$) { - my ($c,$r, $thing, $outfn) = @_; - my $path = $r->_ch('source_dump_get_path', $thing); - copy($path, $utfn +sub srcdump_byvcs_git ($$$$$) { + my ($c, $v, $dumpdir, $dir, $tarballcounter) = @_; + return srcdump_dir_cpio($c,$v,$dumpdir,$dir,$tarballcounter," + git-ls-files -z; + git-ls-files -z --others --exclude-from=.gitignore; + find .git -print0 + "); +} + +sub srcdump_dir_cpio ($$$$$) { + my ($c,$v,$dumpdir,$dir,$tarballcounter,$script) = @_; + my $outfile = "$dumpdir/$$tarballcounter.tar"; + my $pid = fork(); + defined $pid or die $!; + if (!$pid) { + open STDOUT, ">", $outfile or die "$outfile $!"; + chdir $dir or die "chdir $dir: $!"; + exec '/bin/bash','-ec',''," + set -o pipefail + ( + $script + ) | ( + cpio -Hustar -o --quiet -0 -R 1000:1000 || \ + cpio -Hustar -o --quiet -0 + ) + "; + die $!; + } + $!=0; (waitpid $pid, 0) == $pid or die "$!"; + die "$dir ($script) $outfile $?" if $?; + $$tarballcounter++; + return $outfile; +} + +sub srcdump_dirscan_prepare ($$) { + my ($c, $v) = @_; + my $dumpdir = $v->_get_path('srcdump'); + mkdir $dumpdir or $!==&EEXIST or die "mkdir $dumpdir $!"; + my $lockf = new IO::File "$dumpdir/generate.lock", 'w+' + or die "$dumpdir/generate.lock $!"; + flock $lockf, LOCK_EX or die "$dumpdir/generate.lock $!"; + my $needlicence = "$dumpdir/licence.tmp"; + unlink $needlicence or $!==&ENOENT or die "rm $needlicence $!"; + if (defined $v->{S}{srcdump_licence_path}) { + copy($v->{S}{srcdump_licence_path}, $needlicence) + or die "$v->{S}{srcdump_licence_path} $!"; + $needlicence = undef; + } + my $srctarballcounter = 'aaa'; + my %dirsdone; + my @srcfiles = ("$dumpdir/licence.data"); + foreach my $incdir ($v->_ch('srcdump_includedirs')) { + if (defined $needlicence) { + foreach my $try (@{ $v->{S}{srcdump_licence_files} }) { + last if copy("$incdir/$try", $needlicence); + $!==&ENOENT or die "copy $incdir/$try $!"; + } + } + push @srcfiles, $v->_ch('srcdump_process_dir', $dumpdir, $incdir, + \$srctarballcounter, \$needlicence, \%dirsdone); + $dirsdone{$incdir}++; + } + die "licence file not found" unless defined $needlicence; + srcdump_install($c,$v, $dumpdir, 'licence', 'text/plain'); + close $lockf or die $!; +} + +sub srcdump_install ($$$$$) { + my ($c,$v, $dumpdir, $which, $ctype) = @_; + rename "$dumpdir/$which.tmp", "$dumpdir/$which.data" + or die "$dumpdir/$which.data $!"; + my $ctf = new IO::File "$dumpdir/$which.tmp", 'w' + or die "$dumpdir/$which.tmp $!"; + print $ctf $ctype, "\n" or die $!; + close $ctf or die $!; + rename "$dumpdir/$which.tmp", "$dumpdir/$which.ctype" + or die "$dumpdir/$which.ctype $!"; +} #---------- verifier object methods ---------- @@ -231,8 +348,7 @@ sub new_verifier { assocdb_dbh => undef, # must have AutoCommit=0, RaiseError=1 assocdb_path => 'caf-assocs.db', keys_path => 'caf-keys', - source_dump_path_pat => 'caf-%s.dump', - source_dump_get_path => \&source_dump_get_path, + srcdump_path => 'caf-srcdump', assocdb_dsn => undef, assocdb_user => '', assocdb_password => '', @@ -247,7 +363,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)], @@ -279,8 +395,21 @@ sub new_verifier { gen_login_form => \&gen_plain_login_form, gen_login_link => \&gen_plain_login_link, gen_postmainpage_form => \&gen_postmainpage_form, - source_dump_thing => \&source_dump_thing, - source_includedirs => sub { grep { !m#^/etc/# } @INC; }, + srcdump_dump => \&srcdump_dump, + srcdump_prepare => \&srcdump_dirscan_prepare, + srcdump_licence_path => undef, + srcdump_licence_files => [qw(AGPLv3 CGI/Auth/Flexible/AGPLv3)], + srcdump_includedirs => sub { return @INC; }, + srcdump_system_dir => sub { $_[2] =~ m#^/etc/|^/usr/(?!local/)#; }, + srcdump_process_dir => \&srcdump_process_dir, + srcdump_vcs_dirs => [qw(.git .hg .svn CVS)], + srcdump_byvcs_git => \&srcdump_byvcs_git, + srcdump_byvcs_hg => \&srcdump_byvcs_hg, + srcdump_byvcs_svn => \&srcdump_byvcs_svn, + srcdump_byvcs_cvs => \&srcdump_byvcs_cvs, + srcdump_novcs => \&srcdump_novcs, + srcdump_excludes => [qw(*~ *.bak *.tmp), '#*#'], + dump => \&dump_plain, gettext => sub { gettext($_[2]); }, print => sub { print $_[2] or die $!; }, debug => sub { }, # like print; msgs contain trailing \n @@ -294,6 +423,7 @@ sub new_verifier { } bless $verifier, $class; $verifier->_dbopen(); + $verifier->_ch('srcdump_prepare'); return $verifier; } @@ -421,8 +551,8 @@ sub _debug ($@) { } sub _get_path ($$) { - my ($v,$keybase) = @_; - my $leaf = $v->{S}{"${keybase}_path"}; + my ($r,$keybase) = @_; + my $leaf = $r->{S}{"${keybase}_path"}; return $r->_absify_path($leaf); } @@ -565,10 +695,10 @@ my @ca = (-name => $r->{S}{cookie_name}, sub _check_divert_core ($) { my ($r) = @_; - my $special = $r->_rp('special_param_name'); - if ($special) { - die if $special =~ m/\W/; - return ({ Kind => 'SPECIAL-'.uc $special, + my $srcdump = $r->_rp('srcdump_param_name'); + if ($srcdump) { + die if $srcdump =~ m/\W/; + return ({ Kind => 'SRCDUMP-'.uc $srcdump, Message => undef, CookieSecret => undef, Params => { } }); @@ -853,8 +983,8 @@ sub check_ok ($) { my $params = $divert->{Params}; my $cookie = $r->construct_cookie($cookiesecret); - if ($kind =~ m/^SPECIAL-(LICENCE|SOURCE)$/) { - $r->_ch('dump_'.lc $1, \*STDOUT); + if ($kind =~ m/^SRCDUMP-(\w+)$/) { + $r->_ch('srcdump_dump', (lc $1)); return 0; }