2 # Copyright (C) 2006-2008 Georgia Public Library Service
3 # Copyright (C) 2013-2014 Equinox Software, Inc.
5 # Author: David J. Fiander
6 # Author: Mike Rylander
7 # Author: Bill Erickson
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.
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.
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,
28 use Sys::Syslog qw(syslog);
29 use Net::Server::Multiplex;
30 use Net::Server::PreFork;
31 use Net::Server::Proto;
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/;
39 use Sip qw($protocol_version);
40 use Sip::Constants qw(:all);
41 use Sip::Configuration;
42 use Sip::Checksum qw(checksum verify_cksum);
44 use Time::HiRes qw/time/;
48 use constant LOG_SIP => "local6"; # Local alias for the logging facility
51 our @ISA = qw(Net::Server::PreFork);
57 RAW => \&raw_transport,
58 telnet => \&telnet_transport,
59 http => \&http_transport,
64 my $config = Sip::Configuration->new($ARGV[0]);
71 foreach my $svc (keys %{$config->{listeners}}) {
72 push @parms, "port=" . $svc;
78 # Log lines look like this:
79 # Jun 16 21:21:31 server08 steve_sip: Sip::MsgType::_initialize('Login', ...)
80 # [ TIMESTAMP ] [ HOST ] [ IDENT ]: Message...
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.
86 my $syslog_ident = $ENV{SIP_LOG_IDENT} || ($ENV{USER} ? $ENV{USER} . "_sip" : 'acs-server');
89 "log_file=Sys::Syslog",
90 "syslog_ident=$syslog_ident",
91 "syslog_facility=" . LOG_SIP;
94 # Server Management: set parameters for the Net::Server personality
95 # chosen, defaulting to PreFork.
97 # The PreFork module silently ignores parameters that it doesn't
98 # recognize, and complains about invalid values for parameters
101 # The Fork module only cares about max_servers, for our purposes, which
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.
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');
121 print Dumper(@parms);
123 # initialize all remaining global variables before
124 # going into listen mode.
128 my @pending_connections;
129 my %active_connections;
132 # This is the main event.
133 SIPServer->run(@parms);
139 # process_request is the callback used by Net::Server to handle
140 # an incoming connection request when the peronsality is either
143 sub process_request {
147 my ($sockaddr, $port, $proto);
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.
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);
161 "Consider installing Socket::Linux for TCP keepalive: $@") if $@;
163 $self->{account} = undef; # New connection, no need to keep login info
164 $self->{config} = $config;
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");
171 $self->{service} = $config->find_service( $sockaddr, $port, $proto );
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";
179 $transport = $transports{ $self->{service}->{transport} };
181 if ( !defined($transport) ) {
182 syslog("LOG_WARNING", "Unknown transport '%s', dropping", $service->{transport});
186 # Transport has shut down, remove any lingering login info
187 $self->{account} = undef;
190 $self->sip_protocol_loop();
192 syslog("LOG_INFO", '%s: shutting down', $transport);
195 # mux_input is the callback used by Net::Server to handle
196 # an incoming connection request when the peronsality is
201 return $cache if $cache;
203 if (!$config->{cache}) {
204 syslog('LOG_ERR', "Cache servers needed");
207 my $servers = $config->{cache}->{server};
208 syslog('LOG_DEBUG', "Cache servers: @$servers");
210 $cache = Cache::Memcached->new({servers => $servers}) or
211 syslog('LOG_ERR', "Unable to initialize memcache: @$servers");
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;
227 "multi: pending connections to inspect: @pending_connections");
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);
233 for my $key (keys %$values) {
234 my $VAR1; # for Dump() -> eval;
235 eval $values->{$key}; # Data::Dumper->Dump string
237 my $id = $VAR1->{id}; # conn_id
238 $active_connections{$id}{net_server_parts} = $VAR1->{net_server_parts};
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}));
248 syslog('LOG_INFO', "Child $id failed SIP login; removing connection");
249 delete $active_connections{$id};
255 "multi: pending connection for conn_id=$id resolved");
256 $cache->delete($key);
257 @pending_connections = grep {$_ ne $id} @pending_connections;
261 "multi: connections still pending after check: @pending_connections")
262 if @pending_connections;
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}));
275 if ( !scalar(keys(%kid_hash))) { # not using mux mode
276 1 while waitpid(-1, WNOHANG) > 0;
278 for (keys(%kid_hash)) {
279 if ( my $reaped = waitpid($_, WNOHANG) > 0 ) {
280 syslog('LOG_DEBUG', "Reaping child $_");
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};
291 delete $kid_hash{$_};
298 my ($mself, $fh) = @_;
300 my ($peeraddr, $peerport) = (
301 $mself->{net_server}->{server}->{peeraddr},
302 $mself->{net_server}->{server}->{peerport}
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});
316 my $conn_id = $mself->{conn_id}; # see mux_connection
318 # and process any pending logins
319 check_pending_connections();
321 my $c = scalar(keys %active_connections);
322 syslog("LOG_DEBUG", "multi: inbound message on connection $conn_id; $c total");
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");
331 if (!$active_connections{$conn_id}) { # Brand new connection, log them in
332 $self = $mself->{net_server};
334 my ($sockaddr, $port, $proto);
336 $self->{config} = $config;
338 $sockaddr = $self->{server}->{sockaddr};
339 $port = $self->{server}->{sockport};
340 $proto = $self->{server}->{client}->NS_proto();
342 syslog('LOG_INFO', "New client $conn_id connecting to $sockaddr on port $port and proto $proto");
344 $self->{service} = $config->find_service( $sockaddr, $port, $proto );
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");
353 my $transport = $transports{ $self->{service}->{transport} };
355 if ( !defined($transport) ) {
356 syslog("LOG_WARNING", "Unknown transport, dropping");
360 # We stick this here, assuming success. Cleanup comes later via memcache and reaper.
361 $active_connections{$conn_id} = {
363 transport => $transport,
365 worker_pipe => IO::Pipe->new
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.
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);
379 if (!defined($pid) or $pid < 0) {
380 syslog('LOG_ERR', "Unable to fork new child process $!");
384 if ($pid == 0) { # in kid
385 $active_connections{$conn_id}{worker_pipe}->reader;
387 $cache = undef; # don't use the same cache handle as our parent.
388 my $cache_data = {id => $conn_id};
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 {
396 if ($status) { # login OK
398 $self->{state} = $self->{ils}->state() if (UNIVERSAL::can($self->{ils},'state'));
400 $cache_data->{success} = 1;
401 $cache_data->{net_server_parts} = {
402 map { ($_ => $$self{$_}) } qw/state institution account/
405 # Stash the ILS module somewhere handy for later
406 $cache_data->{net_server_parts}{ils} = ref($self->{ils});
409 $cache_data->{success} = 0;
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?
423 $self->{login_complete_called} = 1;
426 syslog('LOG_DEBUG', "Child $$ / $conn_id kicking off login process");
428 eval { &$transport($self, $active_connections{$conn_id}{worker_pipe}) };
431 syslog('LOG_ERR', "ILS login error: $@");
432 $self->{login_complete}->(0) unless $self->{login_complete_called};
435 $self->sip_protocol_loop(
436 $active_connections{$conn_id}{worker_pipe},
437 $self->{account}->{'worker-keepalive'}
438 // $self->{institution}->{'worker-keepalive'}
445 my $fh = $active_connections{$conn_id}{worker_pipe};
449 push(@pending_connections, $conn_id);
450 $kid_hash{$pid} = $conn_id;
456 $self = $active_connections{$conn_id}->{net_server};
457 my $ns_parts = $active_connections{$conn_id}->{net_server_parts};
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};
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");
469 if (!defined($pid) or $pid < 0) {
470 syslog('LOG_ERR', "Unable to fork new child process $!");
474 if ($pid == 0) { # in kid
475 $active_connections{$conn_id}{worker_pipe}->reader;
477 syslog("LOG_DEBUG", "multi: $conn_id to be processed by child $$");
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});
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;
492 syslog('LOG_ERR', "Unable to build ILS module in mux child");
496 $self->sip_protocol_loop(
497 $active_connections{$conn_id}{worker_pipe},
498 $self->{account}->{'worker-keepalive'}
499 // $self->{institution}->{'worker-keepalive'}
507 $active_connections{$conn_id}{worker_pipe}->writer;
508 my $fh = $active_connections{$conn_id}{worker_pipe};
512 $kid_hash{$pid} = $conn_id;
513 syslog("LOG_DEBUG", "multi: $conn_id forked child $pid; $kid_count total");
518 # clear read data from the mux string ref
522 # client disconnected, remove the active connection
524 my ($self, $mux, $fh) = @_;
525 my $conn_id = $self->{conn_id};
527 delete $active_connections{$conn_id};
528 syslog("LOG_DEBUG", "multi: mux_close cleaning up child: $conn_id; ".
529 scalar(keys %active_connections)." remain");
539 my $fh = shift || *STDIN;
543 my $service = $self->{service};
546 my $timeout = $self->{service}->{timeout} || $self->{config}->{timeout} || 0;
549 local $SIG{ALRM} = sub { die "raw_transport Timed Out!\n"; };
550 syslog("LOG_DEBUG", "raw_transport: timeout is $timeout");
554 $input = Sip::read_SIP_packet($fh);
559 syslog("LOG_INFO", "raw_transport: shutting down: EOF during login");
561 } elsif ($input !~ /\S/) {
562 syslog("LOG_INFO", "raw_transport: received whitespace line (length %s) during login, skipping", length($input));
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';
570 Sip::MsgType::handle($input, $self, SC_STATUS);
571 $strikes++; # it's allowed, don't charge for it
574 last if Sip::MsgType::handle($input, $self, LOGIN);
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";
586 syslog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
587 $self->{account}->{id},
588 $self->{account}->{institution});
591 sub telnet_transport {
593 my $fh = shift || *STDIN;
599 my $config = $self->{config};
600 my $timeout = $self->{service}->{timeout} || $config->{timeout} || 0;
601 syslog("LOG_DEBUG", "telnet_transport: timeout is %s", $timeout);
603 # Until the terminal has logged in, we don't trust it
604 # so use a timeout to protect ourselves from hanging.
606 local $SIG{ALRM} = sub { die "telnet_transport: Timed Out ($timeout seconds)!\n";; };
607 local $| = 1; # Unbuffered output
620 $uid =~ s/[\r\n]+$//;
621 $pwd =~ s/[\r\n]+$//;
623 if (exists($config->{accounts}->{$uid})
624 && ($pwd eq $config->{accounts}->{$uid}->password())) {
625 $account = $config->{accounts}->{$uid};
628 syslog("LOG_WARNING", "Invalid login attempt: '%s'", $uid);
629 print("Invalid login$CRLF");
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");
641 print "Login OK. Initiating SIP$CRLF";
644 $self->{account} = $account;
645 syslog("LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'", $account->{id}, $account->{institution});
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 {
659 my $fh = shift || *STDIN;
660 my $keepalive = shift;
662 my $service = $self->{service};
663 my $config = $self->{config};
665 my $timeout = $keepalive || $self->{service}->{timeout} || $config->{timeout} || 0;
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
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
680 #$expect = SC_STATUS;
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
689 my $status = Sip::MsgType::handle($input, $self, $expect);
690 if ($status eq REQUEST_ACS_RESEND) {
695 my $duration = sprintf("%0.3f", time - $start);
696 syslog('LOG_DEBUG', "SIP processing duration $duration : $input");
699 syslog("LOG_ERR", "raw_transport: failed to handle %s", substr($input,0,2));
700 die "sip_protocol_loop: failed Sip::MsgType::handle('$input', $self, '$expect')";
702 elsif ($expect && ($status ne $expect)) {
703 # We received a non-"RESEND" that wasn't what we were expecting.
704 syslog("LOG_ERR", "raw_transport: expected %s, received %s, exiting", $expect, $input);
705 die "sip_protocol_loop: exiting: expected '$expect', received '$status'";
708 last if (defined $keepalive && !$keepalive);
710 # We successfully received and processed what we were expecting
712 alarm $timeout; # Next loop timeout