drpmsync

   1 #!/usr/bin/perl -w
   2
   3 #
   4 # Copyright (c) 2005 Michael Schroeder (mls@suse.de)
   5 #
   6 # This program is licensed under the BSD license, read LICENSE.BSD
   7 # for further information
   8 #
   9
  10 use Socket;
  11 use Fcntl qw(:DEFAULT :flock);
  12 use POSIX;
  13 use Digest::MD5 ();
  14 use Net::Domain ();
  15 use bytes;
  16 my $have_zlib;
  17 my $have_time_hires;
  18 eval {
  19   require Compress::Zlib;
  20   $have_zlib = 1;
  21 };
  22 eval {
  23   require Time::HiRes;
  24   $have_time_hires = 1 if defined &Time::HiRes::gettimeofday;
  25 };
  26 use strict;
  27
  28 $SIG{'PIPE'} = 'IGNORE';
  29
  30 #######################################################################
  31 # Common code user for Client and Server
  32 #######################################################################
  33
  34 my $makedeltarpm = 'makedeltarpm';
  35 my $combinedeltarpm = 'combinedeltarpm';
  36 my $applydeltarpm = 'applydeltarpm';
  37 my $fragiso = 'fragiso';
  38
  39 sub stdinopen {
  40   local *F = shift;
  41   local *I = shift;
  42   my $pid;
  43   while (1) {
  44     $pid = open(F, '-|');
  45     last if defined $pid;
  46     return if $! != POSIX::EAGAIN;
  47     sleep(5);
  48   }
  49   return 1 if $pid;
  50   if (fileno(I) != 0) {
  51     open(STDIN, "<&I") || die("dup stdin: $!\n");
  52     close(I);
  53   }
  54   exec @_;
  55   die("$_[0]: $!\n");
  56 }
  57
  58 sub tmpopen {
  59   local *F = shift;
  60   my $tmpdir = shift;
  61
  62   my $tries = 0;
  63   for ($tries = 0; $tries < 100; $tries++) {
  64     if (sysopen(F, "$tmpdir/drpmsync.$$.$tries", POSIX::O_RDWR|POSIX::O_CREAT|POSIX::O_EXCL, 0600)) {
  65       unlink("$tmpdir/drpmsync.$$.$tries");
  66       return 1;
  67     }
  68   }
  69   return;
  70 }
  71
  72 # cannot use IPC::Open3, sigh...
  73 sub runprg {
  74   return runprg_job(undef, @_);
  75 }
  76
  77 sub runprg_job {
  78   my ($job, $if, $of, @prg) = @_;
  79   local (*O, *OW, *E, *EW);
  80   if (!$of) {
  81     pipe(O, OW) || die("pipe: $!\n");
  82   }
  83   pipe(E, EW) || die("pipe: $!\n");
  84   my $pid;
  85   while (1) {
  86     $pid = fork();
  87     last if defined $pid;
  88     return ('', "runprg: fork: $!") if $! != POSIX::EAGAIN;
  89     sleep(5);
  90   }
  91   if ($pid == 0) {
  92     if ($of) {
  93       *OW = $of;
  94     } else {
  95       close(O);
  96     }
  97     close(E);
  98     if (fileno(OW) != 1) {
  99       open(STDOUT, ">&OW") || die("dup stdout: $!\n");
 100       close(OW);
 101     }
 102     if (fileno(EW) != 2) {
 103       open(STDERR, ">&EW") || die("dup stderr: $!\n");
 104       close(EW);
 105     }
 106     if (defined($if)) {
 107       local (*I) = $if;
 108       if (fileno(I) != 0) {
 109         open(STDIN, "<&I") || die("dup stdin: $!\n");
 110         close(I);
 111       }
 112     } else {
 113       open(STDIN, "</dev/null");
 114     }
 115     exec @prg;
 116     die("$prg[0]: $!\n");
 117   }
 118   close(OW) unless $of;
 119   close(EW);
 120
 121   if ($job) {
 122     $job->{'PID'} = $pid;
 123     $job->{'E'} = *E;
 124     delete $job->{'O'};
 125     $job->{'O'} = *O unless $of;
 126     return $job;
 127   }
 128   $job = {};
 129   $job->{'PID'} = $pid;
 130   $job->{'E'} = *E;
 131   $job->{'O'} = *O unless $of;
 132   return runprg_finish($job);
 133 }
 134
 135 sub runprg_finish {
 136   my ($job) = @_;
 137
 138   die("runprg_finish: no job running\n") unless $job && $job->{'PID'};
 139   my ($out, $err) = ('', '');
 140   my $pid = $job->{'PID'};
 141   local *E = $job->{'E'};
 142   local *O;
 143   my $of = 1;
 144   if (exists $job->{'O'}) {
 145     $of = undef;
 146     *O = $job->{'O'};
 147   }
 148   delete $job->{'PID'};
 149   delete $job->{'O'};
 150   delete $job->{'E'};
 151   my $rin = '';
 152   my $efd = fileno(E);
 153   my $ofd;
 154   if (!$of) {
 155     $ofd = fileno(O);
 156     vec($rin, $ofd, 1) = 1;
 157   }
 158   vec($rin, $efd, 1) = 1;
 159   my $nfound;
 160   my $rout;
 161   my $openfds = $of ? 2 : 3;
 162   while ($openfds) {
 163     $nfound = select($rout = $rin, undef, undef, undef);
 164     if (!defined($nfound)) {
 165       $err .= "select: $!";
 166       close(O) if $openfds & 1;
 167       close(E) if $openfds & 2;
 168       last;
 169     }
 170     if (!$of && vec($rout, $ofd, 1)) {
 171       if (!sysread(O, $out, 4096, length($out))) {
 172         vec($rin, $ofd, 1) = 0;
 173         close(O);
 174         $openfds &= ~1;
 175       }
 176     }
 177     if (vec($rout, $efd, 1)) {
 178       if (!sysread(E, $err, 4096, length($err))) {
 179         vec($rin, $efd, 1) = 0;
 180         close(E);
 181         $openfds &= ~2;
 182       }
 183     }
 184   }
 185   while(1) {
 186     if (waitpid($pid, 0) == $pid) {
 187       $err = "Error $?" if $? && $err eq '';
 188       last;
 189     }
 190     if ($! != POSIX::EINTR) {
 191       $err = "waitpid: $!";
 192       last;
 193     }
 194   }
 195   return ($out, $err);
 196 }
 197
 198 sub cprpm {
 199   local *F = shift;
 200   my ($wri, $verify, $ml) = @_;
 201
 202   local *WF;
 203   *WF = $wri if $wri;
 204
 205   my $ctx;
 206   $ctx = Digest::MD5->new if $verify;
 207
 208   my $buf = '';
 209   my $l;
 210   while (length($buf) < 96 + 16) {
 211     $l = sysread(F, $buf, defined($ml) && $ml < 4096 ? $ml : 4096, length($buf));
 212     return "read error" unless $l;
 213     $ml -= $l if defined $ml;
 214   }
 215   my ($magic, $sigtype) = unpack('N@78n', $buf);
 216   return "not a rpm (bad magic of header type" unless $magic == 0xedabeedb && $sigtype == 5;
 217   my ($headmagic, $cnt, $cntdata) = unpack('@96N@104NN', $buf);
 218   return "not a rpm (bad sig header magic)" unless $headmagic == 0x8eade801;
 219   my $hlen = 96 + 16 + $cnt * 16 + $cntdata;
 220   $hlen = ($hlen + 7) & ~7;
 221   while (length($buf) < $hlen) {
 222     $l = sysread(F, $buf, defined($ml) && $ml < 4096 ? $ml : 4096, length($buf));
 223     return "read error" unless $l;
 224     $ml -= $l if defined $ml;
 225   }
 226   my $lmd5 = Digest::MD5::md5_hex(substr($buf, 0, $hlen));
 227   my $idxarea = substr($buf, 96 + 16, $cnt * 16);
 228   if (!($idxarea =~ /\A(?:.{16})*\000\000\003\354\000\000\000\007(....)\000\000\000\020/s)) {
 229      return "no md5 signature header";
 230   }
 231   my $md5off = unpack('N', $1);
 232   return "bad md5 offset" if $md5off >= $cntdata;
 233   $md5off += 96 + 16 + $cnt * 16;
 234   my $hmd5 = unpack("\@${md5off}H32", $buf);
 235   return "write error" if $wri && (syswrite(WF, substr($buf, 0, $hlen)) || 0) != $hlen;
 236   $buf = substr($buf, $hlen);
 237   while (length($buf) < 16) {
 238     $l = sysread(F, $buf, defined($ml) && $ml < 4096 ? $ml : 4096, length($buf));
 239     return "read error" unless $l;
 240     $ml -= $l if defined $ml;
 241   }
 242   ($headmagic, $cnt, $cntdata) = unpack('N@8NN', $buf);
 243   return "not a rpm (bad header magic)" unless $headmagic == 0x8eade801;
 244   $hlen = 16 + $cnt * 16;
 245   while (length($buf) < $hlen) {
 246     $l = sysread(F, $buf, defined($ml) && $ml < 4096 ? $ml : 4096, length($buf));
 247     return "read error" unless $l;
 248     $ml -= $l if defined $ml;
 249   }
 250   my ($nameoff, $archoff, $btoff);
 251   $idxarea = substr($buf, 0, $hlen);
 252   my $srctype = '';
 253   if (!($idxarea =~ /\A(?:.{16})*\000\000\004\024/s)) {
 254     if (($idxarea =~ /\A(?:.{16})*\000\000\004[\033\034]/s)) {
 255       $srctype = 'nosrc';
 256     } else {
 257       $srctype = 'src';
 258     }
 259   }
 260   if (($idxarea =~ /\A(?:.{16})*\000\000\003\350\000\000\000\006(....)\000\000\000\001/s)) {
 261     $nameoff = unpack('N', $1);
 262   }
 263   if (($idxarea =~ /\A(?:.{16})*\000\000\003\376\000\000\000\006(....)\000\000\000\001/s)) {
 264     $archoff = unpack('N', $1);
 265   }
 266   if (($idxarea =~ /\A(?:.{16})*\000\000\003\356\000\000\000\004(....)\000\000\000\001/s)) {
 267     $btoff = unpack('N', $1);
 268   }
 269   return "rpm contains no name tag" unless defined $nameoff;
 270   return "rpm contains no arch tag" unless defined $archoff;
 271   return "rpm contains no build time" unless defined $btoff;
 272   return "bad name/arch offset" if $nameoff >= $cntdata || $archoff >= $cntdata || $btoff + 3 >= $cntdata;
 273   $ctx->add(substr($buf, 0, $hlen)) if $verify;
 274   return "write error" if $wri && (syswrite(WF, substr($buf, 0, $hlen)) || 0) != $hlen;
 275   $buf = substr($buf, $hlen);
 276   my $maxoff = $nameoff > $archoff ? $nameoff : $archoff;
 277   $maxoff += 1024;      # should be enough
 278   $maxoff = $btoff + 4 if $btoff + 4 > $maxoff;
 279   $maxoff = $cntdata if $maxoff > $cntdata;
 280   while (length($buf) < $maxoff) {
 281     $l = sysread(F, $buf, defined($ml) && $ml < 4096 ? $ml : 4096, length($buf));
 282     return "read error" unless $l;
 283     $ml -= $l if defined $ml;
 284   }
 285   my $name = unpack("\@${nameoff}Z*", $buf);
 286   my $arch = unpack("\@${archoff}Z*", $buf);
 287   my $bt = unpack("\@${btoff}H8", $buf);
 288   if ($verify || $wri) {
 289     $ctx->add($buf) if $verify;
 290     return "write error" if $wri && (syswrite(WF, $buf) || 0) != length($buf);
 291     while(1) {
 292       last if defined($ml) && $ml == 0;
 293       $l = sysread(F, $buf, defined($ml) && $ml < 8192 ? $ml : 8192);
 294       last if !$l && !defined($ml);
 295       return "read error" unless $l;
 296       $ml -= $l if defined $ml;
 297       $ctx->add($buf) if $verify;
 298       return "write error" if $wri && (syswrite(WF, $buf) || 0) != $l;
 299     }
 300     if ($verify) {
 301       my $rmd5 = $ctx->hexdigest;
 302       return "rpm checksum error ($rmd5 != $hmd5)" if $rmd5 ne $hmd5;
 303     }
 304   }
 305   $name = "unknown" if $name =~ /[\000-\040\/]/;
 306   $arch = "unknown" if $arch =~ /[\000-\040\/]/;
 307   $arch = $srctype if $srctype;
 308   return ("$lmd5$hmd5", $bt, "$name.$arch");
 309 }
 310
 311 sub cpfile {
 312   local *F = shift;
 313   my ($wri) = @_;
 314
 315   local *WF;
 316   *WF = $wri if $wri;
 317   my $ctx;
 318   $ctx = Digest::MD5->new;
 319   my ($buf, $l);
 320   while(1) {
 321     $l = sysread(F, $buf, 8192);
 322     last if !$l;
 323     die("cpfile read error\n") unless $l;
 324     $ctx->add($buf);
 325     die("cpfile write error\n") if $wri && (syswrite(WF, $buf) || 0) != $l;
 326   }
 327   return ($ctx->hexdigest);
 328 }
 329
 330 sub rpminfo_f {
 331   my ($fd, $rpm) = @_;
 332   my @info = cprpm($fd);
 333   if (@info == 1) {
 334     warn("$rpm: $info[0]\n");
 335     return ();
 336   }
 337   return @info;
 338 }
 339
 340 sub rpminfo {
 341   my $rpm = shift;
 342   local *RPM;
 343   if (!open(RPM, '<', $rpm)) {
 344     warn("$rpm: $!\n");
 345     return ();
 346   }
 347   my @ret = rpminfo_f(*RPM, $rpm);
 348   close RPM;
 349   return @ret;
 350 }
 351
 352 sub fileinfo_f {
 353   local (*F) = shift;
 354
 355   my $ctx = Digest::MD5->new;
 356   $ctx->addfile(*F);
 357   return $ctx->hexdigest;
 358 }
 359
 360 sub fileinfo {
 361   my $fn = shift;
 362   local *FN;
 363   if (!open(FN, '<', $fn)) {
 364     warn("$fn: $!\n");
 365     return ();
 366   }
 367   my @ret = fileinfo_f(*FN, $fn);
 368   close FN;
 369   return @ret;
 370 }
 371
 372 sub linkinfo {
 373   my $fn = shift;
 374   my $fnc = readlink($fn);
 375   if (!defined($fnc)) {
 376     warn("$fn: $!\n");
 377     return ();
 378   }
 379   return Digest::MD5::md5_hex($fnc);
 380 }
 381
 382 my @filter_comp;
 383 my @filter_arch_comp;
 384
 385 sub run_filter {
 386   my @x = @_;
 387
 388   my @f = @filter_comp;
 389   my @r;
 390   while (@f) {
 391     my ($ft, $fre) = splice(@f, 0, 3);
 392     my @xx = grep {/$fre/} @x;
 393     my %xx = map {$_ => 1} @xx;
 394     push @r, @xx if $ft;
 395     @x = grep {!$xx{$_}} @x;
 396   }
 397   return (@r, @x);
 398 }
 399
 400 sub run_filter_one {
 401   my ($n) = @_;
 402   my @f = @filter_comp;
 403   while (@f) {
 404     my ($ft, $fre) = splice(@f, 0, 3);
 405     if ($ft) {
 406       return 1 if $n =~ /$fre/;
 407     } else {
 408       return if $n =~ /$fre/;
 409     }
 410   }
 411   return 1;
 412 }
 413
 414 sub compile_filter {
 415   my @rules = @_;
 416
 417   my @comp = ();
 418   for my $rule (@rules) {
 419     die("bad filter type, must be '+' or '-'\n") unless $rule =~ /^([+-])(.*)$/;
 420     my $type = $1 eq '+' ? 1 : 0;
 421     my $match = $2;
 422     my $anchored = $match =~ s/^\///;
 423     my @match = split(/\[(\^?.(?:\\.|[^]])*)\]/, $match, -1);
 424     my $i = 0;
 425     for (@match) {
 426       $i = 1 - $i;
 427       if (!$i) {
 428         s/([^-\^a-zA-Z0-9])/\\$1/g;
 429         s/\\\\(\\[]\\\]]|-)/"\\".substr($1, -1)/ge;
 430         $_ = "[$_]";
 431         next;
 432       }
 433       $_ = "\Q$_\E";
 434       s/\\\*\\\*/.*/g;
 435       s/\\\*/[^\/]*/g;
 436       s/\\\?/[^\/]/g;
 437     }
 438     $match = join('', @match);
 439     if ($anchored) {
 440       $match = "^$match";
 441     } else {
 442       $match = "(?:^|\/)$match";
 443     }
 444     $match .= '\/?' if $match !~ /\/$/;
 445     $match .= '$';
 446     eval {
 447       push @comp, $type, qr/$match/s, $rule;
 448     };
 449     die("bad filter rule: $rule\n") if $@;
 450   }
 451   return @comp;
 452 }
 453
 454 sub filelist_apply_filter {
 455   my ($flp) = @_;
 456   return unless @filter_comp;
 457   my @ns = ();
 458   my $x;
 459   for my $e (@$flp) {
 460     if (defined($x)) {
 461       next if substr($e->[0], 0, length($x)) eq $x;
 462       undef $x;
 463     }
 464     if (@$e == 3) {
 465       if (!run_filter_one("$e->[0]/")) {
 466         $x = "$e->[0]/";
 467         next;
 468       }
 469     } else {
 470       next if !run_filter_one("$e->[0]");
 471     }
 472     push @ns, $e;
 473   }
 474   @$flp = @ns;
 475 }
 476
 477 sub filelist_apply_filter_arch {
 478   my ($flp) = @_;
 479   return unless @filter_arch_comp;
 480   my %filtered;
 481   my @filter_comp_save = @filter_comp;
 482   @filter_comp = @filter_arch_comp;
 483   my @ns = ();
 484   for my $e (@$flp) {
 485     if (@$e > 5 && !run_filter_one((split('\.', $e->[5]))[-1])) {
 486       if ($e->[0] =~ /(.*)\.rpm$/) {
 487         $filtered{"$1.changes"} = 1;
 488         $filtered{"$1-MD5SUMS.meta"} = 1;
 489         $filtered{"$1-MD5SUMS.srcdir"} = 1;
 490       }
 491       next;
 492     }
 493     push @ns, $e;
 494   }
 495   @filter_comp = @filter_comp_save;
 496   @$flp = @ns;
 497   if (%filtered) {
 498     # second pass to remove meta files
 499     @ns = ();
 500     for my $e (@$flp) {
 501       next if @$e == 4 && $filtered{$e->[0]};
 502       push @ns, $e;
 503     }
 504     @$flp = @ns;
 505   }
 506 }
 507
 508 sub filelist_exclude_drpmsync {
 509   my ($flp) = @_;
 510   @$flp = grep {$_->[0] =~ /(?:^|\/)drpmsync\//s || (@$_ == 3 && $_->[0] =~ /(?:^|\/)drpmsync$/s)} @$flp;
 511 }
 512
 513 my @files;
 514 my %cache;
 515 my $cachehits = 0;
 516 my $cachemisses = 0;
 517
 518 sub findfiles {
 519   my ($bdir, $dir, $keepdrpmdir, $norecurse) = @_;
 520
 521   local *DH;
 522   if (!opendir(DH, "$bdir$dir")) {
 523     warn("$dir: $!\n");
 524     return;
 525   }
 526   my @ents = sort readdir(DH);
 527   closedir(DH);
 528   $bdir .= '/' if $dir eq '';
 529   $dir .= '/' if $dir ne '';
 530   if ($dir ne '' && grep {$_ eq 'drpmsync'} @ents) {
 531     readcache("$bdir${dir}drpmsync/cache") if -f "$bdir${dir}drpmsync/cache";
 532   }
 533   my %fents;
 534   if (@filter_comp) {
 535     @ents = grep {$_ ne '.' && $_ ne '..'} @ents;
 536     my @fents = run_filter(map {"$dir$_"} @ents);
 537     if (@fents != @ents) {
 538       %fents = map {("$dir$_" => 1)} @ents;
 539       delete $fents{$_} for @fents;
 540     }
 541   }
 542   for my $ent (@ents) {
 543     next if $ent eq '.' || $ent eq '..';
 544     next if $ent =~ /\.new\d*$/;
 545     my @s = lstat "$bdir$dir$ent";
 546     if (!@s) {
 547       warn("$bdir$dir$ent: $!\n");
 548       next;
 549     }
 550     next unless -l _ || -d _ || -f _;
 551     my $id = "$s[9]/$s[7]/$s[1]";
 552     my $mode = -l _ ? 0x2000 : -f _ ? 0x1000 : 0x0000;
 553     $mode |= $s[2] & 07777;
 554     my @data = ($id, sprintf("%04x%08x", $mode, $s[9]));
 555     if (-d _) {
 556       next if $ent eq 'drpmsync' && ($dir eq '' || !$keepdrpmdir);
 557       next if @filter_comp && !run_filter_one("$dir$ent/");
 558       push @files, [ "$dir$ent", @data ];
 559       next if $norecurse;
 560       findfiles($bdir, "$dir$ent", $keepdrpmdir);
 561     } else {
 562       next if @filter_comp && $fents{"$dir$ent"};
 563       my @xdata;
 564       if ($cache{$id}) {
 565         @xdata = @{$cache{$id}};
 566         if (@xdata == ($ent =~ /\.[sr]pm$/) ? 3 : 1) {
 567           $cachehits++;
 568           push @files, [ "$dir$ent", @data, @xdata ];
 569           next;
 570         }
 571       }
 572       # print "miss $id ($ent)\n";
 573       $cachemisses++;
 574       if (-l _) {
 575         @xdata = linkinfo("$bdir$dir$ent");
 576         next if !@xdata;
 577         $cache{$id} = \@xdata;
 578         push @files, [ "$dir$ent", @data, @xdata ];
 579         next;
 580       }
 581       local *F;
 582       if (!open(F, '<', "$bdir$dir$ent")) {
 583         warn("$bdir$dir$ent: $!\n");
 584         next;
 585       }
 586       @s = stat F;
 587       if (!@s || ! -f _) {
 588         warn("$bdir$dir$ent: $!\n");
 589         next;
 590       }
 591       $id = "$s[9]/$s[7]/$s[1]";
 592       @data = ($id, sprintf("1%03x%08x", ($s[2] & 07777), $s[9]));
 593       if ($ent =~ /\.[sr]pm$/) {
 594         @xdata = rpminfo_f(*F, "$bdir$dir$ent");
 595       } else {
 596         @xdata = fileinfo_f(*F, "$bdir$dir$ent");
 597       }
 598       close F;
 599       next if !@xdata;
 600       $cache{$id} = \@xdata;
 601       push @files, [ "$dir$ent", @data, @xdata ];
 602     }
 603   }
 604 }
 605
 606 sub readcache {
 607   my $cf = shift;
 608
 609   local *CF;
 610   open(CF, '<', $cf) || return;
 611   while(<CF>) {
 612     chomp;
 613     my @s = split(' ');
 614     next unless @s == 4 || @s == 2;
 615     my $s = shift @s;
 616     $cache{$s} = \@s;
 617   }
 618   close CF;
 619 }
 620
 621 sub writecache {
 622   my $cf = shift;
 623
 624   local *CF;
 625   open(CF, '>', "$cf.new") || die("$cf.new: $!\n");
 626   for (@files) {
 627     next if @$_ < 4;    # no need to cache dirs
 628     if (@$_ > 5) {
 629       print CF "$_->[1] $_->[3] $_->[4] $_->[5]\n";
 630     } else {
 631       print CF "$_->[1] $_->[3]\n";
 632     }
 633   }
 634   close CF;
 635   rename("$cf.new", $cf) || die("rename $cf.new $cf: $!\n");
 636 }
 637
 638 #######################################################################
 639 # Server stuff
 640 #######################################################################
 641
 642 sub escape {
 643   my $x = shift;
 644   $x =~ s/\&/&amp;/g;
 645   $x =~ s/\</&lt;/g;
 646   $x =~ s/\>/&gt;/g;
 647   $x =~ s/\"/&quot;/g;
 648   return $x;
 649 }
 650
 651 sub aescape {
 652   my $x = shift;
 653   $x =~ s/([\000-\040<>\"#&\+=%[\177-\377])/sprintf("%%%02X",ord($1))/ge;
 654   return $x;
 655 }
 656
 657 sub readfile {
 658   my $fn = shift;
 659   local *FN;
 660   open(FN, '<', $fn) || return ('', "$fn: $!");
 661   my $out = '';
 662   while ((sysread(FN, $out, 8192, length($out)) || 0) == 8192) {}
 663   close FN;
 664   return ($out, '');
 665 }
 666
 667 # server config
 668 my %trees;
 669 my %chld;
 670 my $standalone;
 671 my $sendlogid;
 672 my $servername;
 673 my $serveraddr;
 674 my $serveruser;
 675 my $servergroup;
 676 my $serverlog;
 677 my $maxclients = 10;
 678 my $servertmp = '/var/tmp';
 679 my $serverpidfile;
 680
 681 sub readconfig_server {
 682   my $cf = shift;
 683
 684   my @allow;
 685   my @deny;
 686   my $no_combine;
 687   my $log;
 688   my $slog;
 689   my $deltadirs;
 690   my $maxdeltasize;
 691   my $maxdeltasizeabs;
 692   my @denymsg;
 693   local *CF;
 694   die("config not set\n") unless $cf;
 695   open(CF, '<', $cf) || die("$cf: $!\n");
 696   while(<CF>) {
 697     chomp;
 698     s/^\s+//;
 699     s/\s+$//;
 700     next if $_ eq '' || /^#/;
 701     my @s = split(' ', $_);
 702     my $s0 = lc($s[0]);
 703     $s0 =~ s/:$//;
 704     my $s1 = @s > 1 ? $s[1] : undef;
 705     shift @s;
 706     if ($s0 eq 'allow' || $s0 eq 'deny') {
 707       for (@s) {
 708         if (/^\/(.*)\/$/) {
 709           $_ = $1;
 710           eval { local $::SIG{'__DIE__'}; "" =~ /^$_$/; };
 711           die("$s0: bad regexp: $_\n") if $@;
 712         } else {
 713           s/([^a-zA-Z0-9*])/\\$1/g;
 714           s/\*/.*/g;
 715         }
 716       }
 717       if ($s0 eq 'allow') {
 718         @allow = @s;
 719       } else {
 720         @deny = @s;
 721       }
 722     } elsif ($s0 eq 'denymsg') {
 723       if (!@s) {
 724         @denymsg = ();
 725         next;
 726       }
 727       if ($s1 =~ /^\/(.*)\/$/) {
 728         $s1 = $1;
 729         eval { local $::SIG{'__DIE__'}; "" =~ /^$s1$/; };
 730         die("$s0: bad regexp: $s1\n") if $@;
 731       } else {
 732         $s1 =~ s/([^a-zA-Z0-9*])/\\$1/g;
 733         $s1 =~ s/\*/.*/g;
 734       }
 735       shift @s;
 736       push @denymsg, [ $s1, join(' ', @s) ];
 737     } elsif ($s0 eq 'no_combine') {
 738       $no_combine = ($s1 && $s1 =~ /true/i);
 739     } elsif ($s0 eq 'log') {
 740       $log = $s1;
 741     } elsif ($s0 eq 'serverlog') {
 742       $slog = $s1;
 743     } elsif ($s0 eq 'deltadirs') {
 744       $deltadirs = $s1;
 745     } elsif ($s0 eq 'deltarpmpath') {
 746       my $p = defined($s1) ? "$s1/" : '';
 747       $makedeltarpm = "${p}makedeltarpm";
 748       $combinedeltarpm = "${p}combinedeltarpm";
 749       $fragiso = "${p}fragiso";
 750     } elsif ($s0 eq 'maxclients') {
 751       $maxclients = $s1 || 1;
 752     } elsif ($s0 eq 'servername') {
 753       $servername = $s1;
 754     } elsif ($s0 eq 'serveraddr') {
 755       $serveraddr = $s1;
 756     } elsif ($s0 eq 'serveruser') {
 757       $serveruser = $s1;
 758     } elsif ($s0 eq 'servergroup') {
 759       $servergroup = $s1;
 760     } elsif ($s0 eq 'pidfile') {
 761       $serverpidfile = $s1;
 762     } elsif ($s0 eq 'maxdeltasize') {
 763       $maxdeltasize = $s1;
 764     } elsif ($s0 eq 'maxdeltasizeabs') {
 765       $maxdeltasizeabs = $s1;
 766     } elsif ($s0 eq 'tree') {
 767       die("tree: two arguments required\n") if @s != 2;
 768       $trees{$s[0]} = { 'allow' => [ @allow ],
 769                         'deny' => [ @deny ],
 770                         'denymsg' => [ @denymsg ],
 771                         'no_combine' => $no_combine,
 772                         'maxdeltasize' => $maxdeltasize,
 773                         'maxdeltasizeabs' => $maxdeltasizeabs,
 774                         'deltadirs' => $deltadirs,
 775                         'log' => $log,
 776                         'root' => $s[1],
 777                         'id' => $s[0]
 778                       };
 779     } else {
 780       die("$cf: unknown configuration parameter: $s0\n");
 781     }
 782   }
 783   close CF;
 784   $serverlog = $slog;
 785 }
 786
 787 sub gethead {
 788   my $h = shift;
 789   my $t = shift;
 790
 791   my ($field, $data);
 792   $field = undef;
 793   for (split(/[\r\n]+/, $t)) {
 794     next if $_ eq '';
 795     if (/^[ \t]/) {
 796       next unless defined $field;
 797       s/^\s*/ /;
 798       $h->{$field} .= $_;
 799     } else {
 800       ($field, $data) = split(/\s*:\s*/, $_, 2);
 801       $field =~ tr/A-Z/a-z/;
 802       if ($h->{$field} && $h->{$field} ne '') {
 803         $h->{$field} = $h->{$field}.','.$data;
 804       } else {
 805         $h->{$field} = $data;
 806       }
 807     }
 808   }
 809 }
 810
 811 sub serverlog {
 812   my $id = shift;
 813   my $str = shift;
 814   return unless $serverlog;
 815   $str =~ s/\n$//s;
 816   my @lt = localtime(time());
 817   $lt[5] += 1900;
 818   $lt[4] += 1;
 819   $id = defined($id) ? " [$id]" : '';
 820   printf SERVERLOG "%04d-%02d-%02d %02d:%02d:%02d%s: %s\n", @lt[5,4,3,2,1,0], $id, $str;
 821 }
 822
 823 sub serverdetach {
 824   my $pid;
 825   local (*SR, *SW);
 826   pipe(SR, SW) || die("setsid pipe: $!\n");
 827   while (1) {
 828     $pid = fork();
 829     last if defined $pid;
 830     die("fork: $!") if $! != POSIX::EAGAIN;
 831     sleep(5);
 832   }
 833   if ($pid) {
 834     close SW;
 835     my $dummy = '';
 836     sysread(SR, $dummy, 1);
 837     exit(0);
 838   }
 839   POSIX::setsid();
 840   close SW;
 841   close SR;
 842   open(STDIN, "</dev/null");
 843   open(STDOUT, ">/dev/null");
 844   open(STDERR, ">/dev/null");
 845 }
 846
 847 sub startserver {
 848   my $config = shift;
 849   my $nobg = shift;
 850
 851   # not called from web server, go for standalone
 852   $standalone = 1;
 853   readconfig_server($config);
 854   unlink($serverpidfile) if $serverpidfile;
 855   if ($serverlog && !open(SERVERLOG, '>>', $serverlog)) {
 856     my $err = "$serverlog: $!\n";
 857     undef $serverlog;   # do not log in die() hook
 858     die($err);
 859   }
 860   serverlog(undef, "server start");
 861   $servername = '' unless defined $servername;
 862   $servername = Net::Domain::hostfqdn().$servername if $servername eq '' || $servername =~ /^:\d+$/;
 863   die("need servername for standalone mode\n") unless $servername;
 864   if (defined($serveruser) && $serveruser =~ /[^\d]/) {
 865     my $uid = getpwnam($serveruser);
 866     die("$serveruser: unknown user\n") unless defined $uid;
 867     $serveruser = $uid;
 868   }
 869   if (defined($servergroup) && $servergroup =~ /[^\d]/) {
 870     my $gid = getgrnam($servergroup);
 871     die("$servergroup: unknown group\n") unless defined $gid;
 872     $servergroup = $gid;
 873   }
 874   my ($servern, $servera, $serverp);
 875   ($servern, $serverp) = $servername =~ /^([^\/]+?)(?::(\d+))?$/;
 876   die("bad servername: $servername\n") unless $servern;
 877   $serverp ||= 80;
 878   $servera = INADDR_ANY;
 879   if ($serveraddr) {
 880     $servera = inet_aton($serveraddr) || die("could not resolv $serveraddr\n");
 881   }
 882   my $tcpproto = getprotobyname('tcp');
 883   socket(MS , PF_INET, SOCK_STREAM, $tcpproto) || die("socket: $!\n");
 884   setsockopt(MS, SOL_SOCKET, SO_REUSEADDR, pack("l",1));
 885   bind(MS, sockaddr_in($serverp, $servera)) || die "bind: $!\n";
 886   listen(MS , 512) || die "listen: $!\n";
 887
 888   local *SERVERPID;
 889   if ($serverpidfile) {
 890     open(SERVERPID, '>', $serverpidfile) || die("$serverpidfile: $!\n");
 891   }
 892
 893   if (defined($servergroup)) {
 894     ($(, $)) = ($servergroup, $servergroup);
 895     die "setgid: $!\n" if $) != $servergroup;
 896   }
 897   if (defined($serveruser)) {
 898     ($<, $>) = ($serveruser, $serveruser);
 899     die "setuid: $!\n" if $> != $serveruser;
 900   }
 901   serverdetach() unless $nobg;
 902
 903   if ($serverpidfile) {
 904     syswrite(SERVERPID, "$$\n");
 905     close(SERVERPID) || die("$serverpidfile: $!\n");
 906   }
 907
 908   fcntl(MS, F_SETFL, 0);
 909   my $remote_addr;
 910   while (1) {
 911     $remote_addr = accept(S, MS) || die "accept: $!\n";
 912     my $pid;
 913     while (1) {
 914       $pid = fork();
 915       last if defined($pid);
 916       sleep(5);
 917     }
 918     last if $pid == 0;
 919     close(S);
 920     $chld{$pid} = 1;
 921     $remote_addr = inet_ntoa((sockaddr_in($remote_addr))[1]);
 922     while(1) {
 923       $pid = waitpid(-1, keys %chld < $maxclients ? WNOHANG : 0);
 924       delete $chld{$pid} if $pid && $pid > 0;
 925       last if !($pid && $pid > 0) && keys %chld < $maxclients;
 926     }
 927   }
 928   close MS;
 929   $standalone = 2;
 930   setsockopt(S, SOL_SOCKET, SO_KEEPALIVE, pack("l",1));
 931   $remote_addr = inet_ntoa((sockaddr_in($remote_addr))[1]);
 932   return $remote_addr;
 933 }
 934
 935 sub parse_cgi {
 936   my ($cgip, $query_string) = @_;
 937
 938   %$cgip = ();
 939   my @query_string = split('&', $query_string);
 940   while (@query_string) {
 941     my ($name, $value) = split('=', shift(@query_string), 2);
 942     next unless defined $name && $name ne '';
 943     $name  =~ tr/+/ /;
 944     $name  =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
 945     if (defined($value)) {
 946       $value =~ tr/+/ /;
 947       $value =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
 948     }
 949     if ($name eq 'filter' || $name eq 'filter_arch') {
 950       push @{$cgip->{$name}}, $value;
 951     } else {
 952       $cgip->{$name} = $value;
 953     }
 954   }
 955 }
 956
 957 sub getrequest {
 958   my $qu = '';
 959   do {
 960     die($qu eq '' ? "empty query\n" : "received truncated query\n") if !sysread(S, $qu, 1024, length($qu));
 961   } while ($qu !~ /^(.*?)\r?\n/s);
 962   my $req = $1;
 963   my ($act, $path, $vers, undef) = split(' ', $req, 4);
 964   my %headers;
 965   die("400 No method name\n") if !$act;
 966   if ($vers ne '') {
 967     die("501 Bad method: $act\n") if $act ne 'GET' && $act ne 'HEAD' && $act ne 'POST';
 968     while ($qu !~ /^(.*?)\r?\n\r?\n(.*)$/s) {
 969       die("received truncated query\n") if !sysread(S, $qu, 1024, length($qu));
 970     }
 971     $qu =~ /^(.*?)\r?\n\r?\n(.*)$/s;
 972     $qu = $2;
 973     gethead(\%headers, "Request: $1");
 974   } elsif ($act ne 'GET') {
 975     die("501 Bad method, must be GET\n");
 976     $qu = '';
 977   }
 978   my $query_string = '';
 979   if ($path =~ /^(.*?)\?(.*)$/) {
 980     $path = $1;
 981     $query_string = $2;
 982   }
 983   if ($act eq 'POST') {
 984     $query_string = '';
 985     my $cl = $headers{'content-length'};
 986     while (length($qu) < $cl) {
 987       sysread(S, $qu, $cl - length($qu), length($qu)) || die("400 Truncated body\n");
 988     }
 989     $query_string = substr($qu, 0, $cl);
 990     $qu = substr($qu, $cl);
 991   }
 992   $path =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
 993   return ($path, $query_string, $headers{'via'} ? 1 : 0);
 994 }
 995
 996 sub replystream  {
 997   local (*FF) = shift;
 998   my ($flen, $str, $ctx, @hi) = @_;
 999   die("replystream: bad param\n") unless $flen;
1000   unshift @hi, "HTTP/1.1 200 OK";
1001   push @hi, "Server: drpmsync";
1002   push @hi, "Cache-Control: no-cache";
1003   push @hi, "Content-length: ".(length($str) + $flen + 32);
1004   $str = join("\r\n", @hi)."\r\n\r\n".$str;
1005   if ($standalone) {
1006     fcntl(S, F_SETFL,O_NONBLOCK);
1007     my $dummy = '';
1008     1 while sysread(S, $dummy, 1024, 0);
1009     fcntl(S, F_SETFL,0);
1010   }
1011   my $r;
1012   while (length($str) || $flen) {
1013     if ($flen && length($str) < 16384) {
1014       my $d;
1015       my $r = sysread(FF, $d, $flen > 8192 ? 8192 : $flen);
1016       if (!$r) {
1017         die("replystream: read error: $!\n") unless defined $r;
1018         die("replystream: unexpected EOF\n");
1019       }
1020       die("replystream: too much data\n") if $r > $flen;
1021       $ctx->add($d);
1022       $str .= $d;
1023       $flen -= $r;
1024       $str .= $ctx->hexdigest if !$flen;
1025     }
1026     $r = syswrite(S, $str, length($str));
1027     die("replystream: write error: $!\n") unless $r;
1028     $str = substr($str, $r);
1029   }
1030 }
1031
1032 sub reply {
1033   my ($str, @hi) = @_;
1034
1035   if ($standalone) {
1036     if (@hi && $hi[0] =~ /^status: (\d+.*)/i) {
1037       $hi[0] = "HTTP/1.1 $1";
1038     } else {
1039       unshift @hi, "HTTP/1.1 200 OK";
1040     }
1041   }
1042   push @hi, "Server: drpmsync";
1043   push @hi, "Cache-Control: no-cache";
1044   push @hi, "Content-length: ".length($str);
1045   $str = join("\r\n", @hi)."\r\n\r\n$str";
1046   if (!$standalone) {
1047     print $str;
1048     return;
1049   }
1050   fcntl(S, F_SETFL,O_NONBLOCK);
1051   my $dummy = '';
1052   1 while sysread(S, $dummy, 1024, 0);
1053   fcntl(S, F_SETFL,0);
1054   my $l;
1055   while (length($str)) {
1056     $l = syswrite(S, $str, length($str));
1057     die("write error: $!\n") unless $l;
1058     $str = substr($str, $l);
1059   }
1060 }
1061
1062 sub reply_err {
1063   my ($err, $cgi, $remote_addr) = @_;
1064   serverlog($remote_addr, $err) if $serverlog && !$sendlogid;
1065   sendlog($err) if $sendlogid;
1066   die($err) if $standalone == 1;
1067   $err =~ s/\n$//s;
1068   if (exists($cgi->{'drpmsync'})) {
1069     my $data = 'DRPMSYNC0001ERR 00000000'.sprintf("%08x", length($err)).$err;
1070     reply($data, "Content-type: application/octet-stream");
1071   } elsif ($err =~ /^(\d+[^\r\n]*)/) {
1072     reply("<pre>$err</pre>\n", "Status: $1", "Content-type: text/html");
1073   } else {
1074     reply("<pre>$err</pre>\n", "Status: 404 Error", "Content-type: text/html");
1075   }
1076   exit(0);
1077 }
1078
1079 my $check_access_cache_addr;
1080 my $check_access_cache_name;
1081
1082 sub check_access {
1083   my ($tree, $remote_addr) = @_;
1084   my ($remote_name, $access_ok);
1085
1086   $remote_name = $check_access_cache_name if $check_access_cache_addr && $check_access_cache_addr eq $remote_addr;
1087
1088   if (@{$tree->{'deny'}}) {
1089     if (!$remote_name) {
1090       $remote_name = gethostbyaddr(inet_aton($remote_addr), AF_INET);
1091       die("could not resolve $remote_addr\n") unless $remote_name;
1092       $check_access_cache_addr = $remote_addr;
1093       $check_access_cache_name = $remote_name;
1094     }
1095     for my $deny (@{$tree->{'deny'}}) {
1096       if ($deny =~ /^!/) {
1097         my $d1 = substr($deny, 1);
1098         last if $remote_name =~ /^$d1$/i;
1099         last if $remote_addr =~ /^$d1$/i;
1100       }
1101       goto denied if $remote_name =~ /^$deny$/i;
1102       goto denied if $remote_addr =~ /^$deny$/i;
1103     }
1104   }
1105   for my $allow (@{$tree->{'allow'}}) {
1106     last if $allow =~ /^!/;
1107     return if $remote_addr =~ /^$allow$/i;
1108   }
1109   if (!$remote_name) {
1110     $remote_name = gethostbyaddr(inet_aton($remote_addr), AF_INET);
1111     die("could not resolve $remote_addr\n") unless $remote_name;
1112     $check_access_cache_addr = $remote_addr;
1113     $check_access_cache_name = $remote_name;
1114   }
1115   for my $allow (@{$tree->{'allow'}}) {
1116     if ($allow =~ /^!/) {
1117       my $a1 = substr($allow, 1);
1118       last if $remote_name =~ /^$a1$/i;
1119       last if $remote_addr =~ /^$a1$/i;
1120     }
1121     return if $remote_addr =~ /^$allow$/i;
1122     return if $remote_name =~ /^$allow$/i;
1123   }
1124 denied:
1125   my $denymsg = "access denied [%h]";
1126   for my $dmsg (@{$tree->{'denymsg'}}) {
1127     if ($remote_name =~ /^$dmsg->[0]$/i || $remote_addr =~ /^$dmsg->[0]$/i) {
1128       $denymsg = $dmsg->[1];
1129       last;
1130     }
1131   }
1132   $denymsg =~ s/%h/$remote_addr/g;
1133   $denymsg =~ s/%n/$remote_name/g;
1134   die("$denymsg\n");
1135 }
1136
1137 sub sendlog {
1138   my $str = shift;
1139   return unless $sendlogid;
1140   $str =~ s/\n$//s;
1141   my @lt = localtime(time());
1142   $lt[5] += 1900;
1143   $lt[4] += 1;
1144   printf SENDLOG "%05d %04d-%02d-%02d %02d:%02d:%02d %s: %s\n", $$, @lt[5,4,3,2,1,0], $sendlogid, $str;
1145 }
1146
1147 sub solve {
1148   my ($have2, $info2, @dirs) = @_;
1149
1150   my @avail;
1151   for my $dir (@dirs) {
1152     if (opendir(D, $dir)) {
1153       push @avail, map {"$dir/$_"} grep {/^[0-9a-f]{96}$/} readdir(D);
1154       closedir D;
1155     }
1156   }
1157   return () unless @avail;
1158   my $gotone;
1159   for (@avail) {
1160     if ($have2->{substr($_, -96, 32)}) {
1161       $gotone = 1;
1162       last;
1163     }
1164   }
1165   return () unless $gotone;
1166   my @chains = ([$info2]);
1167   my %avail;
1168   push @{$avail{substr($_, -32, 32)}}, $_ for @avail;
1169   while (@chains && @{$chains[0]} <= @avail) {
1170     for my $pos (splice @chains) {
1171       for my $a (@{$avail{$pos->[0]}}) {
1172         my @n = (@$pos, $a);
1173         $n[0] = substr($a, -96, 32);
1174         if ($have2->{$n[0]}) {
1175           shift @n;
1176           return reverse @n;
1177         }
1178         push @chains, \@n;
1179       }
1180     }
1181   }
1182   return ();
1183 }
1184
1185 sub extractrpm {
1186   local *F = shift;
1187   my ($o, $l) = @_;
1188   local *F2;
1189   tmpopen(*F2, $servertmp);
1190   defined(sysseek(F, $o, 0)) || die("extractrpm: sysseek: $!\n");
1191   my $buf;
1192   while ($l > 0) {
1193     my $r = sysread(F, $buf, $l > 8192 ? 8192 : $l);
1194     if (!$r) {
1195       die("extractrpm: read error: $!\n") unless defined $r;
1196       die("extractrpm: unexpected EOF\n");
1197     }
1198     die("extractrpm: read too much data\n") if $r > $l;
1199     die("extractrpm: write error: $!\n") if (syswrite(F2, $buf) || 0) != $r;
1200     $l -= $r;
1201   }
1202   close(F);
1203   seek(F2, 0, 0);
1204   sysseek(F2, 0, 0);
1205   open(F, "<&F2") || die("extractrpm: dup: $!\n");
1206   close(F2);
1207 }
1208
1209 sub hexit {
1210   my $v = shift;
1211   if ($v >= 4294967295) {
1212     my $v2 = int($v / 4294967296);
1213     return sprintf("FFFFFFFF%02x%08x", $v2, $v - 4294967296 * $v2);
1214   } else {
1215     return sprintf("%08x", $v);
1216   }
1217 }
1218
1219 my $deltadirscache;
1220 my $deltadirscacheid;
1221
1222 sub getdeltadirs {
1223   my ($ddconfig, $path) = @_;
1224
1225   my @dirs;
1226   if ($deltadirscache) {
1227     my @ddstat = stat($ddconfig);
1228     undef $deltadirscache if !@ddstat || "$ddstat[9]/$ddstat[7]/$ddstat[1]" ne $deltadirscacheid;
1229   }
1230   if (!$deltadirscache) {
1231     local *DD;
1232     my @ddc;
1233     if (open(DD, '<', $ddconfig)) {
1234       while(<DD>) {
1235         chomp;
1236         next if /^\s*$/;
1237         if (@ddc && /^\s*\+\s*(.*)/) {
1238           push @{$ddc[-1]}, split(' ', $1);
1239         } else {
1240           push @ddc, [ split(' ', $_) ];
1241         }
1242       }
1243       my @ddstat = stat(DD);
1244       close DD;
1245       $deltadirscache = \@ddc;
1246       $deltadirscacheid = "$ddstat[9]/$ddstat[7]/$ddstat[1]";
1247     }
1248   }
1249   if ($deltadirscache) {
1250     for my $dd (@$deltadirscache) {
1251       my @dd = @$dd;
1252       my $ddre = shift @dd;
1253       eval {
1254         push @dirs, @dd if $path =~ /$ddre/;
1255       };
1256     }
1257   }
1258   return @dirs;
1259 }
1260
1261 sub serve_request {
1262   my ($cgi, $path_info, $script_name, $remote_addr, $keep_ok) = @_;
1263
1264   my $tree;
1265   $path_info = '' unless defined $path_info;
1266   die("invalid path\n") if $path_info =~ /\/(\.|\.\.)?\//;
1267   die("invalid path\n") if $path_info =~ /\/(\.|\.\.)$/;
1268   die("invalid path\n") if "$path_info/" =~ /(\.|\.\.)\//;
1269   die("invalid path\n") if $path_info ne '' && ($path_info !~ /^\//);
1270   die("$script_name not exported\n") unless $trees{$script_name};
1271
1272   my $sendlog = $trees{$script_name}->{'log'};
1273   if ($tree && $tree->{'log'} && (!$sendlog || $tree->{'log'} ne $sendlog)) {
1274       close(SENDLOG);
1275       undef $sendlogid;
1276   }
1277   if ($sendlog && (!$tree || !$tree->{'log'} || $tree->{'log'} ne $sendlog)) {
1278     open(SENDLOG, '>>', $sendlog) || die("$sendlog: $!\n");
1279     select(SENDLOG);
1280     $| = 1;
1281     select(STDOUT);
1282     $sendlogid = "[$remote_addr] $trees{$script_name}->{'id'}";
1283   }
1284   $tree = $trees{$script_name};
1285   check_access($tree, $remote_addr);
1286
1287   my $spath_info = $path_info;
1288   $spath_info =~ s/^\///;
1289
1290   my $root = $tree->{'root'};
1291   die("$root: $!\n") unless -d $root;
1292
1293   my $replyid = $keep_ok ? 'DRPMSYNK' : 'DRPMSYNC';
1294
1295   if ($path_info =~ /(.*)\/drpmsync\/closesock$/ && exists $cgi->{'drpmsync'}) {
1296     my $croot = $1;
1297     sendlog(". $croot bye");
1298     close(S);
1299     exit(0);
1300   }
1301
1302   if ($path_info =~ /^(.*)\/drpmsync\/contents$/) {
1303     my $croot = $1;
1304     die("$croot: does not exist\n") unless -e "$root$croot";
1305     die("$croot: not a directory\n") unless -d "$root$croot";
1306     sendlog("# $croot contents request");
1307     my $ti = time();
1308     readcache("$root$croot/drpmsync/cache");
1309     @files = ();
1310     $cachehits = $cachemisses = 0;
1311     @filter_comp = compile_filter(@{$cgi->{'filter'} || []});
1312     @filter_arch_comp = compile_filter(@{$cgi->{'filter_arch'} || []});
1313     findfiles("$root$croot", '', 0, exists($cgi->{'norecurse'}) ? 1 : 0);
1314     filelist_apply_filter_arch(\@files) if @filter_arch_comp;
1315     %cache = ();
1316     $ti = time() - $ti;
1317     my ($stamp1, $stamp2);
1318     $stamp1 = $stamp2 = sprintf("%08x", time());
1319     if (open(STAMP, '<', "$root$croot/drpmsync/timestamp")) {
1320       my $s = '';
1321       if ((sysread(STAMP, $s, 16) || 0) == 16 && $s !~ /[^0-9a-f]/) {
1322         $stamp1 = substr($s, 0, 8);
1323         $stamp2 = substr($s, 8, 8);
1324       }
1325       close STAMP;
1326     }
1327     my $data = '';
1328     if (!exists $cgi->{'drpmsync'}) {
1329       for (@files) {
1330         my @l = @$_;
1331         $l[0] = aescape($l[0]);
1332         $l[5] = aescape($l[5]) if @l > 5;
1333         splice(@l, 1, 1);
1334         $data .= join(' ', @l)."\n";
1335       }
1336       sendlog("h $croot contents ($cachehits/$cachemisses/$ti)");
1337       reply($data, "Content-type: text/plain");
1338       exit(0);
1339     }
1340     $data = pack('H*', "$stamp1$stamp2");
1341     $data = pack("Nw/a*w/a*", scalar(@files), $tree->{'id'}, $data);
1342     for (@files) {
1343       my @l = @$_;
1344       my $b;
1345       if (@l > 5) {
1346         $b = pack('H*', "$l[2]$l[3]$l[4]").$l[5];
1347       } elsif (@l > 3) {
1348         $b = pack('H*', "$l[2]$l[3]");
1349       } else {
1350         $b = pack('H*', $l[2]);
1351       }
1352       $data .= pack("w/a*w/a*", $l[0], $b);
1353     }
1354     @files = ();
1355     my $dataid = 'SYNC';
1356     if ($have_zlib && exists($cgi->{'zlib'})) {
1357       $data = Compress::Zlib::compress($data);
1358       $dataid = 'SYNZ';
1359       sendlog("z $croot contents ($cachehits/$cachemisses/$ti)");
1360     } else {
1361       sendlog("f $croot contents ($cachehits/$cachemisses/$ti)");
1362     }
1363     $data = sprintf("1%03x%08x", 0644, time()).$data;
1364     $data = "${replyid}0001${dataid}00000000".sprintf("%08x", length($data)).$data.Digest::MD5::md5_hex($data);
1365     reply($data, "Content-type: application/octet-stream");
1366     return;
1367   }
1368
1369   my @s = lstat("$root$path_info");
1370
1371   if (!exists($cgi->{'drpmsync'})) {
1372     die("$spath_info: $!\n") unless @s;
1373     if (! -d _) {
1374       die("$spath_info: bad file type\n") unless -f _;
1375       sendlog("h $path_info");
1376       open(F, '<', "$root$path_info") || die("$spath_info: $!\n");
1377       my $c = '';
1378       while ((sysread(F, $c, 4096, length($c)) || 0) == 4096) {}
1379       close F;
1380       my $ct = 'text/plain';
1381       if ($spath_info =~ /\.(gz|rpm|spm|bz2|tar|tgz|jpg|jpeg|gif|png|pdf)$/) {
1382         $ct = 'application/octet-stream';
1383       }
1384       reply($c, "Content-type: $ct");
1385       exit(0);
1386     }
1387     if (($path_info !~ s/\/$//)) {
1388       if ($standalone) {
1389         reply("The document has moved", "Status: 302 Found", "Content-type: text/html", "Location: http://$servername$tree->{'id'}$path_info/");
1390       } else {
1391         reply("The document has moved", "Status: 302 Found", "Content-type: text/html", "Location: http://$ENV{'SERVER_NAME'}$tree->{'id'}$path_info/");
1392       }
1393       exit(0);
1394     }
1395     sendlog("h $path_info");
1396     opendir(DIR, "$root$path_info") || die("$root$path_info: $!\n");
1397     my @ents = sort readdir(DIR);
1398     closedir DIR;
1399     @ents = grep {$_ ne '.' && $_ ne '..'} @ents;
1400     unshift @ents, '.', '..';
1401     my $data = "<pre>\n";
1402     for my $ent (@ents) {
1403       @s = lstat("$root$path_info/$ent");
1404       if (!@s) {
1405         $data .= escape("$ent: $!\n");
1406         next;
1407       }
1408       my $ent2 = '';
1409       my $info = '?';
1410       $info = 'c' if -c _;
1411       $info = 'b' if -b _;
1412       $info = '-' if -f _;
1413       $info = 'd' if -d _;
1414       if (-l _) {
1415         $info = 'l';
1416         $ent2 = readlink("$root$path_info/$ent");
1417         die("$root$path_info/$ent: $!") unless defined $ent2;
1418         $ent2 = escape(" -> $ent2");
1419       }
1420       my $mode = $s[2] & 0777;
1421       for (split('', 'rwxrwxrwx')) {
1422         $info .= $mode & 0400 ? $_ : '-';
1423         $mode *= 2;
1424       }
1425       my @lt = localtime($s[9]);
1426       $lt[4] += 1;
1427       $lt[5] += 1900;
1428       $info = sprintf("%s %4d root root %8d %04d-%02d-%02d %02d:%02d:%02d", $info, $s[3], $s[7], @lt[5, 4, 3, 2, 1, 0]);
1429       $info = escape($info);
1430       my $ne = "$path_info/$ent";
1431       $ne = $path_info if $ent eq '.';
1432       if ($ent eq '..') {
1433         $ne = $path_info;
1434         $ne =~ s/[^\/]+$//;
1435         $ne =~ s/\/$//;
1436       }
1437       if ((-d _) && ! (-l _)) {
1438         $ent = "<a href=\"".aescape("$script_name$ne/")."\">".escape("$ent")."</a>$ent2";
1439       } elsif ((-f _) && ! (-l _)) {
1440         $ent = "<a href=\"".aescape("$script_name$ne")."\">".escape("$ent")."</a>$ent2";
1441       } else {
1442         $ent = escape("$ent").$ent2;
1443       }
1444       $data .= "$info $ent\n";
1445     }
1446     $data .= "</pre>\n";
1447     reply($data, "Content-type: text/html");
1448     exit(0);
1449   }
1450
1451   if (!@s) {
1452     sendlog("- $path_info");
1453     my $data = "${replyid}0001GONE".sprintf("%08x", length($spath_info)).'00000000'.$spath_info;
1454     reply($data, "Content-type: application/octet-stream");
1455     return;
1456   }
1457
1458   if (-d _) {
1459     # oops, this is bad, the file is now a directory
1460     # send GONE so it will get removed
1461     sendlog("X $path_info");
1462     my $data = "${replyid}0001GONE".sprintf("%08x", length($spath_info)).'00000000'.$spath_info;
1463     reply($data, "Content-type: application/octet-stream");
1464     return;
1465   }
1466
1467   if (-l _) {
1468     sendlog("f $path_info");
1469     my $lc = readlink("$root$path_info");
1470     die("readlink: $!\n") unless defined($lc);
1471     $lc = sprintf("2%03x%08x", $s[2] & 07777, $s[9]).$lc;
1472     my $data = "${replyid}0001FILE".sprintf("%08x%08x", length($spath_info), length($lc)).$spath_info.$lc.Digest::MD5::md5_hex($lc);
1473     reply($data, "Content-type: application/octet-stream");
1474     return;
1475   }
1476
1477   die("$spath_info: bad file type\n") unless -f _;
1478   open(F, '<', "$root$path_info") || die("$spath_info: $!\n");
1479
1480   my $extracto = 0;
1481   my $extractl;
1482
1483   if ((exists($cgi->{'fiso'}) || exists($cgi->{'extract'})) && ($spath_info =~ /(?<!\.delta)\.iso$/i)) {
1484     if (!$cgi->{'extract'}) {
1485       tmpopen(*F2, $servertmp);
1486       my (undef, $err) = runprg(*F, *F2, $fragiso, 'make', '-', '-');
1487       die("fragiso make failed: $err\n") if $err;
1488       close F;
1489       sysseek(F2, 0, 0);        # currently at EOF
1490       sendlog("i $path_info");
1491       my $flen = -s F2;
1492       my $ctx = Digest::MD5->new;
1493       my $data = sprintf("1%03x%08x", $s[2] & 07777, $s[9]);
1494       $ctx->add($data);
1495       $data = "${replyid}0001FISO".sprintf("%08x", length($spath_info)).hexit(length($data) + $flen).$spath_info.$data;
1496       replystream(*F2, $flen, $data, $ctx, "Content-type: application/octet-stream");
1497       close F2;
1498       return;
1499     } else {
1500       die("bad extract: $cgi->{'extract'}\n") unless $cgi->{'extract'} =~ /^([0-9a-fA-F]{2})([0-9a-fA-F]{8}):([0-9a-fA-F]{8})$/;
1501       # always fits in perl's floats
1502       $extracto = hex($1) * 4294967296 + hex($2);
1503       $extractl = hex($3);
1504       defined(sysseek(F, $extracto, 0)) || die("seek error: $!\n");
1505       $path_info .= "\@$cgi->{'extract'}";
1506     }
1507   } elsif ($spath_info !~ /\.[sr]pm$/) {
1508     my $flen = $s[7];
1509     my $data = sprintf("1%03x%08x", $s[2] & 07777, $s[9]);
1510     if ($s[7] >= 67108864) {
1511       sendlog("f $path_info");
1512       my $ctx = Digest::MD5->new;
1513       $ctx->add($data);
1514       $data = "${replyid}0001FILE".sprintf("%08x", length($spath_info)).hexit(length($data) + $flen).$spath_info.$data;
1515       replystream(*F, $flen, $data, $ctx, "Content-type: application/octet-stream");
1516       return;
1517     }
1518     while ((sysread(F, $data, 4096, length($data)) || 0) == 4096) {}
1519     close F;
1520     my $dataid = 'FILE';
1521     if (length($data) >= 12 + 64 && $have_zlib && exists($cgi->{'zlib'}) && substr($data, 12, 2) ne "\037\213" && substr($data, 12, 2) ne "BZ") {
1522       $data = substr($data, 0, 12).Compress::Zlib::compress(substr($data, 12));
1523       $dataid = 'FILZ';
1524       sendlog("z $path_info");
1525     } else {
1526       sendlog("f $path_info");
1527     }
1528     $data = "${replyid}0001$dataid".sprintf("%08x%08x", length($spath_info), length($data)).$spath_info.$data.Digest::MD5::md5_hex($data);
1529     reply($data, "Content-type: application/octet-stream");
1530     return;
1531   }
1532
1533   my $deltadata = '';
1534   my $deltaintro = '';
1535   my $deltanum = 0;
1536   my $sendrpm = exists($cgi->{'withrpm'}) ? 1 : 0;
1537   my $key = '';
1538   if ($cgi->{'have'}) {
1539     my %have2;
1540     for (split(',', $cgi->{'havealso'} ? "$cgi->{'have'},$cgi->{'havealso'}" : $cgi->{'have'})) {
1541       die("bad have parameter\n") if (length($_) != 32 && length($_) != 64) || /[^0-9a-f]/;
1542       $have2{substr($_, -32, 32)} = 1;
1543     }
1544     my @info = rpminfo_f(*F, $spath_info);
1545     die("$spath_info: bad info\n") unless @info;
1546     # seek needed because of perl's autoflush when forking
1547     seek(F, $extracto, 0);
1548     # only sysread after this!
1549     defined(sysseek(F, $extracto, 0)) || die("sysseek: $!\n");
1550     $path_info .= " ($info[2])" if $extracto;
1551     my $info = $info[0];
1552     my $info1 = substr($info, 0, 32);
1553     my $info2 = substr($info, 32, 32);
1554     if ($have2{$info2}) {
1555       if ($extracto) {
1556         # switch to real rpm
1557         extractrpm(*F, $extracto, $extractl);
1558         $extracto = 0;
1559         $extractl = undef;
1560       }
1561       # identical payload, create sign only delta
1562       # sendlog("$path_info: makedeltarpm sign only");
1563       my ($out, $err) = runprg(*F, undef, $makedeltarpm, '-u', '-r', '-', '-');
1564       die("makedeltarpm failed: $err\n") if $err;
1565       $deltaintro .= sprintf("1%03x%08x$info2$info1$info2%08x", $s[2] & 07777, $s[9], length($out));
1566       $deltadata .= $out;
1567       $deltanum++;
1568       $key = 's';
1569       $sendrpm = 0;     # no need to send full rpm in this case
1570     } elsif (!exists($cgi->{'nocomplexdelta'})) {
1571       # ok, lets see if we can build a chain from info2 back to have2
1572       my $dpn = $info[2];
1573   lost_delta:
1574       $key = '';
1575       $deltadata = '';
1576       $deltaintro = '';
1577       $deltanum = 0;
1578
1579       my $deltadir = "$root$path_info";
1580       if ($path_info ne '') {
1581         $deltadir =~ s/[^\/]+$//;
1582         $deltadir =~ s/\/$//;
1583         while ($deltadir ne $root) {
1584           last if -d "$deltadir/drpmsync/deltas";
1585           $deltadir =~ s/[^\/]+$//;
1586           $deltadir =~ s/\/$//;
1587         }
1588       }
1589       $deltadir = "$deltadir/drpmsync/deltas/$dpn";
1590       my @solution;
1591       if (length($cgi->{'have'}) == 64 && -f "$deltadir/$cgi->{'have'}$info2") {
1592         @solution = ("$deltadir/$cgi->{'have'}$info2");
1593       } else {
1594         my @deltadirs = ( $deltadir );
1595         push @deltadirs, map {"$_/$dpn"} getdeltadirs($tree->{'deltadirs'}, $spath_info) if $tree->{'deltadirs'};
1596         @solution = solve(\%have2, $info2, @deltadirs);
1597       }
1598       my $dsize = 0;
1599       for (@solution) {
1600         goto lost_delta if ! -e $_;
1601         die("bad deltarpm: $_\n") if ! -f _;
1602         if (!exists($cgi->{'uncombined'}) && !$tree->{'no_combine'}) {
1603           $dsize = -s _ if (-s _) > $dsize;
1604         } else {
1605           $dsize += -s _;
1606         }
1607       }
1608       my $maxdeltasize = $cgi->{'maxdeltasize'};
1609       $maxdeltasize = $tree->{'maxdeltasize'} if defined($tree->{'maxdeltasize'}) && (!defined($maxdeltasize) || $maxdeltasize > $tree->{'maxdeltasize'});
1610       if (defined($maxdeltasize)) {
1611         my $flen = -s F;
1612         $flen = $extractl if defined $extractl;
1613         @solution = () if $dsize >= ($flen * $maxdeltasize) / 100;
1614       }
1615       my $maxdeltasizeabs = $cgi->{'maxdeltasizeabs'};
1616       $maxdeltasizeabs = $tree->{'maxdeltasizeabs'} if defined($tree->{'maxdeltasizeabs'}) && (!defined($maxdeltasizeabs) || $maxdeltasizeabs > $tree->{'maxdeltasizeabs'});
1617       @solution = () if defined($maxdeltasizeabs) && $dsize >= $maxdeltasizeabs;
1618       if (@solution) {
1619         # sendlog("$path_info: solution @solution");
1620         my @combine = ();
1621         $key = scalar(@solution) if @solution > 1;
1622         $key .= 'd';
1623         for my $dn (@solution) {
1624           push @combine, $dn;
1625           next if @combine < @solution && !exists($cgi->{'uncombined'}) && !$tree->{'no_combine'};
1626           my @ds = stat($combine[0]);
1627           goto lost_delta if !@ds || ! -f _;
1628           my ($out, $err);
1629           if ($dn eq $solution[-1] && substr($dn, -64, 32) ne $info1) {
1630             # sendlog("$path_info: combinedeltarpm -S @combine");
1631             if ($extracto) {
1632               # switch to real rpm
1633               extractrpm(*F, $extracto, $extractl);
1634               $extracto = 0;
1635               $extractl = undef;
1636             }
1637             ($out, $err) = runprg(*F, undef, $combinedeltarpm, '-S', '-', @combine, '-');
1638             defined(sysseek(F, 0, 0)) || die("sysseek: $!\n");
1639             substr($combine[-1], -64, 32) = $info1 unless $err;
1640             $key .= 's';
1641           } elsif (@combine > 1) {
1642             # sendlog("$path_info: combinedeltarpm @combine");
1643             ($out, $err) = runprg(undef, undef, $combinedeltarpm, @combine, '-');
1644           } else {
1645             # sendlog("$path_info: readfile @combine");
1646             ($out, $err) = readfile($dn);
1647           }
1648           if ($err) {
1649             goto lost_delta if grep {! -f $_} @combine;
1650             $err =~ s/\n$//s;
1651             sendlog("! $path_info $err");
1652             %have2 = ();        # try without deltas
1653             goto lost_delta;
1654           }
1655           $deltaintro .= sprintf("1%03x%08x".substr($combine[0], -96, 32).substr($combine[-1], -64, 64)."%08x", $ds[2] & 07777, $ds[9], length($out));
1656           $deltadata .= $out;
1657           $deltanum++;
1658           @combine = ();
1659         }
1660         $key .= $deltanum if $deltanum != 1;
1661       }
1662     }
1663   }
1664   if (exists($cgi->{'deltaonly'}) && !$deltanum) {
1665     sendlog("O $path_info");
1666     my $data = "${replyid}0001NODR".sprintf("%08x", length($spath_info)).'00000000'.$spath_info;
1667     reply($data, "Content-type: application/octet-stream");
1668     return;
1669   }
1670   $sendrpm = 1 if !$deltanum;
1671   $key .= 'r' if $sendrpm;
1672   $key = '?' if $key eq '';
1673   sendlog("$key $path_info");
1674   if ($sendrpm) {
1675     my $flen = -s F;
1676     $flen = $extractl if defined $extractl;
1677     if ($flen > 100000 || defined($extractl)) {
1678       my $data = sprintf("1%03x%08x", $s[2] & 07777, $s[9]);
1679       $data .= sprintf("%08x%08x", $deltanum, $sendrpm).$deltaintro.$deltadata;
1680       my $ctx = Digest::MD5->new;
1681       $ctx->add($data);
1682       $data = "${replyid}0001RPM ".sprintf("%08x%08x", length($spath_info), length($data) + $flen).$spath_info.$data;
1683       replystream(*F, $flen, $data, $ctx, "Content-type: application/octet-stream");
1684       close F;
1685       return;
1686     }
1687   }
1688   my $rdata = '';
1689   if ($sendrpm) {
1690     while ((sysread(F, $rdata, 4096, length($rdata)) || 0) == 4096) {}
1691   }
1692   my $data = sprintf("1%03x%08x", $s[2] & 07777, $s[9]);
1693   $data .= sprintf("%08x%08x", $deltanum, $sendrpm).$deltaintro.$deltadata.$rdata;
1694   undef $deltadata;
1695   $data = "${replyid}0001RPM ".sprintf("%08x%08x", length($spath_info), length($data)).$spath_info.$data.Digest::MD5::md5_hex($data);
1696   reply($data, "Content-type: application/octet-stream");
1697   close F;
1698   undef $data;
1699 }
1700
1701 if ($::ENV{'REQUEST_METHOD'} || (@ARGV && ($ARGV[0] eq '-s' || $ARGV[0] eq '-S'))) {
1702   # server mode
1703   my %cgi;
1704   my $request_method = $::ENV{'REQUEST_METHOD'};
1705   if ($request_method) {
1706     my $query_string = $::ENV{'QUERY_STRING'};
1707     my $script_name = $::ENV{'SCRIPT_NAME'};
1708     my $path_info = $::ENV{'PATH_INFO'};
1709     my $remote_addr = $::ENV{'REMOTE_ADDR'};
1710     if ($request_method eq 'POST') {
1711       $query_string = '';
1712       read(STDIN, $query_string, 0 + $::ENV{'CONTENT_LENGTH'});
1713     }
1714     eval {
1715       parse_cgi(\%cgi, $query_string);
1716       my $config = $::ENV{'DRPMSYNC_CONFIG'};
1717       readconfig_server($config);
1718       serve_request(\%cgi, $path_info, $script_name, $remote_addr, 0);
1719       exit(0);
1720     };
1721     reply_err($@, \%cgi, $remote_addr);
1722     exit(0);
1723   }
1724   my $remote_addr = startserver($ARGV[1], $ARGV[0] eq '-S' ? 1 : 0);
1725   eval {
1726     while (1) {
1727       %cgi = ();
1728       my ($path, $query_string, $has_via) = getrequest(\%cgi);
1729       $request_method = 'GET';
1730       parse_cgi(\%cgi, $query_string);
1731       my $keep_ok = !$has_via && exists($cgi{'drpmsync'});
1732       my @mtrees = grep {$path eq $_->{'id'} || substr($path, 0, length($_->{'id'}) + 1) eq "$_->{'id'}/" } sort {length($b->{'id'}) <=> length($a->{'id'})} values %trees;
1733       die("not exported\n") unless @mtrees;
1734       my $script_name = $mtrees[0]->{'id'};
1735       my $path_info = substr($path, length($script_name));
1736       serve_request(\%cgi, $path_info, $script_name, $remote_addr, $keep_ok);
1737       exit(0) unless $keep_ok;
1738     }
1739   };
1740   reply_err($@, \%cgi, $remote_addr);
1741   exit(0);
1742 }
1743
1744
1745 #######################################################################
1746 # Client code
1747 #######################################################################
1748
1749 my @config_source;
1750 my $config_generate_deltas;
1751 my $config_keep_deltas;
1752 my $config_keep_uncombined;
1753 my $config_always_get_rpm;
1754 my @config_generate_delta_compression;
1755 my $config_recvlog;
1756 my $config_delta_max_age;
1757 my $config_repo;
1758 my $config_timeout;
1759 my @config_filter;
1760 my @config_filter_arch;
1761
1762 my $syncport;
1763 my $syncaddr;
1764 my $syncproto;
1765 my $syncuser;
1766 my $syncpassword;
1767 my $syncurl;
1768 my $syncroot;
1769 my $esyncroot;
1770 my $synctree = '';
1771 my $synchost = Net::Domain::hostfqdn();
1772
1773 my $newstamp1;
1774 my $newstamp2;
1775
1776 my $runningjob;
1777
1778 sub readconfig_client {
1779   my $cf = shift;
1780   local *CF;
1781   open(CF, '<', $cf) || die("$cf: $!\n");
1782   while (<CF>) {
1783     chomp;
1784     s/^\s+//;
1785     s/\s+$//;
1786     next if $_ eq '' || /^#/;
1787     my @s = split(' ', $_);
1788     $s[0] = lc($s[0]);
1789     if ($s[0] eq 'source:') {
1790       shift @s;
1791       @config_source = @s;
1792     } elsif ($s[0] eq 'generate_deltas:') {
1793       $config_generate_deltas = ($s[1] && $s[1] =~ /true/i);
1794     } elsif ($s[0] eq 'generate_delta_compression:') {
1795       @config_generate_delta_compression = ();
1796       @config_generate_delta_compression = ('-z', $s[1]) if $s[1];
1797     } elsif ($s[0] eq 'keep_deltas:') {
1798       $config_keep_deltas = ($s[1] && $s[1] =~ /true/i);
1799     } elsif ($s[0] eq 'keep_uncombined:') {
1800       $config_keep_uncombined = ($s[1] && $s[1] =~ /true/i);
1801     } elsif ($s[0] eq 'always_get_rpm:') {
1802       $config_always_get_rpm = ($s[1] && $s[1] =~ /true/i);
1803     } elsif ($s[0] eq 'delta_max_age:') {
1804       $config_delta_max_age = @s > 1 ? $s[1] : undef;
1805     } elsif ($s[0] eq 'timeout:') {
1806       $config_timeout = @s > 1 ? $s[1] : undef;
1807     } elsif ($s[0] eq 'deltarpmpath:') {
1808       my $p = defined($s[1]) ? "$s[1]/" : '';
1809       $makedeltarpm = "${p}makedeltarpm";
1810       $combinedeltarpm = "${p}combinedeltarpm";
1811       $applydeltarpm = "${p}applydeltarpm";
1812       $fragiso = "${p}fragiso";
1813     } elsif ($s[0] eq 'log:') {
1814       $config_recvlog = @s > 1 ? $s[1] : undef;
1815     } elsif ($s[0] eq 'repo:') {
1816       $config_repo = @s > 1 ? $s[1] : undef;
1817     } elsif ($s[0] eq 'exclude:') {
1818       push @config_filter, map {"-$_"} @s;
1819     } elsif ($s[0] eq 'include:') {
1820       push @config_filter, map {"+$_"} @s;
1821     } elsif ($s[0] eq 'exclude_arch:') {
1822       push @config_filter_arch, map {"-$_"} @s;
1823     } elsif ($s[0] eq 'include_arch:') {
1824       push @config_filter_arch, map {"+$_"} @s;
1825     } else {
1826       $s[0] =~ s/:$//;
1827       die("$cf: unknown configuration parameter: $s[0]\n");
1828     }
1829   }
1830   $config_keep_deltas ||= $config_generate_deltas;
1831   $config_keep_deltas ||= $config_keep_uncombined;
1832   close CF;
1833 }
1834
1835 #######################################################################
1836
1837 sub mkdir_p {
1838   my $dir = shift;
1839   return if -d $dir;
1840   mkdir_p($1) if $dir =~ /^(.*)\//;
1841   mkdir($dir, 0777) || die("mkdir: $dir: $!\n");
1842 }
1843
1844 #######################################################################
1845
1846 sub toiso {
1847   my @lt = localtime($_[0]);
1848   $lt[5] += 1900;
1849   $lt[4] += 1;
1850   return sprintf "%04d-%02d-%02d %02d:%02d:%02d", @lt[5,4,3,2,1,0];
1851 }
1852
1853 #######################################################################
1854
1855 sub recvlog {
1856   my $str = shift;
1857
1858   return unless $config_recvlog;
1859   my @lt = localtime(time());
1860   $lt[5] += 1900;
1861   $lt[4] += 1;
1862   printf RECVLOG "%04d-%02d-%02d %02d:%02d:%02d %s\n", @lt[5,4,3,2,1,0], $str;
1863 }
1864
1865 sub recvlog_print {
1866   my $str = shift;
1867   print "$str\n";
1868   recvlog($str);
1869 }
1870
1871 #######################################################################
1872
1873 sub makedelta {
1874   my ($from, $to, $drpm) = @_;
1875   # print "makedeltarpm $from $to\n";
1876   if (substr($drpm, -96, 32) eq substr($drpm, -32, 32)) {
1877     system($makedeltarpm, @config_generate_delta_compression, '-u', '-r', $to, $drpm) && die("makedeltarpm failed\n");
1878   } else {
1879     system($makedeltarpm, @config_generate_delta_compression, '-r', $from, $to, $drpm) && die("makedeltarpm failed\n");
1880   }
1881   die("makedeltarpm did not create delta\n") unless -s $drpm;
1882   return $drpm;
1883 }
1884
1885 sub applydeltas {
1886   my ($job, $from, $to, $extractoff, @deltas) = @_;
1887   my $dn = $deltas[0];
1888   if (@deltas > 1) {
1889     my $ddir = $deltas[0];
1890     $ddir =~ s/\/[^\/]+$//;
1891     my $d1 = $deltas[0];
1892     my $d2 = $deltas[-1];
1893     my @d1s = stat($d1);
1894     die("$d1: $!\n") if !@d1s;
1895     $d1 =~ s/.*\///;
1896     $d2 =~ s/.*\///;
1897     $dn = "$ddir/".substr($d1, 0, 32).substr($d2, 32, 64);
1898     die("combined delta already exists?\n") if -f $dn;
1899     # print "combinedeltarpm @deltas\n";
1900     if (system($combinedeltarpm, @deltas, $dn) || ! -s $dn) {
1901       recvlog_print("! combinedeltarpm @deltas $dn failed");
1902       unlink @deltas;
1903       return ();
1904     }
1905     utime($d1s[9], $d1s[9], $dn);
1906   }
1907   # print "applydeltarpm $from $dn\n";
1908   my $err;
1909   if ($extractoff) {
1910     local *EXTR;
1911     if (!open(EXTR, '+<', $to)) {
1912       recvlog_print("! open $to failed: $!");
1913       unlink(@deltas);
1914       return ();
1915     }
1916     if (!defined(sysseek(EXTR, $extractoff, 0))) {
1917       recvlog_print("! sysseek $to failed: $!");
1918       unlink(@deltas);
1919       return ();
1920     }
1921     (undef, $err) = runprg_job($job, undef, *EXTR, $applydeltarpm, '-r', $from, $dn, '-');
1922     close(EXTR);
1923   } else {
1924     (undef, $err) = runprg_job($job, undef, undef, $applydeltarpm, '-r', $from, $dn, $to);
1925   }
1926   if ($err) {
1927     recvlog_print("! applydeltarpm -r $from $dn $to failed: $err");
1928     unlink(@deltas);
1929     return ();
1930   }
1931   if ($job) {
1932     $job->{'applydeltas'} = [$from, $dn, $to, @deltas];
1933     return ($job);
1934   }
1935   if ($config_keep_uncombined || @deltas <= 1) {
1936     if (@deltas > 1) {
1937       unlink($dn) || die("unlink $dn: $!\n");
1938     }
1939     return @deltas;
1940   }
1941   for my $d (@deltas) {
1942     unlink($d) || die("unlink $d: $!\n");
1943   }
1944   return ($dn);
1945 }
1946
1947 sub applydeltas_finish {
1948   my ($job) = @_;
1949   die("job not running\n") unless $job && $job->{'applydeltas'};
1950   my ($from, $dn, $to, @deltas) = @{$job->{'applydeltas'}};
1951   delete $job->{'applydeltas'};
1952   my $err;
1953   (undef, $err) = runprg_finish($job);
1954   if ($err) {
1955     recvlog_print("! applydeltarpm -r $from $dn $to failed: $err");
1956     unlink(@deltas);
1957     return ();
1958   }
1959   if ($config_keep_uncombined || @deltas <= 1) {
1960     if (@deltas > 1) {
1961       unlink($dn) || die("unlink $dn: $!\n");
1962     }
1963     return @deltas;
1964   }
1965   for my $d (@deltas) {
1966     unlink($d) || die("unlink $d: $!\n");
1967   }
1968   return ($dn);
1969 }
1970
1971 sub checkjob {
1972   my ($pn) = @_;
1973   return unless $runningjob;
1974   my $job = $runningjob;
1975   if (defined($pn)) {
1976     return if $job->{'wip'} ne $pn;
1977   }
1978   undef $runningjob;
1979   my @args = @{$job->{'finishargs'}};
1980   delete $job->{'finishargs'};
1981   $job->{'finish'}->(@args);
1982 }
1983
1984
1985 #######################################################################
1986 # repo functions
1987 #######################################################################
1988
1989 sub repo_search {
1990   my ($dpn, $k) = @_;
1991   local *F;
1992   open(F, '<', "$config_repo/$dpn") || return ();
1993   my $k2 = substr($k, 32, 32);
1994   my ($l, @l);
1995   my (@r1, @r2, @r3);
1996   while (defined($l = <F>)) {
1997     chomp $l;
1998     my @l = split(' ', $l, 3);
1999     if ($l[0] eq $k) {
2000       push @r1, \@l;
2001     } elsif (substr($l[0], 32, 32) eq $k2) {
2002       push @r2, \@l;
2003     } else {
2004       push @r3, \@l;
2005     }
2006   }
2007   close F;
2008   return (@r1, @r2, @r3);
2009 }
2010
2011 sub repo_check {
2012   my (@r) = @_;
2013
2014   my @s;
2015   for my $r (splice(@r)) {
2016     if ($r->[2] =~ /^(.*)@([0-9a-f]{10}:[0-9a-f]{8}$)/) {
2017       @s = stat($1);
2018     } else {
2019       @s = stat($r->[2]);
2020     }
2021     push @r, $r if @s && $r->[1] eq "$s[9]/$s[7]";
2022   }
2023   return @r;
2024 }
2025
2026 sub repo_cp {
2027   my ($r, $bdir, $to, $extractoff) = @_;
2028
2029   my $d = "$bdir/$to";
2030
2031   local(*F, *OF);
2032   my @s;
2033   my $len;
2034   if ($r->[2] =~ /^(.*)@([0-9a-f]{2})([0-9a-f]{8}):([0-9a-f]{8}$)/) {
2035     my $iso = $1;
2036     open(F, '<', $iso) || return undef;
2037     @s = stat(F);
2038     if (!@s || $r->[1] ne "$s[9]/$s[7]") {
2039       close F;
2040       return undef;
2041     }
2042     $len = hex($4);
2043     if (!$len || !defined(sysseek(F, hex($2) * 4294967296 + hex($3), 0))) {
2044       close F;
2045       return undef;
2046     }
2047   } else {
2048     open(F, '<', $r->[2]) || return undef;
2049     @s = stat(F);
2050     if (!@s || $r->[1] ne "$s[9]/$s[7]") {
2051       close F;
2052       return undef;
2053     }
2054   }
2055   if ($extractoff) {
2056     if (!open(OF, '+<', $d)) {
2057       close F;
2058       return undef;
2059     }
2060     if (!defined(sysseek(OF, $extractoff, 0))) {
2061       close F;
2062       close OF;
2063       return undef;
2064     }
2065   } else {
2066     if (!open(OF, '>', $d)) {
2067       close F;
2068       return undef;
2069     }
2070   }
2071   my @info = cprpm(*F, *OF, 1, $len);
2072   if (!close(OF)) {
2073     close(F);
2074     unlink($d);
2075     return undef;
2076   }
2077   close(F);
2078   if (@info != 3 || $info[0] ne $r->[0]) {
2079     unlink($d);
2080     return undef;
2081   }
2082   @s = stat($d);
2083   if (!@s) {
2084     unlink($d);
2085     return undef;
2086   }
2087   return [ $to, "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), @info ];
2088 }
2089
2090 sub repo_add_iso {
2091   my ($fn, $d) = @_;
2092   local *F;
2093   return unless open(F, '-|', $fragiso, 'listiso', $fn);
2094   my @frags = <F>;
2095   return unless close(F);
2096   chomp @frags;
2097   for my $f (@frags) {
2098     my @f = split(' ', $f, 3);
2099     repo_add("$fn\@$f[0]", [ "$fn\@$f[0]", $d->[1], $d->[2], $f[1], undef, $f[2] ] );
2100   }
2101 }
2102
2103 sub repo_add {
2104   my ($fn, $d) = @_;
2105
2106   return if $fn =~ m!drpmsync/wip.*/!;
2107   if (@$d < 6) {
2108     repo_add_iso($fn, $d) if $fn =~ /(?<!\.delta)\.iso$/i;
2109     return;
2110   }
2111   return if $fn =~ /[\000-\037]/;
2112   return if $d->[5] =~ /[\000-\037\/]/ || length($d->[5]) < 3;
2113   local *OLD;
2114   local *NEW;
2115   my $nlid = $d->[1];
2116   $nlid =~ s/\/[^\/]*$//;
2117   my $nl;
2118   $nl = "$d->[3] $nlid $fn" if $nlid;
2119   my $kill;
2120   $kill = $1 if $fn =~ /^(.*)@[0-9a-f]{2}[0-9a-f]{8}:[0-9a-f]{8}$/;
2121   $kill = $fn if !$nlid && $fn =~ /(?<!\.delta)\.iso$/i;
2122 lock_retry:
2123   if (!sysopen(OLD, "$config_repo/$d->[5]", POSIX::O_RDWR|POSIX::O_CREAT, 0666)) {
2124     if (!sysopen(OLD, "$config_repo/$d->[5]", POSIX::O_RDONLY)) {
2125       warn("$config_repo/$d->[5]: $!\n");
2126       return;
2127     }
2128   }
2129   if (!flock(OLD, LOCK_EX)) {
2130     warn("$config_repo/$d->[5]: flock: $!\n");
2131     return;
2132   }
2133   if (!(stat(OLD))[3]) {
2134     close(OLD);
2135     goto lock_retry;
2136   }
2137   my $old = '';
2138   my $new = '';
2139   while ((sysread(OLD, $old, 8192, length($old)) || 0) == 8192) {};
2140   for my $l (split("\n", $old)) {
2141     if ($nl && $l eq $nl) {
2142       undef $nl;
2143     } else {
2144       if ($kill) {
2145         my @lf = split(' ', $l);
2146         next if $lf[2] =~ /^(.*)@[0-9a-f]{2}[0-9a-f]{8}:[0-9a-f]{8}$/ && $kill eq $1 && $lf[1] ne $nlid;
2147       } else {
2148         next if (split(' ', $l))[2] eq $fn;
2149       }
2150     }
2151     $new .= "$l\n";
2152   }
2153   if ($nl) {
2154     $new .= "$nl\n";
2155   } elsif ($old eq $new) {
2156     close OLD;
2157     return;
2158   }
2159   if (!sysopen(NEW, "$config_repo/$d->[5].new", POSIX::O_WRONLY|POSIX::O_CREAT|POSIX::O_TRUNC, 0666)) {
2160     warn("$config_repo/$d->[5].new open: $!\n");
2161     close(OLD);
2162     return;
2163   }
2164   if ((syswrite(NEW, $new) || 0) != length($new) || !close(NEW)) {
2165     warn("$config_repo/$d->[5].new write: $!\n");
2166     close(NEW);
2167     close(OLD);
2168     unlink("$config_repo/$d->[5].new");
2169     return;
2170   }
2171   if (!rename("$config_repo/$d->[5].new", "$config_repo/$d->[5]")) {
2172     warn("$config_repo/$d->[5] rename: $!\n");
2173     close(OLD);
2174     unlink("$config_repo/$d->[5].new");
2175     return;
2176   }
2177   close(OLD);
2178 }
2179
2180 sub repo_del {
2181   my ($fn, $d) = @_;
2182   my $dir;
2183   if (@$d > 5) {
2184     $dir = $d->[5];
2185   } else {
2186     return if $fn !~ /(?<!\.delta)\.iso$/i;
2187   }
2188   if (!$dir) {
2189     local *DIR;
2190     opendir(DIR, $config_repo) || return;
2191     my @ds = grep {$_ ne '.' && $_ ne '..' && !/\..*\.new$/} readdir(DIR);
2192     closedir(DIR);
2193     for my $ds (@ds) {
2194       repo_add($fn, [undef, '', undef, undef, undef, $ds]);
2195     }
2196   } else {
2197     repo_add($fn, [undef, '', undef, undef, undef, $dir]);
2198   }
2199 }
2200
2201 sub repo_validate {
2202   my $d = shift;
2203   if (!$d) {
2204     local *DIR;
2205     opendir(DIR, $config_repo) || return;
2206     my @ds = grep {$_ ne '.' && $_ ne '..' && !/\..*\.new$/} readdir(DIR);
2207     closedir(DIR);
2208     for my $ds (@ds) {
2209       repo_validate($ds);
2210     }
2211     return;
2212   }
2213   local *OLD;
2214   local *NEW;
2215 lock_retry:
2216   if (!sysopen(OLD, "$config_repo/$d", POSIX::O_RDWR|POSIX::O_CREAT, 0666)) {
2217     if (!sysopen(OLD, "$config_repo/$d", POSIX::O_RDONLY)) {
2218       warn("$config_repo/$d: $!\n");
2219       return;
2220     }
2221   }
2222   if (!flock(OLD, LOCK_EX)) {
2223     warn("$config_repo/$d: flock: $!\n");
2224     return;
2225   }
2226   if (!(stat(OLD))[3]) {
2227     close(OLD);
2228     goto lock_retry;
2229   }
2230   my $old = '';
2231   my $new = '';
2232   while ((sysread(OLD, $old, 8192, length($old)) || 0) == 8192) {};
2233   for my $l (split("\n", $old)) {
2234     my @lf = split(' ', $l);
2235     my @s;
2236     if ($lf[2] =~ /^(.*)@[0-9a-f]{2}[0-9a-f]{8}:[0-9a-f]{8}$/) {
2237       @s = stat($1);
2238     } else {
2239       @s = stat($lf[2]);
2240     }
2241     next if !@s || "$s[9]/$s[7]" ne $lf[1];
2242     $new .= "$l\n";
2243   }
2244   if ($new eq $old) {
2245     close OLD;
2246     return;
2247   }
2248   if (!sysopen(NEW, "$config_repo/$d.new", POSIX::O_WRONLY|POSIX::O_CREAT|POSIX::O_TRUNC, 0666)) {
2249     warn("$config_repo/$d.new open: $!\n");
2250     close(OLD);
2251     return;
2252   }
2253   if ((syswrite(NEW, $new) || 0) != length($new) || !close(NEW)) {
2254     warn("$config_repo/$d.new write: $!\n");
2255     close(NEW);
2256     close(OLD);
2257     unlink("$config_repo/$d.new");
2258     return;
2259   }
2260   if (!rename("$config_repo/$d.new", "$config_repo/$d")) {
2261     warn("$config_repo/$d rename: $!\n");
2262     close(OLD);
2263     unlink("$config_repo/$d.new");
2264     return;
2265   }
2266   close(OLD);
2267 }
2268
2269 #######################################################################
2270
2271 my %files;
2272 my %syncfiles;
2273 my $had_gone;
2274
2275 sub dirchanged {
2276   my $dir = shift;
2277   $dir =~ s/[^\/]+$//;
2278   $dir =~ s/\/+$//;
2279   return unless $dir ne '';
2280   my $d = $files{$dir};
2281   return unless $d && $d->[2] =~ /^0/;
2282   $d->[2] = substr($d->[2], 0, 4)."ffffffff";
2283 }
2284
2285
2286 ##################################################################
2287
2288 my $net_start_tv;
2289 my $net_start_rvbytes;
2290 my $net_recv_bytes = 0;
2291 my $net_spent_time = 0;
2292
2293 my $txbytes = 0;
2294 my $rvbytes = 0;
2295 my $sabytes = 0;
2296
2297 sub setup_proto {
2298   my $proto = shift;
2299   if ($proto eq 'file') {
2300     *get_syncfiles = \&file_get_syncfiles;
2301     *get_update = \&file_get_update;
2302     *send_fin = \&file_send_fin;
2303   } elsif ($proto eq 'drpmsync') {
2304     *get_syncfiles = \&drpmsync_get_syncfiles;
2305     *get_update = \&drpmsync_get_update;
2306     *send_fin = \&drpmsync_send_fin;
2307   } elsif ($proto eq 'rsync') {
2308     *get_syncfiles = \&rsync_get_syncfiles;
2309     *get_update = \&rsync_get_update;
2310     *send_fin = \&rsync_send_fin;
2311   } elsif ($proto eq 'null') {
2312     *get_syncfiles = sub {return ()};
2313     *get_update = sub {die;};
2314     *send_fin = sub {};
2315   } else {
2316     die("unsupported protocol: $proto\n");
2317   }
2318 }
2319
2320 #######################################################################
2321 # file protocol
2322 #######################################################################
2323
2324 sub file_get_syncfiles {
2325   my $norecurse = shift;
2326
2327   my @oldfiles = @files;
2328   my @oldcache = %cache;
2329   my $oldcachehits = $cachehits;
2330   my $oldcachemisses = $cachemisses;
2331   @files = ();
2332   $cachehits = $cachemisses = 0;
2333   readcache("$syncroot/drpmsync/cache");
2334   findfiles($syncroot, '', 0, $norecurse);
2335   my @syncfiles = @files;
2336   @files = @oldfiles;
2337   %cache = @oldcache;
2338   $cachehits = $oldcachehits;
2339   $cachemisses = $oldcachemisses;
2340   $newstamp1 = $newstamp2 = sprintf("%08x", time);
2341   return @syncfiles;
2342 }
2343
2344 sub file_get_update {
2345   my ($dto, $tmpnam, $reqext, $rextract) = @_;
2346
2347   die("rextract in FILE transport\n") if $rextract;
2348   my @s = lstat("$syncroot/$dto->[0]");
2349   return 'GONE' unless @s;
2350   my $type;
2351   my @info;
2352   if (-l _) {
2353     $type = '2';
2354     my $lc = readlink("$syncroot/$dto->[0]");
2355     return 'GONE' unless defined $lc;
2356     symlink($lc, $tmpnam) || die("symlink: $!\n");
2357     @info = linkinfo($tmpnam);
2358   } elsif (! -f _) {
2359     return 'GONE';
2360   } else {
2361     $type = '1';
2362     local *F;
2363     local *NF;
2364     open(F, '<', "$syncroot/$dto->[0]") || return 'GONE';
2365     @s = stat(F);
2366     die("stat: $!\n") unless @s;
2367     open(NF, '>', $tmpnam) || die("$tmpnam: $!\n");
2368     if ($dto->[0] !~ /\.[sr]pm$/) {
2369       @info = cpfile(*F, *NF);
2370     } else {
2371       @info = cprpm(*F, *NF);
2372       if (@info != 3) {
2373         defined(sysseek(F, 0, 0)) || die("sysseek: $!\n");
2374         close(NF);
2375         open(NF, '>', $tmpnam) || die("$tmpnam: $!\n");
2376         @info = cpfile(*F, *NF);
2377       }
2378     }
2379     close(F);
2380     close(NF) || die("$tmpnam: $!\n");
2381     fixmodetime($tmpnam, sprintf("1%03x%08x", ($s[2] & 07777), $s[9]));
2382   }
2383   @s = lstat($tmpnam);
2384   die("$tmpnam: $!\n") unless @s;
2385   if (@info == 3) {
2386     return 'RPM ', [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), @info ];
2387   } else {
2388     return 'FILE', [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("$type%03x%08x", ($s[2] & 07777), $s[9]), @info ];
2389   }
2390 }
2391
2392 sub file_send_fin {
2393 }
2394
2395
2396 #######################################################################
2397 # rsync protocol
2398 #######################################################################
2399
2400 sub sread {
2401   local *SS = shift;
2402   my $len = shift;
2403   $rvbytes += $len;
2404   my $ret = '';
2405   while ($len > 0) {
2406     my $r = sysread(SS, $ret, $len, length($ret));
2407     die("read error") unless $r;
2408     $len -= $r;
2409     die("read too much") if $r < 0;
2410   }
2411   return $ret;
2412 }
2413
2414 sub swrite {
2415   local *SS = shift;
2416   my ($var, $len) = @_;
2417   $len = length($var) unless defined $len;
2418   $txbytes += $len;
2419   (syswrite(SS, $var, $len) || 0) == $len || die("syswrite: $!\n");
2420 }
2421
2422 my $rsync_muxbuf = '';
2423
2424 sub muxread {
2425   local *SS = shift;
2426   my $len = shift;
2427
2428   #print "muxread $len\n";
2429   while(length($rsync_muxbuf) < $len) {
2430     #print "muxbuf len now ".length($muxbuf)."\n";
2431     my $tag = '';
2432     $tag = sread(*SS, 4);
2433     $tag = unpack('V', $tag);
2434     my $tlen = 0+$tag & 0xffffff;
2435     $tag >>= 24;
2436     if ($tag == 7) {
2437       $rsync_muxbuf .= sread(*SS, $tlen);
2438       next;
2439     }
2440     if ($tag == 8 || $tag == 9) {
2441       my $msg = sread(*SS, $tlen);
2442       die("$msg\n") if $tag == 8;
2443       print "info: $msg\n";
2444       next;
2445     }
2446     die("unknown tag: $tag\n");
2447   }
2448   my $ret = substr($rsync_muxbuf, 0, $len);
2449   $rsync_muxbuf = substr($rsync_muxbuf, $len);
2450   return $ret;
2451 }
2452
2453 my $have_md4;
2454 my $rsync_checksum_seed;
2455 my $rsync_protocol;
2456
2457 sub rsync_get_syncfiles {
2458   my $norecurse = shift;
2459
2460   my $user = $syncuser;
2461   my $password = $syncpassword;
2462   if (!defined($have_md4)) {
2463     $have_md4 = 0;
2464     eval {
2465       require Digest::MD4;
2466       $have_md4 = 1;
2467     };
2468   }
2469   $syncroot =~ s/^\/+//;
2470   my $module = $syncroot;
2471   $module =~ s/\/.*//;
2472   my $tcpproto = getprotobyname('tcp');
2473   socket(S, PF_INET, SOCK_STREAM, $tcpproto) || die("socket: $!\n");
2474   connect(S, sockaddr_in($syncport, $syncaddr)) || die("connect: $!\n");
2475   my $hello = "\@RSYNCD: 28\n";
2476   swrite(*S, $hello);
2477   my $buf = '';
2478   sysread(S, $buf, 4096);
2479   die("protocol error [$buf]\n") if $buf !~ /^\@RSYNCD: (\d+)\n/s;
2480   $rsync_protocol = $1;
2481   $rsync_protocol = 28 if $rsync_protocol > 28;
2482   swrite(*S, "$module\n");
2483   while(1) {
2484     sysread(S, $buf, 4096);
2485     die("protocol error [$buf]\n") if $buf !~ s/\n//s;
2486     last if $buf eq "\@RSYNCD: OK";
2487     die("$buf\n") if $buf =~ /^\@ERROR/s;
2488     if ($buf =~ /^\@RSYNCD: AUTHREQD /) {
2489       die("'$module' needs authentification, but Digest::MD4 is not installed\n") unless $have_md4;
2490       $user = "nobody" if !defined($user) || $user eq '';
2491       $password = '' unless defined $password;
2492       my $digest = "$user ".Digest::MD4::md4_base64("\0\0\0\0$password".substr($buf, 18))."\n";
2493       swrite(*S, $digest);
2494       next;
2495     }
2496   }
2497   my @args = ('--server', '--sender', '-rl');
2498   push @args, '--exclude=/*/*' if $norecurse;
2499   for my $arg (@args, '.', "$syncroot/.", '') {
2500     swrite(*S, "$arg\n");
2501   }
2502   $rsync_checksum_seed = unpack('V', sread(*S, 4));
2503   swrite(*S, "\0\0\0\0");
2504   my @filelist;
2505   my $name = '';
2506   my $mtime = 0;
2507   my $mode = 0;
2508   my $uid = 0;
2509   my $gid = 0;
2510   my $flags;
2511   while(1) {
2512     $flags = muxread(*S, 1);
2513     $flags = ord($flags);
2514     # printf "flags = %02x\n", $flags;
2515     last if $flags == 0;
2516     $flags |= ord(muxread(*S, 1)) << 8 if $rsync_protocol >= 28 && ($flags & 0x04) != 0;
2517     my $l1 = $flags & 0x20 ? ord(muxread(*S, 1)) : 0;
2518     my $l2 = $flags & 0x40 ? unpack('V', muxread(*S, 4)) : ord(muxread(*S, 1));
2519     $name = substr($name, 0, $l1).muxread(*S, $l2);
2520     my $len = unpack('V', muxread(*S, 4));
2521     if ($len == 0xffffffff) {
2522       $len = unpack('V', muxread(*S, 4));
2523       my $len2 = unpack('V', muxread(*S, 4));
2524       $len += $len2 * 4294967296;
2525     }
2526     $mtime = unpack('V', muxread(*S, 4)) unless $flags & 0x80;
2527     $mode = unpack('V', muxread(*S, 4)) unless $flags & 0x02;
2528     my $id = "$mtime/$len/";
2529     my @info = ();
2530     my $mmode = $mode & 07777;
2531     if (($mode & 0170000) == 0100000) {
2532       @info = ('x');
2533       $mmode |= 0x1000;
2534     } elsif (($mode & 0170000) == 0040000) {
2535       $mmode |= 0x0000;
2536     } elsif (($mode & 0170000) == 0120000) {
2537       $mmode |= 0x2000;
2538       my $ln = muxread(*S, unpack('V', muxread(*S, 4)));
2539       @info = (Digest::MD5::md5_hex($ln));
2540       $id .= "$ln/";
2541     } else {
2542       print "$name: unknown mode: $mode\n";
2543       next;
2544     }
2545     push @filelist, [$name, $id, sprintf("%04x%08x", $mmode, $mtime), @info];
2546   }
2547   my $io_error = unpack('V', muxread(*S, 4));
2548   @filelist = sort {$a->[0] cmp $b->[0]} @filelist;
2549   my $fidx = 0;
2550   $_->[1] .= $fidx++ for @filelist;
2551   $newstamp1 = $newstamp2 = sprintf("%08x", time);
2552   return grep {$_->[0] ne '.'} @filelist;
2553 }
2554
2555 sub rsync_adapt_filelist {
2556   my $fl = shift;
2557   my %c;
2558   for (@files) {
2559     my $i = $_->[1];
2560     $i =~ s/[^\/]+$//;
2561     $c{$i} = $_;
2562   }
2563   for (@$fl) {
2564     next if @$_ == 3 || $_->[3] ne 'x';
2565     my $i = $_->[1];
2566     $i =~ s/[^\/]+$//;
2567     next unless $c{$i};
2568     my @info = @{$c{$i}};
2569     splice(@info, 0, 3);
2570     splice(@$_, 3, 1, @info);
2571   }
2572 }
2573
2574 sub rsync_get_update {
2575   my ($dto, $tmpnam, $reqext, $rextract) = @_;
2576
2577   die("rextract in RSYNC transport\n") if $rextract;
2578   my $fidx = $dto->[1];
2579   if ($dto->[2] =~ /^2/) {
2580     $fidx =~ s/^[^\/]*\/[^\/]*\///s;
2581     $fidx =~ s/\/[^\/]*$//s;
2582     symlink($fidx, $tmpnam) || die("symlink: $!\n");
2583     my @s = lstat($tmpnam);
2584     die("$tmpnam: $!\n") unless @s;
2585     return 'FILE', [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("2%03x%08x", ($s[2] & 07777), $s[9]), linkinfo($tmpnam) ];
2586   }
2587   $fidx =~ s/.*\///;
2588   swrite(*S, pack('V', $fidx));
2589   swrite(*S, ("\0\0\0\0" x ($rsync_protocol >= 27 ? 4 : 3)));
2590   my $rfidx = unpack('V', muxread(*S, 4));
2591   die("rsync file mismatch $rfidx - $fidx\n") if $rfidx != $fidx;
2592   my $sumhead = muxread(*S, 4 * ($rsync_protocol >= 27 ? 4 : 3));
2593   my $md4ctx;
2594   $md4ctx = Digest::MD4->new if $have_md4;
2595   $md4ctx->add(pack('V', $rsync_checksum_seed)) if $have_md4;
2596   local *OF;
2597   open(OF, '>', $tmpnam) || die("$tmpnam: $!\n");
2598   while(1) {
2599     my $l = unpack('V', muxread(*S, 4));
2600     last if $l == 0;
2601     die("received negative token\n") if $l < 0;
2602     my $chunk = muxread(*S, $l);
2603     $md4ctx->add($chunk) if $have_md4;
2604     syswrite(OF, $chunk) == $l || die("syswrite: $!\n");
2605   }
2606   close(OF) || die("close: $!\n");
2607   my $md4sum = muxread(*S, 16);
2608   if ($have_md4) {
2609     die("data corruption on net\n") if unpack("H32", $md4sum) ne $md4ctx->hexdigest();
2610   }
2611   fixmodetime($tmpnam, $dto->[2]);
2612   my @s = lstat($tmpnam);
2613   die("$tmpnam: $!\n") unless @s;
2614   if ($dto->[0] =~ /\.[sr]pm$/) {
2615     return 'RPM ', [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), rpminfo($tmpnam) ];
2616   } else {
2617     return 'FILE', [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), fileinfo($tmpnam) ];
2618   }
2619 }
2620
2621 sub rsync_send_fin {
2622   swrite(*S, pack('V', -1));      # switch to phase 2
2623   swrite(*S, pack('V', -1));      # switch to phase 3
2624   if ($rsync_protocol >= 24) {
2625     swrite(*S, pack('V', -1));    # goodbye
2626   }
2627   close(S);
2628 }
2629
2630 #######################################################################
2631 # drpmsync protocol
2632 #######################################################################
2633
2634 my $sock_isopen;
2635
2636 sub tolength {
2637   local (*SOCK) = shift;
2638   my ($ans, $l) = @_;
2639   while (length($ans) < $l) {
2640     die("received truncated answer\n") if !sysread(SOCK, $ans, $l - length($ans), length($ans));
2641   }
2642   return $ans;
2643 }
2644
2645 sub copytofile {
2646   return copytofile_seek($_[0], $_[1], 0, $_[2], $_[3], $_[4]);
2647 }
2648
2649 sub copytofile_seek {
2650   local (*SOCK) = shift;
2651   my ($fn, $extractoff, $ans, $l, $ctx) = @_;
2652
2653   local *FD;
2654   if ($extractoff) {
2655     open(FD, '+<', $fn) || die("$fn: $!\n");
2656     defined(sysseek(FD, $extractoff, 0)) || die("sysseek: $!\n");
2657   } else {
2658     open(FD, '>', $fn) || die("$fn: $!\n");
2659   }
2660   my $al = length($ans);
2661   if ($al >= $l) {
2662     die("$fn: write error\n") if syswrite(FD, $ans, $l) != $l;
2663     die("$fn: write error\n") unless close(FD);
2664     $ctx->add(substr($ans, 0, $l));
2665     return substr($ans, $l);
2666   }
2667   if ($al > 0) {
2668     die("$fn: write error\n") if syswrite(FD, $ans, $al) != $al;
2669     $ctx->add($ans);
2670     $l -= $al;
2671     $ans = '';
2672   }
2673   while ($l > 0) {
2674     die("received truncated answer\n") if !sysread(SOCK, $ans, $l > 8192 ? 8192 : $l, 0);
2675     $al = length($ans);
2676     die("$fn: write error\n") if syswrite(FD, $ans, $al) != $al;
2677     $ctx->add($ans);
2678     $l -= $al;
2679     $ans = '';
2680   }
2681   die("$fn: write error\n") unless close(FD);
2682   return '';
2683 }
2684
2685 sub opensock {
2686   return if $sock_isopen;
2687   my $tcpproto = getprotobyname('tcp');
2688   socket(S, PF_INET, SOCK_STREAM, $tcpproto) || die("socket: $!\n");
2689   connect(S, sockaddr_in($syncport, $syncaddr)) || die("connect: $!\n");
2690   $sock_isopen = 1;
2691 }
2692
2693 sub finishreq {
2694   local (*SOCK) = shift;
2695   my ($ans, $ctx, $id) = @_;
2696
2697   if ($ctx) {
2698     $ans = tolength(*SOCK, $ans, 32);
2699     my $netmd5 = substr($ans, 0, 32);
2700     die("network error: bad md5 digest\n") if $netmd5 =~ /[^a-f0-9]/;
2701     my $md5 = $ctx->hexdigest;
2702     die("network error: $md5 should be $netmd5\n") if $md5 ne $netmd5;
2703     $ans = substr($ans, 32);
2704   }
2705   alarm(0) if $config_timeout;
2706   if ($have_time_hires && defined($net_start_tv)) {
2707     $net_spent_time += Time::HiRes::tv_interval($net_start_tv);
2708     $net_recv_bytes += $rvbytes - $net_start_rvbytes;
2709     $net_start_rvbytes = $rvbytes;
2710     undef $net_start_tv;
2711   }
2712   if ($id && ($id ne 'DRPMSYNK' || length($ans))) {
2713     close(SOCK);
2714     undef $sock_isopen;
2715   }
2716   return $ans;
2717 }
2718
2719 sub drpmsync_get_syncfiles {
2720   my ($norecurse, $filelist_data) = @_;
2721
2722   my $data;
2723   if (defined($filelist_data)) {
2724     $data = $filelist_data;
2725     goto use_filelist_data;
2726   }
2727   alarm($config_timeout) if $config_timeout;
2728   opensock() unless $sock_isopen;
2729   my $opts = '';
2730   $opts .= '&zlib' if $have_zlib;
2731   $opts .= '&norecurse' if $norecurse;
2732   if (@filter_comp) {
2733     my @fc = @filter_comp;
2734     while (@fc) {
2735       splice(@fc, 0, 2);
2736       my $r = shift @fc;
2737       $r =~ s/([\000-\040<>\"#&\+=%[\177-\377])/sprintf("%%%02X",ord($1))/sge;
2738       $opts .= "&filter=$r";
2739     }
2740   }
2741   if (@filter_arch_comp) {
2742     my @fc = @filter_arch_comp;
2743     while (@fc) {
2744       splice(@fc, 0, 2);
2745       my $r = shift @fc;
2746       $r =~ s/([\000-\040<>\"#&\+=%[\177-\377])/sprintf("%%%02X",ord($1))/sge;
2747       $opts .= "&filter_arch=$r";
2748     }
2749   }
2750   my $query = "GET $esyncroot/drpmsync/contents?drpmsync$opts HTTP/1.0\r\nHost: $synchost\r\n\r\n";
2751   $txbytes += length($query);
2752   (syswrite(S, $query, length($query)) || 0) == length($query) || die("network write failed\n");
2753   my $ans = '';
2754   do {
2755     die("received truncated answer\n") if !sysread(S, $ans, 1024, length($ans));
2756   } while ($ans !~ /\n\r?\n/s);
2757   $rvbytes += length($ans);
2758   $ans =~ /\n\r?\n(.*)$/s;
2759   $rvbytes -= length($1);
2760   $ans = tolength(*S, $1, 32);
2761   my $id = substr($ans, 0, 8);
2762   die("received bad answer\n") if $id ne 'DRPMSYNC' && $id ne 'DRPMSYNK';
2763   my $vers = hex(substr($ans, 8, 4));
2764   die("answer has bad version\n") if $vers != 1;
2765   my $type = substr($ans, 12, 4);
2766   if ($type eq 'ERR ') {
2767     my $anssize = hex(substr($ans, 24, 8));
2768     $ans = tolength(*S, $ans, 32 + $anssize);
2769     die("remote error: ".substr($ans, 32, $anssize)."\n");
2770   }
2771   die("can only sync complete trees\n") if $type eq 'GONE';
2772   die("server send wrong answer\n") if $type ne 'SYNC' && $type ne 'SYNZ';
2773   die("server send bad answer\n") if hex(substr($ans, 16, 8));
2774   my $anssize = hex(substr($ans, 24, 8));
2775   die("answer is too short\n") if $anssize < 28;
2776   $rvbytes += 32 + $anssize + 32;
2777   $ans = substr($ans, 32);
2778   $ans = tolength(*S, $ans, $anssize);
2779   $data = substr($ans, 0, $anssize);
2780   $ans = substr($ans, $anssize);
2781   my $ctx = Digest::MD5->new;
2782   $ctx->add($data);
2783   $ans = finishreq(*S, $ans, $ctx, $id);
2784   $data = substr($data, 12);
2785   if ($type eq 'SYNZ') {
2786     die("cannot uncompress\n") unless $have_zlib;
2787     $data = Compress::Zlib::uncompress($data);
2788   }
2789 use_filelist_data:
2790   my $filesnum = unpack('N', $data);
2791   # work around perl 5.8.0 bug, where "(w/a*w/a*)*" does not work
2792   my @data = unpack("x[N]".("w/a*w/a*" x ($filesnum + 1)), $data);
2793   die("bad tree start\n") if @data < 2 || length($data[1]) != 8;
2794   die("bad number of file entries\n") if @data != 2 * $filesnum + 2;
2795   $synctree = shift @data;
2796   $synctree .= '/' if $synctree ne '/';
2797   ($newstamp1, $newstamp2) = unpack('H8H8', shift @data);
2798   my @syncfiles = ();
2799   while (@data) {
2800     my ($name, $hex) = splice @data, 0, 2;
2801     die("bad file name in list: $name\n") if "/$name/" =~ /\/(\.|\.\.|)\//;
2802     if (length($hex) == 6) {
2803       push @syncfiles, [ $name, undef, unpack('H12', $hex) ];
2804     } elsif (length($hex) == 6 + 16) {
2805       push @syncfiles, [ $name, undef, unpack('H12H32', $hex) ];
2806     } elsif (length($hex) >= 6 + 32 + 4) {
2807       my @l = ($name, undef, unpack('H12H64H8a*', $hex));
2808       die("bad name.arch in file list: $l[5]\n") if $l[5] eq '.' || $l[5] eq '..' || $l[5] =~ /\//;
2809       push @syncfiles, \@l;
2810     } else {
2811       die("bad line for $name: $hex\n");
2812     }
2813   }
2814   # validate that no entry is listed twice
2815   my %ents;
2816   my %dirs;
2817   for (@syncfiles) {
2818     die("entry $_->[0] is listed twice\n") if exists $ents{$_->[0]};
2819     $ents{$_->[0]} = 1;
2820     if ($_->[2] =~ /^0/) {
2821       $dirs{$_->[0]} = 1;
2822       die("directory $_->[0] has bad data\n") unless @$_ == 3;
2823     } else {
2824       die("entry $_->[0] has bad data\n") unless @$_ > 3;
2825     }
2826   }
2827   # validate that all files are connected to dirs
2828   for (@syncfiles) {
2829     next unless /^(.*)\//;
2830     die("entry $_->[0] is not connected\n") unless $dirs{$1};
2831   }
2832   return @syncfiles;
2833 }
2834
2835 sub drpmsync_send_fin {
2836   return unless $sock_isopen;
2837   my $query = "GET $esyncroot/drpmsync/closesock?drpmsync HTTP/1.0\r\nHost: $synchost\r\n\r\n";
2838   $txbytes += length($query);
2839   syswrite(S, $query, length($query)) == length($query) || die("network write failed\n");
2840   close(S);
2841   undef $sock_isopen;
2842 }
2843
2844 sub drpmsync_get_update {
2845   my ($dto, $tmpnam, $reqext, $rextract) = @_;
2846
2847   my $d;
2848   my $extractoff = 0;
2849   if ($rextract) {
2850     die("bad extract parameter\n") unless $rextract =~ /^([0-9a-fA-F]{2})([0-9a-fA-F]{8}):[0-9a-fA-F]{8}$/;
2851     $extractoff = hex($1) * 4294967296 + hex($2);
2852   }
2853
2854   my $req = aescape($dto->[0]);
2855   $req = "/$req?drpmsync";
2856   $req .= "&extract=$rextract" if $rextract;
2857   $req .= $reqext if $reqext;
2858 # XXX print "-> $req\n";
2859   alarm($config_timeout) if $config_timeout;
2860   opensock() unless $sock_isopen;
2861   my $query = "GET $esyncroot$req HTTP/1.0\r\nHost: $synchost\r\n\r\n";
2862   $txbytes += length($query);
2863   if (syswrite(S, $query, length($query)) != length($query)) {
2864     die("network write failed\n");
2865   }
2866   $net_start_tv = [Time::HiRes::gettimeofday()] if $have_time_hires;
2867   $net_start_rvbytes = $rvbytes;
2868   my $ans = '';
2869   do {
2870     die("received truncated answer\n") if !sysread(S, $ans, 1024, length($ans));
2871   } while ($ans !~ /\n\r?\n/s);
2872   $rvbytes += length($ans);
2873   $ans =~ /\n\r?\n(.*)$/s;
2874   $rvbytes -= length($1);
2875   $ans = tolength(*S, $1, 32);
2876   my $id = substr($ans, 0, 8);
2877   die("received bad answer: $ans\n") if $id ne 'DRPMSYNC' && $id ne 'DRPMSYNK';
2878   my $vers = hex(substr($ans, 8, 4));
2879   die("answer has bad version\n") if $vers != 1;
2880   my $type = substr($ans, 12, 4);
2881   my $namelen = hex(substr($ans, 16, 8));
2882   my $anssize = hex(substr($ans, 24, 8));
2883   if ($anssize == 4294967295) {
2884     $ans = tolength(*S, $ans, 32 + 10);
2885     $anssize = hex(substr($ans, 32, 2)) * 4294967296 + hex(substr($ans, 32 + 2, 8));
2886     $ans = substr($ans, 10);
2887   }
2888   $rvbytes += 32 + $namelen + $anssize + 32;
2889   if ($type eq 'ERR ') {
2890     $ans = tolength(*S, $ans, 32 + $namelen + $anssize);
2891     return $type , substr($ans, 32 + $namelen, $anssize);
2892   }
2893   $ans = tolength(*S, $ans, 32 + $namelen);
2894   die("answer does not match request $syncroot/$dto->[0] - $synctree".substr($ans, 32, $namelen)."\n") if "$syncroot/$dto->[0]" ne $synctree.substr($ans, 32, $namelen);
2895   $ans = substr($ans, 32 + $namelen);
2896
2897   if ($type eq 'GONE' || $type eq 'NODR') {
2898     $ans = finishreq(*S, $ans, undef, $id);
2899     return $type;
2900   }
2901   my $extra = '';
2902   my $extralen = 12;
2903   $extralen = 12 + 16 if $type eq 'RPM ';
2904
2905   die("answer is too short\n") if $anssize < $extralen;
2906   my $ctx = Digest::MD5->new;
2907   my $ndrpm = 0;
2908   my $nrpm = 0;
2909   if ($extralen) {
2910     $ans = tolength(*S, $ans, $extralen);
2911     $extra = substr($ans, 0, $extralen);
2912     die("illegal extra block\n") if $extra =~ /[^a-f0-9]/;
2913     if ($type eq 'RPM ') {
2914       $ndrpm = hex(substr($extra, 12, 8));
2915       $nrpm = hex(substr($extra, 12 + 8, 8));
2916       die("more than one rpm?\n") if $nrpm > 1;
2917       if ($ndrpm) {
2918         $extralen += $ndrpm * (12 + 32 * 3 + 8);
2919         $ans = tolength(*S, $ans, $extralen);
2920         $extra = substr($ans, 0, $extralen);
2921         die("illegal extra block\n") if $extra =~ /[^a-f0-9]/;
2922       }
2923     }
2924     $ans = substr($ans, $extralen);
2925     $anssize -= $extralen;
2926     $ctx->add($extra);
2927   }
2928
2929   die("unexpected type $type\n") if $rextract && $type ne 'RPM ';
2930
2931   if ($type eq 'FILZ') {
2932     die("cannot uncompress\n") unless $have_zlib;
2933     $ans = tolength(*S, $ans, $anssize);
2934     my $data = substr($ans, 0, $anssize);
2935     $ctx->add($data);
2936     $ans = finishreq(*S, substr($ans, $anssize), $ctx, $id);
2937     $data = Compress::Zlib::uncompress($data);
2938     my $datamd5 = Digest::MD5::md5_hex($data);
2939     if ($dto->[2] =~ /^2/) {
2940       symlink($data, $tmpnam) || die("symlink: $!\n");
2941     } else {
2942       open(FD, '>', $tmpnam) || die("$tmpnam: $!\n");
2943       die("$tmpnam: write error\n") if (syswrite(FD, $data) || 0) != length($data);
2944       close(FD) || die("$tmpnam: $!\n");
2945       fixmodetime($tmpnam, substr($extra, 0, 12));
2946     }
2947     my @s = lstat($tmpnam);
2948     die("$tmpnam: $!\n") unless @s;
2949     if ($dto->[2] =~ /^2/) {
2950       $d = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("2%03x%08x", ($s[2] & 07777), $s[9]), linkinfo($tmpnam) ];
2951     } else {
2952       $d = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), $datamd5 ];
2953     }
2954     return ('FILZ', $d);
2955   } elsif ($type eq 'FILE') {
2956     if ($dto->[2] =~ /^2/) {
2957       $ans = tolength(*S, $ans, $anssize);
2958       $ctx->add(substr($ans, 0, $anssize));
2959       symlink(substr($ans, 0, $anssize), $tmpnam) || die("symlink: $!\n");
2960       $ans = substr($ans, $anssize);
2961     } else {
2962       $ans = copytofile(*S, $tmpnam, $ans, $anssize, $ctx);
2963     }
2964     $ans = finishreq(*S, $ans, $ctx, $id);
2965     fixmodetime($tmpnam, substr($extra, 0, 12)) if $dto->[2] !~ /^2/;
2966     my @s = lstat($tmpnam);
2967     die("$tmpnam: $!\n") unless @s;
2968     if ($dto->[2] =~ /^2/) {
2969       $d = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("2%03x%08x", ($s[2] & 07777), $s[9]), linkinfo($tmpnam) ];
2970     } else {
2971       $d = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), fileinfo($tmpnam) ];
2972     }
2973     return ('FILE', $d);
2974   } elsif ($type eq 'FISO') {
2975     $ans = copytofile(*S, "$tmpnam.fiso", $ans, $anssize, $ctx);
2976     $ans = finishreq(*S, $ans, $ctx, $id);
2977     return 'FISO', [ $tmpnam, undef, substr($extra, 0, 12) ];
2978   } elsif ($type eq 'RPM ') {
2979     $sabytes -= $anssize;
2980     my $delta;
2981     die("more than one rpm?\n") if $nrpm > 1;
2982     die("nothing to do?\n") if $nrpm == 0 && $ndrpm == 0;
2983     my @deltas;
2984     my $dextra = substr($extra, 12 + 16);
2985     while ($ndrpm > 0) {
2986       $delta = $tmpnam;
2987       $delta =~ s/[^\/]*$//;
2988       $delta .= substr($dextra, 12, 32 * 3);
2989       # end old job if we have a delta conflict
2990       checkjob() if $runningjob && -e $delta;
2991       my $size = hex(substr($dextra, 12 + 3 * 32, 8));
2992       die("delta rpm bigger than answer? $size > $anssize\n") if $size > $anssize;
2993       $ans = copytofile(*S, $delta, $ans, $size, $ctx);
2994       $anssize -= $size;
2995       fixmodetime($delta, substr($dextra, 0, 12));
2996       $dextra = substr($dextra, 12 + 32 * 3 + 8);
2997       push @deltas, $delta;
2998       $ndrpm--;
2999     }
3000     if ($nrpm == 1) {
3001       $ans = copytofile_seek(*S, $tmpnam, $extractoff, $ans, $anssize, $ctx);
3002       $ans = finishreq(*S, $ans, $ctx, $id);
3003       return 'RPM ', [ $dto->[0] ], @deltas if $rextract;
3004       fixmodetime($tmpnam, substr($extra, 0, 12));
3005       my @s = stat($tmpnam);
3006       die("$tmpnam: $!\n") unless @s;
3007       $sabytes += $s[7];
3008       $d = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), rpminfo($tmpnam) ];
3009     } else {
3010       die("junk at end of answer\n") if $anssize;
3011       $ans = finishreq(*S, $ans, $ctx, $id);
3012       $d = [ undef, undef, substr($extra, 0, 12) ];
3013     }
3014     return 'RPM ', $d, @deltas;
3015   } else {
3016     die("received strange answer type: $type\n");
3017   }
3018 }
3019
3020
3021 #######################################################################
3022 # update functions
3023 #######################################################################
3024
3025 sub save_or_delete_deltas {
3026   my ($bdir, $dpn, @deltas) = @_;
3027
3028   if (!$config_keep_deltas || !$dpn) {
3029     for my $delta (@deltas) {
3030       unlink($delta) || die("unlink $delta: $!\n");
3031     }
3032     return;
3033   }
3034   my $ddir = "$bdir/drpmsync/deltas/$dpn";
3035   mkdir_p($ddir);
3036   for my $delta (@deltas) {
3037     my $dn = $delta;
3038     $dn =~ s/.*\///;
3039     if (substr($dn, 0, 32) eq substr($dn, 64, 32)) {
3040       # print("detected signature-only delta\n");
3041       local(*DDIR);
3042       opendir(DDIR, "$ddir") || die("opendir $ddir: $!\n");
3043       my @dh = grep {$_ =~ /^[0-9a-f]{96}$/} readdir(DDIR);
3044       closedir(DDIR);
3045       @dh = grep {substr($_, 64, 32) eq substr($dn, 64, 32)} @dh;
3046       @dh = grep {substr($_, 32, 32) ne substr($dn, 32, 32)} @dh;
3047       for my $dh (@dh) {
3048         # recvlog_print("! $dh");
3049         my $nn = substr($dh, 0, 32).substr($dn, 32, 64);
3050         my @oldstat = stat("$ddir/$dh");
3051         die("$ddir/$dh: $!") unless @oldstat;
3052         if (system($combinedeltarpm, "$ddir/$dh", $delta, "$bdir/drpmsync/wip/$nn") || ! -f "$bdir/drpmsync/wip/$nn") {
3053           recvlog_print("! combinedeltarpm $ddir/$dh $delta $bdir/drpmsync/wip/$nn failed");
3054           unlink("$bdir/drpmsync/wip/$nn");
3055           next;
3056         }
3057         utime($oldstat[9], $oldstat[9], "$bdir/drpmsync/wip/$nn");
3058         rename("$bdir/drpmsync/wip/$nn", "$ddir/$nn") || die("rename $bdir/drpmsync/wip/$nn $ddir/$nn: $!\n");
3059         unlink("$bdir/drpmsync/deltas/$dpn/$dh") || die("unlink $bdir/drpmsync/deltas/$dpn/$dh: $!\n");
3060       }
3061       unlink($delta) || die("unlink $delta: $!\n");
3062     } else {
3063       rename($delta, "$ddir/$dn") || die("rename $delta $ddir/$dn: $!\n");
3064     }
3065   }
3066 }
3067
3068
3069 # get rpms for fiso, fill iso
3070
3071 sub update_fiso {
3072   my ($bdir, $pn, $dto, $rights) = @_;
3073
3074   local *F;
3075   if (!open(F, '-|', $fragiso, 'list', "$bdir/drpmsync/wip/$pn.fiso")) {
3076     unlink("$bdir/drpmsync/wip/$pn.fiso");
3077     return undef;
3078   }
3079   my @frags = <F>;
3080   close(F) || return undef;
3081   chomp @frags;
3082   open(F, '>', "$bdir/drpmsync/wip/$pn") || die("$bdir/drpmsync/wip/$pn: $!\n");
3083   close(F);
3084   for my $f (@frags) {
3085     my @f = split(' ', $f, 3);
3086     update($bdir, [ $dto->[0], undef, $rights, $f[1], undef, $f[2] ], $f[0]);
3087   }
3088   checkjob() if $runningjob;
3089   my ($md5, $err) = runprg(undef, undef, $fragiso, 'fill', '-m', "$bdir/drpmsync/wip/$pn.fiso", "$bdir/drpmsync/wip/$pn");
3090   unlink("$bdir/drpmsync/wip/$pn.fiso") || die("unlink $bdir/drpmsync/wip/$pn.fiso: $!\n");;
3091   my $tmpnam = "$bdir/drpmsync/wip/$pn";
3092   if ($err) {
3093     recvlog_print("! fragiso fill failed: $err");
3094     unlink($tmpnam);
3095     return undef;
3096   }
3097   die("fragiso did not return md5\n") unless $md5 =~ /^[0-9a-f]{32}$/;
3098   fixmodetime($tmpnam, $rights);
3099   my @s = lstat($tmpnam);
3100   die("$tmpnam: $!\n") unless @s;
3101   $rights = sprintf("1%03x%08x", ($s[2] & 07777), $s[9]);
3102   $files{$dto->[0]} = [ $dto->[0], "$s[9]/$s[7]/$s[1]", $rights, $md5 ];
3103   rename($tmpnam, "$bdir/$dto->[0]") || die("rename $tmpnam $bdir/$dto->[0]: $!\n");
3104   if ($config_repo) {
3105     for my $f (@frags) {
3106       my @f = split(' ', $f, 3);
3107       repo_add("$bdir/$dto->[0]\@$f[0]", [ "$dto->[0]\@$f[0]", "$s[9]/$s[7]/$s[1]", $rights, $f[1], undef, $f[2] ] );
3108     }
3109   }
3110   return 1;
3111 }
3112
3113
3114 # called for files and rpms
3115
3116 sub update {
3117   my ($bdir, $dto, $rextract, $play_it_safe) = @_;
3118
3119   my ($d, $nd, $md);
3120   my $pdto0;
3121   my @deltas;
3122   my $extractoff;
3123   my $tmpnam;
3124
3125   if ($play_it_safe && ref($play_it_safe)) {
3126     # poor mans co-routine implementation...
3127     my $job = $play_it_safe;
3128     $d = $job->{'d'};
3129     $nd = $job->{'nd'};
3130     $md = $job->{'md'};
3131     $pdto0 = $job->{'pdto0'};
3132     $tmpnam = $job->{'tmpnam'};
3133     $extractoff = $job->{'extractoff'};
3134     @deltas = applydeltas_finish($job);
3135     goto applydeltas_finished;
3136   }
3137
3138   die("can only update files and symlinks\n") if $dto->[2] !~ /^[12]/;
3139   $pdto0 = $dto->[0];        # for recvlog_print;
3140
3141   # hack: patch source/dest for special fiso request
3142   if ($rextract) {
3143     die("bad extract parameter\n") unless $rextract =~ /^([0-9a-fA-F]{2})([0-9a-fA-F]{8}):[0-9a-fA-F]{8}$/;
3144     $extractoff = hex($1) * 4294967296 + hex($2);
3145     die("bad extract offset\n") unless $extractoff;
3146     $pdto0 = "$dto->[0]\@$rextract ($dto->[5])";
3147   }
3148
3149   $d = $files{$dto->[0]};
3150   if ($d && !$rextract && $d->[3] eq $dto->[3]) {
3151     return if $d->[2] eq $dto->[2];     # already identical
3152     if (substr($d->[2], 0, 1) eq substr($dto->[2], 0, 1)) {
3153       return if substr($d->[2], 0, 1) eq '2';   # can't change links
3154       fixmodetime("$bdir/$d->[0]", $dto->[2]);
3155       $d->[2] = $dto->[2];
3156       my $newmtime = hex(substr($dto->[2], 4, 8));
3157       $d->[1] =~ s/^.*?\//$newmtime\//;         # patch cache id
3158       return;
3159     }
3160   }
3161
3162   # check for simple renames
3163   if (!$d && !$rextract && substr($dto->[2], 0, 1) eq '1') {
3164     # search for same md5, same mtime and removed files
3165     my @oldds = grep {@$_ > 3 && $_->[3] eq $dto->[3] && substr($_->[2], 4) eq substr($dto->[2], 4) && !$syncfiles{$_->[0]}} values %files;
3166     if (@oldds) {
3167       $d = $oldds[0];
3168       my $pn = $dto->[0];
3169       $pn =~ s/.*\///;
3170       $tmpnam = "$bdir/drpmsync/wip/$pn";
3171       checkjob($pn) if $runningjob;
3172       # rename it
3173       if (rename("$bdir/$d->[0]", $tmpnam)) {
3174         delete $files{$d->[0]};
3175         recvlog_print("- $d->[0]");
3176         repo_del("$bdir/$d->[0]", $d) if $config_repo;
3177         my @s = stat($tmpnam);
3178         # check link count, must be 1
3179         if (!@s || $s[3] != 1) {
3180           unlink($tmpnam);      # oops
3181         } else {
3182           fixmodetime($tmpnam, $dto->[2]);
3183           @s = stat($tmpnam);
3184           die("$tmpnam: $!\n") unless @s;
3185           my @info = @$d;
3186           splice(@info, 0, 3);
3187           $files{$dto->[0]} = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), @info ];
3188           recvlog_print("M $dto->[0]");
3189           rename($tmpnam, "$bdir/$dto->[0]") || die("rename $tmpnam $bdir/$dto->[0]: $!\n");
3190           repo_add("$bdir/$dto->[0]", $files{$dto->[0]}) if $config_repo;
3191           # no need to create delta, as file was already in tree...
3192           return;
3193         }
3194       }
3195       undef $d;
3196     }
3197   }
3198
3199   if (!$d && @$dto > 5) {
3200     my @oldds = grep {@$_ > 5 && $_->[5] eq $dto->[5]} values %files;
3201     $d = $oldds[0] if @oldds;
3202   }
3203
3204   $md = $d;     # make delta against this entry ($d may point to repo)
3205   my $repo_key = '';
3206   my @repo;
3207   my $deltaonly;
3208
3209   if ($config_repo && @$dto > 5) {
3210     @repo = repo_search($dto->[5], $dto->[3]);
3211     # we must not use the repo if we need to store the deltas.
3212     # in this case we will send a delta-only request and retry the
3213     # repo if it fails
3214     if (@repo && !$rextract && !$config_generate_deltas && $config_keep_deltas) {
3215       @repo = repo_check(@repo);
3216       $deltaonly = 1 if @repo;
3217     }
3218   }
3219
3220 ##################################################################
3221 ##################################################################
3222
3223 send_again:
3224
3225   while (@repo && !$deltaonly) {
3226     my $rd;
3227     my $pn = $dto->[0];
3228     $pn =~ s/^.*\///;
3229     checkjob($pn) if $runningjob;
3230     if ($repo[0]->[0] eq $dto->[3]) {
3231       # exact match, great!
3232       $tmpnam = "$bdir/drpmsync/wip/$pn";
3233       $rd = repo_cp($repo[0], $bdir, "drpmsync/wip/$pn", $extractoff);
3234       if (!$rd) {
3235         shift @repo;
3236         next;
3237       }
3238       if ($rextract) {
3239         recvlog_print("R $pdto0");
3240         return;
3241       }
3242       fixmodetime($tmpnam, $dto->[2]);
3243       my @s = stat($tmpnam);
3244       die("$tmpnam: $!\n") unless @s;
3245       my $oldd5 = $md ? substr($md->[3], 32) : undef;
3246       $files{$dto->[0]} = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), $rd->[3], $rd->[4], $rd->[5] ];
3247       if ($oldd5 && $config_generate_deltas) {
3248         recvlog_print("Rm $pdto0");
3249         @deltas = makedelta("$bdir/$md->[0]", $tmpnam, "$bdir/drpmsync/wip/$oldd5$files{$dto->[0]}->[3]");
3250         save_or_delete_deltas($bdir, $dto->[5], @deltas);
3251       } else {
3252         recvlog_print("R $pdto0");
3253       }
3254       rename($tmpnam, "$bdir/$dto->[0]") || die("rename $tmpnam $bdir/$dto->[0]: $!\n");
3255       repo_add("$bdir/$dto->[0]", $files{$dto->[0]});
3256       return;
3257     } elsif (substr($repo[0]->[0], 32, 32) eq substr($dto->[3], 32, 32)) {
3258       # have sign only rpm, copy right away
3259       checkjob() if $runningjob;
3260       $rd = repo_cp($repo[0], $bdir, "drpmsync/wip/repo-$pn");
3261       if (!$rd) {
3262         shift @repo;
3263         next;
3264       }
3265       $d = $rd;
3266       $d->[1] = undef;  # mark as temp, don't gen/save delta
3267       $repo_key = 'R';
3268       @repo = ();
3269     }
3270     @repo = repo_check(@repo) if @repo;
3271     last;
3272   }
3273
3274   # ok, we really need to send a request our server
3275   my $reqext = '';
3276   if (@repo && !$deltaonly && !$play_it_safe) {
3277     my @h = map {$_->[0]} @repo;
3278     unshift @h, $d->[3] if $d && @$d > 5;
3279     $reqext .= "&have=" . shift(@h);
3280     if (@h) {
3281       my %ha = map {substr($_, -32, 32) => 1} @h;
3282       $reqext .= "&havealso=" . join(',', keys %ha);
3283     }
3284   } elsif ($d && @$d > 5 && !$play_it_safe) {
3285     $reqext .= "&have=$d->[3]";
3286     $reqext .= "&uncombined" if $config_keep_uncombined;
3287     $reqext .= "&withrpm" if $config_always_get_rpm && substr($d->[3], 32) ne substr($dto->[3], 32);
3288     $reqext .= "&deltaonly" if $deltaonly;
3289     $reqext .= "&nocomplexdelta" if (!$config_keep_deltas || $rextract) && $config_always_get_rpm;
3290   } else {
3291     $reqext .= "&zlib" if $have_zlib;
3292     $reqext .= "&fiso" if $config_repo && !$play_it_safe && ($dto->[0] =~ /(?<!\.delta)\.iso$/i);
3293   }
3294
3295   my $pn = $dto->[0];
3296   $pn =~ s/^.*\///;
3297   die("no file name?\n") unless $pn ne '';
3298   checkjob($pn) if $runningjob;
3299   $tmpnam = "$bdir/drpmsync/wip/$pn";
3300   my $type;
3301   ($type, $nd, @deltas) = get_update($dto, $tmpnam, $reqext, $rextract);
3302   if ($type eq 'ERR ') {
3303     die("$nd\n");
3304   } elsif ($type eq 'NODR') {
3305     die("unexpected NODR answer\n") unless $deltaonly;
3306     $deltaonly = 0;
3307     goto send_again;
3308   } elsif ($type eq 'GONE') {
3309     warn("$dto->[0] is gone\n");
3310     recvlog_print("${repo_key}G $pdto0");
3311     if (-e "$bdir/$dto->[0]") {
3312       unlink("$bdir/$dto->[0]") || die("unlink $bdir/$dto->[0]: $!\n");
3313     }
3314     delete $files{$dto->[0]};
3315     $had_gone = 1;
3316   } elsif ($type eq 'FILZ') {
3317     recvlog_print("${repo_key}z $pdto0");
3318     rename($tmpnam, "$bdir/$dto->[0]") || die("rename $tmpnam $bdir/$dto->[0]: $!\n");
3319     $files{$dto->[0]} = $nd;
3320   } elsif ($type eq 'FILE') {
3321     recvlog_print("${repo_key}f $pdto0");
3322     rename($tmpnam, "$bdir/$dto->[0]") || die("rename $tmpnam $bdir/$dto->[0]: $!\n");
3323     $files{$dto->[0]} = $nd;
3324   } elsif ($type eq 'FISO') {
3325     checkjob() if $runningjob;
3326     recvlog_print("${repo_key}i $pdto0");
3327     if (!update_fiso($bdir, $pn, $dto, $nd->[2])) {
3328       $play_it_safe = 1;
3329       goto send_again;
3330     }
3331   } elsif ($type eq 'RPM ') {
3332     if (!$nd->[0]) {
3333       checkjob() if $runningjob;
3334       die("no deltas?") unless @deltas;
3335       undef $d if $d && (@$d <= 4 || substr($d->[3], 32, 32) ne substr($deltas[0], -96, 32));
3336       if (!$d && @repo) {
3337         my $dmd5 = substr($deltas[0], -96, 32);
3338         my @mrepo = grep {substr($_->[0], 32, 32) eq $dmd5} @repo;
3339         for my $rd (@mrepo) {
3340           $d = repo_cp($rd, $bdir, "drpmsync/wip/repo-$pn");
3341           last if $d;
3342         }
3343         if (!$d && @mrepo) {
3344           recvlog_print("R! $pdto0");
3345           save_or_delete_deltas($bdir, undef, @deltas);
3346           @repo = grep {substr($_->[0], 32, 32) ne $dmd5} @repo;
3347           goto send_again;      # now without bad repo entries
3348         }
3349         $d->[1] = undef if $d;
3350         $repo_key = 'R';
3351       }
3352       if (@deltas == 1 && substr($deltas[0], -96, 32) eq substr($deltas[0], -32, 32)) {
3353         recvlog_print("${repo_key}s $pdto0");
3354       } else {
3355         recvlog_print("${repo_key}d $pdto0");
3356       }
3357       die("received delta doesn't match request\n") unless $d;
3358
3359 #######################################################################
3360
3361       if (1) {
3362         my $job = {};
3363         $job->{'d'} = $d;
3364         $job->{'nd'} = $nd;
3365         $job->{'md'} = $md;
3366         $job->{'pdto0'} = $pdto0;
3367         $job->{'tmpnam'} = $tmpnam;
3368         $job->{'extractoff'} = $extractoff;
3369         $job->{'wip'} = $pn;
3370         $job->{'finish'} = \&update;
3371         $job->{'finishargs'} = [$bdir, $dto, $rextract, $job];
3372         @deltas = applydeltas($job, "$bdir/$d->[0]", $tmpnam, $extractoff, @deltas);
3373         if (@deltas) {
3374             $runningjob = $job;
3375             return;
3376         }
3377         delete $job->{'finishargs'};    # break circ ref
3378       }
3379
3380 #######################################################################
3381
3382       #recvlog("applying deltarpm to $d->[0]");
3383       #@deltas = applydeltas("$bdir/$d->[0]", $tmpnam, $extractoff, @deltas);
3384 applydeltas_finished:
3385       if (!@deltas) {
3386         return update($bdir, $dto, $rextract, 1);
3387       }
3388       if (!$rextract) {
3389         fixmodetime($tmpnam, $nd->[2]);
3390         my @s = stat($tmpnam);
3391         die("$tmpnam: $!\n") unless @s;
3392         $sabytes += $s[7];
3393         $nd = [ $dto->[0], "$s[9]/$s[7]/$s[1]", sprintf("1%03x%08x", ($s[2] & 07777), $s[9]), rpminfo($tmpnam) ];
3394       }
3395     } else {
3396       recvlog_print("${repo_key}r $pdto0") if $rextract || !(!@deltas && $md && $md->[1] && $config_generate_deltas);
3397     }
3398     if ($rextract) {
3399       save_or_delete_deltas($bdir, undef, @deltas);
3400       unlink("$bdir/$d->[0]") if $d && ($d->[0] =~ m!drpmsync/wip/repo-!);
3401       return;
3402     }
3403     if (@deltas && $d && !$d->[1]) {
3404       # deltas made against some repo rpm, always delete
3405       save_or_delete_deltas($bdir, undef, @deltas);
3406       @deltas = ();
3407     }
3408     if (!@deltas && $md && $md->[1] && $config_generate_deltas) {
3409       recvlog_print("${repo_key}m $pdto0");
3410       @deltas = makedelta("$bdir/$md->[0]", $tmpnam, "$bdir/drpmsync/wip/".substr($md->[3], 32).$nd->[3]);
3411     }
3412     save_or_delete_deltas($bdir, $dto->[5], @deltas);
3413
3414     rename($tmpnam, "$bdir/$dto->[0]") || die("rename $tmpnam $bdir/$dto->[0]: $!\n");
3415     $files{$dto->[0]} = $nd;
3416     repo_add("$bdir/$dto->[0]", $nd) if $config_repo;
3417   } else {
3418     die("received strange answer type: $type\n");
3419   }
3420   unlink("$bdir/$d->[0]") if $d && ($d->[0] =~ m!drpmsync/wip/repo-!);
3421 }
3422
3423 sub fixmodetime {
3424   my ($fn, $mthex) = @_;
3425   my $mode = hex(substr($mthex, 1, 3));
3426   my $ti = hex(substr($mthex, 4, 8));
3427   chmod($mode, $fn) == 1 || die("chmod $fn: $!\n");
3428   utime($ti, $ti, $fn) == 1 || die("utime $fn: $!\n");
3429 }
3430
3431 my $cmdline_cf;
3432 my $cmdline_source;
3433 my $cmdline_repo;
3434 my $cmdline_repo_add;
3435 my $cmdline_repo_validate;
3436 my $cmdline_get_filelist;
3437 my $cmdline_use_filelist;
3438 my $cmdline_norecurse;
3439 my $cmdline_list;
3440 my @cmdline_filter;
3441 my @cmdline_filter_arch;
3442
3443 sub find_source {
3444   my ($syncfilesp, $norecurse, $verbose, @sources) = @_;
3445   my %errors;
3446
3447   if (!@sources) {
3448     setup_proto('null');
3449     @$syncfilesp = ();
3450     return;
3451   }
3452   for my $s (@sources) {
3453     $syncurl = $s;
3454     my $ss = $s;
3455     $syncproto = 'drpmsync';
3456     if ($ss =~ /^(file|drpmsync|rsync):(.*)$/) {
3457       $syncproto = lc($1);
3458       $ss = $2;
3459       if ($syncproto ne 'file') {
3460         $ss =~ s/^\/\///;
3461         if ($ss =~ /^([^\/]+)\@(.*)$/) {
3462           $syncuser = $1;
3463           $ss = $2;
3464           ($syncuser, $syncpassword) = split(':', $syncuser, 2);
3465         }
3466       }
3467     }
3468     if ($syncproto eq 'file') {
3469       $syncroot = $ss;
3470       $syncroot =~ s/\/\.$//;
3471       $syncroot =~ s/\/$// unless $syncroot eq '/';
3472     } else {
3473       ($syncaddr, $syncport, $syncroot) = $ss =~ /^([^\/]+?)(?::(\d+))?(\/.*)$/;
3474       if (!$syncaddr) {
3475         $errors{$s} = "bad url";
3476         next;
3477       }
3478       $syncroot =~ s/\/\.$//;
3479       $syncroot =~ s/\/$// unless $syncroot eq '/';
3480       $esyncroot = aescape($syncroot);
3481       $syncport ||= $syncproto eq 'rsync' ? 873 : 80;
3482       $syncaddr = inet_aton($syncaddr);
3483       if (!$syncaddr) {
3484         $errors{$s} = "could not resolve host";
3485         next;
3486       }
3487       print "trying $s\n" if $verbose;
3488     }
3489     eval {
3490       setup_proto($syncproto);
3491       @$syncfilesp = get_syncfiles($norecurse);
3492     };
3493     alarm(0) if $config_timeout;
3494     last unless $@;
3495     $errors{$s} = "$@";
3496     $errors{$s} =~ s/\n$//s;
3497     undef $syncaddr;
3498   }
3499   if ($syncproto ne 'file' && !$syncaddr) {
3500     if (@sources == 1) {
3501       die("could not connect to $sources[0]: $errors{$sources[0]}\n");
3502     } else {
3503       print STDERR "could not connect to any server:\n";
3504       print STDERR "  $_: $errors{$_}\n" for @sources;
3505       exit(1);
3506     }
3507   }
3508   filelist_apply_filter($syncfilesp);
3509   filelist_apply_filter_arch($syncfilesp);
3510 }
3511
3512 sub filelist_from_file {
3513   my ($flp, $fn) = @_;
3514
3515   local *FL;
3516   if ($fn eq '-') {
3517     open(FL, '<&STDIN') || die("STDIN dup: $!\n");
3518   } else {
3519     open(FL, '<', $fn) || die("$fn: $!\n");
3520   }
3521   my $fldata;
3522   my $data;
3523   my $is_compressed;
3524   die("not a drpmsync filelist\n") if read(FL, $data, 32) != 32;
3525   if (substr($data, 0, 2) eq "\037\213") {
3526     { local $/; $data .= <FL>; }
3527     $data = Compress::Zlib::memGunzip($data);
3528     die("filelist uncompress error\n") unless defined $data;
3529     $is_compressed = 1;
3530   }
3531   die("not a drpmsync filelist\n") if (substr($data, 0, 24) ne 'DRPMSYNC0001SYNC00000000' && substr($data, 0, 24) ne 'DRPMSYNC0001SYNZ00000000');
3532   if ($is_compressed) {
3533     $fldata = substr($data, 32);
3534     $data = substr($data, 0, 32);
3535   } else {
3536     { local $/; $fldata = <FL>; }
3537   }
3538   close FL;
3539   my $md5 = substr($fldata, -32, 32);
3540   $fldata = substr($fldata, 0, -32);
3541   die("drpmsync filelist checksum error\n") if Digest::MD5::md5_hex($fldata) ne $md5;
3542   $fldata = substr($fldata, 12);
3543   if (substr($data, 16, 4) eq 'SYNZ') {
3544     die("cannot uncompress filelist\n") unless $have_zlib;
3545     $fldata = Compress::Zlib::uncompress($fldata);
3546   }
3547   @$flp = drpmsync_get_syncfiles($cmdline_norecurse, $fldata);
3548   filelist_apply_filter($flp);
3549   filelist_apply_filter_arch($flp);
3550 }
3551
3552 while (@ARGV) {
3553   last if $ARGV[0] !~ /^-/;
3554   my $opt = shift @ARGV;
3555   last if $opt eq '--';
3556   if ($opt eq '-c') {
3557     die("-c: argument required\n") unless @ARGV;
3558     $cmdline_cf = shift @ARGV;
3559   } elsif ($opt eq '--repo') {
3560     die("--repo: argument required\n") unless @ARGV;
3561     $cmdline_repo = shift @ARGV;
3562   } elsif ($opt eq '--repo-add') {
3563     $cmdline_repo_add = 1;
3564   } elsif ($opt eq '--repo-validate') {
3565     $cmdline_repo_validate = 1;
3566   } elsif ($opt eq '--norecurse-validate') {
3567     $cmdline_norecurse = 1;
3568   } elsif ($opt eq '--list') {
3569     $cmdline_list = 1;
3570     $cmdline_norecurse = 1;
3571   } elsif ($opt eq '--list-recursive') {
3572     $cmdline_list = 1;
3573   } elsif ($opt eq '--get-filelist') {
3574     die("--get-filelist: argument required\n") unless @ARGV;
3575     $cmdline_get_filelist = shift @ARGV;
3576   } elsif ($opt eq '--filelist-synctree') {
3577     $synctree = shift @ARGV;
3578     $synctree .= '/';
3579   } elsif ($opt eq '--use-filelist') {
3580     die("--use-filelist: argument required\n") unless @ARGV;
3581     $cmdline_use_filelist = shift @ARGV;
3582   } elsif ($opt eq '--exclude') {
3583     die("--exclude: argument required\n") unless @ARGV;
3584     push @cmdline_filter, '-'.shift(@ARGV);
3585   } elsif ($opt eq '--include') {
3586     die("--include: argument required\n") unless @ARGV;
3587     push @cmdline_filter, '+'.shift(@ARGV);
3588   } elsif ($opt eq '--exclude-arch') {
3589     die("--exclude-arch: argument required\n") unless @ARGV;
3590     push @cmdline_filter_arch, '-'.shift(@ARGV);
3591   } elsif ($opt eq '--include-arch') {
3592     die("--include-arch: argument required\n") unless @ARGV;
3593     push @cmdline_filter_arch, '+'.shift(@ARGV);
3594   } else {
3595     die("$opt: unknown option\n");
3596   }
3597 }
3598
3599 if ($cmdline_repo_validate) {
3600   my $basedir;
3601   $basedir = shift @ARGV if @ARGV;
3602   die("illegal source parameter for repo operation\n") if @ARGV;
3603   if (defined($cmdline_cf) || (defined($basedir) && -e "$basedir/drpmsync/config")) {
3604     readconfig_client(defined($cmdline_cf) ? $cmdline_cf : "$basedir/drpmsync/config");
3605   }
3606   $config_repo = $cmdline_repo if defined $cmdline_repo;
3607   die("--repo-validate: no repo specified\n") unless $config_repo;
3608   repo_validate();
3609   exit(0);
3610 }
3611
3612 my $basedir;
3613 if (@ARGV == 2) {
3614   die("illegal source parameter for repo operation\n") if $cmdline_repo_add;
3615   $cmdline_source = shift @ARGV;
3616   $basedir = $ARGV[0];
3617 } elsif (@ARGV == 1) {
3618   if ($cmdline_list || defined($cmdline_get_filelist)) {
3619     $cmdline_source = $ARGV[0];
3620   } else {
3621     $basedir = $ARGV[0];
3622   }
3623 } else {
3624   die("Usage: drpmsync [-c config] [source] <dir> | -s <serverconfig>\n") unless $cmdline_list && defined($cmdline_use_filelist);
3625 }
3626
3627 if (defined($basedir)) {
3628   if (-f $basedir) {
3629     die("$basedir: not a directory (did you forget -s?)\n");
3630   }
3631   mkdir_p($basedir);
3632 }
3633
3634 if (defined($cmdline_cf)) {
3635   readconfig_client($cmdline_cf);
3636 } elsif (defined($basedir) && (-e "$basedir/drpmsync/config")) {
3637   readconfig_client("$basedir/drpmsync/config");
3638 }
3639
3640 @config_source = $cmdline_source if defined $cmdline_source;
3641 $config_repo = $cmdline_repo if defined $cmdline_repo;
3642 @filter_comp = compile_filter(@cmdline_filter, @config_filter);
3643 @filter_arch_comp = compile_filter(@cmdline_filter_arch, @config_filter_arch);
3644
3645 if ($config_repo && defined($basedir)) {
3646   my $nbasedir = `cd $basedir && /bin/pwd`;
3647   chomp $nbasedir;
3648   die("could not canonicalize $basedir\n") if !$nbasedir || !-d "$nbasedir";
3649   $basedir = $nbasedir;
3650 }
3651
3652 if ($cmdline_repo_add) {
3653   die("--repo-add: no repo specified\n") unless $config_repo;
3654   die("need a destination\n") unless defined $basedir;
3655   readcache("$basedir/drpmsync/cache");
3656   print "getting state of local tree...\n";
3657   findfiles($basedir, '');
3658   print("cache:  $cachehits hits, $cachemisses misses\n");
3659   for my $d (@files) {
3660     repo_add("$basedir/$d->[0]", $d);
3661   }
3662   exit(0);
3663 }
3664
3665 if (defined($cmdline_get_filelist)) {
3666   die("need a source for get-filelist\n") unless @config_source;
3667   $SIG{'ALRM'} = sub {die("network timeout\n");};
3668   my @syncfiles;
3669   find_source(\@syncfiles, $cmdline_norecurse, $cmdline_get_filelist eq '-' ? 0 : 1, @config_source);
3670   send_fin();
3671   filelist_from_file(\@syncfiles, $cmdline_use_filelist) if defined $cmdline_use_filelist;
3672   local *FL;
3673   if ($cmdline_get_filelist eq '-') {
3674     open(FL, '>&STDOUT') || die("STDOUT dup: $!\n");
3675   } else {
3676     open(FL, '>', $cmdline_get_filelist) || die("$cmdline_get_filelist: $!\n");
3677   }
3678   my $data;
3679   $data = pack('H*', "$newstamp1$newstamp2");
3680   $data = pack("Nw/a*w/a*", scalar(@syncfiles), $synctree ne '/' ? substr($synctree, 0, -1) : '/', $data);
3681   $data = sprintf("1%03x%08x", 0644, time()).$data;
3682   for (@syncfiles) {
3683     my @l = @$_;
3684     my $b;
3685     if (@l > 5) {
3686       $b = pack('H*', "$l[2]$l[3]$l[4]").$l[5];
3687     } elsif (@l > 3) {
3688       if ($l[3] eq 'x') {
3689         $b = pack('H*', $l[2])."\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
3690       } else {
3691         $b = pack('H*', "$l[2]$l[3]");
3692       }
3693     } else {
3694       $b = pack('H*', $l[2]);
3695     }
3696     $data .= pack("w/a*w/a*", $l[0], $b);
3697   }
3698   $data = "DRPMSYNC0001SYNC00000000".sprintf("%08x", length($data)).$data.Digest::MD5::md5_hex($data);
3699   print FL $data;
3700   close(FL) || die("close: $!\n");
3701   exit(0);
3702 }
3703
3704 if ($cmdline_list) {
3705   $SIG{'ALRM'} = sub {die("network timeout\n");};
3706   my @syncfiles;
3707   find_source(\@syncfiles, $cmdline_norecurse, 0, @config_source);
3708   send_fin();
3709   filelist_from_file(\@syncfiles, $cmdline_use_filelist) if defined $cmdline_use_filelist;
3710   for my $f (@syncfiles) {
3711     my $p = substr($f->[2], 0, 1) eq '0' ? '/' : '';
3712     print "$f->[0]$p\n";
3713   }
3714   exit(0);
3715 }
3716
3717 # get the lock
3718
3719 die("need a destination\n") unless defined $basedir;
3720 mkdir_p("$basedir/drpmsync");
3721 sysopen(LOCK, "$basedir/drpmsync/lock", POSIX::O_RDWR|POSIX::O_CREAT, 0666) || die("$basedir/drpmsync/lock: $!\n");
3722 if (!flock(LOCK, LOCK_EX | LOCK_NB)) {
3723   my $lockuser = '';
3724   sysread(LOCK, $lockuser, 1024);
3725   close LOCK;
3726   $lockuser = "somebody else\n" unless $lockuser =~ /.*[\S].*\n$/s;
3727   print "update already in progress by $lockuser";
3728   exit(1);
3729 }
3730 truncate(LOCK, 0);
3731 syswrite(LOCK, "drpmsync[$$]\@$synchost\n");
3732
3733 my ($oldstamp1, $oldstamp2);
3734 if (open(STAMP, '<', "$basedir/drpmsync/timestamp")) {
3735   my $s = '';
3736   if ((sysread(STAMP, $s, 16) || 0) == 16 && $s !~ /[^0-9a-f]/) {
3737     $oldstamp1 = substr($s, 0, 8);
3738     $oldstamp2 = substr($s, 8, 8);
3739   }
3740   close STAMP;
3741 }
3742 $oldstamp1 ||= "00000000";
3743
3744 # clear the wip
3745 if (opendir(WIP, "$basedir/drpmsync/wip")) {
3746   for (readdir(WIP)) {
3747     next if $_ eq '.' || $_ eq '..';
3748     unlink("$basedir/drpmsync/wip/$_") || die("unlink $basedir/drpmsync/wip/$_: $!\n");
3749   }
3750   closedir(WIP);
3751 }
3752
3753 readcache("$basedir/drpmsync/cache");
3754 print "getting state of local tree...\n";
3755 findfiles($basedir, '', 1);
3756 print("cache:  $cachehits hits, $cachemisses misses\n");
3757 writecache("$basedir/drpmsync/cache");
3758
3759 if (!@config_source) {
3760   # just a cache update...
3761   unlink("$basedir/drpmsync/lock");
3762   close(LOCK);
3763   exit(0);
3764 }
3765
3766 mkdir_p("$basedir/drpmsync/wip");
3767
3768 $SIG{'ALRM'} = sub {die("network timeout\n");};
3769
3770 my @syncfiles;
3771 find_source(\@syncfiles, $cmdline_norecurse || $cmdline_use_filelist, 1, @config_source);
3772 filelist_from_file(\@syncfiles, $cmdline_use_filelist) if defined $cmdline_use_filelist;
3773
3774 $config_recvlog = "$basedir/drpmsync/$config_recvlog" if $config_recvlog && $config_recvlog !~ /^\//;
3775 if ($config_recvlog) {
3776   open(RECVLOG, '>>', $config_recvlog) || die("$config_recvlog: $!\n");
3777   select(RECVLOG);
3778   $| = 1;
3779   select(STDOUT);
3780   recvlog("started update from $syncurl");
3781   $SIG{'__DIE__'} = sub {
3782     my $err = $_[0];
3783     $err =~ s/\n$//s;
3784     recvlog($err);
3785     die("$err\n");
3786   };
3787 }
3788
3789 if ($oldstamp1 ne '00000000' && $oldstamp1 gt $newstamp1) {
3790   if ($newstamp1 eq '00000000') {
3791     die("remote tree is incomplete\n");
3792   }
3793   die("remote tree is older than local tree (last completion): ".toiso(hex($newstamp1))." < ".toiso(hex($oldstamp1))."\n");
3794 }
3795 if ($oldstamp2 && $oldstamp2 gt $newstamp2) {
3796   die("remote tree is older than local tree (last start): ".toiso(hex($newstamp2))." < ".toiso(hex($oldstamp2))."\n");
3797 }
3798 open(STAMP, '>', "$basedir/drpmsync/timestamp.new") || die("$basedir/drpmsync/timestamp.new: $!\n");
3799 print STAMP "$oldstamp1$newstamp2\n";
3800 close STAMP;
3801 rename("$basedir/drpmsync/timestamp.new", "$basedir/drpmsync/timestamp");
3802
3803 # change all directories to at least user rwx
3804 for (@syncfiles) {
3805   next if $_->[2] !~ /^0/;
3806   next if (hex(substr($_->[2], 0, 4)) & 0700) == 0700;
3807   $_->[2] = sprintf("0%03x", hex(substr($_->[2], 0, 4)) | 0700).substr($_->[2], 4);
3808 }
3809
3810 printf "local:  ".@files." entries\n";
3811 printf "remote: ".@syncfiles." entries\n";
3812
3813 rsync_adapt_filelist(\@syncfiles) if $syncproto eq 'rsync';
3814
3815 %files = map {$_->[0] => $_} @files;
3816 %syncfiles = map {$_->[0] => $_} @syncfiles;
3817
3818 # 1) create all new directories
3819 # 2) delete all dirs that are now files
3820 # 3) get all rpms and update/delete the associated files
3821 # 4) update all other files
3822 # 5) delete all files/rpms/directories
3823 # 6) set mode/time of directories
3824
3825 # part 1
3826 for my $dir (grep {@$_ == 3} @syncfiles) {
3827   my $d = $files{$dir->[0]};
3828   if ($d) {
3829     next if $d->[2] =~ /^0/;
3830     recvlog_print("- $d->[0]");
3831     unlink("$basedir/$d->[0]") || die("unlink $basedir/$d->[0]: $!\n");
3832   }
3833   recvlog_print("+ $dir->[0]");
3834   mkdir("$basedir/$dir->[0]", 0755) || die("mkdir $basedir/$dir->[0]: $!\n");
3835   fixmodetime("$basedir/$dir->[0]", $dir->[2]);
3836   my @s = lstat("$basedir/$dir->[0]");
3837   die("$basedir/$dir->[0]: $!\n") unless @s;
3838   $files{$dir->[0]} = [ $dir->[0], "$s[9]/$s[7]/$s[1]", sprintf("0%03x%08x", ($s[2] & 07777), $s[9]) ];
3839   dirchanged($dir->[0]);
3840 }
3841
3842 # part 2
3843 @files = sort {$a->[0] cmp $b->[0]} values %files;
3844 for my $dir (grep {@$_ == 3} @files) {
3845   my $sd = $syncfiles{$dir->[0]};
3846   next if !$sd || $sd->[2] =~ /^0/;
3847   next unless $files{$dir->[0]};
3848   my @subf = grep {$_->[0] =~ /^\Q$dir->[0]\E\//} @files;
3849   unshift @subf, $dir;
3850   @subf = reverse @subf;
3851   for my $subf (@subf) {
3852     recvlog_print("- $subf->[0]");
3853     if ($subf->[2] =~ /^0/) {
3854       rmdir("$basedir/$subf->[0]") || die("rmdir $basedir/$subf->[0]: $!\n");
3855     } else {
3856       unlink("$basedir/$subf->[0]") || die("unlink $basedir/$subf->[0]: $!\n");
3857     }
3858     repo_del("$basedir/$subf->[0]", $subf) if $config_repo;
3859     delete $files{$subf->[0]};
3860   }
3861   dirchanged($dir->[0]);
3862   @files = sort {$a->[0] cmp $b->[0]} values %files;
3863 }
3864
3865 # part 3
3866 my @syncrpms = grep {@$_ > 5} @syncfiles;
3867 # sort by rpm built date
3868 @syncrpms = sort {$a->[4] cmp $b->[4]} @syncrpms;
3869 for my $rpm (@syncrpms) {
3870   update($basedir, $rpm);
3871   # update meta file(s)
3872   my $rpmname = $rpm->[0];
3873   $rpmname =~ s/\.[sr]pm$//;
3874   for my $afn ("$rpmname.changes", "$rpmname-MD5SUMS.meta", "$rpmname-MD5SUMS.srcdir") {
3875     my $sd = $syncfiles{$afn};
3876     my $d = $files{$afn};
3877     next if !$d && !$sd;
3878     if ($d && !$sd) {
3879       next if $d->[2] =~ /^0/;
3880       recvlog_print("- $d->[0]");
3881       unlink("$basedir/$d->[0]") || die("unlink $basedir/$d->[0]: $!\n");
3882       dirchanged($d->[0]);
3883       delete $files{$d->[0]};
3884     } else {
3885       update($basedir, $sd);
3886     }
3887   }
3888 }
3889
3890 # part 4
3891 for my $file (grep {@$_ == 4} @syncfiles) {
3892   update($basedir, $file);
3893 }
3894
3895 checkjob() if $runningjob;
3896
3897 send_fin();
3898
3899 # part 5
3900 @files = sort {$a->[0] cmp $b->[0]} values %files;
3901 for my $file (grep {!$syncfiles{$_->[0]}} reverse @files) {
3902   recvlog_print("- $file->[0]");
3903   if ($file->[2] =~ /^0/) {
3904     rmdir("$basedir/$file->[0]") || die("rmdir $basedir/$file->[0]: $!\n");
3905   } else {
3906     unlink("$basedir/$file->[0]") || die("unlink $basedir/$file->[0]: $!\n");
3907     repo_del("$basedir/$file->[0]", $file) if $config_repo;
3908   }
3909   dirchanged($file->[0]);
3910   delete $files{$file->[0]};
3911 }
3912
3913 # part 6
3914 for my $dir (grep {@$_ == 3} @syncfiles) {
3915   my $d = $files{$dir->[0]};
3916   next if !$d || $d->[2] eq $dir->[2];
3917   fixmodetime("$basedir/$dir->[0]", $dir->[2]);
3918 }
3919
3920 @files = sort {$a->[0] cmp $b->[0]} values %files;
3921 writecache("$basedir/drpmsync/cache");
3922
3923 if (!$had_gone) {
3924   open(STAMP, '>', "$basedir/drpmsync/timestamp.new") || die("$basedir/drpmsync/timestamp.new: $!\n");
3925   print STAMP "$newstamp1$newstamp2\n";
3926   close STAMP;
3927   rename("$basedir/drpmsync/timestamp.new", "$basedir/drpmsync/timestamp");
3928 }
3929
3930 if (defined($config_delta_max_age)) {
3931   print "removing outdated deltas...\n";
3932   my $nold = 0;
3933   my $cut = time() - 24*60*60*$config_delta_max_age;
3934   if (opendir(PACKS, "$basedir/drpmsync/deltas")) {
3935     my @packs = readdir(PACKS);
3936     closedir(PACKS);
3937     for my $pack (@packs) {
3938       next if $pack eq '.' || $pack eq '..';
3939       next unless opendir(DELTAS, "$basedir/drpmsync/deltas/$pack");
3940       my @deltas = readdir(DELTAS);
3941       closedir(DELTAS);
3942       for my $delta (@deltas) {
3943         next if $delta eq '.' || $delta eq '..';
3944         my @s = stat "$basedir/drpmsync/deltas/$pack/$delta";
3945         next unless @s;
3946         next if $s[9] >= $cut;
3947         unlink("$basedir/drpmsync/deltas/$pack/$delta") || die("unlink $basedir/drpmsync/deltas/$pack/$delta: $!\n");
3948         $nold++;
3949       }
3950     }
3951   }
3952   recvlog_print("removed $nold deltarpms") if $nold;
3953 }
3954 my $net_kbsec = 0;
3955 $net_kbsec = int($net_recv_bytes / 1024 / $net_spent_time) if $net_spent_time;
3956 recvlog("update finished $txbytes/$rvbytes/$sabytes $net_kbsec");
3957 close(RECVLOG) if $config_recvlog;
3958 unlink("$basedir/drpmsync/lock");
3959 close(LOCK);
3960 if ($sabytes == 0) {
3961   printf "update finished, sent %.1f K, received %.1f M\n", $txbytes / 1000, $rvbytes / 1000000;
3962 } elsif ($sabytes < 0) {
3963   printf "update finished, sent %.1f K, received %.1f M, deltarpm excess %.1f M\n", $txbytes / 1000, $rvbytes / 1000000, (-$sabytes) /1000000;
3964 } else {
3965   printf "update finished, sent %.1f K, received %.1f M, deltarpm savings %.1f M\n", $txbytes / 1000, $rvbytes / 1000000, $sabytes /1000000;
3966 }
3967 printf "network throughput %d kbyte/sec\n", $net_kbsec if $net_spent_time;
3968 exit 24 if $had_gone;