chiark - git - mdw - profile/blob - bin/disorder-propagate-autoplay

   1 #! /usr/bin/perl -w
   2
   3 use autodie qw{:all};
   4 use strict;
   5
   6 use Digest::SHA;
   7 use Socket qw{:DEFAULT :addrinfo};
   8
   9 use Data::Dumper;
  10
  11 (my $PROG = $0) =~ s:.*/::;
  12
  13 sub get_response ($) {
  14   my ($sk) = @_;
  15   (my $st, my $r) = split ' ', (readline $sk), 2;
  16   chomp $r;
  17   my $c = $st%10; $st = int($st/10);
  18   my $b = $st%10; $st = int($st/10);
  19   my $a = $st;
  20
  21   if ($a == 5) {
  22     if ($c == 5) { return undef; }
  23     else { die "server error: $r"; }
  24   }
  25   elsif ($a != 2) { die "unexpected status code $a"; }
  26   elsif ($c == 0 || $c == 9) { return undef; }
  27   elsif ($c == 1 || $c == 2) { return $r; }
  28   elsif ($c == 3) {
  29     my @r = ();
  30     LINE: for (;;) {
  31       chomp (my $line = readline $sk);
  32       last LINE if $line eq ".";
  33       $line =~ s/^\.//;
  34       push @r, $line;
  35     }
  36     return @r;
  37   } else { die "unexpected format code $c"; }
  38 }
  39
  40 sub send_command ($@) {
  41   my ($sk, @f) = @_;
  42
  43   my $t = "";
  44   for my $f (@f) {
  45     if ($f eq "" || $f =~ /[\\"'\s]/) {
  46       $f =~ s/([\\"])/\\$1/g;
  47       $f = '"' . $f . '"';
  48     }
  49     $t .= " " if $t;
  50     $t .= $f;
  51   }
  52 #print STDERR ";; <$t>\n";
  53   print $sk "$t\n";
  54   return get_response $sk;
  55 }
  56
  57 sub split_fields ($) {
  58   my ($l) = @_;
  59   my @f = ();
  60   my $f;
  61
  62   FIELD: for (;;) {
  63     $l =~ s/^\s*//;
  64     last FIELD unless $l;
  65     if ($l =~ /^(["'])/) {
  66       my $q = $1;
  67       ($f, $l) = $l =~ /^ $q ((?: [^\\$q]+ | \\ .)* ) $q (.*) $/x;
  68       $f =~ s/\\(.)/$1/g;
  69     } else {
  70       ($f, $l) = split ' ', $l, 2; $l //= "";
  71     }
  72     push @f, $f;
  73   }
  74   return @f;
  75 }
  76
  77 sub connect_to_server ($) {
  78   my ($conf) = @_;
  79   my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
  80   my @f;
  81
  82   open my $fh, "<", $conf;
  83   LINE: while (<$fh>) {
  84     chomp;
  85     next LINE unless /^\s*[^\s#]/;
  86     (my $k, my @f) = split;
  87     $conf{$k} = \@f;
  88   }
  89   close $fh;
  90   for my $i (qw{ username password })
  91     { die "missing configuration keyword `$i'" unless exists $conf{$i}; }
  92
  93   my $af = AF_UNSPEC;
  94   my @a = $conf{connect}->@*;
  95   die "empty address" unless @a;
  96   if ($a[0] eq "-unix") { $af = AF_UNIX; shift @a; }
  97   elsif ($a[0] eq "-4") { $af = AF_INET; shift @a; }
  98   elsif ($a[0] eq "-6") { $af = AF_INET6; shift @a; }
  99   elsif ($a[0] eq "-") { shift @a; }
 100   die "empty address" unless @a;
 101
 102   my $a;
 103   my @i;
 104   if ($af == AF_UNIX || ($af == AF_UNSPEC && $a[0] =~ m{^/})) {
 105     @i = ({ family => AF_UNIX, addr => pack_sockaddr_un($a[0]) });
 106     shift @a;
 107   } else {
 108     die "missing port" unless @a >= 2;
 109     (my $e, @i) = getaddrinfo $a[0], $a[1],
 110       { family => $af, socktype => SOCK_STREAM };
 111     die "getaddrinfo (host `$a[0]', service `$a[1]'): $e" if $e;
 112     splice @a, 0, 2;
 113   }
 114   die "junk in address" if @a;
 115
 116   my $sk;
 117   my @e;
 118   ADDR: for my $i (@i) {
 119     eval {
 120       socket $sk, $i->{family}, SOCK_STREAM, 0;
 121       connect $sk, $i->{addr};
 122     };
 123     last ADDR unless $@;
 124     close $sk if defined $sk;
 125     push @e, $@->errno;
 126     $sk = undef;
 127   }
 128
 129   unless (defined $sk) {
 130     print STDERR "failed to connect!\n";
 131     for (my $i = 0; $i < @i; $i++) {
 132       if ($i[$i]{family} == AF_UNIX)
 133         { $a = unpack_sockaddr_un $i[$i]{addr}; }
 134       else {
 135         my ($e, $host, $svc) = getnameinfo $i[$i]{addr},
 136           NI_NUMERICHOST | NI_NUMERICSERV;
 137         die "getnameinfo: $e" if $e;
 138         $a = $host . ":" . $svc;
 139       }
 140       print STDERR "\t$a: $e[$i]\n";
 141     }
 142     die "giving up";
 143   }
 144   autoflush $sk 1;
 145
 146   @f = split_fields get_response $sk;
 147   die "expected version 2" unless $f[0] eq "2";
 148   my $h = Digest::SHA->new($f[1]);
 149   $h->add($conf{password}[0], pack "H*", $f[2]);
 150   my $d = $h->hexdigest;
 151   send_command $sk, "user", $conf{username}[0], $d;
 152
 153   return $sk;
 154 }
 155
 156 sub grobble_dir (\@$$$);
 157
 158 sub grobble_dir (\@$$$) {
 159   my ($list, $sk, $root, $dir) = @_;
 160   my @d;
 161
 162   for my $f (send_command $sk, "files", "$root$dir") {
 163     my ($tail) = $f =~ /\Q$root\E(.*)$/;
 164     die "`$f' not under root `$root'" unless $tail;
 165     push @$list, $tail;
 166   }
 167
 168   for my $d (send_command $sk, "dirs", "$root$dir") {
 169     my ($tail) = $d =~ /\Q$root\E(.*)$/;
 170     die "`$d' not under root `$root'" unless $tail;
 171     push @d, $tail;
 172   }
 173   for my $d (@d) { grobble_dir @$list, $sk, $root, $d; }
 174 }
 175
 176 sub grobble_root ($) {
 177   my ($sk) = @_;
 178   my $root = undef;
 179   my @list = ();
 180
 181   for my $d (send_command $sk, "dirs", "") {
 182     my ($pre, $tail) = $d =~ m{^(.*/)([^/]*)$};
 183     die "no root in `$_'?" unless $pre;
 184     if (!defined $root) { $root = $pre; }
 185     elsif ($root ne $pre) { die "root was `$root'; now it's `$pre'"; }
 186     grobble_dir @list, $sk, $root, $tail;
 187   }
 188   return $root, \@list;
 189 }
 190
 191 sub trim_extension ($) {
 192   my ($f) = @_;
 193   $f =~ s/\.(flac|mp[23]|ogg|wav)$//;
 194   return $f;
 195 }
 196
 197 if (@ARGV != 2) { die "usage: $PROG FROM TO\n"; }
 198 my ($from, $to) = @ARGV;
 199
 200 my $sk = connect_to_server $from;
 201 my ($root0, $list) = grobble_root $sk;
 202 my %black = ();
 203 for my $f (@$list) {
 204   my $pick = send_command $sk, "get", "$root0$f", "pick_at_random";
 205   if (($pick // 1) eq "0") { $black{trim_extension $f} = 1; }
 206 }
 207 close $sk;
 208
 209 $sk = connect_to_server $to;
 210 (my $root1, $list) = grobble_root $sk;
 211 FILE: for my $f (@$list) {
 212   my $pick = send_command $sk, "get", "$root1$f", "pick_at_random";
 213   if (($pick // 1) eq "0") {
 214     next FILE if $black{trim_extension $f};
 215     send_command $sk, "unset", "$root1$f", "pick_at_random";
 216     print STDERR ";; reinstate <$f>\n";
 217   } else {
 218     next FILE unless $black{trim_extension $f};
 219     send_command $sk, "set", "$root1$f", "pick_at_random", 0;
 220     print STDERR ";; blacklist <$f>\n";
 221   }
 222 }
 223 close $sk;