dgit

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 use IO::Handle;
   5 use Data::Dumper;
   6 use LWP::UserAgent;
   7 use Dpkg::Control::Hash;
   8 use File::Path;
   9 use POSIX;
  10
  11 open DEBUG, ">&STDERR" or die $!;
  12
  13 our $pdo = 'http://packages.debian.org/';
  14 #our $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/';
  15 our $suite = 'sid';
  16 our $package = '2vcard';
  17
  18 our $aliothname = 'iwj@git.debian.org';
  19 our $aliothpath = '/git/dgit-test';
  20 our $alioth_git = "git+ssh://$aliothname/$aliothpath";
  21 our $alioth_sshtestbodge = [$aliothname,$aliothpath];
  22
  23 our (@dget_opts) = qw(-u);
  24
  25 our $remotename = 'dgit';
  26
  27 sub mainbranch () { return "$suite"; }
  28 sub uploadbranch () { return "upload/$suite"; }
  29
  30 our $ua;
  31
  32 sub url_get {
  33     if (!$ua) {
  34         $ua = LWP::UserAgent->new();
  35         $ua->env_proxy;
  36     }
  37     print DEBUG "fetching @_...\n";
  38     my $r = $ua->get(@_) or die $!;
  39     die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
  40     return $r->decoded_content();
  41 }
  42
  43 our ($dscdata,$dscurl,$dsc);
  44
  45 sub parsecontrol {
  46     my $c = Dpkg::Control::Hash->new();
  47     $c->load(@_) or return undef;
  48     return $c;
  49 }
  50
  51 sub get_archive_dsc () {
  52     my $pdourl = "$pdo/source/$suite/$package";
  53     my $pdodata = url_get($pdourl);
  54     # FFS.  The Debian archive has no sane way to find what
  55     # version is currently the tip in any branch (aka, what
  56     # is the current version in any suite).
  57     $pdodata =~ m{
  58         Download\ \Q$package\E .*
  59         \<a\ href=\"([^"&]+([^"/]+\.dsc))\"\>\2\</a\>
  60     }msx
  61         or die "screenscraping of $pdourl failed :-(\n";
  62     $dscurl = $1;
  63 #print DEBUG Dumper($pdodata, $&, $dscurl);
  64     $dscdata = url_get($dscurl);
  65     my $dscfh = new IO::File \$dscdata, '<' or die $!;
  66 #print DEBUG Dumper($dscdata, $dscfh);
  67     $dsc = Dpkg::Control::Hash->new(allow_pgp=>1);
  68     $dsc->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
  69 #print DEBUG Dumper($dsc);
  70     my $fmt = $dsc->{Format};
  71     die "unsupported format $fmt, sorry\n" unless $fmt eq '1.0';
  72 }
  73
  74 sub check_for_git () {
  75     # returns 0 or 1
  76     my $cmd=
  77         "ssh $alioth_sshtestbodge->[0] '".
  78         " set -e; cd /git/dgit-test;".
  79         " if test -d $package.git; then echo 1; else echo 0; fi".
  80         "'";
  81     #print DEBUG "$cmd\n";
  82     open P, "$cmd |" or die $!;
  83     $!=0; $?=0;
  84     my $r = <P>; close P;
  85 #print STDERR ">$r<\n";
  86     die "$r $! $?" unless $r =~ m/^[01]$/;
  87     return $r+0;
  88 }
  89
  90 sub runcmd {
  91     $!=0; $?=0;
  92     die "@_ $! $?" if system @_;
  93 }
  94
  95 sub cmdoutput {
  96     open P, "-|", @_ or die $!;
  97     my $d;
  98     $!=0; $?=0;
  99     { local $/ = undef; $d = <P>; }
 100     die if P->error;
 101     close P or die "@_ $? $!";
 102     chomp $d;
 103     return $d;
 104 }
 105
 106 our ($dsc_hash,$lastupl_hash);
 107
 108 sub generate_commit_from_dsc () {
 109     my $ud = '.git/dgit/unpack';
 110     rmtree($ud);
 111     mkpath '.git/dgit';
 112     mkdir $ud or die $!;
 113     chdir $ud or die $!;
 114     my @files;
 115     foreach (split /\n/, ($dsc->{'Checksums-Sha256'} || $dsc->{Files})) {
 116         next unless m/\S/;
 117         m/^\w+ \d+ (\S+)$/ or die "$_ ?";
 118         my $f = $1;
 119         die if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
 120         push @files, $f;
 121         link "../../../$f", $f
 122             or $!==&ENOENT
 123             or die "$f $!";
 124     }
 125     runcmd qw(dget), @dget_opts, qw(--), $dscurl;
 126     foreach my $f (grep { m/\.tar\.gz$/ } @files) {
 127         link $f, "../../../$f"
 128             or $!==&EEXIST
 129             or die "$f $!";
 130     }
 131     my (@dirs) = <*/.>;
 132     die unless @dirs==1;
 133     $dirs[0] =~ m#^([^/]+)/\.$# or die;
 134     my $dir = $1;
 135     chdir $dir or die "$dir $!";
 136     die if stat '.git';
 137     die $! unless $!==&ENOENT;
 138     runcmd qw(git init -q);
 139     rmtree('.git/objects');
 140     symlink '../../../../objects','.git/objects' or die $!;
 141     runcmd qw(git add -Af);
 142     my $tree = cmdoutput qw(git write-tree);
 143     chomp $tree; $tree =~ m/^\w+$/ or die "$tree ?";
 144     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
 145     my $clogp = parsecontrol('../changelog.tmp','changelog') or die;
 146     my $date = cmdoutput qw(date), '+%s %z', qw(-d),$clogp->{Date};
 147     my $author = $clogp->{Maintainer};
 148     $author =~ s#,.*##ms;
 149     my $authline = "$author $date";
 150     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or die $authline;
 151     open C, ">../commit.tmp" or die $!;
 152     print C "tree $tree\n" or die $!;
 153     print C "parent $lastupl_hash\n" or die $! if defined $lastupl_hash;
 154     print C <<END or die $!;
 155 author $authline
 156 committer $authline
 157
 158 $clogp->{Changes}
 159
 160 # imported by dgit from the archive
 161 END
 162     close C or die $!;
 163     print "synthesised git commit from .dsc $clogp->{Version}\n";
 164     my $commithash = cmdoutput qw(git hash-object -w -t commit ../commit.tmp);
 165     chdir '../../../..' or die $!;
 166     cmdoutput qw(git update-ref -m),"dgit synthesise $clogp->{Version}",
 167               'DGIT_ARCHIVE', $commithash;
 168     cmdoutput qw(git log -n2), $commithash;
 169     # ... gives git a chance to complain if our commit is malformed
 170     my $outputhash = $commithash;
 171     if (defined $lastupl_hash) {
 172         chdir "$ud/$dir" or die $!;
 173         runcmd qw(git reset --hard), $lastupl_hash;
 174         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
 175         my $oldclogp = Dpkg::Control::Hash->new();
 176         $oldclogp->parse('../changelogold.tmp','previous changelog') or die;
 177         my $vcmp =
 178             version_compare_string($oldclogp->{Version}, $clogp->{Version});
 179         if ($vcmp < 0) {
 180             # git upload/ is earlier vsn than archive, use archive
 181         } elsif ($vcmp >= 0) {
 182             print STDERR <<END or die $!;
 183 Version actually in archive:    $clogp->{Version} (older)
 184 Last allegedly pushed/uploaded: $oldclogp->{Version} (newer or same)
 185 Perhaps the upload is stuck in incoming.  Using the version from git.
 186 END
 187         } else {
 188             die "version in archive is same as version in git".
 189                 " to-be-uploaded (upload/) branch but archive".
 190                 " version hash no commit hash?!\n";
 191         }
 192         chdir '../../../..' or die $!;
 193     }
 194     rmtree($ud);
 195     return $outputhash;
 196 }
 197
 198 my $lastupl_ref = "refs/remotes/$remotename/upload/$suite";
 199
 200 sub fetch_from_archive () {
 201     # ensures that $lastupl_ref is what is actually in the archive,
 202     #  one way or another
 203     $!=0; $lastupl_hash = `git show-ref --heads $lastupl_ref`;
 204     die $! if $!;
 205     die $? unless ($?==0 && chomp $lastupl_hash)
 206         or ($?==128 && !length $lastupl_hash);
 207     my $hash;
 208     if (defined $dsc_hash) {
 209         $hash = $dsc_hash;
 210     } else {
 211         $hash = generate_commit_from_dsc();
 212     }
 213     if ($lastupl_hash) {
 214         my $mb = cmdoutput qw(git merge-base), $dsc_hash, $lastupl_hash;
 215         die "not fast forward on last upload branch!".
 216             " (archive's version left in DGIT_ARCHIVE)"
 217             unless $mb eq $lastupl_hash;
 218     }
 219     if ($lastupl_ref ne $hash) {
 220         cmdoutput qw(git update-ref -m), 'dgit fetch', $lastupl_ref, $hash;
 221     }
 222 }
 223
 224 #sub combine () {
 225 #    if (
 226
 227 #       runcmd qw(git write-tree
 228
 229
 230         runcmd qw(mkdir -p '');
 231 #       chdir '.git/dgit/unpack' or die $!;
 232
 233
 234 #       with_tmpdir($td,{
 235
 236 #    });
 237
 238 #    }
 239
 240 #       open P, "-|", qw(git rev-parse --), $dsc_hash;
 241
 242 #}
 243
 244 sub clone () {
 245     get_archive_dsc();
 246     $dsc_hash = $dsc->{'Vcs-git-master'};
 247     if (defined $dsc_hash) {
 248         $dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
 249         $dsc_hash = $&;
 250         print "last upload to archive specified git hash\n";
 251     } else {
 252         print "last upload to archive has NO git hash\n";
 253     }
 254     my $dstdir = "$package";
 255     if (check_for_git()) {
 256         print "cloning existing git history\n";
 257         runcmd qw(git clone --origin),$remotename, qw(-b), $suite, '--',
 258             $alioth_git, $dstdir;
 259         chdir "$dstdir" or die "$dstdir $!";
 260         fetch_from_archive();
 261         runcmd qw(git reset --hard), $lastupl_ref;
 262     } else {
 263         die "missing git history even though dsc has hash" if defined $dsc_hash;
 264         print "starting new git history\n";
 265         mkdir $dstdir or die "$dstdir $!";
 266         chdir "$dstdir" or die "$dstdir $!";
 267         runcmd qw(git init -q);
 268         open H, "> .git/HEAD" or die $!;
 269         print H "ref: refs/heads/$suite\n" or die $!;
 270         close H or die $!;
 271         runcmd qw(git remote add), $remotename, $alioth_git;
 272         runcmd "git config branch.$suite.remote $remotename";
 273         runcmd "git config branch.$suite.merge refs/heads/$suite";
 274         my $newhash = generate_commit_from_dsc();
 275         runcmd qw(git reset --hard), $newhash;
 276     }
 277     print "ready for work in $dstdir\n";
 278 }
 279
 280 sub fetch () {
 281
 282 }
 283
 284 #print Dumper(get_archive_dsc());
 285 clone();