file-fetcher.pl

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