--- /dev/null
+#! /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;
~mdw / profile / commitdiff