perl/client.pl

   1 #!/usr/bin/perl
   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
  30 # search local then perl directories
  31 BEGIN {
  32         # root of directory tree for this system
  33         $root = "/spider";
  34         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
  35
  36         unshift @INC, "$root/perl";     # this IS the right way round!
  37         unshift @INC, "$root/local";
  38 }
  39
  40 use Msg;
  41 use DXVars;
  42 use DXDebug;
  43 use DXUser;
  44 use IO::File;
  45 use IO::Socket;
  46 use IPC::Open2;
  47 use Net::Telnet qw(TELOPT_ECHO);
  48 use Carp;
  49
  50 # cease communications
  51 sub cease
  52 {
  53         my $sendz = shift;
  54         if ($conn && $sendz) {
  55                 $conn->send_now("Z$call|bye...\n");
  56         }
  57         $stdout->flush if $stdout;
  58         kill(15, $pid) if $pid;
  59         sleep(1);
  60         exit(0);
  61 }
  62
  63 # terminate program from signal
  64 sub sig_term
  65 {
  66         cease(1);
  67 }
  68
  69 # terminate a child
  70 sub sig_chld
  71 {
  72         $SIG{CHLD} = \&sig_chld;
  73         $waitedpid = wait;
  74 }
  75
  76
  77 sub setmode
  78 {
  79         if ($mode == 1) {
  80                 $mynl = "\r";
  81         } else {
  82                 $mynl = "\n";
  83         }
  84         $/ = $mynl;
  85 }
  86
  87 # handle incoming messages
  88 sub rec_socket
  89 {
  90         my ($con, $msg, $err) = @_;
  91         if (defined $err && $err) {
  92                 cease(1);
  93         }
  94         if (defined $msg) {
  95                 my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
  96
  97                 if ($sort eq 'D') {
  98                         my $snl = $mynl;
  99                         my $newsavenl = "";
 100                         $snl = "" if $mode == 0;
 101                         if ($mode == 2 && $line =~ />$/) {
 102                                 $newsavenl = $snl;
 103                                 $snl = ' ';
 104                         }
 105                         $line =~ s/\n/\r/og if $mode == 1;
 106                         #my $p = qq($line$snl);
 107                         if ($buffered) {
 108                                 if (length $outqueue >= 128) {
 109                                         print $stdout $outqueue;
 110                                         $outqueue = "";
 111                                 }
 112                                 $outqueue .= "$savenl$line$snl";
 113                                 $lasttime = time;
 114                         } else {
 115                                 print $stdout $savenl, $line, $snl;;
 116                         }
 117                         $savenl = $newsavenl;
 118                 } elsif ($sort eq 'M') {
 119                         $mode = $line;          # set new mode from cluster
 120                         setmode();
 121                 } elsif ($sort eq 'E') {
 122                         if ($sort eq 'telnet') {
 123                                 $mode = $line;          # set echo mode from cluster
 124                                 my $term = POSIX::Termios->new;
 125                                 $term->getattr(fileno($sock));
 126                                 $term->setflag( &POSIX::ISIG );
 127                                 $term->setattr(fileno($sock), &POSIX::TCSANOW );
 128                         }
 129                 } elsif ($sort eq 'I') {
 130                         ;                       # ignore echoed I frames
 131                 } elsif ($sort eq 'B') {
 132                         if ($buffered && $outqueue) {
 133                                 print $stdout $outqueue;
 134                                 $outqueue = "";
 135                         }
 136                         $buffered = $line;      # set buffered or unbuffered
 137                 } elsif ($sort eq 'Z') { # end, disconnect, go, away .....
 138                         cease(0);
 139                 }
 140         }
 141         $lasttime = time;
 142 }
 143
 144 sub rec_stdin
 145 {
 146         my ($fh) = @_;
 147         my $buf;
 148         my @lines;
 149         my $r;
 150         my $first;
 151         my $dangle = 0;
 152
 153         $r = sysread($fh, $buf, 1024);
 154         #  my $prbuf;
 155         #  $prbuf = $buf;
 156         #  $prbuf =~ s/\r/\\r/;
 157         #  $prbuf =~ s/\n/\\n/;
 158         #  print "sys: $r ($prbuf)\n";
 159         if ($r > 0) {
 160                 if ($mode) {
 161                         $buf =~ s/\r/\n/og if $mode == 1;
 162                         $buf =~ s/\r\n/\n/og if $mode == 2;
 163                         $dangle = !($buf =~ /\n$/);
 164                         if ($buf eq "\n") {
 165                                 @lines = (" ");
 166                         } else {
 167                                 @lines = split /\n/, $buf;
 168                         }
 169                         if ($dangle) {          # pull off any dangly bits
 170                                 $buf = pop @lines;
 171                         } else {
 172                                 $buf = "";
 173                         }
 174                         $first = shift @lines;
 175                         unshift @lines, ($lastbit . $first) if ($first);
 176                         foreach $first (@lines) {
 177                                 #                 print "send_now $call $first\n";
 178                                 $conn->send_later("I$call|$first");
 179                         }
 180                         $lastbit = $buf;
 181                         $savenl = "";           # reset savenl 'cos we will have done a newline on input
 182                 } else {
 183                         $conn->send_later("I$call|$buf");
 184                 }
 185         } elsif ($r == 0) {
 186                 cease(1);
 187         }
 188         $lasttime = time;
 189 }
 190
 191 sub optioncb
 192 {
 193 }
 194
 195 sub doconnect
 196 {
 197         my ($sort, $line) = @_;
 198         dbg('connect', "CONNECT sort: $sort command: $line");
 199         if ($sort eq 'telnet') {
 200                 # this is a straight network connect
 201                 my ($host, $port) = split /\s+/, $line;
 202                 $port = 23 if !$port;
 203
 204                 if ($port == 23) {
 205                         $sock = new Net::Telnet (Timeout => $timeout);
 206                         $sock->option_callback(\&optioncb);
 207                         $sock->output_record_separator('');
 208                         $sock->option_log('option_log');
 209                         $sock->dump_log('dump');
 210                         $sock->option_accept(Wont => TELOPT_ECHO);
 211                         $sock->open($host) or die "Can't connect to $host port $port $!";
 212                 } else {
 213                         $sock = IO::Socket::INET->new(PeerAddr => "$host:$port", Proto => 'tcp')
 214                                 or die "Can't connect to $host port $port $!";
 215
 216                 }
 217         } elsif ($sort eq 'ax25' || $sort eq 'prog') {
 218                 my @args = split /\s+/, $line;
 219                 $rfh = new IO::File;
 220                 $wfh = new IO::File;
 221                 $pid = open2($rfh, $wfh, "$line") or die "can't do $line $!";
 222                 dbg('connect', "got pid $pid");
 223                 $wfh->autoflush(1);
 224         } else {
 225                 die "invalid type of connection ($sort)";
 226         }
 227         $csort = $sort;
 228 }
 229
 230 sub doabort
 231 {
 232         my $string = shift;
 233         dbg('connect', "abort $string");
 234         $abort = $string;
 235 }
 236
 237 sub dotimeout
 238 {
 239         my $val = shift;
 240         dbg('connect', "timeout set to $val");
 241         $timeout = $val;
 242 }
 243
 244 sub dochat
 245 {
 246         my ($expect, $send) = @_;
 247         dbg('connect', "CHAT \"$expect\" -> \"$send\"");
 248     my $line;
 249
 250         alarm($timeout);
 251
 252     if ($expect) {
 253                 for (;;) {
 254                         if ($csort eq 'telnet') {
 255                                 $line = $sock->get();
 256                                 $line =~ s/\r\n/\n/og;
 257                                 chomp;
 258                         } elsif ($csort eq 'ax25' || $csort eq 'prog') {
 259                                 local $/ = "\r";
 260                                 $line = <$rfh>;
 261                                 $line =~ s/\r//og;
 262                         }
 263                         dbg('connect', "received \"$line\"");
 264                         if ($abort && $line =~ /$abort/i) {
 265                                 dbg('connect', "aborted on /$abort/");
 266                                 cease(11);
 267                         }
 268                         last if $line =~ /$expect/i;
 269                 }
 270         }
 271         if ($send) {
 272                 if ($csort eq 'telnet') {
 273                         $sock->print("$send\n");
 274                 } elsif ($csort eq 'ax25') {
 275                         local $\ = "\r";
 276                         $wfh->print("$send");
 277                 }
 278                 dbg('connect', "sent \"$send\"");
 279         }
 280 }
 281
 282 sub timeout
 283 {
 284         dbg('connect', "timed out after $timeout seconds");
 285         cease(10);
 286 }
 287
 288
 289 #
 290 # initialisation
 291 #
 292
 293 $mode = 2;                      # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent
 294 $call = "";                     # the callsign being used
 295 @stdoutq = ();                  # the queue of stuff to send out to the user
 296 $conn = 0;                      # the connection object for the cluster
 297 $lastbit = "";                  # the last bit of an incomplete input line
 298 $mynl = "\n";                   # standard terminator
 299 $lasttime = time;               # lasttime something happened on the interface
 300 $outqueue = "";                 # the output queue length
 301 $buffered = 1;                  # buffer output
 302 $savenl = "";                   # an NL that has been saved from last time
 303 $timeout = 60;                  # default timeout for connects
 304 $abort = "";                    # the current abort string
 305 $cpath = "$root/connect";               # the basic connect directory
 306
 307 $pid = 0;                       # the pid of the child program
 308 $csort = "";                    # the connection type
 309 $sock = 0;                      # connection socket
 310
 311 $stdin = *STDIN;
 312 $stdout = *STDOUT;
 313 $rfh = 0;
 314 $wfh = 0;
 315
 316
 317 #
 318 # deal with args
 319 #
 320
 321 $call = uc shift @ARGV;
 322 $call = uc $myalias if !$call;
 323 $connsort = lc shift @ARGV;
 324 $connsort = 'local' if !$connsort;
 325
 326 $loginreq = $call eq 'LOGIN';
 327
 328 # we will do this again later 'cos things may have changed
 329 $mode = ($connsort eq 'ax25') ? 1 : 2;
 330 setmode();
 331
 332 if ($call eq $mycall) {
 333         print $stdout "You cannot connect as your cluster callsign ($mycall)", $nl;
 334         cease(0);
 335 }
 336
 337 $stdout->autoflush(1);
 338
 339 $SIG{'INT'} = \&sig_term;
 340 $SIG{'TERM'} = \&sig_term;
 341 $SIG{'HUP'} = 'IGNORE';
 342 $SIG{'CHLD'} = \&sig_chld;
 343
 344 dbgadd('connect');
 345
 346 # do we need to do a login and password job?
 347 if ($loginreq) {
 348         my $user;
 349         my $s;
 350
 351         DXUser->init($userfn);
 352
 353         for ($state = 0; $state < 2; ) {
 354                 alarm($timeout);
 355
 356                 if ($state == 0) {
 357                         $stdout->print('login: ');
 358                         $stdout->flush();
 359                         local $/ = $mode == 1 ? "\r" : "\n";
 360                         $s = $stdin->getline();
 361                         chomp $s;
 362                         $call = uc $s;
 363                         $user = DXUser->get($call);
 364                         $state = 1;
 365                 } elsif ($state == 1) {
 366                         $stdout->print('password: ');
 367                         $stdout->flush();
 368                         local $/ = $mode == 1 ? "\r" : "\n";
 369                         $s = $stdin->getline();
 370                         chomp $s;
 371                         $state = 2;
 372                         cease(0) if !$user || ($user->passwd && $user->passwd ne $s);
 373                 }
 374         }
 375 }
 376
 377 # handle callsign and connection type firtling
 378 sub doclient
 379 {
 380         my $line = shift;
 381         my @f = split /\s+/, $line;
 382         $call = uc $f[0] if $f[0];
 383         $csort = $f[1] if $f[1];
 384 }
 385
 386 # is this an out going connection?
 387 if ($connsort eq "connect") {
 388         my $mcall = lc $call;
 389
 390         open(IN, "$cpath/$mcall") or cease(2);
 391         @in = <IN>;
 392         close IN;
 393
 394         #       alarm($timeout);
 395
 396         for (@in) {
 397                 chomp;
 398                 next if /^\s*\#/o;
 399                 next if /^\s*$/o;
 400                 doconnect($1, $2) if /^\s*co\w*\s+(\w+)\s+(.*)$/io;
 401                 doabort($1) if /^\s*a\w*\s+(.*)/io;
 402                 dotimeout($1) if /^\s*t\w*\s+(\d+)/io;
 403                 dochat($1, $2) if /\s*\'(.*)\'\s+\'(.*)\'/io;
 404                 if (/\s*cl\w+\s+(.*)/io) {
 405                         doclient($1);
 406                         last;
 407                 }
 408         }
 409
 410     dbg('connect', "Connected to $call ($csort), starting normal protocol");
 411         dbgsub('connect');
 412
 413         # if we get here we are connected
 414         if ($csort eq 'ax25' || $csort eq 'prog') {
 415                 #               open(STDIN, "<&R");
 416                 #               open(STDOUT, ">&W");
 417                 #               close R;
 418                 #               close W;
 419         $stdin = $rfh;
 420                 $stdout = $wfh;
 421                 $csort = 'telnet' if $sort eq 'prog';
 422         } elsif ($csort eq 'telnet') {
 423                 #               open(STDIN, "<&$sock");
 424                 #               open(STDOUT, ">&$sock");
 425                 #               close $sock;
 426                 $stdin = $sock;
 427                 $stdout = $sock;
 428         }
 429     alarm(0);
 430     $outbound = 1;
 431         $connsort = $csort;
 432         $stdout->autoflush(1);
 433         close STDIN;
 434         close STDOUT;
 435         close STDERR;
 436 }
 437
 438 $mode = ($connsort eq 'ax25') ? 1 : 2;
 439 setmode();
 440
 441 $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
 442 if (! $conn) {
 443         if (-r "$data/offline") {
 444                 open IN, "$data/offline" or die;
 445                 while (<IN>) {
 446                         s/\n/\r/og if $mode == 1;
 447                         print $stdout;
 448                 }
 449                 close IN;
 450         } else {
 451                 print $stdout "Sorry, the cluster $mycall is currently off-line", $mynl;
 452         }
 453         cease(0);
 454 }
 455
 456 $let = $outbound ? 'O' : 'A';
 457 $conn->send_now("$let$call|$connsort");
 458 Msg->set_event_handler($stdin, "read" => \&rec_stdin);
 459
 460 for (;;) {
 461         my $t;
 462         Msg->event_loop(1, 0.010);
 463         $t = time;
 464         if ($t > $lasttime) {
 465                 if ($outqueue) {
 466                         print $stdout $outqueue;
 467                         $outqueue = "";
 468                 }
 469                 $lasttime = $t;
 470         }
 471 }
 472
 473 exit(0);