From 94275284d2cd640eba70d101c3b3723a72177117 Mon Sep 17 00:00:00 2001 Message-Id: <94275284d2cd640eba70d101c3b3723a72177117.1716686894.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sat, 30 May 2020 13:12:57 +0100 Subject: [PATCH] pl/DisOrder.pm: Extract and enhance the DisOrder protocol machinery. Organization: Straylight/Edgeware From: Mark Wooding --- Makefile | 2 + bin/disorder-propagate-autoplay | 148 +------------------------ pl/DisOrder.pm | 185 ++++++++++++++++++++++++++++++++ 3 files changed, 188 insertions(+), 147 deletions(-) create mode 100644 pl/DisOrder.pm diff --git a/Makefile b/Makefile index 4742ad6..95d0a45 100644 --- a/Makefile +++ b/Makefile @@ -220,6 +220,8 @@ DOTLINKS += .tclshrc .wishrc .wishrc_SRC = tclshrc ## Jukebox things. +MISCLINKS += lib/perl/DisOrder.pm +lib/perl/DisOrder.pm_SRC = pl/DisOrder.pm SCRIPTLINKS += disorder-switch-config SCRIPTLINKS += disorder-propagate-autoplay diff --git a/bin/disorder-propagate-autoplay b/bin/disorder-propagate-autoplay index e70bb6a..be38510 100755 --- a/bin/disorder-propagate-autoplay +++ b/bin/disorder-propagate-autoplay @@ -3,156 +3,10 @@ use autodie qw{:all}; use strict; -use Digest::SHA; -use Socket qw{:DEFAULT :addrinfo}; - -use Data::Dumper; +use DisOrder; (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 (\@$$$) { diff --git a/pl/DisOrder.pm b/pl/DisOrder.pm new file mode 100644 index 0000000..5f72131 --- /dev/null +++ b/pl/DisOrder.pm @@ -0,0 +1,185 @@ +### -*-perl-*- + +use autodie qw{:all}; +use strict; + +use Digest::SHA; +use Exporter qw{import}; +use Socket qw{:DEFAULT :addrinfo}; + +our @EXPORT_OK = qw{get_response0 decode_response get_response + send_command0 send_command + split_fields + connect_to_server}; + +use Data::Dumper; + +sub split_response_code ($) { + my ($st) = @_; + my $c = $st%10; $st = int($st/10); + my $b = $st%10; $st = int($st/10); + my $a = $st; + return ($a, $b, $c); +} + +sub get_response0 ($) { + my ($sk) = @_; + (my $st, my $r) = split ' ', (readline $sk), 2; + chomp $r; + + my ($a, $b, $c) = split_response_code $st; + if ($a == 5) { + if ($c == 5) { return $st, undef; } + else { die "server error: $r"; } + } + elsif ($a != 2) { die "unexpected status code $a"; } + else { return $st, $r; } +} + +sub decode_response ($$$) { + my ($sk, $st, $r) = @_; + my ($a, $b, $c) = split_response_code $st; + + if ($c == 0 || $c == 5 || $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 in $st"; } +} + +sub get_response ($) { + my ($sk) = @_; + my ($st, $r) = get_response0 $sk; + return decode_response $sk, $st, $r; +} + +sub send_command0 ($@) { + 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 $sk "$t\n"; + return get_response0 $sk; +} + +sub send_command ($@) { + my ($sk, @f) = @_; + my ($st, $r) = send_command0 $sk, @f; + return decode_response $sk, $st, $r; +} + +sub split_fields ($) { + my ($l) = @_; + my @f = (); + my $f; + + FIELD: for (;;) { + $l =~ s/^\s*//; + last FIELD if $l eq ""; + 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, $quietp) = @_; + 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) { + die "failed to connect" if $quietp; + 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; +} + +1; -- [mdw]