X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;f=cgi-auth-flexible.pm;h=d4f248ef4d3d884c376bae7e0e736f5dcbe28275;hb=7722fff31ecfdfb87d0194e933daad9f7d0e7bca;hp=4dd6daf2ddaca6fdc0c433cf26a7960b86593f0a;hpb=7fd33ab35a68417cac98fd0a8aa4ffcfecf86015;p=cgi-auth-flexible.git diff --git a/cgi-auth-flexible.pm b/cgi-auth-flexible.pm index 4dd6daf..d4f248e 100644 --- a/cgi-auth-flexible.pm +++ b/cgi-auth-flexible.pm @@ -48,6 +48,8 @@ use Digest::HMAC; use Digest::SHA; use Data::Dumper; use File::Copy; +use Cwd qw/realpath/; + #---------- public utilities ---------- @@ -200,15 +202,15 @@ sub gen_plain_footer_html ($$) { #---------- licence and source code ---------- -sub srcdump_dump_thing ($$$) { - my ($c,$r, $thing, $outfn) = @_; +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 ?"; - $ct->close 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); @@ -216,7 +218,7 @@ sub srcdump_dump_thing ($$$) { sub dump_plain ($$$$) { my ($c, $r, $ct, $df) = @_; - $r->_print($c->header(-type $ct)); + $r->_print($c->header('-type' => $ct)); my $buffer; for (;;) { my $got = read $df, $buffer, 65536; @@ -226,57 +228,82 @@ sub dump_plain ($$$$) { } } -sub srcdump_process_dir ($$$$$$) { - my ($c, $v, $dumpdir, $incdir, $tarballcounter, - $needlicence, $dirsdone) = @_; - return () if $v->_ch('srcdump_system_dir', $incdir); - my $upwards = $incdir; +sub srcdump_process_item ($$$$$$) { + my ($c, $v, $dumpdir, $item, $outfn, $needlicence, $dirsdone) = @_; + if ($v->_ch('srcdump_system_dir', $item)) { + $outfn->("srcdump_process_item: srcdump_system_dir, skipping $item"); + return; + } + my $upwards = $item; for (;;) { - $upwards =~ s#/+##; + $upwards =~ s#/+$##; + $upwards =~ s#/+\.$##; last unless $upwards =~ m#[^/]#; foreach my $try (@{ $v->{S}{srcdump_vcs_dirs} }) { +#print STDERR "TRY $item $upwards $try\n"; if (!stat "$upwards/$try") { - $!==&ENOENT or die "check $upwards/$try $!"; + $!==&ENOENT or $!==&ENOTDIR or die "check $upwards/$try $!"; next; } +#print STDERR "VCS $item $upwards $try\n"; + if ($dirsdone->{$upwards}++) { + $outfn->("srcdump_process_item: did $upwards,". + " skipping $item"); + return; + } +#print STDERR "VCS $item $upwards $try GO\n"; $try =~ m/\w+/ or die; - return if $dirsdone->{$upwards}++; - return $v->_ch(('srcdump_byvcs_'.lc $try), - $dumpdir, $upwards, $tarballcounter); + return $v->_ch('srcdump_byvcs', $dumpdir, $upwards, $outfn, lc $&); } - $upwards =~ s#/*[^/]+##; + $upwards =~ s#/*[^/]+$##; } - return $v->_ch('srcdump_novcs', $dumpdir, $incdir, $tarballcounter); + return $v->_ch('srcdump_novcs', $dumpdir, $item, $outfn); } 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'"; + my ($c, $v, $dumpdir, $item, $outfn) = @_; + stat $item or die "$item $!"; + if (-d _) { + 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,$item,$outfn,'novcs',$script); + } elsif (-f _) { + return srcdump_file($c,$v,$dumpdir,$item,$outfn); + } else { + die "$item not file or directory"; } - $script .= " -print0"; - return srcdump_dir_cpio($c,$v,$dumpdir,$dir,$tarballcounter,$script); } -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_byvcs ($$$$$$) { + my ($c, $v, $dumpdir, $dir, $outfn, $vcs) = @_; +#print STDERR "BYVCS GIT $dir\n"; + return srcdump_dir_cpio($c,$v,$dumpdir,$dir,$outfn,$vcs, + $v->{S}{"srcdump_vcsscript_$vcs"}); } -sub scrdump_dir_cpio ($$$$$) { - my ($c,$v,$dumpdir,$dir,$tarballcounter,$script) = @_; - my $outfile = "$dumpdir/$$tarballcounter.tar"; +sub srcdump_file ($$$$) { + my ($c,$v,$dumpdir,$file,$outfn) = @_; + my $outfile = $outfn->("srcdump_file saved $file", "src"); + copy($file,$outfile) or die "$file $outfile $!"; +} + +sub srcdump_dir_cpio ($$$$$$$) { + my ($c,$v,$dumpdir,$dir,$outfn,$how,$script) = @_; + my $outfile = $outfn->("srcdump_dir_cpio $how saved $dir", "tar"); +#print STDERR "CPIO $dir >$script<\n"; my $pid = fork(); defined $pid or die $!; if (!$pid) { + $SIG{__DIE__} = sub { + print STDERR "CGI::Auth::Flexible srcdump error: $@\n"; + exit 127; + }; open STDOUT, ">", $outfile or die "$outfile $!"; chdir $dir or die "chdir $dir: $!"; - exec '/bin/bash','-ec',''," + exec '/bin/bash','-ec'," set -o pipefail ( $script @@ -288,40 +315,85 @@ sub scrdump_dir_cpio ($$$$$) { die $!; } $!=0; (waitpid $pid, 0) == $pid or die "$!"; - die "$dir ($script) $outfile $?" if $?; - $$tarballcounter++; - return $outfile; + die "$dir ($how $script) $outfile $?" if $?; } 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 || $!==&ENOENT or die "rm $needlicence $!"; + 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'; + unlink <"$dumpdir/s.[a-z][a-z][a-z].*">; + my @srcfiles = qw(licence.data manifest.txt); + my $srcoutcounter = 'aaa'; + + my $reportfh = new IO::File "$dumpdir/manifest.txt", 'w' or die $!; + my $outfn = sub { + my ($message, $extension) = @_; + if (defined $extension) { + my $leaf = "s.$srcoutcounter.$extension"; + $srcoutcounter++; + push @srcfiles, $leaf; + print $reportfh "$leaf: $message\n" or die $!; + return "$dumpdir/$leaf"; + } else { + print $reportfh "none: $message\n" or die $!; + return undef; + } + }; my %dirsdone; - my @srcfiles = ("$dumpdir/licence.data"); - foreach my $incdir ($v->_ch('getsource_includedirs')) { + foreach my $item ($v->_ch('srcdump_listitems')) { + if ($item eq '.' && $v->{S}{srcdump_filter_cwd}) { + my @bad = grep { !m#^/# } values %INC; + die "filtering . from srcdump items and \@INC but already". + " included @bad " if @bad; + @INC = grep { $_ ne '.' } @INC; + next; + } + if (!lstat "$item") { + die "stat $item $!" unless $!==&ENOENT; + $outfn->("srcdump_dirscan_prepare stat ENOENT, skipping $item"); + next; + }; + if (-l _) { + $item = realpath($item); + if (!defined $item) { + die "realpath $item $!" unless $!==&ENOENT; + $outfn->("srcdump_dirscan_prepare realpath ENOENT,". + " skipping $item"); + } + } if (defined $needlicence) { foreach my $try (@{ $v->{S}{srcdump_licence_files} }) { - last if copy("$incdir/$try", $needlicence); - $!==&ENOENT or die "copy $incdir/$try $!"; + last if copy("$item/$try", $needlicence); + $!==&ENOENT or $!==&ENOTDIR or die "copy $item/$try $!"; } } - push @srcfiles, $v->_ch('srcdump_process_dir', $dumpdir, $incdir, - \$srctarballcounter, \$needlicence, \%dirsdone); - $dirsdone{$incdir}++; + $v->_ch('srcdump_process_item', $dumpdir, $item, + $outfn, \$needlicence, \%dirsdone); + $dirsdone{$item}++; } - die "licence file not found" unless defined $needlicence; + close $reportfh or die $!; srcdump_install($c,$v, $dumpdir, 'licence', 'text/plain'); + $!=0; + my @cmd = (qw(tar -zvvcf), "$dumpdir/source.tmp", + "-C", $dumpdir, qw( --), @srcfiles); + my $r = system(@cmd); + if ($r) { + print STDERR "CGI::Auth::Flexible tar failed ($r $!) @cmd\n"; + die "tar failed"; + } + die "licence file not found" unless defined $needlicence; + srcdump_install($c,$v, $dumpdir, 'source', 'application/octet-stream'); close $lockf or die $!; } @@ -394,18 +466,30 @@ sub new_verifier { 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, + srcdump_dump => \&srcdump_dump, srcdump_prepare => \&srcdump_dirscan_prepare, srcdump_licence_path => undef, srcdump_licence_files => [qw(AGPLv3 CGI/Auth/Flexible/AGPLv3)], - srcdump_system_dir => sub { $_[2] =~ m#^/etc/|^/usr/(?!local/)#; }, - 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_listitems => sub { (@INC, $ENV{'SCRIPT_FILENAME'}, $0); }, + srcdump_filter_cwd => 1, + srcdump_system_dir => sub { + $_[2] =~ m#^/etc/|^/usr/(?!local/)(?!lib/cgi)#; + }, + srcdump_process_item => \&srcdump_process_item, + srcdump_vcs_dirs => [qw(.git .hg .bzr .svn CVS)], + srcdump_vcsscript_git => " + git ls-files -z + git ls-files -z --others --exclude-from=.gitignore + find .git -print0 + ", + srcdump_vcsscript_hg => "false hg", + srcdump_vcsscript_bzr => "false bzr", + srcdump_vcsscript_svn => "false svn", + srcdump_vcsscript_cvs => "false cvs", + srcdump_byvcs => \&srcdump_byvcs, 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 @@ -419,6 +503,7 @@ sub new_verifier { } bless $verifier, $class; $verifier->_dbopen(); + $verifier->_ch('srcdump_prepare'); return $verifier; } @@ -979,7 +1064,7 @@ sub check_ok ($) { my $cookie = $r->construct_cookie($cookiesecret); if ($kind =~ m/^SRCDUMP-(\w+)$/) { - $r->_ch('srcdump_dump_thing', (lc $1)); + $r->_ch('srcdump_dump', (lc $1)); return 0; } @@ -1237,34 +1322,26 @@ __END__ CGI::Auth::Flexible - web authentication optionally using cookies -=head1 SYNOPSYS +=head1 SYNOPSYS - STARTUP my $verifier = CGI::Auth::Flexible->new_verifier(setting => value,...); my $authreq = $verifier->new_request($cgi_request_object); - my $authreq = CGI::Auth::Flexible->new_request($cgi_request_object, - setting => value,...); - -=head1 USAGE PATTERN FOR SIMPLE APPLICATIONS +=head1 SYNOPSYS - SIMPLE APPLICATIONS $authreq->check_ok() or return; - - blah blah blah + ... $authreq->check_mutate(); - blah blah blah + ... -=head1 USAGE PATTERN FOR FANCY APPLICATIONS +=head1 SYNOPSIS - SOPHISTICATED APPLICATIONS my $divert_kind = $authreq->check_divert(); - if ($divert_kind) { - if ($divert_kind eq 'LOGGEDOUT') { - print "goodbye you are now logged out" and quit - } elsif ($divert_kind eq 'NOCOOKIES') { - print "you need cookies" and quit - ... etc. - } - } - - blah blah blah + if ($divert_kind) { ... print diversion page and quit ... } + ... $authreq->check_mutate(); - blah blah blah + ... + +=head1 DESCRIPTION + +CGI::Auth::Flexible is a