Commit | Line | Data |
---|---|---|
94275284 MW |
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; |