]> git.pld-linux.org Git - projects/distfiles.git/blobdiff - file-fetcher.pl
- allow ";" in uris
[projects/distfiles.git] / file-fetcher.pl
index 27c45b9602f058ee5a75ff211b3bc4f309649876..c7fdf186b7c621d174f30949dd660b44b02cf8f1 100644 (file)
@@ -1,21 +1,28 @@
 #!/usr/bin/perl -w
-#
+# $Id$
 
-$commits_list = "pld-cvs-commit\@pld-linux.org";
+use IPC::Run qw(run);
+
+$commits_list = "pld-cvs-commit\@lists.pld-linux.org";
 
 $spool_dir = "./spool";
-$ftp_dir = "./ftp";
-$copy_dir = "src"; # relative to $ftp_dir
-$no_url_dir = "./plddfadd";
+$copy_dir = "src"; # relative to ftp root
+$no_url_dir = "./upload";
+$df_server = "distfiles.pld-linux.org";
+$df_scp = "plddist\@ep09.pld-linux.org:ftp";
+$user_agent = "PLD/distfiles";
 
 @md5 = ();
-%url = ();
+@url = ();
 $problems = "";
 $normal_out = "";
 $requester = "";
 $file = "";
 $fetched_count = 0;
 $force_reply = 0;
+$req_login = "nobody";
+$spec = "";
+@files = ();
 
 # try lookup some file in spool, exit if it cannot be done
 sub find_file_in_spool()
@@ -34,86 +41,115 @@ sub find_file_in_spool()
 }
 
 # read file from spool, and try unlink it. if cannot unlink -- exit
-# sets $requester (email), $problems, @md5 (arrays of md5's) 
-# and %url (map from md5 to urls)
+# sets $requester (email), $problems, @md5 (arrays of md5's)
+# and @url (map from md5 to urls)
 sub read_spool_file()
 {
   open(F, "< $file") || exit 0;
   $requester = <F>;
   chomp $requester;
-  $requester =~ /^[a-zA-Z_\-0-9\@\.]+$/ 
+  $requester =~ /^[a-zA-Z_0-9@.-]+$/
        or die "$file: evil requester: $requester";
+  $req_login = "";
+  $requester =~ /^([^@]+)\@/ and $req_login = $1;
+  $req_login =~ /^[a-z0-9A-Z_.]+$/ or die "$file: evil requester $requester";
+  $spec = <F>;
+  $spec =~ s/\.spec$//;
   my $flags = <F>;
   $force_reply++ if ($flags =~ /force-reply/);
-       
+
   while (<F>) {
     if (/^ERROR/) {
       s/^ERROR: //;
       $problems .= $_;
       next;
     }
-    /^([a-f0-9]{32})\s+((ftp|http|no-url|no-url-copy):\/\/([a-z0-9A-Z:\+\~\.\-\/_]|\%[0-9])+)\s*$/ 
-       or die "$file: corrupted";
-    push @md5, $1;
-    $url{$1} = $2;
-    /\/$/ and die "$file: cannot fetch dir";
+    if (/^([a-f0-9]{32})\s+((ftp|http|https|no-url|no-url-copy):\/\/([=\@\?a-z0-9A-Z:\+\~\.,\-\/_]|\%[0-9])+)\s*$/) {
+      if (/\/$/) {
+       $problems .= "$file: cannot fetch dir";
+      } else {
+       push @md5, $1;
+       push @url, $2;
+      }
+    } else {
+       $problems .= "FILE: $file: corrupted";
+    }
   }
   close(F);
 
   unlink($file) || exit 0;
 }
 
-sub file_path($$)
+sub basename($)
+{
+  my $f = shift;
+  $f =~ s|.*/||;
+  return $f;
+}
+
+sub by_md5($$)
 {
   my ($md5, $url) = @_;
-  
   $md5 =~ /^(.)(.)/;
-  my $md5_dir = "$ftp_dir/by-md5/$1/$2/$md5";
-  $url =~ /\/([^\/]+)$/ or die;
-  my $basename = $1;
-  return "$md5_dir/$basename";
+  return "/by-md5/$1/$2/$md5/" . basename($url);
+}
+
+sub got_on_distfiles($$)
+{
+  my ($md5, $url) = @_;
+  my $p = by_md5($md5, $url);
+  my $l = `lftp -c 'debug 0; open $df_server; quote size $p'`;
+  return $l =~ /^213 /;
 }
 
