dgit

   1 #!/usr/bin/perl -w
   2 # dgit
   3 # Integration between git and Debian-style archives
   4 #
   5 # Copyright (C)2013 Ian Jackson
   6 #
   7 # This program is free software: you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation, either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 use strict;
  21
  22 use IO::Handle;
  23 use Data::Dumper;
  24 use LWP::UserAgent;
  25 use Dpkg::Control::Hash;
  26 use File::Path;
  27 use POSIX;
  28
  29 open DEBUG, ">&STDERR" or die $!;
  30
  31 our $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/';
  32 our $suite = 'sid';
  33 our $package;
  34
  35 our $sign = 1;
  36 our $nopush = 0;
  37
  38 our $aliothname = 'iwj@git.debian.org';
  39 our $aliothpath = '/git/dgit-test';
  40 our $alioth_git = "git+ssh://$aliothname/$aliothpath";
  41 our $alioth_sshtestbodge = [$aliothname,$aliothpath];
  42
  43 our (@dget_opts) = qw(-u);
  44 our (@git_tag_opts);
  45 our (@gpg_opts);
  46
  47 our $remotename = 'dgit';
  48 our $ourdscfield = 'Vcs-git-master';
  49
  50 sub uploadbranch () { return "dgit/$suite"; }
  51 sub lref ($) { return "refs/heads/$_[0]"; }
  52 sub rref ($) { return "refs/remotes/$remotename/$_[0]"; }
  53 sub debiantag ($) { return "debian/$_[0]"; }
  54
  55 our $ua;
  56
  57 sub url_get {
  58     if (!$ua) {
  59         $ua = LWP::UserAgent->new();
  60         $ua->env_proxy;
  61     }
  62     print DEBUG "fetching @_...\n";
  63     my $r = $ua->get(@_) or die $!;
  64     die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
  65     return $r->decoded_content();
  66 }
  67
  68 our ($dscdata,$dscurl,$dsc);
  69
  70 sub runcmd {
  71     $!=0; $?=0;
  72     die "@_ $! $?" if system @_;
  73 }
  74
  75 sub cmdoutput {
  76     open P, "-|", @_ or die $!;
  77     my $d;
  78     $!=0; $?=0;
  79     { local $/ = undef; $d = <P>; }
  80     die if P->error;
  81     close P or die "@_ $? $!";
  82     chomp $d;
  83     return $d;
  84 }
  85
  86 sub parsecontrol {
  87     my $c = Dpkg::Control::Hash->new();
  88     $c->load(@_) or return undef;
  89     return $c;
  90 }
  91
  92 sub parsechangelog {
  93     my $c = Dpkg::Control::Hash->new();
  94     my $p = new IO::Handle;
  95     open $p, '-|', qw(dpkg-parsechangelog) or die $!;
  96     $c->parse($p);
  97     $?=0; $!=0; close $p or die "$! $?";
  98     return $c;
  99 }
 100
 101 sub get_archive_dsc () {
 102     my $rmad = cmdoutput qw(rmadison -asource),"-s$suite",$package;
 103     $rmad =~ m/^ \s*( [^ \t|]+ )\s* \|
 104                  \s*( [^ \t|]+ )\s* \|
 105                  \s*( [^ \t|]+ )\s* \|
 106                  \s*( [^ \t|]+ )\s* /x or die "$rmad $?";
 107     $1 eq $package or die "$rmad $package ?";
 108     my $vsn = $2;
 109     $3 eq $suite or die "$rmad $suite ?";
 110     $4 eq 'source' or die "$rmad ?";
 111     # fixme it does not show us the component ?
 112     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
 113     $dscurl = "$mirror/pool/main/$prefix/$package/${package}_$vsn.dsc";
 114 #print DEBUG Dumper($pdodata, $&, $dscurl);
 115     $dscdata = url_get($dscurl);
 116     my $dscfh = new IO::File \$dscdata, '<' or die $!;
 117 #print DEBUG Dumper($dscdata, $dscfh);
 118     $dsc = Dpkg::Control::Hash->new(allow_pgp=>1);
 119     $dsc->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
 120 #print DEBUG Dumper($dsc);
 121     my $fmt = $dsc->{Format};
 122     die "unsupported format $fmt, sorry\n" unless $fmt eq '1.0';
 123 }
 124
 125 sub check_for_git () {
 126     # returns 0 or 1
 127     my $cmd=
 128         "ssh $alioth_sshtestbodge->[0] '".
 129         " set -e; cd /git/dgit-test;".
 130         " if test -d $package.git; then echo 1; else echo 0; fi".
 131         "'";
 132     #print DEBUG "$cmd\n";
 133     open P, "$cmd |" or die $!;
 134     $!=0; $?=0;
 135     my $r = <P>; close P;
 136 #print STDERR ">$r<\n";
 137     die "$r $! $?" unless $r =~ m/^[01]$/;
 138     return $r+0;
 139 }
 140
 141 our ($dsc_hash,$upload_hash);
 142
 143 our $ud = '.git/dgit/unpack';
 144
 145 sub prep_ud () {
 146     rmtree($ud);
 147     mkpath '.git/dgit';
 148     mkdir $ud or die $!;
 149 }
 150
 151 sub mktree_in_ud_from_only_subdir () {
 152     # changes into the subdir
 153     my (@dirs) = <*/.>;
 154     die unless @dirs==1;
 155     $dirs[0] =~ m#^([^/]+)/\.$# or die;
 156     my $dir = $1;
 157     chdir $dir or die "$dir $!";
 158     die if stat '.git';
 159     die $! unless $!==&ENOENT;
 160     runcmd qw(git init -q);
 161     rmtree('.git/objects');
 162     symlink '../../../../objects','.git/objects' or die $!;
 163     runcmd qw(git add -Af);
 164     my $tree = cmdoutput qw(git write-tree);
 165     chomp $tree; $tree =~ m/^\w+$/ or die "$tree ?";
 166     return ($tree,$dir);
 167 }
 168
 169 sub dsc_files () {
 170     map {
 171         m/^\w+ \d+ (\S+)$/ or die "$_ ?";
 172         $1;
 173     } grep m/\S/, split /\n/, ($dsc->{'Checksums-Sha256'} || $dsc->{Files});
 174 }
 175
 176 sub is_orig_file ($) {
 177     local ($_) = @_;
 178     m/\.orig\.tar\.\w+$/;
 179 }
 180
 181 sub generate_commit_from_dsc () {
 182     prep_ud();
 183     chdir $ud or die $!;
 184     my @files;
 185     foreach my $f (dsc_files()) {
 186         die if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
 187         push @files, $f;
 188         link "../../../$f", $f
 189             or $!==&ENOENT
 190             or die "$f $!";
 191     }
 192     runcmd qw(dget), @dget_opts, qw(--), $dscurl;
 193     foreach my $f (grep { is_orig_file($_) } @files) {
 194         link $f, "../../../$f"
 195             or $!==&EEXIST
 196             or die "$f $!";
 197     }
 198     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
 199     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
 200     my $clogp = parsecontrol('../changelog.tmp','changelog') or die;
 201     my $date = cmdoutput qw(date), '+%s %z', qw(-d),$clogp->{Date};
 202     my $author = $clogp->{Maintainer};
 203     $author =~ s#,.*##ms;
 204     my $authline = "$author $date";
 205     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or die $authline;
 206     open C, ">../commit.tmp" or die $!;
 207     print C "tree $tree\n" or die $!;
 208     print C "parent $upload_hash\n" or die $! if defined $upload_hash;
 209     print C <<END or die $!;
 210 author $authline
 211 committer $authline
 212
 213 $clogp->{Changes}
 214
 215 # imported by dgit from the archive
 216 END
 217     close C or die $!;
 218     print "synthesised git commit from .dsc $clogp->{Version}\n";
 219     my $commithash = cmdoutput qw(git hash-object -w -t commit ../commit.tmp);
 220     chdir '../../../..' or die $!;
 221     cmdoutput qw(git update-ref -m),"dgit synthesise $clogp->{Version}",
 222               'DGIT_ARCHIVE', $commithash;
 223     cmdoutput qw(git log -n2), $commithash;
 224     # ... gives git a chance to complain if our commit is malformed
 225     my $outputhash = $commithash;
 226     if (defined $upload_hash) {
 227         chdir "$ud/$dir" or die $!;
 228         runcmd qw(git reset --hard), $upload_hash;
 229         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
 230         my $oldclogp = Dpkg::Control::Hash->new();
 231         $oldclogp->parse('../changelogold.tmp','previous changelog') or die;
 232         my $vcmp =
 233             version_compare_string($oldclogp->{Version}, $clogp->{Version});
 234         if ($vcmp < 0) {
 235             # git upload/ is earlier vsn than archive, use archive
 236         } elsif ($vcmp >= 0) {
 237             print STDERR <<END or die $!;
 238 Version actually in archive:    $clogp->{Version} (older)
 239 Last allegedly pushed/uploaded: $oldclogp->{Version} (newer or same)
 240 Perhaps the upload is stuck in incoming.  Using the version from git.
 241 END
 242         } else {
 243             die "version in archive is same as version in git".
 244                 " to-be-uploaded (upload/) branch but archive".
 245                 " version hash no commit hash?!\n";
 246         }
 247         chdir '../../../..' or die $!;
 248     }
 249     rmtree($ud);
 250     return $outputhash;
 251 }
 252
 253 sub ensure_we_have_orig () {
 254     foreach my $f (dsc_files()) {
 255         next unless is_orig_file($f);
 256         if (stat "../$f") {
 257             die "$f ?" unless -f _;
 258         } else {
 259             die "$f $!" unless $!==&ENOENT;
 260         }
 261         my $origurl = $dscurl;
 262         $origurl =~ s{/[^/]+$}{};
 263         $origurl .= "/$f";
 264         die "$f ?" unless $f =~ m/^${package}_/;
 265         die "$f ?" if $f =~ m#/#;
 266         runcmd qw(sh -ec),'cd ..; exec dget -- "$1"','x',$origurl;
 267     }
 268 }
 269
 270 sub rev_parse ($) {
 271     return cmdoutput qw(git rev-parse --), "$_[0]~0";
 272 }
 273
 274 sub is_fast_fwd ($$) {
 275     my ($ancestor,$child) = @_;
 276     my $mb = cmdoutput qw(git merge-base), $dsc_hash, $upload_hash;
 277     return rev_parse($mb) eq rev_parse($ancestor);
 278 }
 279
 280 sub fetch_from_archive () {
 281     # ensures that rref(uploadbranch()) is what is actually in the archive,
 282     #  one way or another
 283     my $upload_ref = rref(uploadbranch());
 284     $!=0; $upload_hash = `git show-ref --heads $upload_ref`;
 285     die $! if $!;
 286     die $? unless ($?==0 && chomp $upload_hash)
 287         or ($?==256 && !length $upload_hash);
 288     my $hash;
 289     if (defined $dsc_hash) {
 290         die "missing git history even though dsc has hash"
 291             unless length $upload_hash;
 292         $hash = $dsc_hash;
 293         ensure_we_have_orig();
 294     } else {
 295         $hash = generate_commit_from_dsc();
 296     }
 297     if (length $upload_hash) {
 298         die "not fast forward on last upload branch!".
 299             " (archive's version left in DGIT_ARCHIVE)"
 300             unless is_fast_fwd($dsc_hash, $upload_hash);
 301     }
 302     if ($upload_hash ne $hash) {
 303         cmdoutput qw(git update-ref -m), 'dgit fetch', $upload_ref, $hash;
 304     }
 305 }
 306
 307 sub clone () {
 308     get_archive_dsc();
 309     $dsc_hash = $dsc->{$ourdscfield};
 310     if (defined $dsc_hash) {
 311         $dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
 312         $dsc_hash = $&;
 313         print "last upload to archive specified git hash\n";
 314     } else {
 315         print "last upload to archive has NO git hash\n";
 316     }
 317     my $dstdir = "$package";
 318     if (check_for_git()) {
 319         print "cloning existing git history\n";
 320         runcmd qw(git clone --origin),$remotename, qw(-b), $suite, '--',
 321             $alioth_git, $dstdir;
 322         chdir "$dstdir" or die "$dstdir $!";
 323         fetch_from_archive();
 324         runcmd qw(git reset --hard), rref(uploadbranch());
 325     } else {
 326         print "starting new git history\n";
 327         mkdir $dstdir or die "$dstdir $!";
 328         chdir "$dstdir" or die "$dstdir $!";
 329         runcmd qw(git init -q);
 330         open H, "> .git/HEAD" or die $!;
 331         print H "ref: ".lref(uploadbranch())."\n" or die $!;
 332         close H or die $!;
 333         runcmd qw(git remote add), $remotename, $alioth_git;
 334         runcmd "git config branch.$suite.remote $remotename";
 335         runcmd "git config branch.$suite.merge ".lref(uploadbranch());
 336         my $newhash = generate_commit_from_dsc();
 337         runcmd qw(git reset --hard), $newhash;
 338     }
 339     print "ready for work in $dstdir\n";
 340 }
 341
 342 sub fetch () {
 343     if (check_for_git()) {
 344         runcmd qw(git fetch -p),$remotename,
 345             '+refs/heads/*:refs/remotes/origin/*';
 346     }
 347     fetch_from_archive();
 348 }
 349
 350 sub pull () {
 351     fetch();
 352     runcmd qw(git merge -m),"Merge from $suite [dgit]",lref(uploadbranch());
 353 }
 354
 355 sub dopush () {
 356     runcmd qw(git diff --quiet HEAD);
 357     my $clogp = parsechangelog();
 358     $package = $clogp->{Source};
 359     my $dscfn = "${package}_$clogp->{Version}.dsc";
 360     stat $dscfn or die "$dscfn $!";
 361     $dsc = parsecontrol("../$dscfn");
 362     prep_ud();
 363     chdir $ud or die $!;
 364     print "checking that $dscfn corresponds to HEAD\n";
 365     runcmd qw(dpkg-source -x --), "../../../../$dscfn";
 366     my $tree = mktree_in_ud_from_only_subdir();
 367     chdir '../../../..' or die $!;
 368     runcmd qw(git diff --exit-code), $tree;
 369 #fetch from alioth
 370 #do fast forward check and maybe fake merge
 371 #    if (!is_fast_fwd(mainbranch
 372 #    runcmd qw(git fetch -p ), $alioth_git,
 373 #        map { lref($_).":".rref($_) }
 374 #        (uploadbranch());
 375     $dsc->{$ourdscfield} = rev_parse('HEAD');
 376     $dsc->save("../$dscfn.tmp") or die $!;
 377     rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
 378     if ($sign) {
 379         runcmd qw(git tag -s),@git_tag_opts,qw(-m),
 380             "Release $dsc->{Version} for $suite [dgit]";
 381         unlink "../$dscfn.asc" or $!==&ENOENT or die "$dscfn.asc $!";
 382         runcmd qw(gpg --clearsign),@gpg_opts,"../$dscfn";
 383         rename "../$dscfn.asc","../$dscfn" or die "$dscfn $!";
 384     }
 385     if (!$nopush) {
 386         runcmd qw(git push),$remotename,"HEAD:".lref(uploadbranch());
 387         runcmd qw(dput),"../$dscfn";
 388     }
 389 }
 390
 391 sub cmd_clone {
 392     if (@ARGV==1) {
 393         ($package) = @ARGV;
 394     } elsif (@ARGV==2) {
 395         ($package,$suite) = @ARGV;
 396     } else {
 397         die;
 398     }
 399     clone();
 400 }
 401
 402 sub branchsuite () {
 403     my $branch = `git-symbolic-ref HEAD`;
 404     if ($branch =~ m#^refs/heads/dgit/([^/.]+)$#) {
 405         return $1;
 406     } else {
 407         return undef;
 408     }
 409 }
 410
 411 sub cmd_fetch {
 412     my $clogp = parsechangelog();
 413     $package = $clogp->{Source};
 414     if (@ARGV==0) {
 415         $suite = branchsuite();
 416         $suite ||= $clogp->{Distribution};
 417         print "fetching from suite $suite\n";
 418     } elsif (@ARGV==1) {
 419         ($suite) = @ARGV;
 420     } else {
 421         die;
 422     }
 423     fetch();
 424 }
 425
 426 sub cmd_push {
 427     my $clogp = parsechangelog();
 428     $package = $clogp->{Source};
 429     if (@ARGV==0) {
 430         $suite = $clogp->{Distribution};
 431     } else {
 432         die;
 433     }
 434     dopush();
 435 }
 436
 437 sub parseopts () {
 438     die if @ARGV && $ARGV[0] =~ m/^\-/;
 439 }
 440
 441 parseopts();
 442 die unless @ARGV;
 443 my $cmd = shift @ARGV;
 444 parseopts();
 445
 446 { no strict qw(refs); &{"cmd_$cmd"}(); }