file-fetcher.pl

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