Archive.pm (2969B)
1 package Bluto::Archive; 2 3 use Cwd; 4 use File::Basename qw/basename fileparse/; 5 use Digest::SHA; 6 7 use Bluto::Log qw/error info debug warn trace/; 8 use Bluto::Tree qw/release_path/; 9 use File::Path qw / make_path /; 10 11 12 sub seal { 13 my $targz = shift; 14 my $keygrip = shift; 15 # TODO: intended to be numeric flags but now we just use the first bit to force sign or not 16 my $safe = shift; 17 18 if (!defined $keygrip) { 19 if ($safe) { 20 error('have no signing key and safe bit set'); 21 return undef; 22 } 23 } 24 25 my $h = Digest::SHA->new('sha256'); 26 $h->addfile($targz); 27 my $z = $h->hexdigest; 28 debug('calculated sha256 ' . $z . ' for archive ' . $targz); 29 my $hp = $targz . '.sha256'; 30 my $f; 31 open($f, ">$hp") or (error('could not open digest file: ' . $!) && return undef); 32 print $f $z . "\t" . basename($targz) . "\n"; 33 close($f); 34 35 if (!defined $keygrip) { 36 warn('skipping signature due to missing key'); 37 return $z; 38 } 39 40 my @cmd = ('gpg', '-a', '-b', '-u', $keygrip, $hp); 41 system(@cmd); 42 if ($?) { 43 error('failed sign with key '. $keygrip); 44 unlink($hp); 45 return undef; 46 } 47 48 return $z; 49 } 50 51 sub create { 52 my $release = shift; 53 my $env = shift; 54 my $flags = shift; 55 56 my $keygrip = $release->{_author_maintainer}->[2]; 57 debug('using keygrip: ' . $keygrip); 58 59 my $old_dir = cwd; 60 61 chdir($env->{content_dir}); 62 63 my $targz_local = undef; 64 my $targz_stem = $release->{slug} . '-' . $release->{version}; 65 66 my $rev_version = $release->{tag_prefix} . $release->{version}; 67 my $rev = `git rev-parse $rev_version --abbrev-ref`; 68 if (!defined $rev) { 69 error('unable to determine revision'); 70 chdir($old_dir); 71 return undef; 72 } 73 chomp($rev); 74 my $targz = $targz_stem . '+build.' . $rev . '.tar.gz'; 75 my $targz_base = File::Spec->catfile(Bluto::Tree->release_path); 76 make_path($targz_base); 77 $targz_local = File::Spec->catfile($targz_base, $targz); 78 79 if (! -f $targz_local ) { 80 debug("no package file found, looked for: " . $targz_local); 81 my @cmd = ('git', 'archive', $release->{tag_prefix} . $release->{version}, '--format', 'tar.gz', '-o', $targz_local); 82 system(@cmd); 83 if ($?) { 84 error("package file generation fail: " . $e); 85 unlink($targz); 86 chdir($old_dir); 87 return undef; 88 } 89 90 # my $cmd = Git::Repository::Command(['git', 'archive', '--format=tar.gz', '-o', $targz]); 91 # my $e = $cmd->stderr(); 92 # $cmd->close(); 93 # if ($cmd->exit()) { 94 # error("package file generation fail: " . $e); 95 # } 96 97 if (! -f $targz_local ) { 98 error("package generation reported ok but still no file"); 99 chdir($old_dir); 100 return undef; 101 } 102 103 my $seal = seal($targz_local, $keygrip, $flags & 1); 104 if (!defined $seal) { 105 error("failed sealing archive"); 106 unlink($targz_local); 107 chdir($old_dir); 108 return undef; 109 } 110 info('sealed archive as sha256 ' . $seal . ' signed by ' . $keygrip); 111 } else { 112 info("using existing package file: " . $targz_local); 113 warn("existing package file is not being checked in any way 8|"); 114 } 115 116 chdir($old_dir); 117 118 return $targz_local; 119 } 120 121 1;