C4/SIP/SIPServer.pm

   1 #!/usr/bin/perl
   2 package SIPServer;
   3
   4 use strict;
   5 use warnings;
   6 use FindBin qw($Bin);
   7 use lib "$Bin";
   8 use Sys::Syslog qw(syslog);
   9 use Net::Server::PreFork;
  10 use IO::Socket::INET;
  11 use Socket qw(:DEFAULT :crlf);
  12 require UNIVERSAL::require;
  13
  14 use Sip::Constants qw(:all);
  15 use Sip::Configuration;
  16 use Sip::Checksum qw(checksum verify_cksum);
  17 use Sip::MsgType;
  18
  19 use base qw(Net::Server::PreFork);
  20
  21 use constant LOG_SIP => "local6"; # Local alias for the logging facility
  22
  23 #
  24 # Main  # not really, since package SIPServer
  25 #
  26 # FIXME: Is this a module or a script?
  27 # A script with no MAIN namespace?
  28 # A module that takes command line args?
  29
  30 my %transports = (
  31     RAW    => \&raw_transport,
  32     telnet => \&telnet_transport,
  33 );
  34
  35 #
  36 # Read configuration
  37 #
  38 my $config = new Sip::Configuration $ARGV[0];
  39 my @parms;
  40
  41 #
  42 # Ports to bind
  43 #
  44 foreach my $svc (keys %{$config->{listeners}}) {
  45     push @parms, "port=" . $svc;
  46 }
  47
  48 #
  49 # Logging
  50 #
  51 # Log lines look like this:
  52 # Jun 16 21:21:31 server08 steve_sip[19305]: ILS::Transaction::Checkout performing checkout...
  53 # [  TIMESTAMP  ] [ HOST ] [ IDENT ]  PID  : Message...
  54 #
  55 # The IDENT is determined by config file 'server-params' arguments
  56
  57
  58 #
  59 # Server Management: set parameters for the Net::Server::PreFork
  60 # module.  The module silently ignores parameters that it doesn't
  61 # recognize, and complains about invalid values for parameters
  62 # that it does.
  63 #
  64 if (defined($config->{'server-params'})) {
  65     while (my ($key, $val) = each %{$config->{'server-params'}}) {
  66                 push @parms, $key . '=' . $val;
  67     }
  68 }
  69
  70
  71 #
  72 # This is the main event.
  73 __PACKAGE__ ->run(@parms);
  74
  75 #
  76 # Child
  77 #
  78
  79 # process_request is the callback used by Net::Server to handle
  80 # an incoming connection request.
  81
  82 sub process_request {
  83     my $self = shift;
  84     my $service;
  85     my ($sockaddr, $port, $proto);
  86     my $transport;
  87
  88     $self->{config} = $config;
  89
  90     my $sockname = getsockname(STDIN);
  91     ($port, $sockaddr) = sockaddr_in($sockname);
  92     $sockaddr = inet_ntoa($sockaddr);
  93     $proto = $self->{server}->{client}->NS_proto();
  94
  95     $self->{service} = $config->find_service($sockaddr, $port, $proto);
  96
  97     if (!defined($self->{service})) {
  98                 syslog("LOG_ERR", "process_request: Unknown recognized server connection: %s:%s/%s", $sockaddr, $port, $proto);
  99                 die "process_request: Bad server connection";
 100     }
 101
 102     $transport = $transports{$self->{service}->{transport}};
 103
 104     if (!defined($transport)) {
 105                 syslog("LOG_WARNING", "Unknown transport '%s', dropping", $service->{transport});
 106                 return;
 107     } else {
 108                 &$transport($self);
 109     }
 110 }
 111
 112 #
 113 # Transports
 114 #
 115
 116 sub raw_transport {
 117     my $self = shift;
 118     my ($input);
 119     my $service = $self->{service};
 120
 121     while (!$self->{account}) {
 122     local $SIG{ALRM} = sub { die "raw_transport Timed Out!\n"; };
 123     syslog("LOG_DEBUG", "raw_transport: timeout is %d", $service->{timeout});
 124     $input = Sip::read_SIP_packet(*STDIN);
 125     if (!$input) {
 126         # EOF on the socket
 127         syslog("LOG_INFO", "raw_transport: shutting down: EOF during login");
 128         return;
 129     }
 130     $input =~ s/[\r\n]+$//sm;   # Strip off trailing line terminator(s)
 131     last if Sip::MsgType::handle($input, $self, LOGIN);
 132     }
 133
 134     syslog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
 135            $self->{account}->{id},
 136            $self->{account}->{institution});
 137
 138     $self->sip_protocol_loop();
 139     syslog("LOG_INFO", "raw_transport: shutting down");
 140 }
 141
 142 sub get_clean_string {
 143         my $string = shift;
 144         if (defined $string) {
 145                 syslog("LOG_DEBUG", "get_clean_string  pre-clean(length %s): %s", length($string), $string);
 146                 chomp($string);
 147                 $string =~ s/^[^A-z0-9]+//;
 148                 $string =~ s/[^A-z0-9]+$//;
 149                 syslog("LOG_DEBUG", "get_clean_string post-clean(length %s): %s", length($string), $string);
 150         } else {
 151                 syslog("LOG_INFO", "get_clean_string called on undefined");
 152         }
 153         return $string;
 154 }
 155
 156 sub get_clean_input {
 157         local $/ = "\012";
 158         my $in = <STDIN>;
 159         $in = get_clean_string($in);
 160         while (my $extra = <STDIN>){
 161                 syslog("LOG_ERR", "get_clean_input got extra lines: %s", $extra);
 162         }
 163         return $in;
 164 }
 165
 166 sub telnet_transport {
 167     my $self = shift;
 168     my ($uid, $pwd);
 169     my $strikes = 3;
 170     my $account = undef;
 171     my $input;
 172     my $config  = $self->{config};
 173         my $timeout = $self->{service}->{timeout} || $config->{timeout} || 30;
 174         syslog("LOG_DEBUG", "telnet_transport: timeout is %s", $timeout);
 175
 176     eval {
 177         local $SIG{ALRM} = sub { die "telnet_transport: Timed Out ($timeout seconds)!\n"; };
 178         local $| = 1;                   # Unbuffered output
 179         $/ = "\015";            # Internet Record Separator (lax version)
 180     # Until the terminal has logged in, we don't trust it
 181     # so use a timeout to protect ourselves from hanging.
 182
 183         while ($strikes--) {
 184             print "login: ";
 185                 alarm $timeout;
 186                 # $uid = &get_clean_input;
 187                 $uid = <STDIN>;
 188             print "password: ";
 189             # $pwd = &get_clean_input || '';
 190                 $pwd = <STDIN>;
 191                 alarm 0;
 192
 193                 syslog("LOG_DEBUG", "telnet_transport 1: uid length %s, pwd length %s", length($uid), length($pwd));
 194                 $uid = get_clean_string ($uid);
 195                 $pwd = get_clean_string ($pwd);
 196                 syslog("LOG_DEBUG", "telnet_transport 2: uid length %s, pwd length %s", length($uid), length($pwd));
 197
 198             if (exists ($config->{accounts}->{$uid})
 199                 && ($pwd eq $config->{accounts}->{$uid}->password())) {
 200                         $account = $config->{accounts}->{$uid};
 201                         Sip::MsgType::login_core($self,$uid,$pwd) and last;
 202             }
 203                 syslog("LOG_WARNING", "Invalid login attempt: '%s'", ($uid||''));
 204                 print("Invalid login$CRLF");
 205         }
 206     }; # End of eval
 207
 208     if ($@) {
 209                 syslog("LOG_ERR", "telnet_transport: Login timed out");
 210                 die "Telnet Login Timed out";
 211     } elsif (!defined($account)) {
 212                 syslog("LOG_ERR", "telnet_transport: Login Failed");
 213                 die "Login Failure";
 214     } else {
 215                 print "Login OK.  Initiating SIP$CRLF";
 216     }
 217
 218     $self->{account} = $account;
 219     syslog("LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'", $account->{id}, $account->{institution});
 220     $self->sip_protocol_loop();
 221     syslog("LOG_INFO", "telnet_transport: shutting down");
 222 }
 223
 224 #
 225 # The terminal has logged in, using either the SIP login process
 226 # over a raw socket, or via the pseudo-unix login provided by the
 227 # telnet transport.  From that point on, both the raw and the telnet
 228 # processes are the same:
 229 sub sip_protocol_loop {
 230         my $self = shift;
 231         my $service = $self->{service};
 232         my $config  = $self->{config};
 233         my $input;
 234
 235     # The spec says the first message will be:
 236         #       SIP v1: SC_STATUS
 237         #       SIP v2: LOGIN (or SC_STATUS via telnet?)
 238     # But it might be SC_REQUEST_RESEND.  As long as we get
 239     # SC_REQUEST_RESEND, we keep waiting.
 240
 241     # Comprise reports that no other ILS actually enforces this
 242     # constraint, so we'll relax about it too.
 243     # Using the SIP "raw" login process, rather than telnet,
 244     # requires the LOGIN message and forces SIP 2.00.  In that
 245         # case, the LOGIN message has already been processed (above).
 246         #
 247         # In short, we'll take any valid message here.
 248         #my $expect = SC_STATUS;
 249     my $expect = '';
 250     while (1) {
 251         $input = Sip::read_SIP_packet(*STDIN);
 252         unless ($input) {
 253             return;             # EOF
 254         }
 255                 # begin input hacks ...  a cheap stand in for better Telnet layer
 256                 $input =~ s/^[^A-z0-9]+//s;     # Kill leading bad characters... like Telnet handshakers
 257                 $input =~ s/[^A-z0-9]+$//s;     # Same on the end, should get DOSsy ^M line-endings too.
 258                 while (chomp($input)) {warn "Extra line ending on input";}
 259                 unless ($input) {
 260             syslog("LOG_ERR", "sip_protocol_loop: empty input skipped");
 261             print("96$CR");
 262             next;
 263                 }
 264                 # end cheap input hacks
 265                 my $status = Sip::MsgType::handle($input, $self, $expect);
 266                 if (!$status) {
 267                         syslog("LOG_ERR", "sip_protocol_loop: failed to handle %s",substr($input,0,2));
 268                 }
 269                 next if $status eq REQUEST_ACS_RESEND;
 270                 if ($expect && ($status ne $expect)) {
 271                         # We received a non-"RESEND" that wasn't what we were expecting.
 272                     syslog("LOG_ERR", "sip_protocol_loop: expected %s, received %s, exiting", $expect, $input);
 273                 }
 274                 # We successfully received and processed what we were expecting
 275                 $expect = '';
 276         }
 277 }
 278
 279 1;
 280 __END__