SIPServer.pm

   1 #
   2 # Copyright (C) 2006-2008  Georgia Public Library Service
   3 # Copyright (C) 2013-2014  Equinox Software, Inc.
   4 #
   5 # Author: David J. Fiander
   6 # Author: Mike Rylander
   7 # Author: Bill Erickson
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of version 2 of the GNU General Public
  11 # License as published by the Free Software Foundation.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public
  19 # License along with this program; if not, write to the Free
  20 # Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
  21 # MA 02111-1307 USA
  22
  23 package SIPServer;
  24
  25 use strict;
  26 use warnings;
  27 use Exporter;
  28 use Sys::Syslog qw(syslog);
  29 use Net::Server::Multiplex;
  30 use Net::Server::PreFork;
  31 use Net::Server::Proto;
  32 use IO::Socket::INET;
  33 use IO::Pipe;
  34 use Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE IPPROTO_TCP TCP_KEEPALIVE);
  35 use Data::Dumper;               # For debugging
  36 require UNIVERSAL::require;
  37 use POSIX qw/:sys_wait_h :errno_h/;
  38
  39 use Sip qw($protocol_version);
  40 use Sip::Constants qw(:all);
  41 use Sip::Configuration;
  42 use Sip::Checksum qw(checksum verify_cksum);
  43 use Sip::MsgType;
  44 use Time::HiRes qw/time/;
  45
  46 use Cache::Memcached;
  47
  48 use constant LOG_SIP => "local6"; # Local alias for the logging facility
  49
  50 our $VERSION = 0.02;
  51 our @ISA = qw(Net::Server::PreFork);
  52 #
  53 # Main
  54 #
  55
  56 my %transports = (
  57     RAW    => \&raw_transport,
  58     telnet => \&telnet_transport,
  59     http   => \&http_transport,
  60 );
  61
  62 # Read configuration
  63
  64 my $config = Sip::Configuration->new($ARGV[0]);
  65
  66 my @parms;
  67
  68 #
  69 # Ports to bind
  70 #
  71 foreach my $svc (keys %{$config->{listeners}}) {
  72     push @parms, "port=" . $svc;
  73 }
  74
  75 #
  76 # Logging
  77 #
  78 # Log lines look like this:
  79 # Jun 16 21:21:31 server08 steve_sip: Sip::MsgType::_initialize('Login', ...)
  80 # [  TIMESTAMP  ] [ HOST ] [ IDENT ]: Message...
  81 #
  82 # The IDENT is determined by $ENV{SIP_LOG_IDENT}, if present.
  83 # Otherwise it is "_sip" appended to $USER, if present, or "acs-server" as a fallback.
  84 #
  85
  86 my $syslog_ident = $ENV{SIP_LOG_IDENT} || ($ENV{USER} ? $ENV{USER} . "_sip" : 'acs-server');
  87
  88 push @parms,
  89     "log_file=Sys::Syslog",
  90     "syslog_ident=$syslog_ident",
  91     "syslog_facility=" . LOG_SIP;
  92
  93 #
  94 # Server Management: set parameters for the Net::Server personality
  95 # chosen, defaulting to PreFork.
  96 #
  97 # The PreFork module silently ignores parameters that it doesn't
  98 # recognize, and complains about invalid values for parameters
  99 # that it does.
 100 #
 101 # The Fork module only cares about max_servers, for our purposes, which
 102 # defaults to 256.
 103 #
 104 # The Multiplex module ignores all runtime params, and triggers an
 105 # alternate implementation of the processing loop.  See the Net::Server
 106 # personality documentation for details. The max-concurrent parameter
 107 # can be used here to limit the number of concurrent in-flight requests
 108 # to avoid a fork-bomb DoS situation.  The default is 256.
 109 #
 110 my $worker_keepalive = 5;
 111 my $max_concurrent = 256;
 112 if (defined($config->{'server-params'})) {
 113     while (my ($key, $val) = each %{$config->{'server-params'}}) {
 114         push @parms, $key . '=' . $val;
 115         @ISA = ('Net::Server::'.$val) if ($key eq 'personality');
 116         $max_concurrent = $val if ($key eq 'max-concurrent');
 117         $worker_keepalive = $val if ($key eq 'worker-keepalive');
 118     }
 119 }
 120
 121 print Dumper(@parms);
 122
 123 # initialize all remaining global variables before
 124 # going into listen mode.
 125 my %kid_hash;
 126 my $kid_count = 0;
 127 my $cache;
 128 my @pending_connections;
 129 my %active_connections;
 130
 131 #
 132 # This is the main event.
 133 SIPServer->run(@parms);
 134
 135 #
 136 # Child
 137 #
 138
 139 # process_request is the callback used by Net::Server to handle
 140 # an incoming connection request when the peronsality is either
 141 # Fork or PreFork.
 142
 143 sub process_request {
 144     my $self = shift;
 145     my $service;
 146     my $sockname;
 147     my ($sockaddr, $port, $proto);
 148     my $transport;
 149
 150     # This is kind of kinky, but allows us to avoid requiring Socket::Linux.
 151     # A simple "Socket::Linux"->use won't suffice since we need access to
 152     # all of it's bareword constants as well.
 153     eval <<'    EVAL';
 154     use Socket::Linux qw(TCP_KEEPINTVL TCP_KEEPIDLE TCP_KEEPCNT);
 155     setsockopt($self->{server}->{client}, SOL_SOCKET,  SO_KEEPALIVE, 1);
 156     setsockopt($self->{server}->{client}, IPPROTO_TCP, TCP_KEEPIDLE, 120);
 157     setsockopt($self->{server}->{client}, IPPROTO_TCP, TCP_KEEPINTVL, 10);
 158     EVAL
 159
 160     syslog('LOG_DEBUG',
 161         "Consider installing Socket::Linux for TCP keepalive: $@") if $@;
 162
 163     $self->{account} = undef; # New connection, no need to keep login info
 164     $self->{config} = $config;
 165
 166     $sockaddr = $self->{server}->{sockaddr};
 167     $port     = $self->{server}->{sockport};
 168     $proto    = $self->{server}->{client}->NS_proto();
 169     syslog('LOG_INFO', "Inbound connection from $sockaddr on port $port and proto $proto");
 170
 171     $self->{service} = $config->find_service( $sockaddr, $port, $proto );
 172
 173     if (! defined($self->{service})) {
 174         syslog( "LOG_ERR", "process_request: Unrecognized server connection: %s:%s/%s",
 175             $sockaddr, $port, $proto );
 176         die "process_request: Bad server connection";
 177     }
 178
 179     $transport = $transports{ $self->{service}->{transport} };
 180
 181     if ( !defined($transport) ) {
 182         syslog("LOG_WARNING", "Unknown transport '%s', dropping", $service->{transport});
 183         return;
 184     } else {
 185         # handle client authentication prior to
 186         # passing further processing to sip_protocol_loop()
 187         &$transport($self);
 188     }
 189
 190     $self->sip_protocol_loop();
 191
 192     syslog("LOG_INFO", '%s: shutting down', $transport);
 193 }
 194
 195 # for forking personalities, don belt and suspenders
 196 # and ensure that the session account is cleared when
 197 # a client connection ends cleanly (as opposed to the
 198 # Net::Server backend having been terminated).
 199 sub post_process_request {
 200     my $self = shift;
 201
 202     $self->{account} = undef;
 203
 204 }
 205
 206 # mux_input is the callback used by Net::Server to handle
 207 # an incoming connection request when the peronsality is
 208 # Multiplex.
 209
 210
 211 sub init_cache {
 212     return $cache if $cache;
 213
 214     if (!$config->{cache}) {
 215         syslog('LOG_ERR', "Cache servers needed");
 216         return;
 217     }
 218     my $servers = $config->{cache}->{server};
 219     syslog('LOG_DEBUG', "Cache servers: @$servers");
 220
 221     $cache = Cache::Memcached->new({servers => $servers}) or
 222         syslog('LOG_ERR', "Unable to initialize memcache: @$servers");
 223
 224     return $cache;
 225 }
 226
 227 # In the parent, pending connections are tracked as an array of PIDs.
 228 # As each child process completes the login dance, it plops some
 229 # info into memcache for us to pickup and copy into our active
 230 # connections.  No memcache entry means the child login dance
 231 # is still in progress.
 232 sub check_pending_connections {
 233     return unless @pending_connections;
 234
 235     init_cache();
 236
 237     syslog('LOG_DEBUG',
 238         "multi: pending connections to inspect: @pending_connections");
 239
 240     # get_multi will return all completed login blobs
 241     my @keys = map { "sip_pending_auth_$_" } @pending_connections;
 242     my $values = $cache->get_multi(@keys);
 243
 244     for my $key (keys %$values) {
 245         my $VAR1; # for Dump() -> eval;
 246         eval $values->{$key}; # Data::Dumper->Dump string
 247
 248         my $id = $VAR1->{id}; # conn_id
 249         $active_connections{$id}{net_server_parts} = $VAR1->{net_server_parts};
 250
 251         if ($VAR1->{success}) {
 252             if ($active_connections{$id}{net_server_parts}{state}) {
 253                 local $Data::Dumper::Indent = 0;
 254                 syslog('LOG_DEBUG', "multi: conn_id=$id has state: ".
 255                     Dumper($active_connections{$id}{net_server_parts}{state}));
 256             }
 257
 258         } else {
 259             syslog('LOG_INFO', "Child $id failed SIP login; removing connection");
 260             delete $active_connections{$id};
 261         }
 262
 263         # clean up ---
 264
 265         syslog('LOG_DEBUG',
 266             "multi: pending connection for conn_id=$id resolved");
 267         $cache->delete($key);
 268         @pending_connections = grep {$_ ne $id} @pending_connections;
 269     }
 270
 271     syslog('LOG_DEBUG',
 272         "multi: connections still pending after check: @pending_connections")
 273         if @pending_connections;
 274
 275     if (0) {
 276         # useful for debugging connection-specific state information
 277         local $Data::Dumper::Indent = 0;
 278         for my $conn_id (keys %active_connections) {
 279             syslog('LOG_DEBUG', "Connection $conn_id has state "
 280                 .Dumper($active_connections{$conn_id}{net_server_parts}{state}));
 281         }
 282     }
 283 }
 284
 285 sub sig_chld {
 286     if ( !scalar(keys(%kid_hash))) { # not using mux mode
 287         1 while waitpid(-1, WNOHANG) > 0;
 288     } else {
 289         for (keys(%kid_hash)) {
 290             if ( my $reaped = waitpid($_, WNOHANG) > 0 ) {
 291                 syslog('LOG_DEBUG', "Reaping child $_");
 292                 # Mourning... done.
 293                 $kid_count--;
 294                 # note: in some cases (when the primary connection is severed),
 295                 # the active connection is cleaned up in mux_close.
 296                 if ($active_connections{$kid_hash{$_}}) {
 297                     if ($active_connections{$kid_hash{$_}}{worker_pipe}) {
 298                         syslog('LOG_DEBUG', "Closing worker pipe after timeout for: $kid_hash{$_}");
 299                         delete $active_connections{$kid_hash{$_}}{worker_pipe};
 300                     }
 301                 }
 302                 delete $kid_hash{$_};
 303             }
 304         }
 305     }
 306 }
 307
 308 sub mux_connection {
 309     my ($mself, $fh) = @_;
 310
 311     my ($peeraddr, $peerport) = (
 312         $mself->{net_server}->{server}->{peeraddr},
 313         $mself->{net_server}->{server}->{peerport}
 314     );
 315
 316     # create a new connection ID for this MUX handler.
 317     $mself->{conn_id} = "$peeraddr:$peerport\@" . time();
 318     syslog('LOG_DEBUG', "New connection created: ".$mself->{conn_id});
 319 }
 320
 321 sub mux_input {
 322     my $mself = shift;
 323     my $mux = shift;
 324     my $mux_fh = shift;
 325     my $str_ref = shift;
 326
 327     my $conn_id = $mself->{conn_id}; # see mux_connection
 328
 329     # and process any pending logins
 330     check_pending_connections();
 331
 332     my $c = scalar(keys %active_connections);
 333     syslog("LOG_DEBUG", "multi: inbound message on connection $conn_id; $c total");
 334
 335     if ($kid_count >= $max_concurrent) {
 336         # XXX should we say something to the client? maybe wait and try again?
 337         syslog('LOG_ERR', "Unwilling to fork new child process, at least $max_concurrent already ongoing");
 338         return;
 339     }
 340
 341     my $self;
 342     if (!$active_connections{$conn_id}) { # Brand new connection, log them in
 343         $self = $mself->{net_server};
 344
 345         my ($sockaddr, $port, $proto);
 346
 347         $self->{config} = $config;
 348
 349         $sockaddr = $self->{server}->{sockaddr};
 350         $port     = $self->{server}->{sockport};
 351         $proto    = $self->{server}->{client}->NS_proto();
 352
 353         syslog('LOG_INFO', "New client $conn_id connecting to $sockaddr on port $port and proto $proto");
 354
 355         $self->{service} = $config->find_service( $sockaddr, $port, $proto );
 356
 357         if (! defined($self->{service})) {
 358             syslog( "LOG_ERR", "process_request: Unrecognized server connection: %s:%s/%s",
 359                 $sockaddr, $port, $proto );
 360             syslog('LOG_ERR', "process_request: Bad server connection");
 361             return;
 362         }
 363
 364         my $transport = $transports{ $self->{service}->{transport} };
 365
 366         if ( !defined($transport) ) {
 367             syslog("LOG_WARNING", "Unknown transport, dropping");
 368             return;
 369         }
 370
 371         # We stick this here, assuming success. Cleanup comes later via memcache and reaper.
 372         $active_connections{$conn_id} = {
 373             id => $conn_id,
 374             transport => $transport,
 375             net_server => $self,
 376             worker_pipe => IO::Pipe->new
 377         };
 378
 379         # This is kind of kinky, but allows us to avoid requiring Socket::Linux.
 380         # A simple "Socket::Linux"->use won't suffice since we need access to
 381         # all of it's bareword constants as well.
 382         eval <<'        EVAL';
 383         use Socket::Linux qw(TCP_KEEPINTVL TCP_KEEPIDLE TCP_KEEPCNT);
 384         setsockopt($self->{server}->{client}, SOL_SOCKET,  SO_KEEPALIVE, 1);
 385         setsockopt($self->{server}->{client}, IPPROTO_TCP, TCP_KEEPIDLE, 120);
 386         setsockopt($self->{server}->{client}, IPPROTO_TCP, TCP_KEEPINTVL, 10);
 387         EVAL
 388
 389         my $pid = fork();
 390         if (!defined($pid) or $pid < 0) {
 391             syslog('LOG_ERR', "Unable to fork new child process $!");
 392             return;
 393         }
 394
 395         if ($pid == 0) { # in kid
 396             $active_connections{$conn_id}{worker_pipe}->reader;
 397
 398             $cache = undef; # don't use the same cache handle as our parent.
 399             my $cache_data = {id => $conn_id};
 400
 401             # Once the login dance is complete in SipMsg, login_complete() is
 402             # called so that we may cache the results before the login response
 403             # message is delivered to the client.
 404             $self->{login_complete} = sub {
 405                 my $status = shift;
 406
 407                 if ($status) { # login OK
 408
 409                     $self->{state} = $self->{ils}->state() if (UNIVERSAL::can($self->{ils},'state'));
 410
 411                     $cache_data->{success} = 1;
 412                     $cache_data->{net_server_parts} = {
 413                         map { ($_ => $$self{$_}) } qw/state institution account/
 414                     };
 415
 416                     # Stash the ILS module somewhere handy for later
 417                     $cache_data->{net_server_parts}{ils} = ref($self->{ils});
 418
 419                 } else {
 420                     $cache_data->{success} = 0;
 421                 }
 422
 423                 init_cache()->set(
 424                     "sip_pending_auth_$conn_id",
 425                     Data::Dumper->Dump([$cache_data]),
 426                     # Our cache entry is only inspected when the parent process
 427                     # wakes up from an inbound request.  If this is the last child
 428                     # to connect before a long period of inactivity, our cache
 429                     # entry may sit unnattended for some time, hence the
 430                     # 12 hour cache timeout.  XXX: make it configurable?
 431                     43200 # 12 hours
 432                 );
 433
 434                 $self->{login_complete_called} = 1;
 435             };
 436
 437             syslog('LOG_DEBUG', "Child $$ / $conn_id kicking off login process");
 438
 439             eval { &$transport($self, $active_connections{$conn_id}{worker_pipe}) };
 440
 441             if ($@) {
 442                 syslog('LOG_ERR', "ILS login error: $@");
 443                 $self->{login_complete}->(0) unless $self->{login_complete_called};
 444             }
 445
 446             $self->sip_protocol_loop(
 447                 $active_connections{$conn_id}{worker_pipe},
 448                 $self->{account}->{'worker-keepalive'}
 449                     // $self->{institution}->{'worker-keepalive'}
 450                     // $worker_keepalive
 451             );
 452
 453             exit(0);
 454
 455         } else {
 456             my $fh = $active_connections{$conn_id}{worker_pipe};
 457             $fh->writer;
 458             $fh->autoflush;
 459             print $fh $$str_ref;
 460             push(@pending_connections, $conn_id);
 461             $kid_hash{$pid} = $conn_id;
 462             $kid_count++;
 463         }
 464
 465     } else {
 466
 467         $self = $active_connections{$conn_id}->{net_server};
 468         my $ns_parts = $active_connections{$conn_id}->{net_server_parts};
 469
 470         if ($active_connections{$conn_id}{worker_pipe}) {
 471             syslog('LOG_DEBUG', "multi: parent writing msg to existing child process");
 472             my $fh = $active_connections{$conn_id}{worker_pipe};
 473             print $fh $$str_ref;
 474
 475         } else { # waited too long, kid and pipe are gone
 476             $active_connections{$conn_id}{worker_pipe} = IO::Pipe->new;
 477             syslog('LOG_DEBUG', "multi: parent creating new pipe for existing connection");
 478
 479             my $pid = fork();
 480             if (!defined($pid) or $pid < 0) {
 481                 syslog('LOG_ERR', "Unable to fork new child process $!");
 482                 return;
 483             }
 484
 485             if ($pid == 0) { # in kid
 486                 $active_connections{$conn_id}{worker_pipe}->reader;
 487
 488                 syslog("LOG_DEBUG", "multi: $conn_id to be processed by child $$");
 489
 490                 # build the connection we deleted after logging in
 491                 $ns_parts->{ils}->use; # module name in the parent
 492                 $self->{$_} = $ns_parts->{$_} for keys %$ns_parts;
 493                 $self->{ils} = $ns_parts->{ils}->new(
 494                     $ns_parts->{institution}, $ns_parts->{account}, $ns_parts->{state});
 495
 496                 # MUX mode only works with protocol version 2, because it assumes
 497                 # a SIP login has occured.  However, since the login occured
 498                 # within a different now-dead process, the previously modified
 499                 # protocol_version is lost.  Re-apply it globally here.
 500                 $protocol_version = 2;
 501
 502                 if (!$self->{ils}) {
 503                     syslog('LOG_ERR', "Unable to build ILS module in mux child");
 504                     exit(0);
 505                 }
 506
 507                 $self->sip_protocol_loop(
 508                     $active_connections{$conn_id}{worker_pipe},
 509                     $self->{account}->{'worker-keepalive'}
 510                         // $self->{institution}->{'worker-keepalive'}
 511                         // $worker_keepalive
 512                 );
 513
 514
 515                 exit(0);
 516
 517             } else { # in parent
 518                 $active_connections{$conn_id}{worker_pipe}->writer;
 519                 my $fh = $active_connections{$conn_id}{worker_pipe};
 520                 $fh->autoflush;
 521                 print $fh $$str_ref;
 522                 $kid_count++;
 523                 $kid_hash{$pid} = $conn_id;
 524                 syslog("LOG_DEBUG", "multi: $conn_id forked child $pid; $kid_count total");
 525             }
 526         }
 527     }
 528
 529     # clear read data from the mux string ref
 530     $$str_ref = '';
 531 }
 532
 533 # client disconnected, remove the active connection
 534 sub mux_close {
 535     my ($self, $mux, $fh) = @_;
 536     my $conn_id = $self->{conn_id};
 537
 538     delete $active_connections{$conn_id};
 539     syslog("LOG_DEBUG", "multi: mux_close cleaning up child: $conn_id; ".
 540         scalar(keys %active_connections)." remain");
 541 }
 542
 543
 544 #
 545 # Transports
 546 #
 547
 548 sub raw_transport {
 549     my $self = shift;
 550     my $fh = shift || *STDIN;
 551
 552     my ($uid, $pwd);
 553     my $input;
 554     my $service = $self->{service};
 555     my $strikes = 3;
 556     my $inst;
 557     my $timeout = $self->{service}->{timeout} || $self->{config}->{timeout} || 0;
 558
 559     eval {
 560         local $SIG{ALRM} = sub { die "raw_transport Timed Out!\n"; };
 561         syslog("LOG_DEBUG", "raw_transport: timeout is $timeout");
 562
 563     while ($strikes--) {
 564         alarm $timeout;
 565         $input = Sip::read_SIP_packet($fh);
 566         alarm 0;
 567
 568         if (!$input) {
 569             # EOF on the socket
 570             syslog("LOG_INFO", "raw_transport: shutting down: EOF during login");
 571             return;
 572         } elsif ($input !~ /\S/) {
 573             syslog("LOG_INFO", "raw_transport: received whitespace line (length %s) during login, skipping", length($input));
 574             next;
 575         }
 576         $input =~ s/[\r\n]+$//sm;       # Strip off trailing line terminator
 577         if ($input =~ /^99/) { # SC Status
 578             unless ($service->allow_sc_status_then_login()) {
 579                 die 'raw_transport: sending SC status before login not enabled, exiting';
 580             }
 581             Sip::MsgType::handle($input, $self, SC_STATUS);
 582             $strikes++; # it's allowed, don't charge for it
 583             next;
 584         }
 585         last if Sip::MsgType::handle($input, $self, LOGIN);
 586     }
 587     };
 588
 589     if ($@) {
 590         syslog("LOG_ERR", "raw_transport: LOGIN ERROR: '$@'");
 591         die "raw_transport: login error (timeout? $@), exiting";
 592     } elsif (!$self->{account}) {
 593         syslog("LOG_ERR", "raw_transport: LOGIN FAILED");
 594         die "raw_transport: Login failed (no account), exiting";
 595     }
 596
 597     syslog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
 598         $self->{account}->{id},
 599         $self->{account}->{institution});
 600 }
 601
 602 sub telnet_transport {
 603     my $self = shift;
 604     my $fh = shift || *STDIN;
 605
 606     my ($uid, $pwd);
 607     my $strikes = 3;
 608     my $account = undef;
 609     my $input;
 610     my $config = $self->{config};
 611     my $timeout = $self->{service}->{timeout} || $config->{timeout} || 0;
 612     syslog("LOG_DEBUG", "telnet_transport: timeout is %s", $timeout);
 613
 614     # Until the terminal has logged in, we don't trust it
 615     # so use a timeout to protect ourselves from hanging.
 616     eval {
 617     local $SIG{ALRM} = sub { die "telnet_transport: Timed Out ($timeout seconds)!\n";; };
 618     local $| = 1;                       # Unbuffered output
 619
 620     while ($strikes--) {
 621         print "login: ";
 622         alarm $timeout;
 623         $uid = <$fh>;
 624         alarm 0;
 625
 626         print "password: ";
 627         alarm $timeout;
 628         $pwd = <$fh>;
 629         alarm 0;
 630
 631         $uid =~ s/[\r\n]+$//;
 632         $pwd =~ s/[\r\n]+$//;
 633
 634         if (exists($config->{accounts}->{$uid})
 635         && ($pwd eq $config->{accounts}->{$uid}->password())) {
 636             $account = $config->{accounts}->{$uid};
 637             last;
 638         } else {
 639             syslog("LOG_WARNING", "Invalid login attempt: '%s'", $uid);
 640             print("Invalid login$CRLF");
 641         }
 642     }
 643     }; # End of eval
 644
 645     if ($@) {
 646         syslog("LOG_ERR", "telnet_transport: Login timed out");
 647         die "Telnet Login Timed out";
 648     } elsif (!defined($account)) {
 649         syslog("LOG_ERR", "telnet_transport: Login Failed");
 650         die "Login Failure";
 651     } else {
 652         print "Login OK.  Initiating SIP$CRLF";
 653     }
 654
 655     $self->{account} = $account;
 656     syslog("LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'", $account->{id}, $account->{institution});
 657 }
 658
 659
 660 sub http_transport {
 661 }
 662
 663 #
 664 # The terminal has logged in, using either the SIP login process
 665 # over a raw socket, or via the pseudo-unix login provided by the
 666 # telnet transport.  From that point on, both the raw and the telnet
 667 # processes are the same:
 668 sub sip_protocol_loop {
 669     my $self = shift;
 670     my $fh = shift || *STDIN;
 671     my $keepalive = shift;
 672     my $expect;
 673     my $service = $self->{service};
 674     my $config  = $self->{config};
 675     my $input;
 676     my $timeout = $keepalive || $self->{service}->{timeout} || $config->{timeout} || 0;
 677
 678     # Now that the terminal has logged in, the first message
 679     # we recieve must be an SC_STATUS message.  But it might be
 680     # an SC_REQUEST_RESEND.  So, as long as we keep receiving
 681     # SC_REQUEST_RESEND, we keep waiting for an SC_STATUS
 682
 683     # Comprise reports that no other ILS actually enforces this
 684     # constraint, so we'll relax about it too.  As long as everybody
 685     # uses the SIP "raw" login process, rather than telnet, this
 686     # will be fine, becaues the LOGIN protocol exchange will force
 687     # us into SIP 2.00 anyway.  Machines that want to log in using
 688     # telnet MUST send an SC Status message first, even though we're
 689     # not enforcing it.
 690     #
 691     #$expect = SC_STATUS;
 692     $expect = '';
 693
 694     alarm $timeout; # First loop timeout
 695     while ( $input = Sip::read_SIP_packet($fh) ) {
 696         alarm 0; # Don't timeout while we are processing
 697         $input =~ s/[\r\n]+$//sm;    # Strip off any trailing line ends
 698
 699         my $start = time;
 700         my $status = Sip::MsgType::handle($input, $self, $expect);
 701         if ($status eq REQUEST_ACS_RESEND) {
 702             alarm $timeout;
 703             next;
 704         }
 705
 706         my $duration = sprintf("%0.3f", time - $start);
 707         syslog('LOG_DEBUG', "SIP processing duration $duration : $input");
 708
 709         if (!$status) {
 710             syslog("LOG_ERR", "raw_transport: failed to handle %s", substr($input,0,2));
 711             die "sip_protocol_loop: failed Sip::MsgType::handle('$input', $self, '$expect')";
 712         }
 713         elsif ($expect && ($status ne $expect)) {
 714             # We received a non-"RESEND" that wasn't what we were expecting.
 715             syslog("LOG_ERR", "raw_transport: expected %s, received %s, exiting", $expect, $input);
 716             die "sip_protocol_loop: exiting: expected '$expect', received '$status'";
 717         }
 718
 719         last if (defined $keepalive && !$keepalive);
 720
 721         # We successfully received and processed what we were expecting
 722         $expect = '';
 723         alarm $timeout; # Next loop timeout
 724
 725     }
 726 }