chiark - git - mdw - profile/blob - pl/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                     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 connect_to_server ($;$) {
 106   my ($conf, $quietp) = @_;
 107   my %conf = (connect => ["-unix", "/var/lib/disorder/socket"]);
 108   my @f;
 109
 110   open my $fh, "<", $conf;
 111   LINE: while (<$fh>) {
 112     chomp;
 113     next LINE unless /^\s*[^\s#]/;
 114     (my $k, my @f) = split;
 115     $conf{$k} = \@f;
 116   }
 117   close $fh;
 118   for my $i (qw{ username password })
 119     { die "missing configuration keyword `$i'" unless exists $conf{$i}; }
 120
 121   my $af = AF_UNSPEC;
 122   my @a = $conf{connect}->@*;
 123   die "empty address" unless @a;
 124   if ($a[0] eq "-unix") { $af = AF_UNIX; shift @a; }
 125   elsif ($a[0] eq "-4") { $af = AF_INET; shift @a; }
 126   elsif ($a[0] eq "-6") { $af = AF_INET6; shift @a; }
 127   elsif ($a[0] eq "-") { shift @a; }
 128   die "empty address" unless @a;
 129
 130   my $a;
 131   my @i;
 132   if ($af == AF_UNIX || ($af == AF_UNSPEC && $a[0] =~ m{^/})) {
 133     @i = ({ family => AF_UNIX, addr => pack_sockaddr_un($a[0]) });
 134     shift @a;
 135   } else {
 136     die "missing port" unless @a >= 2;
 137     (my $e, @i) = getaddrinfo $a[0], $a[1],
 138       { family => $af, socktype => SOCK_STREAM };
 139     die "getaddrinfo (host `$a[0]', service `$a[1]'): $e" if $e;
 140     splice @a, 0, 2;
 141   }
 142   die "junk in address" if @a;
 143
 144   my $sk;
 145   my @e;
 146   ADDR: for my $i (@i) {
 147     eval {
 148       socket $sk, $i->{family}, SOCK_STREAM, 0;
 149       connect $sk, $i->{addr};
 150     };
 151     last ADDR unless $@;
 152     close $sk if defined $sk;
 153     push @e, $@->errno;
 154     $sk = undef;
 155   }
 156
 157   unless (defined $sk) {
 158     die "failed to connect" if $quietp;
 159     print STDERR "failed to connect!\n";
 160     for (my $i = 0; $i < @i; $i++) {
 161       if ($i[$i]{family} == AF_UNIX)
 162         { $a = unpack_sockaddr_un $i[$i]{addr}; }
 163       else {
 164         my ($e, $host, $svc) = getnameinfo $i[$i]{addr},
 165           NI_NUMERICHOST | NI_NUMERICSERV;
 166         die "getnameinfo: $e" if $e;
 167         $a = $host . ":" . $svc;
 168       }
 169       print STDERR "\t$a: $e[$i]\n";
 170     }
 171     die "giving up";
 172   }
 173   autoflush $sk 1;
 174
 175   @f = split_fields get_response $sk;
 176   die "expected version 2" unless $f[0] eq "2";
 177   my $h = Digest::SHA->new($f[1]);
 178   $h->add($conf{password}[0], pack "H*", $f[2]);
 179   my $d = $h->hexdigest;
 180   send_command $sk, "user", $conf{username}[0], $d;
 181
 182   return $sk;
 183 }
 184
 185 1;