-sub install_dir
+sub copy_to_df($$)
 {
-  my $dir = shift;
-  return if (-e $dir);
-  $dir =~ /(.*)\/[^\/]+$/ and install_dir($1);
-  mkdir($dir);
+  my ($from, $to) = @_;
+  my $cmd = "scp -r -B -q $from $df_scp/$to";
+  open(E, "$cmd 2>&1 |") or die;
+  my $oops = "";
+  while (<E>) {
+    $oops .= $_;
+  }
+  $oops .= "\nThe command has exited with a non-zero status."
+    unless (close (E));
+  $problems .= "scp problems: $cmd:\n$oops\n"
+    if ($oops ne "");
+  return ($oops ne "");
 }
 
 sub move_file($$$)
 {
   my ($md5, $url, $local_copy) = @_;
 
-  my $path = file_path($md5, $url);
-  
-  $path =~ /(.*)\/[^\/]+$/ and install_dir($1);
-  
-  if (system("mv -f \"$local_copy\" \"$path\"")) {
-    $problems .= "FATAL: cannot mv file ($url)\n";
-  } else {
-    if (open(D, "> $path.desc")) {
-      print D "URL: $url\n";
-      print D "MD5: $md5\n";
-      print D 'Fetched-by: $Id$'."\n";
-      print D "Time: " . time . "\n";
-      close(D);
-    } else {
-      $problems .= "ERROR: cannot write $path.desc\n";
-    }
-    
-    # Forg logs
-    $md5 =~ /^(..)/ and my $m2 = $1;
-    $md5 =~ /^(.)(.)/;
-    if (open(L, ">> $ENV{HOME}/.lists/lista_$m2")) {
-      print L "/home/ftp/pub/Linux/distfiles/by-md5/$1/$2/$md5/";
-      $url =~ /\/([^\/]+)$/;
-      print L "$1\n";
-      close(L);
+  my $bn = basename($url);
+
+  if ($local_copy ne "$tmp_dir/$md5/$bn") {
+    if (system("mv -f \"$local_copy\" \"$tmp_dir/$md5/$bn\"")) {
+      $problems .= "FATAL: cannot move $local_copy to $tmp_dir\n";
+      return;
     }
-    
-    $normal_out .= "STORED: $url ($md5, " .  (-s $path) . " bytes)\n";
+    $local_copy = "$tmp_dir/$md5/$bn";
+  }
+
+  if (open(D, "> $tmp_dir/$md5/$bn.desc")) {
+    print D "URL: $url\n";
+    print D "Login: $req_login\n";
+    print D "MD5: $md5\n";
+    print D 'Fetched-by: $Id$'."\n";
+    print D "Time: " . time . "\n";
+    close(D);
+  } else {
+    $problems .= "ERROR: cannot write $bn.desc\n";
+  }
+
+  my $dir = by_md5($md5, $url);
+  $dir =~ s|/[^/]+/[^/]+$||;
+  if (copy_to_df("$tmp_dir/$md5/", $dir) == 0) {
+    $normal_out .=
+      "STORED: $url\n" .
+      "\t$md5  " . basename($url) . "\n" .
+      "\tSize: " .  (-s $local_copy) . " bytes\n";
     $fetched_count++;
   }
 }
@@ -121,37 +157,38 @@ sub move_file($$$)
 sub make_src_symlink($$)
 {
   my ($md5, $url) = @_;
-  my $path = file_path($md5, $url);
-  $path =~ s/.*?by-md5/..\/by-md5/;
-  $url =~ m|://([^/]+)| or die "corrupted! (no-url, copy)";
-  my $basename = $1;
-  my $symlink = "$ftp_dir/$copy_dir/$basename";
-  $! = 0;
-  my $old = readlink $symlink;
-  if ($!) {
+
+  return unless ($url =~ /^no-url/);
+
+  my $b = basename($url);
+  if (open(S, "> $tmp_dir/$b.link")) {
     if ($url =~ /^no-url-copy/) {
-      symlink($path, $symlink);
-      $force_reply++;
-      $normal_out .= "Made symlink in src/ for $basename\n";
-    }
-  } elsif ($url =~ /^no-url-copy/) {
-    if ($old ne $path) {
-      unlink($symlink);
-      symlink($path, $symlink);
-      $problems .= "WARNING: $symlink already existed with value $old, set to $path\n";
+      print S (".." . by_md5($md5, $url));
     } else {
-      $normal_out .= "Symlink in src/ for $basename already there\n";
+      print S "REMOVE";
     }
+    close(S);
+    copy_to_df("$tmp_dir/$b.link", "$copy_dir/$b.link");
   } else {
-    unlink($symlink);
-    $problems .= "WARNING: Removed symlink $symlink\n";
+    $problems .= "ERROR: cannot write $tmp_dir/$b.link\n";
   }
 }
 
 sub md5($)
 {
   my $file = shift;
-  my $md5 = `md5sum "$file" 2>/dev/null`;
+  my $in = "";
+  my $md5 = "";
+  my $err = "";
+  my @cmd = ("md5sum", $file);
+
+  run \@cmd, \$in, \$md5, \$err;
+  if ($err ne "") {
+    chomp($err);
+    $problems .= "FATAL: " . $err . "\n";
+    return "error";
+  }
+  chomp $md5;
   $md5 =~ /^([a-f0-9]{32})/ and $md5 = $1;
   return $md5;
 }
@@ -159,10 +196,13 @@ sub md5($)
 sub handle_no_url($$)
 {
   my ($md5, $url) = @_;
-  
-  $url =~ m|://([^/]+)| or die "corrupted! (no-url)";
+
+  unless ($url =~ m#://([^/]+)#) {
+    $problems .= "$url: corrupted! (no-url)";
+    return;
+  }
   my $basename = $1;
-  my $file = "$no_url_dir/$basename";
+  my $file = "$no_url_dir/$req_login/$basename";
 
   if (-f $file) {
     my $computed_md5 = md5($file);
@@ -173,7 +213,7 @@ sub handle_no_url($$)
       make_src_symlink($md5, $url);
     }
   } else {
-    $problems .= "FATAL: $file was not scp'ed\n";
+    $problems .= "FATAL: $file was not uploaded\n";
   }
 }
 
@@ -181,22 +221,32 @@ sub fetch_file($$)
 {
   my ($md5, $url) = @_;
   my $out = "";
-  my $cmd = "wget -nv -O tmp/$md5 \"$url\"";
+  my $all_out = "";
+  my $bn = basename($url);
+  my $local = "$tmp_dir/$md5/$bn";
+  my $cmd = "wget -nv --no-check-certificate --user-agent=$user_agent -O $local \"$url\"";
+  my $cmd2 = "wget -nv --no-check-certificate --user-agent=$user_agent --passive-ftp -O $local \"$url\"";
+
+  push @files, $bn;
 
-  my $path = file_path($md5, $url);
-  if (-f $path) {
-    $normal_out .= "ALREADY GOT: $url ($md5, " .  (-s $path) . " bytes)\n";
+  if (got_on_distfiles($md5, $url)) {
+    $normal_out .=
+       "ALREADY GOT: $url\n" .
+       "\t$md5  " . basename($url) . "\n";
     make_src_symlink($md5, $url);
     return;
   }
-    
+
+  mkdir("$tmp_dir/$md5");
+
   if ($url =~ /^no-url/) {
     handle_no_url($md5, $url);
     return;
   }
-  
+
   open(W, "$cmd 2>&1 |");
   while (<W>) {
+    $all_out .= $_;
     /URL:.*\s+\-\>\s+.*/ and next;
     $out .= $_;
   }
@@ -204,24 +254,52 @@ sub fetch_file($$)
   if ($out ne "") {
     $problems .= "$cmd:\n$out\n\n";
   }
-  if (-f "tmp/$md5" && -s "tmp/$md5" > 0) {
-    my $computed_md5 = md5("tmp/$md5");
+  if (-f $local && -s $local == 0 && $url =~ /^ftp:/) {
+    $out = "";
+    open(W, "$cmd2 2>&1 |");
+    while (<W>) {
+      $all_out .= "\n\t\t$_";
+      /URL:.*\s+\-\>\s+.*/ and next;
+      $out .= $_;
+    }
+    close(W);
+    if ($out ne "") {
+      $problems .= "$cmd:\n$out\n\n";
+    }
+  }
+  if (-r $local && -s $local > 0) {
+    my $computed_md5 = md5($local);
     if ($computed_md5 ne $md5) {
       $problems .= "FATAL: $url md5 mismatch, needed $md5, got $computed_md5\n";
     } else {
-      move_file($md5, $url, "tmp/$md5");
+      my $testcmd = "file \"$local\" |";
+      my $testres = "";
+      if ($url =~ /^(http|https):/ && $local =~ /\.(tar\.(bz2|gz)|tgz|zip|jar|xpi)$/) {
+        open(T, $testcmd) or die;
+        $testres = <T>;
+        close(T);
+      }
+      if ($testres =~ /empty|(ASCII|HTML|SGML).*text/) {
+        $testres =~ s/.*://;
+        $problems .= "FATAL: data returned from $url: $testres";
+      } else {
+        move_file($md5, $url, $local);
+      }
     }
+  } elsif (-f $local && -s $local > 0) {
+    $problems .= "FATAL: $url ($md5) was not fetched ($cmd: $all_out): file is not readable\n";
   } else {
-    $problems .= "FATAL: $url ($md5) was not fetched\n";
+    $problems .= "FATAL: $url ($md5) was not fetched ($cmd: $all_out)\n";
   }
-  unlink("tmp/$md5");
+  # save space
+  unlink($local);
 }
 
 sub fetch_files()
 {
   $problems .= "\n\n" if ($problems ne "");
-  foreach $md5 (@md5) {
-    fetch_file($md5, $url{$md5});
+  foreach $i (0..$#md5) {
+    fetch_file($md5[$i], $url[$i]);
   }
 }
 
@@ -229,17 +307,21 @@ sub send_email()
 {
   open(EMAIL, "| /usr/sbin/sendmail -t");
   #open(EMAIL, "| cat");
-  my $marker = "OK";
+  my $marker = "";
   if ($problems ne "") {
-    $marker = "ERRORS";
+    $marker = "ERRORS";
   }
   my $req_login;
   $requester =~ /^(.*)\@/ and $req_login = $1;
-  print EMAIL 
+
+  splice(@files, 10, @files - 10, "...")
+    if (@files > 10);
+
+  print EMAIL
 "From: $req_login <$requester>
 To: $commits_list
 Cc: $requester
-Subject: DISTFILES: sources fetched $marker
+Subject: DISTFILES: ${spec}: ${marker}@{files}
 Message-ID: <$$." . time . "\@distfiles.pld-linux.org>
 X-distfiles-program: file-fetcher.pl
 X-distfiles-version: " . '$Id$' . "
@@ -255,7 +337,26 @@ Virtually Yours: distfiles.
   close(EMAIL) or die;
 }
 
+sub make_tmp_dir()
+{
+  my $id = `uuidgen 2>/dev/null`;
+  chomp $id;
+  $id = rand if (!defined $id or $id eq "");
+  $tmp_dir = "./tmp/$id";
+  mkdir($tmp_dir) or die;
+}
+
+sub clean_tmp_dir()
+{
+  system("rm -rf $tmp_dir")
+    if ($tmp_dir ne "" && -d $tmp_dir);
+}
+
+umask(002);
+
 find_file_in_spool();
 read_spool_file();
+make_tmp_dir();
 fetch_files();
 send_email() unless (!$force_reply and $problems eq "" and $fetched_count == 0);
+clean_tmp_dir();
This page took 0.049056 seconds and 4 git commands to generate.