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