file-fetcher.pl

   1 #!/usr/bin/perl -w
   2 #
   3
   4 use IPC::Run qw(run);
   5
   6 $commits_list = "pld-cvs-commit\@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\@$df_server:ftp";
  13
  14 @md5 = ();
  15 %url = ();
  16 $problems = "";
  17 $normal_out = "";
  18 $requester = "";
  19 $file = "";
  20 $fetched_count = 0;
  21 $force_reply = 0;
  22 $req_login = "nobody";
  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   my $flags = <F>;
  55   $force_reply++ if ($flags =~ /force-reply/);
  56
  57   while (<F>) {
  58     if (/^ERROR/) {
  59       s/^ERROR: //;
  60       $problems .= $_;
  61       next;
  62     }
  63     /^([a-f0-9]{32})\s+((ftp|http|no-url|no-url-copy):\/\/([=\@\?a-z0-9A-Z:\+\~\.\-\/_]|\%[0-9])+)\s*$/
  64         or die "$file: corrupted";
  65     push @md5, $1;
  66     $url{$1} = $2;
  67     /\/$/ and die "$file: cannot fetch dir";
  68   }
  69   close(F);
  70
  71   unlink($file) || exit 0;
  72 }
  73
  74 sub basename($)
  75 {
  76   my $f = shift;
  77   $f =~ s|.*/||;
  78   return $f;
  79 }
  80
  81 sub by_md5($$)
  82 {
  83   my ($md5, $url) = @_;
  84   $md5 =~ /^(.)(.)/;
  85   return "/by-md5/$1/$2/$md5/" . basename($url);
  86 }
  87
  88 sub got_on_distfiles($$)
  89 {
  90   my ($md5, $url) = @_;
  91   my $p = by_md5($md5, $url);
  92   my $l = `lftp -c 'debug 0; open $df_server; quote size $p'`;
  93   return $l =~ /^213 /;
  94 }
  95
  96 sub copy_to_df($$)
  97 {
  98   my ($from, $to) = @_;
  99   my $cmd = "scp -r -B -q $from $df_scp/$to";
 100   open(E, "$cmd 2>&1 |") or die;
 101   my $oops = "";
 102   while (<E>) {
 103     $oops .= $_;
 104   }
 105   close(E);
 106   $problems .= "scp problems: $cmd:\n$oops\n"
 107     if ($oops ne "");
 108   return ($oops ne "");
 109 }
 110
 111 sub move_file($$$)
 112 {
 113   my ($md5, $url, $local_copy) = @_;
 114
 115   my $bn = basename($url);
 116
 117   if ($local_copy ne "$tmp_dir/$md5/$bn") {
 118     if (system("mv -f \"$local_copy\" \"$tmp_dir/$md5/$bn\"")) {
 119       $problems .= "FATAL: cannot move $local_copy to $tmp_dir\n";
 120       return;
 121     }
 122     $local_copy = "$tmp_dir/$md5/$bn";
 123   }
 124
 125   if (open(D, "> $tmp_dir/$md5/$bn.desc")) {
 126     print D "URL: $url\n";
 127     print D "Login: $req_login\n";
 128     print D "MD5: $md5\n";
 129     print D 'Fetched-by: $Id$'."\n";
 130     print D "Time: " . time . "\n";
 131     close(D);
 132   } else {
 133     $problems .= "ERROR: cannot write $bn.desc\n";
 134   }
 135
 136   my $dir = by_md5($md5, $url);
 137   $dir =~ s|/[^/]+/[^/]+$||;
 138   if (copy_to_df("$tmp_dir/$md5/", $dir) == 0) {
 139     $normal_out .=
 140       "STORED: $url\n" .
 141       "\t$md5  " . basename($url) . "\n" .
 142       "\tSize: " .  (-s $local_copy) . " bytes\n";
 143     $fetched_count++;
 144   }
 145 }
 146
 147 sub make_src_symlink($$)
 148 {
 149   my ($md5, $url) = @_;
 150
 151   return unless ($url =~ /^no-url/);
 152
 153   my $b = basename($url);
 154   if (open(S, "> $tmp_dir/$b.link")) {
 155     if ($url =~ /^no-url-copy/) {
 156       print S (".." . by_md5($md5, $url));
 157     } else {
 158       print S "REMOVE";
 159     }
 160     close(S);
 161     copy_to_df("$tmp_dir/$b.link", "$copy_dir/$b.link");
 162   } else {
 163     $problems .= "ERROR: cannot write $tmp_dir/$b.link\n";
 164   }
 165 }
 166
 167 sub md5($)
 168 {
 169   my $file = shift;
 170   my $in = "";
 171   my $md5 = "";
 172   my $err = "";
 173   my @cmd = ("md5sum", $file);
 174
 175   run \@cmd, \$in, \$md5, \$err;
 176   if ($err ne "") {
 177     chomp($err);
 178     $problems .= "FATAL: " . $err . "\n";
 179     return "error";
 180   }
 181   chomp $md5;
 182   $md5 =~ /^([a-f0-9]{32})/ and $md5 = $1;
 183   return $md5;
 184 }
 185
 186 sub handle_no_url($$)
 187 {
 188   my ($md5, $url) = @_;
 189
 190   $url =~ m|://([^/]+)| or die "corrupted! (no-url)";
 191   my $basename = $1;
 192   my $file = "$no_url_dir/$req_login/$basename";
 193
 194   if (-f $file) {
 195     my $computed_md5 = md5($file);
 196     if ($computed_md5 ne $md5) {
 197       $problems .= "FATAL: $file md5 mismatch, needed $md5, got $computed_md5\n";
 198     } else {
 199       move_file($md5, $url, $file);
 200       make_src_symlink($md5, $url);
 201     }
 202   } else {
 203     $problems .= "FATAL: $file was not uploaded\n";
 204   }
 205 }
 206
 207 sub fetch_file($$)
 208 {
 209   my ($md5, $url) = @_;
 210   my $out = "";
 211   my $all_out = "";
 212   my $bn = basename($url);
 213   my $local = "$tmp_dir/$md5/$bn";
 214   my $cmd = "wget -nv -O $local \"$url\"";
 215   my $cmd2 = "wget -nv --passive-ftp -O $local \"$url\"";
 216
 217   push @files, $bn;
 218
 219   if (got_on_distfiles($md5, $url)) {
 220     $normal_out .=
 221         "ALREADY GOT: $url\n" .
 222         "\t$md5  " . basename($url) . "\n";
 223     make_src_symlink($md5, $url);
 224     return;
 225   }
 226
 227   mkdir("$tmp_dir/$md5") or die;
 228
 229   if ($url =~ /^no-url/) {
 230     handle_no_url($md5, $url);
 231     return;
 232   }
 233
 234   open(W, "$cmd 2>&1 |");
 235   while (<W>) {
 236     $all_out .= $_;
 237     /URL:.*\s+\-\>\s+.*/ and next;
 238     $out .= $_;
 239   }
 240   close(W);
 241   if ($out ne "") {
 242     $problems .= "$cmd:\n$out\n\n";
 243   }
 244   if (-f $local && -s $local == 0 && $url =~ /^ftp:/) {
 245     $out = "";
 246     open(W, "$cmd2 2>&1 |");
 247     while (<W>) {
 248       $all_out .= "\n\t\t$_";
 249       /URL:.*\s+\-\>\s+.*/ and next;
 250       $out .= $_;
 251     }
 252     close(W);
 253     if ($out ne "") {
 254       $problems .= "$cmd:\n$out\n\n";
 255     }
 256   }
 257   if (-r $local && -s $local > 0) {
 258     my $computed_md5 = md5($local);
 259     if ($computed_md5 ne $md5) {
 260       $problems .= "FATAL: $url md5 mismatch, needed $md5, got $computed_md5\n";
 261     } else {
 262       my $testcmd = "file \"$local\" |";
 263       my $testres = "";
 264       if ($url =~ /^http:/ && $local =~ /\.(tar\.(bz2|gz)|tgz|zip|jar|xpi)$/) {
 265         open(T, $testcmd) or die;
 266         $testres = <T>;
 267         close(T);
 268       }
 269       if ($testres =~ /empty|(ASCII|HTML|SGML).*text/) {
 270         $testres =~ s/.*://;
 271         $problems .= "FATAL: data returned from $url: $testres";
 272       } else {
 273         move_file($md5, $url, $local);
 274       }
 275     }
 276   } elsif (-f $local && -s $local > 0) {
 277     $problems .= "FATAL: $url ($md5) was not fetched ($cmd: $all_out): file is not readable\n";
 278   } else {
 279     $problems .= "FATAL: $url ($md5) was not fetched ($cmd: $all_out)\n";
 280   }
 281   # save space
 282   unlink($local);
 283 }
 284
 285 sub fetch_files()
 286 {
 287   $problems .= "\n\n" if ($problems ne "");
 288   foreach $md5 (@md5) {
 289     fetch_file($md5, $url{$md5});
 290   }
 291 }
 292
 293 sub send_email()
 294 {
 295   open(EMAIL, "| /usr/sbin/sendmail -t");
 296   #open(EMAIL, "| cat");
 297   my $marker = "";
 298   if ($problems ne "") {
 299     $marker = "ERRORS: ";
 300   }
 301   my $req_login;
 302   $requester =~ /^(.*)\@/ and $req_login = $1;
 303
 304   splice(@files, 10, @files - 10, "...")
 305     if (@files > 10);
 306
 307   print EMAIL
 308 "From: $req_login <$requester>
 309 To: $commits_list
 310 Cc: $requester
 311 Subject: DISTFILES: ${marker}@{files}
 312 Message-ID: <$$." . time . "\@distfiles.pld-linux.org>
 313 X-distfiles-program: file-fetcher.pl
 314 X-distfiles-version: " . '$Id$' . "
 315
 316 $problems
 317 Files fetched: $fetched_count
 318
 319 $normal_out
 320
 321 --
 322 Virtually Yours: distfiles.
 323 ";
 324   close(EMAIL) or die;
 325 }
 326
 327 sub make_tmp_dir()
 328 {
 329   my $id = `uuidgen 2>/dev/null`;
 330   chomp $id;
 331   $id = rand if (!defined $id or $id eq "");
 332   $tmp_dir = "./tmp/$id";
 333   mkdir($tmp_dir) or die;
 334 }
 335
 336 sub clean_tmp_dir()
 337 {
 338   system("rm -rf $tmp_dir")
 339     if ($tmp_dir ne "" && -d $tmp_dir);
 340 }
 341
 342 umask(002);
 343
 344 find_file_in_spool();
 345 read_spool_file();
 346 make_tmp_dir();
 347 fetch_files();
 348 send_email() unless (!$force_reply and $problems eq "" and $fetched_count == 0);
 349 clean_tmp_dir();