- allow ";" in uris

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

#!/usr/bin/perl -w
# $Id$

use IPC::Run qw(run);

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

$spool_dir = "./spool";
$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 = ();
$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()
{
  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";
  $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;
    }
    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 basename($)
{
  my $f = shift;
  $f =~ s|.*/||;
  return $f;
}

sub by_md5($$)
{
  my ($md5, $url) = @_;
  $md5 =~ /^(.)(.)/;
  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 copy_to_df($$)
{
  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 $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;
    }
    $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++;
  }
}

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/) {
      print S (".." . by_md5($md5, $url));
    } else {
      print S "REMOVE";
    }
    close(S);
    copy_to_df("$tmp_dir/$b.link", "$copy_dir/$b.link");
  } else {
    $problems .= "ERROR: cannot write $tmp_dir/$b.link\n";
  }
}

sub md5($)
{
  my $file = shift;
  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;
}

sub handle_no_url($$)
{
  my ($md5, $url) = @_;

  unless ($url =~ m#://([^/]+)#) {
    $problems .= "$url: corrupted! (no-url)";
    return;
  }
  my $basename = $1;
  my $file = "$no_url_dir/$req_login/$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 uploaded\n";
  }
}

sub fetch_file($$)
{
  my ($md5, $url) = @_;
  my $out = "";
  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;

  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 .= $_;
  }
  close(W);
  if ($out ne "") {
    $problems .= "$cmd:\n$out\n\n";
  }
  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 {
      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 ($cmd: $all_out)\n";
  }
  # save space
  unlink($local);
}

sub fetch_files()
{
  $problems .= "\n\n" if ($problems ne "");
  foreach $i (0..$#md5) {
    fetch_file($md5[$i], $url[$i]);
  }
}

sub send_email()
{
  open(EMAIL, "| /usr/sbin/sendmail -t");
  #open(EMAIL, "| cat");
  my $marker = "";
  if ($problems ne "") {
    $marker = "ERRORS: ";
  }
  my $req_login;
  $requester =~ /^(.*)\@/ and $req_login = $1;

  splice(@files, 10, @files - 10, "...")
    if (@files > 10);

  print EMAIL
"From: $req_login <$requester>
To: $commits_list
Cc: $requester
Subject: DISTFILES: ${spec}: ${marker}@{files}
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;
}

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();