- allow ";" in uris

[projects/distfiles.git] / file-fetcher.pl

diff --git a/file-fetcher.pl b/file-fetcher.pl
index a79d720d798db40b1bcf25333812eac275249ed4..c7fdf186b7c621d174f30949dd660b44b02cf8f1 100644 (file)
--- a/file-fetcher.pl
+++ b/file-fetcher.pl
@@ -1,5 +1,5 @@
 #!/usr/bin/perl -w
-#
+# $Id$
 
 use IPC::Run qw(run);
 
@@ -10,9 +10,10 @@ $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 = "";
@@ -20,6 +21,7 @@ $file = "";
 $fetched_count = 0;
 $force_reply = 0;
 $req_login = "nobody";
+$spec = "";
 @files = ();
 
 # try lookup some file in spool, exit if it cannot be done
@@ -39,32 +41,39 @@ 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";
+  $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|https|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);
 
@@ -114,7 +123,7 @@ sub move_file($$$)
   my ($md5, $url, $local_copy) = @_;
 
   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";
@@ -122,7 +131,7 @@ sub move_file($$$)
     }
     $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";
@@ -137,7 +146,7 @@ sub move_file($$$)
   my $dir = by_md5($md5, $url);
   $dir =~ s|/[^/]+/[^/]+$||;
   if (copy_to_df("$tmp_dir/$md5/", $dir) == 0) {
-    $normal_out .= 
+    $normal_out .=
       "STORED: $url\n" .
       "\t$md5  " . basename($url) . "\n" .
       "\tSize: " .  (-s $local_copy) . " bytes\n";
@@ -148,9 +157,9 @@ sub move_file($$$)
 sub make_src_symlink($$)
 {
   my ($md5, $url) = @_;
-  
+
   return unless ($url =~ /^no-url/);
-  
+
   my $b = basename($url);
   if (open(S, "> $tmp_dir/$b.link")) {
     if ($url =~ /^no-url-copy/) {
@@ -187,8 +196,11 @@ 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/$req_login/$basename";
 
@@ -212,26 +224,26 @@ sub fetch_file($$)
   my $all_out = "";
   my $bn = basename($url);
   my $local = "$tmp_dir/$md5/$bn";
-  my $cmd = "wget -nv --no-check-certificate -O $local \"$url\"";
-  my $cmd2 = "wget -nv --no-check-certificate --passive-ftp -O $local \"$url\"";
+  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;
 
   if (got_on_distfiles($md5, $url)) {
-    $normal_out .= 
+    $normal_out .=
        "ALREADY GOT: $url\n" .
        "\t$md5  " . basename($url) . "\n";
     make_src_symlink($md5, $url);
     return;
   }
 
-  mkdir("$tmp_dir/$md5") or die;
-  
+  mkdir("$tmp_dir/$md5");
+
   if ($url =~ /^no-url/) {
     handle_no_url($md5, $url);
     return;
   }
-  
+
   open(W, "$cmd 2>&1 |");
   while (<W>) {
     $all_out .= $_;
@@ -286,8 +298,8 @@ sub fetch_file($$)
 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]);
   }
 }
 
@@ -304,12 +316,12 @@ sub send_email()
 
   splice(@files, 10, @files - 10, "...")
     if (@files > 10);
-  
-  print EMAIL 
+
+  print EMAIL
 "From: $req_login <$requester>
 To: $commits_list
 Cc: $requester
-Subject: DISTFILES: ${marker}@{files}
+Subject: DISTFILES: ${spec}: ${marker}@{files}
 Message-ID: <$$." . time . "\@distfiles.pld-linux.org>
 X-distfiles-program: file-fetcher.pl
 X-distfiles-version: " . '$Id$' . "