- fix commits email

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

#!/usr/bin/perl -w
#

$email_cc = "pld-cvs-commit\@pld-linux.org";

$spool_dir = "./spool";
$ftp_dir = "./ftp";
$copy_dir = "src"; # relative to $ftp_dir
$no_url_dir = "./plddfadd";

@md5 = ();
%url = ();
$problems = "";
$normal_out = "";
$requester = "";
$file = "";
$fetched_count = 0;
$force_reply = 0;

# try lookup some file in spool, exit if it cannot be done
sub find_file_in_spool()
{
  opendir(DIR, $spool_dir) || die "can't opendir $spool_dir: $!";
  while (1) {
    my $f = readdir(DIR);
    defined $f or last;
    -f "$spool_dir/$f" or next;
    $file = "$spool_dir/$f";
    last;
  }
  closedir(DIR);

  exit 0 if ($file eq "");
}

# 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)
sub read_spool_file()
{
  open(F, "< $file") || exit 0;
  $requester = <F>;
  chomp $requester;
  $requester =~ /^[a-zA-Z_\-0-9\@\.]+$/ 
	or die "$file: evil requester: $requester";
  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";
  }
  close(F);

  unlink($file) || exit 0;
}

sub file_path($$)
{
  my ($md5, $url) = @_;
  
  $md5 =~ /^(.)(.)/;
  my $md5_dir = "$ftp_dir/by-md5/$1/$2/$md5";
  $url =~ /\/([^\/]+)$/ or die;
  my $basename = $1;
  return "$md5_dir/$basename";
}

sub install_dir
{
  my $dir = shift;
  return if (-e $dir);
  $dir =~ /(.*)\/[^\/]+$/ and install_dir($1);
  mkdir($dir);
}

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);
    }
    
    $normal_out .= "STORED: $url ($md5, " .  (-s $path) . " bytes)\n";
    $fetched_count++;
  }
}

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 ($!) {
    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";
    } else {
      $normal_out .= "Symlink in src/ for $basename already there\n";
    }
  } else {
    unlink($symlink);
    $problems .= "WARNING: Removed symlink $symlink\n";
  }
}

sub md5($)
{
  my $file = shift;
  my $md5 = `md5sum "$file" 2>/dev/null`;
  $md5 =~ /^([a-f0-9]{32})/ and $md5 = $1;
  return $md5;
}

sub handle_no_url($$)
{
  my ($md5, $url) = @_;
  
  $url =~ m|://([^/]+)| or die "corrupted! (no-url)";
  my $basename = $1;
  my $file = "$no_url_dir/$basename";

  if (-f $file) {
    my $computed_md5 = md5($file);
    if ($computed_md5 ne $md5) {
      $problems .= "FATAL: $file md5 mismatch, needed $md5, got $computed_md5\n";
    } else {
      move_file($md5, $url, $file);
      make_src_symlink($md5, $url);
    }
  } else {
    $problems .= "FATAL: $file was not scp'ed\n";
  }
}

sub fetch_file($$)
{
  my ($md5, $url) = @_;
  my $out = "";
  my $cmd = "wget -nv -O tmp/$md5 \"$url\"";

  my $path = file_path($md5, $url);
  if (-f $path) {
    $normal_out .= "ALREADY GOT: $url ($md5, " .  (-s $path) . " bytes)\n";
    make_src_symlink($md5, $url);
    return;
  }
    
  if ($url =~ /^no-url/) {
    handle_no_url($md5, $url);
    return;
  }
  
  open(W, "$cmd 2>&1 |");
  while (<W>) {
    /URL:.*\s+\-\>\s+.*/ and next;
    $out .= $_;
  }
  close(W);
  if ($out ne "") {
    $problems .= "$cmd:\n$out\n\n";
  }
  if (-f "tmp/$md5" && -s "tmp/$md5" > 0) {
    my $computed_md5 = md5("tmp/$md5");
    if ($computed_md5 ne $md5) {
      $problems .= "FATAL: $url md5 mismatch, needed $md5, got $computed_md5\n";
    } else {
      move_file($md5, $url, "tmp/$md5");
    }
  } else {
    $problems .= "FATAL: $url ($md5) was not fetched\n";
  }
  unlink("tmp/$md5");
}

sub fetch_files()
{
  $problems .= "\n\n" if ($problems ne "");
  foreach $md5 (@md5) {
    fetch_file($md5, $url{$md5});
  }
}

sub send_email()
{
  open(EMAIL, "| /usr/sbin/sendmail -t");
  #open(EMAIL, "| cat");
  my $marker = "OK";
  if ($problems ne "") {
    $marker = "ERRORS";
  }
  print EMAIL 
"From: distfiles <feedback\@pld-linux.org>
To: $requester
Cc: $email_cc
Subject: [distfiles] sources fetched $marker
Message-ID: <$$." . time . "\@distfiles.pld-linux.org>
X-distfiles-program: file-fetcher.pl
X-distfiles-version: " . '$Id$' . "

$problems
Files fetched: $fetched_count

$normal_out

-- 
Virtually Yours: distfiles.
";
  close(EMAIL) or die;
}

find_file_in_spool();
read_spool_file();
fetch_files();
send_email() unless (!$force_reply and $problems eq "" and $fetched_count == 0);