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         &$transport($self);
 186         # Transport has shut down, remove any lingering login info
 187         $self->{account} = undef;
 188     }
 189
 190     $self->sip_protocol_loop();
 191
 192     syslog("LOG_INFO", '%s: shutting down', $transport);
 193 }
 194
 195 # mux_input is the callback used by Net::Server to handle
 196 # an incoming connection request when the peronsality is
 197 # Multiplex.
 198
 199
 200 sub init_cache {
 201     return $cache if $cache;
 202
 203     if (!$config->{cache}) {
 204         syslog('LOG_ERR', "Cache servers needed");
 205         return;
 206     }
 207     my $servers = $config->{cache}->{server};
 208     syslog('LOG_DEBUG', "Cache servers: @$servers");
 209
 210     $cache = Cache::Memcached->new({servers => $servers}) or
 211         syslog('LOG_ERR', "Unable to initialize memcache: @$servers");
 212
 213     return $cache;
 214 }
 215
 216 # In the parent, pending connections are tracked as an array of PIDs.
 217 # As each child process completes the login dance, it plops some
 218 # info into memcache for us to pickup and copy into our active
 219 # connections.  No memcache entry means the child login dance
 220 # is still in progress.
 221 sub check_pending_connections {
 222     return unless @pending_connections;
 223
 224     init_cache();
 225
 226     syslog('LOG_DEBUG',
 227         "multi: pending connections to inspect: @pending_connections");
 228
 229     # get_multi will return all completed login blobs
 230     my @keys = map { "sip_pending_auth_$_" } @pending_connections;
 231     my $values = $cache->get_multi(@keys);
 232
 233     for my $key (keys %$values) {
 234         my $VAR1; # for Dump() -> eval;
 235         eval $values->{$key}; # Data::Dumper->Dump string
 236
 237         my $id = $VAR1->{id}; # conn_id
 238         $active_connections{$id}{net_server_parts} = $VAR1->{net_server_parts};
 239
 240         if ($VAR1->{success}) {
 241             if ($active_connections{$id}{net_server_parts}{state}) {
 242                 local $Data::Dumper::Indent = 0;
 243                 syslog('LOG_DEBUG', "multi: conn_id=$id has state: ".
 244                     Dumper($active_connections{$id}{net_server_parts}{state}));
 245             }
 246
 247         } else {
 248             syslog('LOG_INFO', "Child $id failed SIP login; removing connection");
 249             delete $active_connections{$id};
 250         }
 251
 252         # clean up ---
 253
 254         syslog('LOG_DEBUG',
 255             "multi: pending connection for conn_id=$id resolved");
 256         $cache->delete($key);
 257         @pending_connections = grep {$_ ne $id} @pending_connections;
 258     }
 259
 260     syslog('LOG_DEBUG',
 261         "multi: connections still pending after check: @pending_connections")
 262         if @pending_connections;
 263
 264     if (0) {
 265         # useful for debugging connection-specific state information
 266         local $Data::Dumper::Indent = 0;
 267         for my $conn_id (keys %active_connections) {
 268             syslog('LOG_DEBUG', "Connection $conn_id has state "
 269                 .Dumper($active_connections{$conn_id}{net_server_parts}{state}));
 270         }
 271     }
 272 }
 273
 274 sub sig_chld {
 275     if ( !scalar(keys(%kid_hash))) { # not using mux mode
 276         1 while waitpid(-1, WNOHANG) > 0;
 277     } else {
 278         for (keys(%kid_hash)) {
 279             if ( my $reaped = waitpid($_, WNOHANG) > 0 ) {
 280                 syslog('LOG_DEBUG', "Reaping child $_");
 281                 # Mourning... done.
 282                 $kid_count--;
 283                 # note: in some cases (when the primary connection is severed),
 284                 # the active connection is cleaned up in mux_close.
 285                 if ($active_connections{$kid_hash{$_}}) {
 286                     if ($active_connections{$kid_hash{$_}}{worker_pipe}) {
 287                         syslog('LOG_DEBUG', "Closing worker pipe after timeout for: $kid_hash{$_}");
 288                         delete $active_connections{$kid_hash{$_}}{worker_pipe};
 289                     }
 290                 }
 291                 delete $kid_hash{$_};
 292             }
 293         }
 294     }
 295 }
 296
 297 sub mux_connection {
 298     my ($mself, $fh) = @_;
 299
 300     my ($peeraddr, $peerport) = (
 301         $mself->{net_server}->{server}->{peeraddr},
 302         $mself->{net_server}->{server}->{peerport}
 303     );
 304
 305     # create a new connection ID for this MUX handler.
 306     $mself->{conn_id} = "$peeraddr:$peerport\@" . time();
 307     syslog('LOG_DEBUG', "New connection created: ".$mself->{conn_id});
 308 }
 309
 310 sub mux_input {
 311     my $mself = shift;
 312     my $mux = shift;
 313     my $mux_fh = shift;
 314     my $str_ref = shift;
 315
 316     my $conn_id = $mself->{conn_id}; # see mux_connection
 317
 318     # and process any pending logins
 319     check_pending_connections();
 320
 321     my $c = scalar(keys %active_connections);
 322     syslog("LOG_DEBUG", "multi: inbound message on connection $conn_id; $c total");
 323
 324     if ($kid_count >= $max_concurrent) {
 325         # XXX should we say something to the client? maybe wait and try again?
 326         syslog('LOG_ERR', "Unwilling to fork new child process, at least $max_concurrent already ongoing");
 327         return;
 328     }
 329
 330     my $self;
 331     if (!$active_connections{$conn_id}) { # Brand new connection, log them in
 332         $self = $mself->{net_server};
 333
 334         my ($sockaddr, $port, $proto);
 335
 336         $self->{config} = $config;
 337
 338         $sockaddr = $self->{server}->{sockaddr};
 339         $port     = $self->{server}->{sockport};
 340         $proto    = $self->{server}->{client}->NS_proto();
 341
 342         syslog('LOG_INFO', "New client $conn_id connecting to $sockaddr on port $port and proto $proto");
 343
 344         $self->{service} = $config->find_service( $sockaddr, $port, $proto );
 345
 346         if (! defined($self->{service})) {
 347             syslog( "LOG_ERR", "process_request: Unrecognized server connection: %s:%s/%s",
 348                 $sockaddr, $port, $proto );
 349             syslog('LOG_ERR', "process_request: Bad server connection");
 350             return;
 351         }
 352
 353         my $transport = $transports{ $self->{service}->{transport} };
 354
 355         if ( !defined($transport) ) {
 356             syslog("LOG_WARNING", "Unknown transport, dropping");
 357             return;
 358         }
 359
 360         # We stick this here, assuming success. Cleanup comes later via memcache and reaper.
 361         $active_connections{$conn_id} = {
 362             id => $conn_id,
 363             transport => $transport,
 364             net_server => $self,
 365             worker_pipe => IO::Pipe->new
 366         };
 367
 368         # This is kind of kinky, but allows us to avoid requiring Socket::Linux.
 369         # A simple "Socket::Linux"->use won't suffice since we need access to
 370         # all of it's bareword constants as well.
 371         eval <<'        EVAL';
 372         use Socket::Linux qw(TCP_KEEPINTVL TCP_KEEPIDLE TCP_KEEPCNT);
 373         setsockopt($self->{server}->{client}, SOL_SOCKET,  SO_KEEPALIVE, 1);
 374         setsockopt($self->{server}->{client}, IPPROTO_TCP, TCP_KEEPIDLE, 120);
 375         setsockopt($self->{server}->{client}, IPPROTO_TCP, TCP_KEEPINTVL, 10);
 376         EVAL
 377
 378         my $pid = fork();
 379         if (!defined($pid) or $pid < 0) {
 380             syslog('LOG_ERR', "Unable to fork new child process $!");
 381             return;
 382         }
 383
 384         if ($pid == 0) { # in kid
 385             $active_connections{$conn_id}{worker_pipe}->reader;
 386
 387             $cache = undef; # don't use the same cache handle as our parent.
 388             my $cache_data = {id => $conn_id};
 389
 390             # Once the login dance is complete in SipMsg, login_complete() is
 391             # called so that we may cache the results before the login response
 392             # message is delivered to the client.
 393             $self->{login_complete} = sub {
 394                 my $status = shift;
 395
 396                 if ($status) { # login OK
 397
 398                     $self->{state} = $self->{ils}->state() if (UNIVERSAL::can($self->{ils},'state'));
 399
 400                     $cache_data->{success} = 1;
 401                     $cache_data->{net_server_parts} = {
 402                         map { ($_ => $$self{$_}) } qw/state institution account/
 403                     };
 404
 405                     # Stash the ILS module somewhere handy for later
 406                     $cache_data->{net_server_parts}{ils} = ref($self->{ils});
 407
 408                 } else {
 409                     $cache_data->{success} = 0;
 410                 }
 411
 412                 init_cache()->set(
 413                     "sip_pending_auth_$conn_id",
 414                     Data::Dumper->Dump([$cache_data]),
 415                     # Our cache entry is only inspected when the parent process
 416                     # wakes up from an inbound request.  If this is the last child
 417                     # to connect before a long period of inactivity, our cache
 418                     # entry may sit unnattended for some time, hence the
 419                     # 12 hour cache timeout.  XXX: make it configurable?
 420                     43200 # 12 hours
 421                 );
 422
 423                 $self->{login_complete_called} = 1;
 424             };
 425
 426             syslog('LOG_DEBUG', "Child $$ / $conn_id kicking off login process");
 427
 428             eval { &$transport($self, $active_connections{$conn_id}{worker_pipe}) };
 429
 430             if ($@) {
 431                 syslog('LOG_ERR', "ILS login error: $@");
 432                 $self->{login_complete}->(0) unless $self->{login_complete_called};
 433             }
 434
 435             $self->sip_protocol_loop(
 436                 $active_connections{$conn_id}{worker_pipe},
 437                 $self->{account}->{'worker-keepalive'}
 438                     // $self->{institution}->{'worker-keepalive'}
 439                     // $worker_keepalive
 440             );
 441
 442             exit(0);
 443
 444         } else {
 445             my $fh = $active_connections{$conn_id}{worker_pipe};
 446             $fh->writer;
 447             $fh->autoflush;
 448             print $fh $$str_ref;
 449             push(@pending_connections, $conn_id);
 450             $kid_hash{$pid} = $conn_id;
 451             $kid_count++;
 452         }
 453
 454     } else {
 455
 456         $self = $active_connections{$conn_id}->{net_server};
 457         my $ns_parts = $active_connections{$conn_id}->{net_server_parts};
 458
 459         if ($active_connections{$conn_id}{worker_pipe}) {
 460             syslog('LOG_DEBUG', "multi: parent writing msg to existing child process");
 461             my $fh = $active_connections{$conn_id}{worker_pipe};
 462             print $fh $$str_ref;
 463
 464         } else { # waited too long, kid and pipe are gone
 465             $active_connections{$conn_id}{worker_pipe} = IO::Pipe->new;
 466             syslog('LOG_DEBUG', "multi: parent creating new pipe for existing connection");
 467
 468             my $pid = fork();
 469             if (!defined($pid) or $pid < 0) {
 470                 syslog('LOG_ERR', "Unable to fork new child process $!");
 471                 return;
 472             }
 473
 474             if ($pid == 0) { # in kid
 475                 $active_connections{$conn_id}{worker_pipe}->reader;
 476
 477                 syslog("LOG_DEBUG", "multi: $conn_id to be processed by child $$");
 478
 479                 # build the connection we deleted after logging in
 480                 $ns_parts->{ils}->use; # module name in the parent
 481                 $self->{$_} = $ns_parts->{$_} for keys %$ns_parts;
 482                 $self->{ils} = $ns_parts->{ils}->new(
 483                     $ns_parts->{institution}, $ns_parts->{account}, $ns_parts->{state});
 484
 485                 # MUX mode only works with protocol version 2, because it assumes
 486                 # a SIP login has occured.  However, since the login occured
 487                 # within a different now-dead process, the previously modified
 488                 # protocol_version is lost.  Re-apply it globally here.
 489                 $protocol_version = 2;
 490
 491                 if (!$self->{ils}) {
 492                     syslog('LOG_ERR', "Unable to build ILS module in mux child");
 493                     exit(0);
 494                 }
 495
 496                 $self->sip_protocol_loop(
 497                     $active_connections{$conn_id}{worker_pipe},
 498                     $self->{account}->{'worker-keepalive'}
 499                         // $self->{institution}->{'worker-keepalive'}
 500                         // $worker_keepalive
 501                 );
 502
 503
 504                 exit(0);
 505
 506             } else { # in parent
 507                 $active_connections{$conn_id}{worker_pipe}->writer;
 508                 my $fh = $active_connections{$conn_id}{worker_pipe};
 509                 $fh->autoflush;
 510                 print $fh $$str_ref;
 511                 $kid_count++;
 512                 $kid_hash{$pid} = $conn_id;
 513                 syslog("LOG_DEBUG", "multi: $conn_id forked child $pid; $kid_count total");
 514             }
 515         }
 516     }
 517
 518     # clear read data from the mux string ref
 519     $$str_ref = '';
 520 }
 521
 522 # client disconnected, remove the active connection
 523 sub mux_close {
 524     my ($self, $mux, $fh) = @_;
 525     my $conn_id = $self->{conn_id};
 526
 527     delete $active_connections{$conn_id};
 528     syslog("LOG_DEBUG", "multi: mux_close cleaning up child: $conn_id; ".
 529         scalar(keys %active_connections)." remain");
 530 }
 531
 532
 533 #
 534 # Transports
 535 #
 536
 537 sub raw_transport {
 538     my $self = shift;
 539     my $fh = shift || *STDIN;
 540
 541     my ($uid, $pwd);
 542     my $input;
 543     my $service = $self->{service};
 544     my $strikes = 3;
 545     my $inst;
 546     my $timeout = $self->{service}->{timeout} || $self->{config}->{timeout} || 0;
 547
 548     eval {
 549         local $SIG{ALRM} = sub { die "raw_transport Timed Out!\n"; };
 550         syslog("LOG_DEBUG", "raw_transport: timeout is $timeout");
 551
 552     while ($strikes--) {
 553         alarm $timeout;
 554         $input = Sip::read_SIP_packet($fh);
 555         alarm 0;
 556
 557         if (!$input) {
 558             # EOF on the socket
 559             syslog("LOG_INFO", "raw_transport: shutting down: EOF during login");
 560             return;
 561         } elsif ($input !~ /\S/) {
 562             syslog("LOG_INFO", "raw_transport: received whitespace line (length %s) during login, skipping", length($input));
 563             next;
 564         }
 565         $input =~ s/[\r\n]+$//sm;       # Strip off trailing line terminator
 566         if ($input =~ /^99/) { # SC Status
 567             unless ($service->allow_sc_status_then_login()) {
 568                 die 'raw_transport: sending SC status before login not enabled, exiting';
 569             }
 570             Sip::MsgType::handle($input, $self, SC_STATUS);
 571             $strikes++; # it's allowed, don't charge for it
 572             next;
 573         }
 574         last if Sip::MsgType::handle($input, $self, LOGIN);
 575     }
 576     };
 577
 578     if ($@) {
 579         syslog("LOG_ERR", "raw_transport: LOGIN ERROR: '$@'");
 580         die "raw_transport: login error (timeout? $@), exiting";
 581     } elsif (!$self->{account}) {
 582         syslog("LOG_ERR", "raw_transport: LOGIN FAILED");
 583         die "raw_transport: Login failed (no account), exiting";
 584     }
 585
 586     syslog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
 587         $self->{account}->{id},
 588         $self->{account}->{institution});
 589 }
 590
 591 sub telnet_transport {
 592     my $self = shift;
 593     my $fh = shift || *STDIN;
 594
 595     my ($uid, $pwd);
 596     my $strikes = 3;
 597     my $account = undef;
 598     my $input;
 599     my $config = $self->{config};
 600     my $timeout = $self->{service}->{timeout} || $config->{timeout} || 0;
 601     syslog("LOG_DEBUG", "telnet_transport: timeout is %s", $timeout);
 602
 603     # Until the terminal has logged in, we don't trust it
 604     # so use a timeout to protect ourselves from hanging.
 605     eval {
 606     local $SIG{ALRM} = sub { die "telnet_transport: Timed Out ($timeout seconds)!\n";; };
 607     local $| = 1;                       # Unbuffered output
 608
 609     while ($strikes--) {
 610         print "login: ";
 611         alarm $timeout;
 612         $uid = <$fh>;
 613         alarm 0;
 614
 615         print "password: ";
 616         alarm $timeout;
 617         $pwd = <$fh>;
 618         alarm 0;
 619
 620         $uid =~ s/[\r\n]+$//;
 621         $pwd =~ s/[\r\n]+$//;
 622
 623         if (exists($config->{accounts}->{$uid})
 624         && ($pwd eq $config->{accounts}->{$uid}->password())) {
 625             $account = $config->{accounts}->{$uid};
 626             last;
 627         } else {
 628             syslog("LOG_WARNING", "Invalid login attempt: '%s'", $uid);
 629             print("Invalid login$CRLF");
 630         }
 631     }
 632     }; # End of eval
 633
 634     if ($@) {
 635         syslog("LOG_ERR", "telnet_transport: Login timed out");
 636         die "Telnet Login Timed out";
 637     } elsif (!defined($account)) {
 638         syslog("LOG_ERR", "telnet_transport: Login Failed");
 639         die "Login Failure";
 640     } else {
 641         print "Login OK.  Initiating SIP$CRLF";
 642     }
 643
 644     $self->{account} = $account;
 645     syslog("LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'", $account->{id}, $account->{institution});
 646 }
 647
 648
 649 sub http_transport {
 650 }
 651
 652 #
 653 # The terminal has logged in, using either the SIP login process
 654 # over a raw socket, or via the pseudo-unix login provided by the
 655 # telnet transport.  From that point on, both the raw and the telnet
 656 # processes are the same:
 657 sub sip_protocol_loop {
 658     my $self = shift;
 659     my $fh = shift || *STDIN;
 660     my $keepalive = shift;
 661     my $expect;
 662     my $service = $self->{service};
 663     my $config  = $self->{config};
 664     my $input;
 665     my $timeout = $keepalive || $self->{service}->{timeout} || $config->{timeout} || 0;
 666
 667     # Now that the terminal has logged in, the first message
 668     # we recieve must be an SC_STATUS message.  But it might be
 669     # an SC_REQUEST_RESEND.  So, as long as we keep receiving
 670     # SC_REQUEST_RESEND, we keep waiting for an SC_STATUS
 671
 672     # Comprise reports that no other ILS actually enforces this
 673     # constraint, so we'll relax about it too.  As long as everybody
 674     # uses the SIP "raw" login process, rather than telnet, this
 675     # will be fine, becaues the LOGIN protocol exchange will force
 676     # us into SIP 2.00 anyway.  Machines that want to log in using
 677     # telnet MUST send an SC Status message first, even though we're
 678     # not enforcing it.
 679     #
 680     #$expect = SC_STATUS;
 681     $expect = '';
 682
 683     alarm $timeout; # First loop timeout
 684     while ( $input = Sip::read_SIP_packet($fh) ) {
 685         alarm 0; # Don't timeout while we are processing
 686         $input =~ s/[\r\n]+$//sm;    # Strip off any trailing line ends
 687
 688         my $status = Sip::MsgType::handle($input, $self, $expect);
 689         if ($status eq REQUEST_ACS_RESEND) {
 690             alarm $timeout;
 691             next;
 692         }
 693
 694         if (!$status) {
 695             syslog("LOG_ERR", "raw_transport: failed to handle %s", substr($input,0,2));
 696             die "sip_protocol_loop: failed Sip::MsgType::handle('$input', $self, '$expect')";
 697         }
 698         elsif ($expect && ($status ne $expect)) {
 699             # We received a non-"RESEND" that wasn't what we were expecting.
 700             syslog("LOG_ERR", "raw_transport: expected %s, received %s, exiting", $expect, $input);
 701             die "sip_protocol_loop: exiting: expected '$expect', received '$status'";
 702         }
 703
 704         last if (defined $keepalive && !$keepalive);
 705
 706         # We successfully received and processed what we were expecting
 707         $expect = '';
 708         alarm $timeout; # Next loop timeout
 709
 710     }
 711 }