]> dxcluster.net Git - spider.git/blob - perl/ExtMsg.pm
added Windows only BPQ interface from John G8BPQ
[spider.git] / perl / ExtMsg.pm
1 #
2 # This class is the internal subclass that deals with the external port
3 # communications for Msg.pm
4 #
5 # This is where the cluster handles direct connections coming both in
6 # and out
7 #
8 # $Id$
9 #
10 # Copyright (c) 2001 - Dirk Koopman G1TLH
11 #
12 #       Modified Jan 2006 by John Wiseman G8BPQ to support connections to BPQ32 node,
13 #               and fix pattern matching on 'chat' abort handling
14 #
15
16 package ExtMsg;
17
18 use strict;
19 use Msg;
20 use DXVars;
21 use DXUtil;
22 use DXDebug;
23 use IO::File;
24 use IO::Socket;
25 use IPC::Open3;
26
27 use vars qw(@ISA $deftimeout);
28
29 @ISA = qw(Msg);
30 $deftimeout = 60;
31
32 sub login
33 {
34         goto &main::login;        # save some writing, this was the default
35 }
36
37 sub enqueue
38 {
39         my ($conn, $msg) = @_;
40         unless ($msg =~ /^[ABZ]/) {
41                 if ($msg =~ /^E[-\w]+\|([01])/ && $conn->{csort} eq 'telnet') {
42                         $conn->{echo} = $1;
43                         if ($1) {
44 #                               $conn->send_raw("\xFF\xFC\x01");
45                         } else {
46 #                               $conn->send_raw("\xFF\xFB\x01");
47                         }
48                 } else {
49                         $msg =~ s/^[-\w]+\|//;
50                         push (@{$conn->{outqueue}}, $msg . $conn->{lineend});
51                 }
52         }
53 }
54
55 sub send_raw
56 {
57         my ($conn, $msg) = @_;
58     my $sock = $conn->{sock};
59     return unless defined($sock);
60         push (@{$conn->{outqueue}}, $msg);
61         dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect');
62     Msg::set_event_handler ($sock, "write" => sub {$conn->_send(0)});
63 }
64
65 sub echo
66 {
67         my $conn = shift;
68         $conn->{echo} = shift;
69 }
70
71 sub dequeue
72 {
73         my $conn = shift;
74         my $msg;
75
76         if ($conn->{csort} eq 'ax25' && exists $conn->{msg}) {
77                 $conn->{msg} =~ s/\cM/\cJ/g;
78         }
79         if ($conn->{state} eq 'WC') {
80                 if (exists $conn->{cmd}) {
81                         if (@{$conn->{cmd}}) {
82                                 dbg("connect $conn->{cnum}: $conn->{msg}") if isdbg('connect');
83                                 $conn->_docmd($conn->{msg});
84                         } 
85                 }
86                 if ($conn->{state} eq 'WC' && exists $conn->{cmd} && @{$conn->{cmd}} == 0) {
87                         $conn->to_connected($conn->{call}, 'O', $conn->{csort});
88                 }
89         } elsif ($conn->{msg} =~ /\cJ/) {
90                 my @lines =  $conn->{msg} =~ /([^\cM\cJ]*)\cM?\cJ/g;
91                 if ($conn->{msg} =~ /\cJ$/) {
92                         delete $conn->{msg};
93                 } else {
94                         $conn->{msg} =~ s/([^\cM\cJ]*)\cM?\cJ//g;
95                 }
96                 while (defined ($msg = shift @lines)) {
97                         dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect');
98                 
99                         $msg =~ s/\xff\xfa.*\xff\xf0|\xff[\xf0-\xfe].//g; # remove telnet options
100 #                       $msg =~ s/[\x00-\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g;         # immutable CSI sequence + control characters
101                         
102                         if ($conn->{state} eq 'C') {
103                                 &{$conn->{rproc}}($conn, "I$conn->{call}|$msg");
104                         } elsif ($conn->{state} eq 'WL' ) {
105                                 $msg = uc $msg;
106                                 if (is_callsign($msg) && $msg !~ m|/| ) {
107                                         my $sort = $conn->{csort};
108                                         $sort = 'local' if $conn->{peerhost} eq "127.0.0.1";
109                                         my $uref;
110                                         if ($main::passwdreq || ($uref = DXUser->get_current($msg)) && $uref->passwd ) {
111                                                 $conn->conns($msg);
112                                                 $conn->{state} = 'WP';
113                                                 $conn->{decho} = $conn->{echo};
114                                                 $conn->{echo} = 0;
115                                                 $conn->send_raw('password: ');
116                                         } else {
117                                                 $conn->to_connected($msg, 'A', $sort);
118                                         }
119                                 } else {
120                                         $conn->send_now("Sorry $msg is an invalid callsign");
121                                         $conn->disconnect;
122                                 }
123                         } elsif ($conn->{state} eq 'WP' ) {
124                                 my $uref = DXUser->get_current($conn->{call});
125                                 $msg =~ s/[\r\n]+$//;
126                                 if ($uref && $msg eq $uref->passwd) {
127                                         my $sort = $conn->{csort};
128                                         $conn->{echo} = $conn->{decho};
129                                         delete $conn->{decho};
130                                         $sort = 'local' if $conn->{peerhost} eq "127.0.0.1";
131                                         $conn->{usedpasswd} = 1;
132                                         $conn->to_connected($conn->{call}, 'A', $sort);
133                                 } else {
134                                         $conn->send_now("Sorry");
135                                         $conn->disconnect;
136                                 }
137                         } elsif ($conn->{state} eq 'WC') {
138                                 if (exists $conn->{cmd} && @{$conn->{cmd}}) {
139                                         $conn->_docmd($msg);
140                                         if ($conn->{state} eq 'WC' && exists $conn->{cmd} &&  @{$conn->{cmd}} == 0) {
141                                                 $conn->to_connected($conn->{call}, 'O', $conn->{csort});
142                                         }
143                                 }
144                         }
145                 }
146         }
147 }
148
149 sub to_connected
150 {
151         my ($conn, $call, $dir, $sort) = @_;
152         $conn->{state} = 'C';
153         $conn->conns($call);
154         delete $conn->{cmd};
155         $conn->{timeout}->del if $conn->{timeout};
156         delete $conn->{timeout};
157         $conn->nolinger unless $conn->isa('AGWMsg');
158         &{$conn->{rproc}}($conn, "$dir$call|$sort");
159         $conn->_send_file("$main::data/connected") unless $conn->{outgoing};
160 }
161
162 sub new_client {
163         my $server_conn = shift;
164     my $sock = $server_conn->{sock}->accept();
165         if ($sock) {
166                 my $conn = $server_conn->new($server_conn->{rproc});
167                 $conn->{sock} = $sock;
168                 $conn->nolinger;
169                 Msg::blocking($sock, 0);
170                 $conn->{blocking} = 0;
171                 eval {$conn->{peerhost} = $sock->peerhost};
172                 if ($@) {
173                         dbg($@) if isdbg('connll');
174                         $conn->disconnect;
175                 } else {
176                         eval {$conn->{peerport} = $sock->peerport};
177                         $conn->{peerport} = 0 if $@;
178                         my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost}, $conn->{peerport});
179                         dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll');
180                         if ($eproc) {
181                                 $conn->{eproc} = $eproc;
182                                 Msg::set_event_handler ($sock, "error" => $eproc);
183                         }
184                         if ($rproc) {
185                                 $conn->{rproc} = $rproc;
186                                 my $callback = sub {$conn->_rcv};
187                                 Msg::set_event_handler ($sock, "read" => $callback);
188                                 # send login prompt
189                                 $conn->{state} = 'WL';
190                                 #               $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22");
191                                 #               $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0");
192                                 #               $conn->send_raw("\xFF\xFC\x01");
193                                 $conn->_send_file("$main::data/issue");
194                                 $conn->send_raw("login: ");
195                                 $conn->_dotimeout(60);
196                                 $conn->{echo} = 1;
197                         } else { 
198                                 &{$conn->{eproc}}() if $conn->{eproc};
199                                 $conn->disconnect();
200                         }
201                 }
202         } else {
203                 dbg("ExtMsg: error on accept ($!)") if isdbg('err');
204         }
205 }
206
207 sub start_connect
208 {
209         my $call = shift;
210         my $fn = shift;
211         my $conn = ExtMsg->new(\&main::new_channel); 
212         $conn->{outgoing} = 1;
213         $conn->conns($call);
214         
215         my $f = new IO::File $fn;
216         push @{$conn->{cmd}}, <$f>;
217         $f->close;
218         $conn->{state} = 'WC';
219         $conn->_dotimeout($deftimeout);
220         $conn->_docmd;
221 }
222
223 sub _docmd
224 {
225         my $conn = shift;
226         my $msg = shift;
227         my $cmd;
228
229         while ($cmd = shift @{$conn->{cmd}}) {
230                 chomp $cmd;
231                 next if $cmd =~ /^\s*\#/o;
232                 next if $cmd =~ /^\s*$/o;
233                 $conn->_doabort($1) if $cmd =~ /^\s*a\w*\s+(.*)/i;
234                 $conn->_dotimeout($1) if $cmd =~ /^\s*t\w*\s+(\d+)/i;
235                 $conn->_dolineend($1) if $cmd =~ /^\s*[Ll]\w*\s+\'((?:\\[rn])+)\'/i;
236                 if ($cmd =~ /^\s*co\w*\s+(\w+)\s+(.*)$/i) {
237                         unless ($conn->_doconnect($1, $2)) {
238                                 $conn->disconnect;
239                                 @{$conn->{cmd}} = [];    # empty any further commands
240                                 last;
241                         }  
242                 }
243                 if ($cmd =~ /^\s*\'([^\']*)\'\s+\'([^\']*)\'/) {
244                         $conn->_dochat($cmd, $msg, $1, $2);
245                         last;
246                 }
247                 if ($cmd =~ /^\s*cl\w+\s+(.*)/i) {
248                         $conn->_doclient($1);
249                         last;
250                 }
251                 last if $conn->{state} eq 'E';
252         }
253 }
254
255 sub _doconnect
256 {
257         my ($conn, $sort, $line) = @_;
258         my $r;
259
260         $sort = lc $sort;
261         dbg("CONNECT $conn->{cnum} sort: $sort command: $line") if isdbg('connect');
262         if ($sort eq 'telnet') {
263                 # this is a straight network connect
264                 my ($host, $port) = split /\s+/, $line;
265                 $port = 23 if !$port;
266                 $r = $conn->connect($host, $port);
267                 if ($r) {
268                         dbg("Connected $conn->{cnum} to $host $port") if isdbg('connect');
269                 } else {
270                         dbg("***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('connect');
271                 }
272         } elsif ($sort eq 'agw') {
273                 # turn it into an AGW object
274                 bless $conn, 'AGWMsg';
275                 $r = $conn->connect($line);
276         } elsif ($sort eq 'bpq') {
277                 # turn it into an BPQ object
278                 bless $conn, 'BPQMsg';
279                 $r = $conn->connect($line);
280         } elsif ($sort eq 'ax25' || $sort eq 'prog') {
281                 $r = $conn->start_program($line, $sort);
282         } else {
283                 dbg("invalid type of connection ($sort)");
284         }
285         $conn->disconnect unless $r;
286         return $r;
287 }
288
289 sub _doabort
290 {
291         my $conn = shift;
292         my $string = shift;
293         dbg("connect $conn->{cnum}: abort $string") if isdbg('connect');
294         $conn->{abort} = $string;
295 }
296
297 sub _dotimeout
298 {
299         my $conn = shift;
300         my $val = shift;
301         dbg("connect $conn->{cnum}: timeout set to $val") if isdbg('connect');
302         $conn->{timeout}->del if $conn->{timeout};
303         $conn->{timeval} = $val;
304         $conn->{timeout} = Timer->new($val, sub{ &_timedout($conn) });
305 }
306
307 sub _dolineend
308 {
309         my $conn = shift;
310         my $val = shift;
311         dbg("connect $conn->{cnum}: lineend set to $val ") if isdbg('connect');
312         $val =~ s/\\r/\r/g;
313         $val =~ s/\\n/\n/g;
314         $conn->{lineend} = $val;
315 }
316
317 sub _dochat
318 {
319         my $conn = shift;
320         my $cmd = shift;
321         my $line = shift;
322         my $expect = shift;
323         my $send = shift;
324                 
325         if ($line) {
326                 if ($expect) {
327                         dbg("connect $conn->{cnum}: expecting: \"$expect\" received: \"$line\"") if isdbg('connect');
328                         if ($conn->{abort} && $line =~ /$conn->{abort}/i) {
329                                 dbg("connect $conn->{cnum}: aborted on /$conn->{abort}/") if isdbg('connect');
330                                 $conn->disconnect;
331                                 delete $conn->{cmd};
332                                 return;
333                         }
334                         if ($line =~ /\Q$expect/i) {
335                                 if (length $send) {
336                                         dbg("connect $conn->{cnum}: got: \"$expect\" sending: \"$send\"") if isdbg('connect');
337                                         $conn->send_later("D$conn->{call}|$send");
338                                 }
339                                 delete $conn->{msg}; # get rid any input if a match
340                                 return;
341                         }
342                 }
343         }
344         $conn->{state} = 'WC';
345         unshift @{$conn->{cmd}}, $cmd;
346 }
347
348 sub _timedout
349 {
350         my $conn = shift;
351         dbg("connect $conn->{cnum}: timed out after $conn->{timeval} seconds") if isdbg('connect');
352         $conn->disconnect;
353 }
354
355 # handle callsign and connection type firtling
356 sub _doclient
357 {
358         my $conn = shift;
359         my $line = shift;
360         my @f = split /\s+/, $line;
361         my $call = uc $f[0] if $f[0];
362         $conn->conns($call);
363         $conn->{csort} = $f[1] if $f[1];
364         $conn->{state} = 'C';
365         &{$conn->{rproc}}($conn, "O$call|$conn->{csort}");
366         delete $conn->{cmd};
367         $conn->{timeout}->del if $conn->{timeout};
368 }
369
370 sub _send_file
371 {
372         my $conn = shift;
373         my $fn = shift;
374         
375         if (-e $fn) {
376                 my $f = new IO::File $fn;
377                 if ($f) {
378                         while (<$f>) {
379                                 chomp;
380                                 my $l = $_;
381                                 dbg("connect $conn->{cnum}: $l") if isdbg('connll');
382                                 $conn->send_raw($l . $conn->{lineend});
383                         }
384                         $f->close;
385                 }
386         }
387 }