#! /usr/bin/perl -w

use autodie qw{:all};
use strict;

use Digest::SHA;
use Socket qw{:DEFAULT :addrinfo};

use Data::Dumper;

(my $PROG = $0) =~ s:.*/::;

sub get_response ($) {
  my ($sk) = @_;
  (my $st, my $r) = split ' ', (readline $sk), 2;
  chomp $r;
  my $c = $st%10; $st = int($st/10);
  my $b = $st%10; $st = int($st/10);
  my $a = $st;

  if ($a == 5) {
    if ($c == 5) { return undef; }
    else { die "server error: $r"; }
  }
  elsif ($a != 2) { die "unexpected status code $a"; }
  elsif ($c == 0 || $c == 9) { return undef; }
  elsif ($c == 1 || $c == 2) { return $r; }
  elsif ($c == 3) {
    my @r = ();
    LINE: for (;;) {
      chomp (my $line = readline $sk);
      last LINE if $line eq ".";
      $line =~ s/^\.//;
      push @r, $line;
    }
    return @r;
  } else { die "unexpected format code $c"; }
}

sub send_command ($@) {
  my ($sk, @f) = @_;

  my $t = "";
  for my $f (@f) {
    if ($f eq "" || $f =~ /[\\"'\s]/) {
      $f =~ s/([\\"])/\\$1/g;
      $f = '"' . $f . '"';
    }
    $t .= " " if $t;
    $t .= $f;
  }
#print STDERR ";; <$t>\n";
  print $sk "$t\n";
  return get_response $sk;
}

sub split_fields ($) {
  my ($l) = @_;
  my @f = ();
  my $f;

  FIELD: for (;;) {
    $l =~ s/^\s*//;
    last FIELD unless $l;
    if ($l =~ /^(["'])/) {
      my $q = $1;
      ($f, $l) = $l =~ /^ $q ((?: [^\\$q]+ | \\ .)* ) $q (.*) $/x;
      $f =~ s/\\(.)/$1/g;
    } else {
      ($f, $l) = split ' ', $l, 2; $l //= "";
    }
    push @f, $f;
  }
  return @f;
}

sub connect_to_server ($) {
  my ($conf) = @_;
  my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
  my @f;

  open my $fh, "<", $conf;
  LINE: while (<$fh>) {
    chomp;
    next LINE unless /^\s*[^\s#]/;
    (my $k, my @f) = split;
    $conf{$k} = \@f;
  }
  close $fh;
  for my $i (qw{ username password })
    { die "missing configuration keyword `$i'" unless exists $conf{$i}; }

  my $af = AF_UNSPEC;
  my @a = $conf{connect}->@*;
  die "empty address" unless @a;
  if ($a[0] eq "-unix") { $af = AF_UNIX; shift @a; }
  elsif ($a[0] eq "-4") { $af = AF_INET; shift @a; }
  elsif ($a[0] eq "-6") { $af = AF_INET6; shift @a; }
  elsif ($a[0] eq "-") { shift @a; }
  die "empty address" unless @a;

  my $a;
  my @i;
  if ($af == AF_UNIX || ($af == AF_UNSPEC && $a[0] =~ m{^/})) {
    @i = ({ family => AF_UNIX, addr => pack_sockaddr_un($a[0]) });
    shift @a;
  } else {
    die "missing port" unless @a >= 2;
    (my $e, @i) = getaddrinfo $a[0], $a[1],
      { family => $af, socktype => SOCK_STREAM };
    die "getaddrinfo (host `$a[0]', service `$a[1]'): $e" if $e;
    splice @a, 0, 2;
  }
  die "junk in address" if @a;

  my $sk;
  my @e;
  ADDR: for my $i (@i) {
    eval {
      socket $sk, $i->{family}, SOCK_STREAM, 0;
      connect $sk, $i->{addr};
    };
    last ADDR unless $@;
    close $sk if defined $sk;
    push @e, $@->errno;
    $sk = undef;
  }

  unless (defined $sk) {
    print STDERR "failed to connect!\n";
    for (my $i = 0; $i < @i; $i++) {
      if ($i[$i]{family} == AF_UNIX)
	{ $a = unpack_sockaddr_un $i[$i]{addr}; }
      else {
	my ($e, $host, $svc) = getnameinfo $i[$i]{addr},
	  NI_NUMERICHOST | NI_NUMERICSERV;
	die "getnameinfo: $e" if $e;
	$a = $host . ":" . $svc;
      }
      print STDERR "\t$a: $e[$i]\n";
    }
    die "giving up";
  }
  autoflush $sk 1;

  @f = split_fields get_response $sk;
  die "expected version 2" unless $f[0] eq "2";
  my $h = Digest::SHA->new($f[1]);
  $h->add($conf{password}[0], pack "H*", $f[2]);
  my $d = $h->hexdigest;
  send_command $sk, "user", $conf{username}[0], $d;

  return $sk;
}

sub grobble_dir (\@$$$);

sub grobble_dir (\@$$$) {
  my ($list, $sk, $root, $dir) = @_;
  my @d;

  for my $f (send_command $sk, "files", "$root$dir") {
    my ($tail) = $f =~ /\Q$root\E(.*)$/;
    die "`$f' not under root `$root'" unless $tail;
    push @$list, $tail;
  }

  for my $d (send_command $sk, "dirs", "$root$dir") {
    my ($tail) = $d =~ /\Q$root\E(.*)$/;
    die "`$d' not under root `$root'" unless $tail;
    push @d, $tail;
  }
  for my $d (@d) { grobble_dir @$list, $sk, $root, $d; }
}

sub grobble_root ($) {
  my ($sk) = @_;
  my $root = undef;
  my @list = ();

  for my $d (send_command $sk, "dirs", "") {
    my ($pre, $tail) = $d =~ m{^(.*/)([^/]*)$};
    die "no root in `$_'?" unless $pre;
    if (!defined $root) { $root = $pre; }
    elsif ($root ne $pre) { die "root was `$root'; now it's `$pre'"; }
    grobble_dir @list, $sk, $root, $tail;
  }
  return $root, \@list;
}

sub trim_extension ($) {
  my ($f) = @_;
  $f =~ s/\.(flac|mp[23]|ogg|wav)$//;
  return $f;
}

if (@ARGV != 2) { die "usage: $PROG FROM TO\n"; }
my ($from, $to) = @ARGV;

my $sk = connect_to_server $from;
my ($root0, $list) = grobble_root $sk;
my %black = ();
for my $f (@$list) {
  my $pick = send_command $sk, "get", "$root0$f", "pick_at_random";
  if (($pick // 1) eq "0") { $black{trim_extension $f} = 1; }
}
close $sk;

$sk = connect_to_server $to;
(my $root1, $list) = grobble_root $sk;
FILE: for my $f (@$list) {
  my $pick = send_command $sk, "get", "$root1$f", "pick_at_random";
  if (($pick // 1) eq "0") {
    next FILE if $black{trim_extension $f};
    send_command $sk, "unset", "$root1$f", "pick_at_random";
    print STDERR ";; reinstate <$f>\n";
  } else {
    next FILE unless $black{trim_extension $f};
    send_command $sk, "set", "$root1$f", "pick_at_random", 0;
    print STDERR ";; blacklist <$f>\n";
  }
}
close $sk;