file-fetcher.pl

   1 #!/usr/bin/perl -w
   2 use IPC::Run qw(run);
   3
   4 $commits_list = "pld-cvs-commit\@lists.pld-linux.org";
   5
   6 $spool_dir = "./spool";
   7 $copy_dir = "src"; # relative to ftp root
   8 $no_url_dir = "./upload";
   9 $df_server = "distfiles.pld-linux.org";
  10 $df_scp = "plddist\@ep09.pld-linux.org:ftp";
  11 $user_agent = "PLD/distfiles";
  12
  13 @md5 = ();
  14 @url = ();
  15 $problems = "";
  16 $normal_out = "";
  17 $requester = "";
  18 $file = "";
  19 $fetched_count = 0;
  20 $force_reply = 0;
  21 $req_login = "nobody";
  22 $spec = "";
  23 @files = ();
  24
  25 # try lookup some file in spool, exit if it cannot be done
  26 sub find_file_in_spool()
  27 {
  28   opendir(DIR, $spool_dir) || die "can't opendir $spool_dir: $!";
  29   while (1) {
  30     my $f = readdir(DIR);
  31     defined $f or last;
  32     -f "$spool_dir/$f" or next;
  33     $file = "$spool_dir/$f";
  34     last;
  35   }
  36   closedir(DIR);
  37
  38   exit 0 if ($file eq "");
  39 }
  40
  41 # read file from spool, and try unlink it. if cannot unlink -- exit
  42 # sets $requester (email), $problems, @md5 (arrays of md5's)
  43 # and @url (map from md5 to urls)
  44 sub read_spool_file()
  45 {
  46   open(F, "< $file") || exit 0;
  47   $requester = <F>;
  48   chomp $requester;
  49   $requester =~ /^[a-zA-Z_0-9@.-]+$/
  50         or die "$file: evil requester: $requester";
  51   $req_login = "";
  52   $requester =~ /^([^@]+)\@/ and $req_login = $1;
  53   $req_login =~ /^[a-z0-9A-Z_.]+$/ or die "$file: evil requester $requester";
  54   $spec = <F>;
  55   chomp $spec;
  56   $spec =~ s/\.spec$//;
  57
  58   my $flags = <F>;
  59   $force_reply++ if ($flags =~ /force-reply/);
  60
  61   while (<F>) {
  62     if (/^ERROR/) {
  63       s/^ERROR: //;
  64       $problems .= $_;
  65       next;
  66     }
  67     if (/^([a-f0-9]{32})\s+((ftp|http|https|no-url|no-url-copy):\/\/([a-z0-9A-Z;:\=\?&\@\+\~\.,\-\/_]|\%[0-9])+(#\/[a-zA-Z0-9\._-]+)?)\s*$/) {
  68       if (/\/$/) {
  69         $problems .= "$file: cannot fetch dir";
  70       } else {
  71         push @md5, $1;
  72         push @url, $2;
  73       }
  74     } else {
  75         $problems .= "FILE: $file: corrupted";
  76     }
  77   }
  78   close(F);
  79
  80   unlink($file) || exit 0;
  81 }
  82
  83 sub basename($)
  84 {
  85   my $f = shift;
  86   $f =~ s|.*/||;
  87   return $f;
  88 }
  89
  90 sub by_md5($$)
  91 {
  92   my ($md5, $url) = @_;
  93   $md5 =~ /^(.)(.)/;
  94   return "/by-md5/$1/$2/$md5/" . basename($url);
  95 }
  96
  97 sub got_on_distfiles($$)
  98 {
  99   my ($md5, $url) = @_;
 100   my $p = by_md5($md5, $url);
 101   my $l = `lftp -c 'debug 0; open $df_server; quote size $p'`;
 102   return $l =~ /^213 /;
 103 }
 104
 105 sub copy_to_df($$)
 106 {
 107   my ($from, $to) = @_;
 108   my $cmd = "scp -pr -B -q $from $df_scp/$to";
 109   open(E, "$cmd 2>&1 |") or die;
 110   my $oops = "";
 111   while (<E>) {
 112     $oops .= $_;
 113   }
 114   $oops .= "\nThe command has exited with a non-zero status."
 115     unless (close (E));
 116   $problems .= "scp problems: $cmd:\n$oops\n"
 117     if ($oops ne "");
 118   return ($oops ne "");
 119 }
 120
 121 sub move_file($$$)
 122 {
 123   my ($md5, $url, $local_copy) = @_;
 124
 125   my $bn = basename($url);
 126
 127   if ($local_copy ne "$tmp_dir/$md5/$bn") {
 128     if (system("mv -f \"$local_copy\" \"$tmp_dir/$md5/$bn\"")) {
 129       $problems .= "FATAL: cannot move $local_copy to $tmp_dir\n";
 130       return;
 131     }
 132     $local_copy = "$tmp_dir/$md5/$bn";
 133   }
 134
 135   if (open(D, "> $tmp_dir/$md5/$bn.desc")) {
 136     print D "URL: $url\n";
 137     print D "Login: $req_login\n";
 138     print D "MD5: $md5\n";
 139     print D 'Fetched-by: $Id$'."\n";
 140     print D "Time: " . time . "\n";
 141     close(D);
 142   } else {
 143     $problems .= "ERROR: cannot write $bn.desc\n";
 144   }
 145
 146   my $dir = by_md5($md5, $url);
 147   $dir =~ s|/[^/]+/[^/]+$||;
 148   if (copy_to_df("$tmp_dir/$md5/", $dir) == 0) {
 149     $normal_out .=
 150       "STORED: $url\n" .
 151       "\t$md5  " . basename($url) . "\n" .
 152       "\tSize: " .  (-s $local_copy) . " bytes\n";
 153     $fetched_count++;
 154   }
 155 }
 156
 157 sub make_src_symlink($$)
 158 {
 159   my ($md5, $url) = @_;
 160
 161   return unless ($url =~ /^no-url/);
 162
 163   my $b = basename($url);
 164   if (open(S, "> $tmp_dir/$b.link")) {
 165     if ($url =~ /^no-url-copy/) {
 166       print S (".." . by_md5($md5, $url));
 167     } else {
 168       print S "REMOVE";
 169     }
 170     close(S);
 171     copy_to_df("$tmp_dir/$b.link", "$copy_dir/$b.link");
 172   } else {
 173     $problems .= "ERROR: cannot write $tmp_dir/$b.link\n";
 174   }
 175 }
 176
 177 sub md5($)
 178 {
 179   my $file = shift;
 180   my $in = "";
 181   my $md5 = "";
 182   my $err = "";
 183   my @cmd = ("md5sum", $file);
 184
 185   run \@cmd, \$in, \$md5, \$err;
 186   if ($err ne "") {
 187     chomp($err);
 188     $problems .= "FATAL: " . $err . "\n";
 189     return "error";
 190   }
 191   chomp $md5;
 192   $md5 =~ /^([a-f0-9]{32})/ and $md5 = $1;
 193   return $md5;
 194 }
 195
 196 sub handle_no_url($$)
 197 {
 198   my ($md5, $url) = @_;
 199
 200   unless ($url =~ m#://([^/]+)#) {
 201     $problems .= "$url: corrupted! (no-url)";
 202     return;
 203   }
 204   my $basename = $1;
 205   my $file = "$no_url_dir/$req_login/$basename";
 206
 207   if (-f $file) {
 208     my $computed_md5 = md5($file);
 209     if ($computed_md5 ne $md5) {
 210       $problems .= "FATAL: $file md5 mismatch, needed $md5, got $computed_md5\n";
 211     } else {
 212       move_file($md5, $url, $file);
 213       make_src_symlink($md5, $url);
 214     }
 215   } else {
 216     $problems .= "FATAL: $file was not uploaded\n";
 217   }
 218 }
 219
 220 sub fetch_file($$)
 221 {
 222   my ($md5, $url) = @_;
 223   my $out = "";
 224   my $all_out = "";
 225   my $bn = basename($url);
 226   my $local = "$tmp_dir/$md5/$bn";
 227   my $cmd = "wget -nv --no-check-certificate --user-agent=$user_agent -O $local \"$url\"";
 228   my $cmd2 = "wget -nv --no-check-certificate --user-agent=$user_agent --passive-ftp -O $local \"$url\"";
 229
 230   push @files, $bn;
 231
 232   if ( $bn =~ m/(%[0-9a-f]{2})/i ) {
 233     $problems .= "$bn: refusing to download file with uri escape codes ($1) in the name\n";
 234     $bn =~ s/%[0-9a-f]{2}/_/g;
 235     $problems .= "HINT: use $url?/$bn as source to rename the file\n\n";
 236     return;
 237   }
 238
 239   if (got_on_distfiles($md5, $url)) {
 240     $normal_out .=
 241         "ALREADY GOT: $url\n" .
 242         "\t$md5  " . basename($url) . "\n";
 243     make_src_symlink($md5, $url);
 244     return;
 245   }
 246
 247   mkdir("$tmp_dir/$md5");
 248
 249   if ($url =~ /^no-url/) {
 250     handle_no_url($md5, $url);
 251     return;
 252   }
 253
 254   open(W, "$cmd 2>&1 |");
 255   while (<W>) {
 256     $all_out .= $_;
 257     /URL:.*\s+\-\>\s+.*/ and next;
 258     $out .= $_;
 259   }
 260   close(W);
 261   if ($out ne "") {
 262     $problems .= "$cmd:\n$out\n\n";
 263   }
 264   if ( $? ) {
 265     $problems .= sprintf "%s:\nexited with code %d (0x%02x)\n\n",
 266       $cmd,
 267       $? >> 8,
 268       $? & 0xff;
 269   }
 270   if (-f $local && -s $local == 0 && $url =~ /^ftp:/) {
 271     $out = "";
 272     open(W, "$cmd2 2>&1 |");
 273     while (<W>) {
 274       $all_out .= "\n\t\t$_";
 275       /URL:.*\s+\-\>\s+.*/ and next;
 276       $out .= $_;
 277     }
 278     close(W);
 279     if ($out ne "") {
 280       $problems .= "$cmd2:\n$out\n\n";
 281     }
 282     if ( $? ) {
 283       $problems .= sprintf "%s:\nexited with code %d (0x%02x)\n\n",
 284         $cmd2,
 285         $? >> 8,
 286         $? & 0xff;
 287     }
 288   }
 289   if (-r $local && -s $local > 0) {
 290     my $computed_md5 = md5($local);
 291     if ($computed_md5 ne $md5) {
 292       $problems .= "FATAL: $url md5 mismatch, needed $md5, got $computed_md5\n";
 293     } else {
 294       my $testcmd = "file \"$local\" |";
 295       my $testres = "";
 296       if ($url =~ /^(http|https):/ && $local =~ /\.(tar\.(bz2|gz)|tgz|zip|jar|xpi)$/) {
 297         open(T, $testcmd) or die;
 298         $testres = <T>;
 299         close(T);
 300       }
 301       if ($testres =~ /empty|(ASCII|HTML|SGML).*text/) {
 302         $testres =~ s/.*://;
 303         $problems .= "FATAL: data returned from $url: $testres";
 304       } else {
 305         move_file($md5, $url, $local);
 306       }
 307     }
 308   } elsif (-f $local && -s $local > 0) {
 309     $problems .= "FATAL: $url ($md5) was not fetched correctly ($cmd: $all_out): file is not readable\n";
 310   } elsif (-f $local && not -s $local) {
 311     $problems .= "FATAL: $url ($md5) was not fetched correctly ($cmd: $all_out): file fetched but has 0 length\n";
 312   } else {
 313     $problems .= "FATAL: $url ($md5) was not fetched correctly ($cmd: $all_out)\n";
 314   }
 315   # save space
 316   unlink($local);
 317 }
 318
 319 sub fetch_files()
 320 {
 321   $problems .= "\n\n" if ($problems ne "");
 322   foreach $i (0..$#md5) {
 323     fetch_file($md5[$i], $url[$i]);
 324   }
 325 }
 326
 327 sub send_email()
 328 {
 329   open(EMAIL, "| /usr/sbin/sendmail -t");
 330   #open(EMAIL, "| cat");
 331   my $marker = "";
 332   if ($problems ne "") {
 333     $marker = "ERRORS: ";
 334   }
 335   my $req_login;
 336   $requester =~ /^(.*)\@/ and $req_login = $1;
 337
 338   splice(@files, 10, @files - 10, "...")
 339     if (@files > 10);
 340
 341   print EMAIL
 342 "From: $req_login <$requester>
 343 To: $commits_list
 344 Cc: $requester
 345 Subject: DISTFILES: ${spec}: ${marker}@{files}
 346 Message-ID: <$$." . time . "\@distfiles.pld-linux.org>
 347 X-distfiles-program: file-fetcher.pl
 348 X-distfiles-version: " . '$Id$' . "
 349
 350 $problems
 351 Files fetched: $fetched_count
 352
 353 $normal_out
 354
 355 --
 356 Virtually Yours: distfiles.
 357 ";
 358   close(EMAIL) or die;
 359 }
 360
 361 sub make_tmp_dir()
 362 {
 363   my $id = `uuidgen 2>/dev/null`;
 364   chomp $id;
 365   $id = rand if (!defined $id or $id eq "");
 366   $tmp_dir = "./tmp/$id";
 367   mkdir($tmp_dir) or die;
 368 }
 369
 370 sub clean_tmp_dir()
 371 {
 372   system("rm -rf $tmp_dir")
 373     if ($tmp_dir ne "" && -d $tmp_dir);
 374 }
 375
 376 umask(002);
 377
 378 find_file_in_spool();
 379 read_spool_file();
 380 make_tmp_dir();
 381 fetch_files();
 382 send_email() unless (!$force_reply and $problems eq "" and $fetched_count == 0);
 383 clean_tmp_dir();
 384
 385 # vim: ts=2:sw=2:et:fdm=marker