perl/client.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # A thing that implements dxcluster 'protocol'
   4 #
   5 # This is a perl module/program that sits on the end of a dxcluster
   6 # 'protocol' connection and deals with anything that might come along.
   7 #
   8 # this program is called by ax25d or inetd and gets raw ax25 text on its input
   9 # It can also be launched into the ether by the cluster program itself for outgoing
  10 # connections
  11 #
  12 # Calling syntax is:-
  13 #
  14 # client.pl [callsign] [telnet|ax25|local] [[connect] [program name and args ...]]
  15 #
  16 # if the callsign isn't given then the sysop callsign in DXVars.pm is assumed
  17 #
  18 # if there is no connection type then 'local' is assumed
  19 #
  20 # if there is a 'connect' keyword then it will try to launch the following program
  21 # and any arguments and connect the stdin & stdout of both the program and the
  22 # client together.
  23 #
  24 # Copyright (c) 1998 Dirk Koopman G1TLH
  25 #
  26 # $Id$
  27 #
  28
  29 require 5.004;
  30
  31 # search local then perl directories
  32 BEGIN {
  33         # root of directory tree for this system
  34         $root = "/spider";
  35         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
  36
  37         unshift @INC, "$root/perl";     # this IS the right way round!
  38         unshift @INC, "$root/local";
  39 }
  40
  41 use Msg;
  42 use IntMsg;
  43 use DXVars;
  44 use DXDebug;
  45 use DXUtil;
  46 use Net::Telnet qw(TELOPT_ECHO TELOPT_BINARY);
  47 use IO::File;
  48 use IO::Socket;
  49 use IPC::Open2;
  50
  51 # cease communications
  52 sub cease
  53 {
  54         my $sendz = shift;
  55 #       if ($conn && $sendz) {
  56 #               $conn->send_now("Z$call|bye...");
  57 #               sleep(1);
  58 #       }
  59         $stdout->flush if $stdout;
  60         if ($pid) {
  61                 dbg('connect', "killing $pid");
  62                 kill(9, $pid);
  63         }
  64         dbgclose();
  65 #       $SIG{__WARN__} = sub {my $a = shift; cluck($a); };
  66         sleep(1);
  67
  68         # do we need this ?
  69         $conn->disconnect if $conn;
  70         exit(0);
  71 }
  72
  73 # terminate program from signal
  74 sub sig_term
  75 {
  76         cease(1);
  77 }
  78
  79 # terminate a child
  80 sub sig_chld
  81 {
  82         unless ($^O =~ /^MS/i) {
  83                 $SIG{CHLD} = \&sig_chld;
  84                 $waitedpid = wait;
  85         }
  86         dbg('connect', "caught $pid");
  87 }
  88
  89
  90 sub setmode
  91 {
  92         if ($mode == 1) {
  93                 $mynl = "\r";
  94                 $out_lineend = "\r";
  95         } else {
  96                 $mynl = "\n";
  97                 $out_lineend = "\r\n";
  98         }
  99         $/ = $mynl;
 100         $out_lineend = $mynl;
 101 }
 102
 103 # handle incoming messages
 104 sub rec_socket
 105 {
 106         my ($con, $msg, $err) = @_;
 107         if (defined $err && $err) {
 108                 cease(0);
 109         }
 110         if (defined $msg) {
 111                 my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/;
 112
 113                 if ($sort eq 'D') {
 114                         my $snl = $mynl;
 115                         my $newsavenl = "";
 116                         $snl = "" if $mode == 0;
 117                         $snl = "\r\n" if $mode == 3;
 118                         $snl = "\n" if $mode == 2;
 119                         if ($mode == 2 && $line =~ />$/) {
 120                                 $newsavenl = $snl;
 121                                 $snl = ' ';
 122                         }
 123                         $line =~ s/\n/\r/og if $mode == 1;
 124                         #my $p = qq($line$snl);
 125                         if ($buffered) {
 126                                 if (length $outqueue >= $client_buffer_lth) {
 127                                         print $stdout $outqueue;
 128                                         pop @echo while (@echo > $maxecho);
 129                                         push @echo, $outqueue;
 130                                         $outqueue = "";
 131                                 }
 132                                 $outqueue .= "$savenl$line$snl";
 133                                 $lasttime = time;
 134                         } else {
 135                                 print $stdout $savenl, $line, $snl;;
 136                         }
 137                         $savenl = $newsavenl;
 138                 } elsif ($sort eq 'M') {
 139                         $mode = $line;          # set new mode from cluster
 140                         setmode();
 141                 } elsif ($sort eq 'E') {
 142                         if ($sort eq 'telnet') {
 143                                 $mode = $line;          # set echo mode from cluster
 144                                 my $term = POSIX::Termios->new;
 145                                 $term->getattr(fileno($sock));
 146                                 $term->setiflag( 0 );
 147                                 $term->setoflag( 0 );
 148                                 $term->setattr(fileno($sock), &POSIX::TCSANOW );
 149                         }
 150                 } elsif ($sort eq 'I') {
 151                         ;                       # ignore echoed I frames
 152                 } elsif ($sort eq 'B') {
 153                         if ($buffered && $outqueue) {
 154                                 print $stdout $outqueue;
 155                                 pop @echo while(@echo > $maxecho);
 156                                 push @echo, $outqueue;
 157                                 $outqueue = "";
 158                         }
 159                         $buffered = $line;      # set buffered or unbuffered
 160                 } elsif ($sort eq 'Z') { # end, disconnect, go, away .....
 161                         cease(0);
 162                 }
 163
 164                 # ******************************************************
 165                 # ******************************************************
 166                 # any other sorts that might happen are silently ignored.
 167                 # ******************************************************
 168                 # ******************************************************
 169         } else {
 170                 cease(0);
 171         }
 172         $lasttime = time;
 173 }
 174
 175 sub rec_stdin
 176 {
 177         my ($fh) = @_;
 178         my $buf;
 179         my @lines;
 180         my $r;
 181         my $first;
 182         my $dangle = 0;
 183
 184         $r = sysread($fh, $buf, 1024);
 185         #  my $prbuf;
 186         #  $prbuf = $buf;
 187         #  $prbuf =~ s/\r/\\r/;
 188         #  $prbuf =~ s/\n/\\n/;
 189         #  print "sys: $r ($prbuf)\n";
 190         if (!defined $r || $r == 0) {
 191                 cease(1);
 192         } elsif ($r > 0) {
 193                 if ($mode) {
 194                         $buf =~ s/\r/\n/g if $mode == 1;
 195                         $buf =~ s/[\r\x00]//g if $mode == 2 || $mode == 3;
 196
 197                         $dangle = !($buf =~ /\n$/);
 198                         if ($buf eq "\n") {
 199                                 @lines = (" ");
 200                         } else {
 201                                 @lines = split /\n/, $buf;
 202                         }
 203                         if ($dangle) {          # pull off any dangly bits
 204                                 $buf = pop @lines;
 205                         } else {
 206                                 $buf = "";
 207                         }
 208                         $first = shift @lines;
 209                         unshift @lines, ($lastbit . $first) if ($first);
 210                         foreach $first (@lines) {
 211                                 #                 print "send_now $call $first\n";
 212                                 next if grep {$_ eq $first } @echo;
 213                                 $conn->send_later("I$call|$first");
 214                         }
 215                         $lastbit = $buf;
 216                         $savenl = "";           # reset savenl 'cos we will have done a newline on input
 217                 } else {
 218                         $conn->send_later("I$call|$buf");
 219                 }
 220         }
 221         $lasttime = time;
 222 }
 223
 224 sub optioncb
 225 {
 226 }
 227
 228 sub doconnect
 229 {
 230         my ($sort, $line) = @_;
 231         dbg('connect', "CONNECT sort: $sort command: $line");
 232         if ($sort eq 'telnet') {
 233                 # this is a straight network connect
 234                 my ($host, $port) = split /\s+/, $line;
 235                 $port = 23 if !$port;
 236
 237                 $sock = new Net::Telnet (Timeout => $timeout, Port => $port);
 238                 $sock->option_callback(\&optioncb);
 239                 $sock->output_record_separator('');
 240                 $sock->option_accept(Dont => TELOPT_ECHO, Wont => TELOPT_ECHO);
 241                 $sock->open($host) or die "Can't connect to $host port $port $!";
 242                 if ($port == 23) {
 243                         $sock->telnetmode(1);
 244                         $sock->option_send(Dont => TELOPT_ECHO, Wont => TELOPT_ECHO) if $port == 23;
 245                 } else {
 246                         $sock->telnetmode(0);
 247                 }
 248                 $sock->binmode(0);
 249                 $mode = 3;
 250         } elsif ($sort eq 'ax25' || $sort eq 'prog') {
 251                 my @args = split /\s+/, $line;
 252                 $rfh = new IO::File;
 253                 $wfh = new IO::File;
 254                 $pid = open2($rfh, $wfh, "$line") or die "can't do $line $!";
 255                 die "no receive channel $!" unless $rfh;
 256                 die "no transmit channel $!" unless $wfh;
 257                 dbg('connect', "got pid $pid");
 258                 $wfh->autoflush(1);
 259                 $mode = 1;
 260         } else {
 261                 die "invalid type of connection ($sort)";
 262         }
 263         $csort = $sort;
 264 }
 265
 266 sub doabort
 267 {
 268         my $string = shift;
 269         dbg('connect', "abort $string");
 270         $abort = $string;
 271 }
 272
 273 sub dotimeout
 274 {
 275         my $val = shift;
 276         dbg('connect', "timeout set to $val");
 277         $timeout = $val;
 278 }
 279
 280 sub dolineend
 281 {
 282         my $val = shift;
 283         $out_lineend = $val;
 284         $out_lineend =~ s/\\r/\r/g;
 285         $out_lineend =~ s/\\n/\n/g;
 286         dbg('connect', "lineend set to $val ");
 287         $out_lineend = $mynl unless $out_lineend;
 288 }
 289
 290 sub dochat
 291 {
 292         my ($expect, $send) = @_;
 293         dbg('connect', "CHAT \"$expect\" -> \"$send\"");
 294     my $line;
 295
 296         alarm($timeout);
 297
 298     if ($expect) {
 299                 for (;;) {
 300                         if ($csort eq 'telnet') {
 301                                 $line = $sock->get();
 302                                 cease(11) unless $line;          # the socket has gone away?
 303                                 if (length $line == 0) {
 304                                         dbg('connect', "received 0 length line, aborting...");
 305                                         cease(11);
 306                                 }
 307                                 $line =~ s/\r//g;
 308                                 chomp;
 309                         } elsif ($csort eq 'ax25' || $csort eq 'prog') {
 310                                 local $/ = "\r";
 311                                 $line = <$rfh>;
 312                                 if (length $line == 0) {
 313                                         dbg('connect', "received 0 length line, aborting...");
 314                                         cease(11);
 315                                 }
 316                                 $line =~ s/\r/\n/g;
 317                                 chomp;
 318                         }
 319                         dbg('connect', map { "received \"$_\"" } split /\n/, $line);
 320                         if ($abort && $line =~ /$abort/i) {
 321                                 dbg('connect', "aborted on /$abort/");
 322                                 cease(11);
 323                         }
 324                         last if $line =~ /$expect/i;
 325                 }
 326         }
 327         if ($send) {
 328                 if ($csort eq 'telnet') {
 329 #                       local $\ = $out_lineend;
 330                         $sock->print("$send\n");
 331                 } elsif ($csort eq 'ax25') {
 332                         local $\ = $out_lineend;
 333                         $wfh->print("$send");
 334                 }
 335                 dbg('connect', "sent \"$send\"");
 336         }
 337 }
 338
 339 sub timeout
 340 {
 341         dbg('connect', "timed out after $timeout seconds");
 342         cease(0);
 343 }
 344
 345 # handle callsign and connection type firtling
 346 sub doclient
 347 {
 348         my $line = shift;
 349         my @f = split /\s+/, $line;
 350         $call = uc $f[0] if $f[0];
 351         $csort = $f[1] if $f[1];
 352 }
 353
 354 #
 355 # initialisation
 356 #
 357
 358 $mode = 2;                      # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent
 359 $call = "";                     # the callsign being used
 360 $conn = 0;                      # the connection object for the cluster
 361 $lastbit = "";                  # the last bit of an incomplete input line
 362 $mynl = "\n";                   # standard terminator
 363 $lasttime = time;               # lasttime something happened on the interface
 364 $outqueue = "";                 # the output queue
 365 $client_buffer_lth = 200;       # how many characters are buffered up on outqueue
 366 $buffered = 1;                  # buffer output
 367 $savenl = "";                   # an NL that has been saved from last time
 368 $timeout = 60;                  # default timeout for connects
 369 $abort = "";                    # the current abort string
 370 $cpath = "$root/connect";               # the basic connect directory
 371 $maxecho = 5;                  # length of max echo queue
 372
 373 $pid = 0;                       # the pid of the child program
 374 $csort = "";                    # the connection type
 375 $sock = 0;                      # connection socket
 376 $out_lineend = $mynl;          # connection lineending (used for outgoing connects)
 377
 378 $stdin = *STDIN;
 379 $stdout = *STDOUT;
 380 $rfh = 0;
 381 $wfh = 0;
 382
 383 $waitedpid = 0;
 384
 385 #
 386 # deal with args
 387 #
 388
 389 $call = uc shift @ARGV if @ARGV;
 390 $call = uc $myalias if !$call;
 391 $connsort = lc shift @ARGV if @ARGV;
 392 $connsort = 'local' if !$connsort;
 393
 394 $loginreq = $call eq 'LOGIN';
 395
 396 # we will do this again later 'cos things may have changed
 397 $mode = ($connsort eq 'ax25') ? 1 : 2;
 398 setmode();
 399
 400 if ($call eq $mycall) {
 401         print $stdout "You cannot connect as your cluster callsign ($mycall)", $nl;
 402         cease(0);
 403 }
 404
 405 $stdout->autoflush(1);
 406
 407 unless ($^O =~ /^MS/i) {
 408         $SIG{'INT'} = \&sig_term;
 409         $SIG{'TERM'} = \&sig_term;
 410         $SIG{'HUP'} = \&sig_term;
 411         $SIG{'CHLD'} = \&sig_chld;
 412 }
 413
 414 dbgadd('connect');
 415
 416 # do we need to do a login and password job?
 417 if ($loginreq) {
 418         my $user;
 419         my $s;
 420
 421         $connsort = 'telnet' if $connsort eq 'local';
 422         setmode();
 423
 424         if (-e "$data/issue") {
 425                 open(I, "$data/issue") or die;
 426                 local $/ = undef;
 427                 $issue = <I>;
 428                 close(I);
 429                 $issue = s/\n/\r/og if $mode == 1;
 430                 local $/ = $nl;
 431                 $stdout->print($issue) if $issue;
 432         }
 433
 434         # allow a login from an existing user. I could create a user but
 435         # I want to check for valid callsigns and I don't have the
 436         # necessary info / regular expression yet
 437         alarm($timeout);
 438
 439         $stdout->print('login: ');
 440         $stdout->flush();
 441         local $\ = $mynl;
 442         $s = $stdin->getline();
 443         chomp $s;
 444         $s =~ s/\s+//og;
 445         $s =~ s/-\d+$//o;            # no ssids!
 446         cease(0) unless $s && $s gt ' ';
 447         unless (is_callsign($s)) {
 448                 $stdout->print("Sorry, $s is an invalid callsign");
 449                 cease(0);
 450         }
 451         $call = uc $s;
 452         alarm(0);
 453 }
 454
 455 # is this an out going connection?
 456 if ($connsort eq "connect") {
 457         my $mcall = lc $call;
 458
 459         open(IN, "$cpath/$mcall") or cease(2);
 460         @in = <IN>;
 461         close IN;
 462
 463         alarm($timeout);
 464
 465         for (@in) {
 466                 chomp;
 467                 next if /^\s*\#/o;
 468                 next if /^\s*$/o;
 469                 doconnect($1, $2) if /^\s*co\w*\s+(\w+)\s+(.*)$/io;
 470                 doabort($1) if /^\s*a\w*\s+(.*)/io;
 471                 dotimeout($1) if /^\s*t\w*\s+(\d+)/io;
 472                 dolineend($1) if /^\s*[Ll]\w*\s+\'((?:\\[rn])+)\'/;
 473                 dochat($1, $2) if /^\s*\'(.*)\'\s+\'(.*)\'/io;
 474
 475                 if (/^\s*cl\w+\s+(.*)/io) {
 476                         doclient($1);
 477                         last;
 478                 }
 479         }
 480
 481     dbg('connect', "Connected to $call ($csort), starting normal protocol");
 482         dbgsub('connect');
 483
 484         # if we get here we are connected
 485         if ($csort eq 'ax25' || $csort eq 'prog') {
 486                 #               open(STDIN, "<&R");
 487                 #               open(STDOUT, ">&W");
 488                 #               close R;
 489                 #               close W;
 490         $stdin = $rfh;
 491                 $stdout = $wfh;
 492                 $csort = 'telnet' if $csort eq 'prog';
 493         } elsif ($csort eq 'telnet') {
 494                 #               open(STDIN, "<&$sock");
 495                 #               open(STDOUT, ">&$sock");
 496                 #               close $sock;
 497                 $stdin = $sock;
 498                 $stdout = $sock;
 499         }
 500     alarm(0);
 501     $outbound = 1;
 502         $connsort = $csort;
 503         $stdout->autoflush(1);
 504         $mode = ($connsort eq 'ax25') ? 1 : $mode;
 505         close STDIN;
 506         close STDOUT;
 507         close STDERR;
 508 }
 509
 510 setmode();
 511
 512 # adjust the callsign if it has an SSID, SSID <= 8 are legal > 8 are netrom connections
 513 $call =~ s/-0$//;     # strip off -0 as this is equiv to just call on its own
 514 my ($scall, $ssid) = split /-/, $call;
 515 $ssid = undef unless $ssid && $ssid =~ /^\d+$/;
 516 if ($ssid) {
 517         $ssid = 15 if $ssid > 15;
 518         if ($connsort eq 'ax25') {
 519                 if ($ssid > 8) {
 520                         $ssid = 15 - $ssid;
 521                 }
 522         }
 523         $call = "$scall-$ssid";
 524 }
 525
 526
 527 $conn = IntMsg->connect("$clusteraddr", $clusterport, \&rec_socket);
 528 if (! $conn) {
 529         if (-r "$data/offline") {
 530                 open IN, "$data/offline" or die;
 531                 while (<IN>) {
 532                         s/\n/\r/og if $mode == 1;
 533                         print $stdout $_;
 534                 }
 535                 close IN;
 536         } else {
 537                 print $stdout "Sorry, the cluster $mycall is currently off-line", $mynl;
 538         }
 539         cease(0);
 540 }
 541
 542 $let = $outbound ? 'O' : 'A';
 543 $conn->send_now("$let$call|$connsort");
 544 Msg->set_event_handler($stdin, "read" => \&rec_stdin);
 545
 546 for (;;) {
 547         my $t;
 548         Msg->event_loop(1, 0.1);
 549         $t = time;
 550         if ($t > $lasttime) {
 551                 if ($outqueue) {
 552                         print $stdout $outqueue;
 553                         $outqueue = "";
 554                 }
 555                 $lasttime = $t;
 556         }
 557 }
 558
 559 exit(0);