| 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; |