#!/usr/bin/perl

use strict;
use warnings;

use URI;

sub find_archive
  {
    my $name = shift;
    return $name if -d $name;
    my $location = `tla whereis-archive $name`;
    chomp $location;
    return $location;
  }

my $from;
my $to;

if (scalar @ARGV == 2)
  {
    $from = find_archive(shift);
    $to = find_archive(shift);
  }
elsif (scalar @ARGV == 1)
  {
    $from = shift;
    $to = $from . "-MIRROR";
    $from = find_archive($from);
    $to = find_archive($to);
  }
else
  {
    print <<END;
tla-rsync-mirror FROM TO
tla-rsync-mirror ARCHIVE

FROM and TO can be paths or archive names

ARCHIVE must be a single archive name, for which either a -MIRROR or a
-MIRROR-FROM exists.
END
    exit 0;
  }

die "Couldn't find FROM path" unless $from;
die "Couldn't find TO path" unless $to;

sub process_location
  {
    my $location = shift;
    my $uri = URI->new($location, "file");
    if (not defined $uri->scheme or $uri->scheme eq "file")
      {
        return $uri->path;
      }
    elsif ($uri->scheme eq "sftp")
      {
        $uri->opaque =~ m,^//([^/]+)/(.*)$, or die "Failed to parse sftp URI: $uri";
        my $host = $1;
        my $path = $2;
        return "$1:/$2";
      }
    die "Don't know how to handle URI scheme " . $uri->scheme;
  }

# Blindly append a trailing / in order to avoid problems with rsync's
# idiosyncratic handling of trailing slashes.

$from = process_location($from) . "/";
$to = process_location($to) . "/";

$ENV{RSYNC_RSH} = "ssh";
system("rsync", "-vtr", "--delete", "--delete-after", "--exclude", "=meta-info", $from, $to);
