file-fetcher.pl

   1 #!/usr/bin/perl -w
   2 #
   3
   4 $commits_list = "pld-cvs-commit\@pld-linux.org";
   5
   6 $spool_dir = "./spool";
   7 $ftp_dir = "./ftp";
   8 $copy_dir = "src"; # relative to $ftp_dir
   9 $no_url_dir = "./plddfadd";
  10
  11 @md5 = ();
  12 %url = ();
  13 $problems = "";
  14 $normal_out = "";
  15 $requester = "";
  16 $file = "";
  17 $fetched_count = 0;
  18 $force_reply = 0;
  19 $req_login = "nobody";
  20 @files = ();
  21
  22 # try lookup some file in spool, exit if it cannot be done
  23 sub find_file_in_spool()
  24 {
  25   opendir(DIR, $spool_dir) || die "can't opendir $spool_dir: $!";
  26   while (1) {
  27     my $f = readdir(DIR);
  28     defined $f or last;
  29     -f "$spool_dir/$f" or next;
  30     $file = "$spool_dir/$f";
  31     last;
  32   }
  33   closedir(DIR);
  34
  35   exit 0 if ($file eq "");
  36 }
  37
  38 # read file from spool, and try unlink it. if cannot unlink -- exit
  39 # sets $requester (email), $problems, @md5 (arrays of md5's)
  40 # and %url (map from md5 to urls)
  41 sub read_spool_file()
  42 {
  43   open(F, "< $file") || exit 0;
  44   $requester = <F>;
  45   chomp $requester;
  46   $requester =~ /^[a-zA-Z_\-0-9\@\.]+$/
  47         or die "$file: evil requester: $requester";
  48   $req_login = "";
  49   $requester =~ /^([^@]+)\@/ and $req_login = $1;
  50   $req_login =~ /^[a-z0-9A-Z_]+$/ or die "$file: evil requester $requester";
  51   my $flags = <F>;
  52   $force_reply++ if ($flags =~ /force-reply/);
  53
  54   while (<F>) {
  55     if (/^ERROR/) {
  56       s/^ERROR: //;
  57       $problems .= $_;
  58       next;
  59     }
  60     /^([a-f0-9]{32})\s+((ftp|http|no-url|no-url-copy):\/\/([a-z0-9A-Z:\+\~\.\-\/_]|\%[0-9])+)\s*$/
  61         or die "$file: corrupted";
  62     push @md5, $1;
  63     $url{$1} = $2;
  64     /\/$/ and die "$file: cannot fetch dir";
  65   }
  66   close(F);
  67
  68   unlink($file) || exit 0;
  69 }
  70
  71 sub basename($)
  72 {
  73   my $f = shift;
  74   $f =~ s|.*/||;
  75   return $f;
  76 }
  77
  78 sub file_path($$)
  79 {
  80   my ($md5, $url) = @_;
  81   $md5 =~ /^(.)(.)/;
  82   return "$ftp_dir/by-md5/$1/$2/$md5/" . basename($url);
  83 }
  84
  85 sub install_dir
  86 {
  87   my $dir = shift;
  88   return if (-e $dir);
  89   $dir =~ /(.*)\/[^\/]+$/ and install_dir($1);
  90   mkdir($dir);
  91 }
  92
  93 sub move_file($$$)
  94 {
  95   my ($md5, $url, $local_copy) = @_;
  96
  97   my $path = file_path($md5, $url);
  98
  99   $path =~ /(.*)\/[^\/]+$/ and install_dir($1);
 100
 101   if (system("mv -f \"$local_copy\" \"$path\"")) {
 102     $problems .= "FATAL: cannot mv file ($url)\n";
 103   } else {
 104     if (open(D, "> $path.desc")) {
 105       print D "URL: $url\n";
 106       print D "MD5: $md5\n";
 107       print D 'Fetched-by: $Id$'."\n";
 108       print D "Time: " . time . "\n";
 109       close(D);
 110     } else {
 111       $problems .= "ERROR: cannot write $path.desc\n";
 112     }
 113
 114     # Forg logs
 115     $md5 =~ /^(..)/ and my $m2 = $1;
 116     $md5 =~ /^(.)(.)/;
 117     if (open(L, ">> $ENV{HOME}/.lists/lista_$m2")) {
 118       print L "/home/ftp/pub/Linux/distfiles/by-md5/$1/$2/$md5/" . basename($url) . "\n";
 119       close(L);
 120     }
 121
 122     $normal_out .=
 123       "STORED: $url\n" .
 124       "\t$md5  " . basename($url) . "\n" .
 125       "\tSize: " .  (-s $path) . " bytes\n";
 126     $fetched_count++;
 127   }
 128 }
 129
 130 sub make_src_symlink($$)
 131 {
 132   my ($md5, $url) = @_;
 133   my $path = file_path($md5, $url);
 134   $path =~ s/.*?by-md5/..\/by-md5/;
 135   $url =~ m|://([^/]+)| or die "corrupted! (no-url, copy)";
 136   my $basename = $1;
 137   my $symlink = "$ftp_dir/$copy_dir/$basename";
 138   $! = 0;
 139   my $old = readlink $symlink;
 140   if ($!) {
 141     if ($url =~ /^no-url-copy/) {
 142       symlink($path, $symlink);
 143       $force_reply++;
 144       $normal_out .= "Made symlink in src/ for $basename\n";
 145     }
 146   } elsif ($url =~ /^no-url-copy/) {
 147     if ($old ne $path) {
 148       unlink($symlink);
 149       symlink($path, $symlink);
 150       $problems .= "WARNING: $symlink already existed with value $old, set to $path\n";
 151     } else {
 152       $normal_out .= "Symlink in src/ for $basename already there\n";
 153     }
 154   } else {
 155     unlink($symlink);
 156     $problems .= "WARNING: Removed symlink $symlink\n";
 157   }
 158 }
 159
 160 sub md5($)
 161 {
 162   my $file = shift;
 163   my $md5 = `md5sum "$file" 2>/dev/null`;
 164   $md5 =~ /^([a-f0-9]{32})/ and $md5 = $1;
 165   return $md5;
 166 }
 167
 168 sub handle_no_url($$)
 169 {
 170   my ($md5, $url) = @_;
 171
 172   $url =~ m|://([^/]+)| or die "corrupted! (no-url)";
 173   my $basename = $1;
 174   my $file = "$no_url_dir/$req_login/$basename";
 175
 176   if (-f $file) {
 177     my $computed_md5 = md5($file);
 178     if ($computed_md5 ne $md5) {
 179       $problems .= "FATAL: $file md5 mismatch, needed $md5, got $computed_md5\n";
 180     } else {
 181       move_file($md5, $url, $file);
 182       make_src_symlink($md5, $url);
 183     }
 184   } else {
 185     $problems .= "FATAL: $file was not uploaded\n";
 186   }
 187 }
 188
 189 sub fetch_file($$)
 190 {
 191   my ($md5, $url) = @_;
 192   my $out = "";
 193   my $cmd = "wget -nv -O tmp/$md5 \"$url\"";
 194
 195   push @files, basename($url);
 196
 197   my $path = file_path($md5, $url);
 198   if (-f $path) {
 199     $normal_out .=
 200         "ALREADY GOT: $url\n" .
 201         "\t$md5  " . basename($url) . "\n" .
 202         "\tSize: " . (-s $path) . " bytes.\n";
 203     make_src_symlink($md5, $url);
 204     return;
 205   }
 206
 207   if ($url =~ /^no-url/) {
 208     handle_no_url($md5, $url);
 209     return;
 210   }
 211
 212   open(W, "$cmd 2>&1 |");
 213   while (<W>) {
 214     /URL:.*\s+\-\>\s+.*/ and next;
 215     $out .= $_;
 216   }
 217   close(W);
 218   if ($out ne "") {
 219     $problems .= "$cmd:\n$out\n\n";
 220   }
 221   if (-f "tmp/$md5" && -s "tmp/$md5" > 0) {
 222     my $computed_md5 = md5("tmp/$md5");
 223     if ($computed_md5 ne $md5) {
 224       $problems .= "FATAL: $url md5 mismatch, needed $md5, got $computed_md5\n";
 225     } else {
 226       move_file($md5, $url, "tmp/$md5");
 227     }
 228   } else {
 229     $problems .= "FATAL: $url ($md5) was not fetched\n";
 230   }
 231   unlink("tmp/$md5");
 232 }
 233
 234 sub fetch_files()
 235 {
 236   $problems .= "\n\n" if ($problems ne "");
 237   foreach $md5 (@md5) {
 238     fetch_file($md5, $url{$md5});
 239   }
 240 }
 241
 242 sub send_email()
 243 {
 244   open(EMAIL, "| /usr/sbin/sendmail -t");
 245   #open(EMAIL, "| cat");
 246   my $marker = "";
 247   if ($problems ne "") {
 248     $marker = "ERRORS: ";
 249   }
 250   my $req_login;
 251   $requester =~ /^(.*)\@/ and $req_login = $1;
 252
 253   splice(@files, 10, @files - 10, "...")
 254     if (@files > 10);
 255
 256   print EMAIL
 257 "From: $req_login <$requester>
 258 To: $commits_list
 259 Cc: $requester
 260 Subject: DISTFILES: ${marker}@{files}
 261 Message-ID: <$$." . time . "\@distfiles.pld-linux.org>
 262 X-distfiles-program: file-fetcher.pl
 263 X-distfiles-version: " . '$Id$' . "
 264
 265 $problems
 266 Files fetched: $fetched_count
 267
 268 $normal_out
 269
 270 --
 271 Virtually Yours: distfiles.
 272 ";
 273   close(EMAIL) or die;
 274 }
 275
 276 find_file_in_spool();
 277 read_spool_file();
 278 fetch_files();
 279 send_email() unless (!$force_reply and $problems eq "" and $fetched_count == 0);