|
996
|
1 package Language::INTERCAL::Theft;
|
|
|
2
|
|
|
3 # Implementation of "theft protocol" for the INTERcal NETworking
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2007-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Theft.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Socket qw(:DEFAULT :crlf);
|
|
|
19 use FindBin qw($Bin);
|
|
|
20 use File::Spec::Functions qw(catfile);
|
|
|
21 use IO::Socket::INET;
|
|
|
22 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
23 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
24 use Language::INTERCAL::Server '1.-94.-2';
|
|
|
25 use Language::INTERCAL::HostIP '1.-94.-2', qw(find_interfaces);
|
|
|
26
|
|
|
27 use constant DEFAULT_PORT => 64928;
|
|
|
28
|
|
|
29 my $if_cache = 0;
|
|
|
30 my @if_list = ();
|
|
|
31 my %if_map = ();
|
|
|
32
|
|
|
33 sub new {
|
|
|
34 @_ == 5 or croak "Usage: Language::INTERCAL::Theft->new"
|
|
|
35 . "(SERVER, RC, CODE, ARGS)";
|
|
|
36 my ($class, $server, $rc, $code, $args) = @_;
|
|
|
37 my $port;
|
|
|
38 my %options = $rc->program_options('INTERNET');
|
|
|
39 $port = exists $options{PORT} ? $options{PORT}[0] : DEFAULT_PORT;
|
|
|
40 my $host = '127.0.0.1';
|
|
|
41 $port or faint(SP_INTERNET, $host, "INTERNET disabled by configuration");
|
|
|
42 $@ = '';
|
|
|
43 my $id = eval { $server->tcp_socket($host, $port) };
|
|
|
44 if ($@) {
|
|
|
45 my $tf = 'theft-server';
|
|
|
46 my $ftf = catfile($Bin, $tf);
|
|
|
47 -f $ftf and $tf = $ftf;
|
|
|
48 $ftf = catfile(qw(blib script), $tf);
|
|
|
49 -f $ftf and $tf = $ftf;
|
|
|
50 my @I = map { "-I$_" } @INC;
|
|
|
51 system $^X, @I, '-S', $tf, "--port=$port";
|
|
|
52 my $timeout = 10;
|
|
|
53 while ($timeout-- > 0) {
|
|
|
54 select undef, undef, undef, 0.1;
|
|
|
55 $@ = '';
|
|
|
56 $id = eval { $server->tcp_socket($host, $port) };
|
|
|
57 $@ or last;
|
|
|
58 }
|
|
|
59 $@ and faint(SP_INTERNET, $host, $!);
|
|
|
60 }
|
|
|
61 my $t = bless {
|
|
|
62 server => $server,
|
|
|
63 id => $id,
|
|
|
64 host => $host,
|
|
|
65 port => $port,
|
|
|
66 broadcast => {},
|
|
|
67 code => $code,
|
|
|
68 args => $args,
|
|
|
69 }, $class;
|
|
|
70 my $line = $t->_getline;
|
|
|
71 defined $line or faint(SP_INTERNET, $host, "Connection lost");
|
|
|
72 $line =~ /^2/ or faint(SP_INTERNET, $host, $line);
|
|
|
73 _get_interfaces($rc);
|
|
|
74 my $lp = $server->tcp_listen(\&_open, \&_line, \&_close, $t);
|
|
|
75 $t->{victim_port} = $lp;
|
|
|
76 $t->_command("VICTIM $$ ON PORT $lp");
|
|
|
77 $t;
|
|
|
78 }
|
|
|
79
|
|
|
80 sub server {
|
|
|
81 @_ == 1 or croak "Usage: THEFT->server";
|
|
|
82 my ($t) = @_;
|
|
|
83 $t->{server};
|
|
|
84 }
|
|
|
85
|
|
|
86 sub find_theft_servers {
|
|
|
87 @_ == 1 || @_ == 2
|
|
|
88 or croak "Usage: THEFT->find_theft_servers[(BROADCAST)]";
|
|
|
89 my ($t, $bcast) = @_;
|
|
|
90 if (defined $bcast) {
|
|
|
91 $bcast eq INADDR_ANY || $bcast eq INADDR_BROADCAST and $bcast = undef;
|
|
|
92 }
|
|
|
93 my $index = defined $bcast ? $bcast : '';
|
|
|
94 return @{$t->{all_servers}{$index}}
|
|
|
95 if $t->{all_servers}{$index} && $t->{servers_valid}{$index} >= time;
|
|
|
96 # send all requests...
|
|
|
97 my $port = $t->{port};
|
|
|
98 my @sockets = ();
|
|
|
99 my $select = '';
|
|
|
100 for my $item (@if_list) {
|
|
|
101 my ($if, $ip, $bc) = @$item;
|
|
|
102 next if defined $bcast && $bcast ne inet_aton($bc);
|
|
|
103 my $socket = IO::Socket::INET->new(
|
|
|
104 PeerPort => $port,
|
|
|
105 Proto => 'udp',
|
|
|
106 Type => SOCK_DGRAM,
|
|
|
107 Broadcast => 1,
|
|
|
108 ReuseAddr => 1,
|
|
|
109 ) or faint(SP_INTERNET, "broadcast", $!);
|
|
|
110 defined $socket->send('x', 0, pack_sockaddr_in($port, inet_aton($bc)))
|
|
|
111 or faint(SP_INTERNET, "broadcast", $!);
|
|
|
112 vec($select, fileno($socket), 1) = 1;
|
|
|
113 push @sockets, $socket;
|
|
|
114 }
|
|
|
115 # wait for all replies, with a timeout of 5 seconds
|
|
|
116 my $list;
|
|
|
117 my %ips = ();
|
|
|
118 defined $bcast or $ips{inet_ntoa(INADDR_LOOPBACK)} = 1;
|
|
|
119 # 2 seconds should be plenty on a LAN...
|
|
|
120 my $timeout = 2;
|
|
|
121 my $limit = time + $timeout;
|
|
|
122 while ($timeout >= 0 && select($list = $select, undef, undef, $timeout)) {
|
|
|
123 for my $socket (@sockets) {
|
|
|
124 vec($list, fileno($socket), 1) or next;
|
|
|
125 my $buffer = '';
|
|
|
126 my $ip = $socket->recv($buffer, 1, 0)
|
|
|
127 or faint(SP_INTERNET, "broadcast", $!);
|
|
|
128 my ($port, $addr) = unpack_sockaddr_in($ip);
|
|
|
129 $ips{inet_ntoa($addr)} = 1;
|
|
|
130 }
|
|
|
131 $timeout = $limit - time;
|
|
|
132 }
|
|
|
133 my @s = keys %ips;
|
|
|
134 $t->{all_servers}{$index} = \@s;
|
|
|
135 $t->{servers_valid}{$index} = time + 30;
|
|
|
136 return @s;
|
|
|
137 }
|
|
|
138
|
|
|
139 sub make_broadcast {
|
|
|
140 @_ == 2 or croak "THEFT->make_broadcast(ADDR)";
|
|
|
141 my ($t, $addr) = @_;
|
|
|
142 my $ip = inet_aton($addr) or return undef;
|
|
|
143 $ip eq INADDR_ANY || $ip eq INADDR_BROADCAST
|
|
|
144 and return INADDR_BROADCAST;
|
|
|
145 $ip = inet_ntoa($ip);
|
|
|
146 exists $if_map{$ip} or return undef;
|
|
|
147 return $if_map{$ip};
|
|
|
148 }
|
|
|
149
|
|
|
150 sub _getline {
|
|
|
151 my ($t, $id) = @_;
|
|
|
152 my $server = $t->{server};
|
|
|
153 $id = $t->{id} if ! defined $id;
|
|
|
154 $server->progress(0); # in case I'm talking to myself
|
|
|
155 while (1) {
|
|
|
156 my $count = $server->data_count($id, 1);
|
|
|
157 defined $count or return undef;
|
|
|
158 $count and return $server->write_in($id, 0);
|
|
|
159 $server->progress(0.01); # in case I'm talking to myself
|
|
|
160 }
|
|
|
161 }
|
|
|
162
|
|
|
163 sub _putline {
|
|
|
164 my ($t, $line, $id) = @_;
|
|
|
165 my $server = $t->{server};
|
|
|
166 $id = $t->{id} if ! defined $id;
|
|
|
167 $server->read_out($id, $line);
|
|
|
168 $server->progress(0); # in case I'm talking to myself
|
|
|
169 }
|
|
|
170
|
|
|
171 sub _get_interfaces {
|
|
|
172 my ($rc) = @_;
|
|
|
173 return if $if_cache;
|
|
|
174 %if_map = ();
|
|
|
175 @if_list = ();
|
|
|
176 my %options = $rc->program_options('INTERNET');
|
|
|
177 if (keys %options) {
|
|
|
178 require Net::Netmask;
|
|
|
179 for my $name (keys %options) {
|
|
|
180 $name =~ /^DEVICE\.(.*)$/ or next;
|
|
|
181 my $if = $1;
|
|
|
182 my ($ip, $map) = @{$options{$name}};
|
|
|
183 my $pack = inet_aton($ip) or next;
|
|
|
184 @{$map->{''}} or next;
|
|
|
185 my ($bits) = @{$map->{''}};
|
|
|
186 my $net = new2 Net::Netmask("$ip/$bits") or next;
|
|
|
187 my $bc = $net->broadcast;
|
|
|
188 my $pbc = inet_aton($bc) or next;
|
|
|
189 $if_map{$bc} = $pbc;
|
|
|
190 push @if_list, [$if, $ip, $bc];
|
|
|
191 $if_cache = 1;
|
|
|
192 }
|
|
|
193 }
|
|
|
194 return if $if_cache;
|
|
|
195 my $if = find_interfaces;
|
|
|
196 for my $name (keys %$if) {
|
|
|
197 $if->{$name}{addr} or next;
|
|
|
198 my $ip = inet_aton($if->{$name}{addr}) or next;
|
|
|
199 $if->{$name}{bcast} or next;
|
|
|
200 my $pbc = inet_aton($if->{$name}{bcast}) or next;
|
|
|
201 my $bc = inet_ntoa($pbc);
|
|
|
202 $if_map{$bc} = $pbc;
|
|
|
203 push @if_list, [$name, $ip, $bc];
|
|
|
204 }
|
|
|
205 $if_cache = 1;
|
|
|
206 }
|
|
|
207
|
|
|
208 sub _command {
|
|
|
209 @_ == 2 || @_ == 3
|
|
|
210 or croak "Usage: THEFT->_command(COMMAND [, ID])";
|
|
|
211 my ($t, $cmd, $id) = @_;
|
|
|
212 $t->_putline($cmd, $id);
|
|
|
213 my $reply = $t->_getline($id);
|
|
|
214 defined $reply or faint(SP_INTERNET, $t->{host}, "($cmd) Connection lost");
|
|
|
215 $reply =~ /^2/ or faint(SP_INTERNET, $t->{host}, $reply);
|
|
|
216 $reply;
|
|
|
217 }
|
|
|
218
|
|
|
219 sub _getlist {
|
|
|
220 @_ == 1 || @_ == 2 or croak "Usage: THEFT->_getlist [(ID)]";
|
|
|
221 my ($t, $id) = @_;
|
|
|
222 my @list = ();
|
|
|
223 while (1) {
|
|
|
224 my $r = $t->_getline($id);
|
|
|
225 defined $r or faint(SP_INTERNET, $t->{host}, "Connection lost");
|
|
|
226 $r eq '.' and last;
|
|
|
227 push @list, $r;
|
|
|
228 }
|
|
|
229 @list;
|
|
|
230 }
|
|
|
231
|
|
|
232 sub _open {
|
|
|
233 my ($id, $sockhost, $peerhost, $close, $t) = @_;
|
|
|
234 return "201 INTERNET (VICTIM) on $sockhost ($VERSION)";
|
|
|
235 }
|
|
|
236
|
|
|
237 sub _line {
|
|
|
238 my ($server, $id, $close, $line, $t) = @_;
|
|
|
239 if ($line =~ /^\s*(STEAL|SMUGGLE)\s+(\S+)/i) {
|
|
|
240 my $code = $t->{code};
|
|
|
241 return $code->(uc($1), $2, $id, $t, $t->{args});
|
|
|
242 } elsif ($line =~ /^\s*THANKS/i) {
|
|
|
243 $$close = 1;
|
|
|
244 return "251 You are welcome";
|
|
|
245 } else {
|
|
|
246 return "550 Bad request";
|
|
|
247 }
|
|
|
248 }
|
|
|
249
|
|
|
250 sub _close {
|
|
|
251 my ($id, $t) = @_;
|
|
|
252 # nothing to do here
|
|
|
253 }
|
|
|
254
|
|
|
255 sub pids {
|
|
|
256 @_ == 1 || @_ == 2 or croak "Usage: THEFT->pids";
|
|
|
257 my ($t, $server) = @_;
|
|
|
258 my $id = undef;
|
|
|
259 if (defined $server) {
|
|
|
260 $id = $t->{server}->tcp_socket($server, $t->{port});
|
|
|
261 $t->_getline($id);
|
|
|
262 }
|
|
|
263 $t->_command("CASE PID", $id);
|
|
|
264 my @pids = map { /^(\d+)/ ? $1 : () } $t->_getlist($id);
|
|
|
265 defined $id and $t->{server}->tcp_socket_close($id);
|
|
|
266 @pids;
|
|
|
267 }
|
|
|
268
|
|
|
269 sub start_request {
|
|
|
270 @_ == 4 or croak "Usage: THEFT->start_request(HOST, PID, TYPE)";
|
|
|
271 my ($t, $host, $pid, $type) = @_;
|
|
|
272 $type = uc($type);
|
|
|
273 $type eq 'STEAL' || $type eq 'SMUGGLE'
|
|
|
274 or faint(SP_INTERNET, $host, "Invalid type $type");
|
|
|
275 $t->{req_type} = $type;
|
|
|
276 my $id = $t->{server}->tcp_socket($host, $t->{port});
|
|
|
277 $t->_getline($id);
|
|
|
278 my $port = $t->_command("CASE PORT $pid", $id);
|
|
|
279 $t->{server}->tcp_socket_close($id);
|
|
|
280 $port =~ /^520/
|
|
|
281 and faint(SP_INTERNET, $host, "No such PID $pid");
|
|
|
282 $port =~ /^2\d+\s+(\d+)/
|
|
|
283 or faint(SP_INTERNET, $host, "Invalid reply $port");
|
|
|
284 $port = $1;
|
|
|
285 my $request = $t->{server}->tcp_socket($host, $port);
|
|
|
286 $t->_getline($request);
|
|
|
287 $t->{request} = $request;
|
|
|
288 $t;
|
|
|
289 }
|
|
|
290
|
|
|
291 sub finish_request {
|
|
|
292 @_ == 1 or croak "Usage: THEFT->end_request";
|
|
|
293 my ($t) = @_;
|
|
|
294 exists $t->{request} or faint(SP_INTERNET, $t->{host}, "Not in request");
|
|
|
295 my $request = $t->{request};
|
|
|
296 $t->_putline("THANKS", $request);
|
|
|
297 $t->{server}->tcp_socket_close($request);
|
|
|
298 delete $t->{request};
|
|
|
299 $t;
|
|
|
300 }
|
|
|
301
|
|
|
302 sub request {
|
|
|
303 @_ == 2 or croak "Usage: THEFT->request(REGISTER)";
|
|
|
304 my ($t, $reg) = @_;
|
|
|
305 exists $t->{req_type} or faint(SP_INTERNET, $t->{host}, "No TYPE");
|
|
|
306 exists $t->{request} or faint(SP_INTERNET, $t->{host}, "Not in request");
|
|
|
307 my $request = $t->{request};
|
|
|
308 $t->_command($t->{req_type} . ' ' . $reg, $request);
|
|
|
309 return $t->_getlist($request);
|
|
|
310 }
|
|
|
311
|
|
|
312 1;
|
