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