mdw@git.distorted.org.uk Git - disorder-toys/blob - DisOrder.pm

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