C4/SIP/SIPServer.pm

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