2 package C4
::SIP
::SIPServer
;
8 use Sys::Syslog qw(syslog);
9 use Net
::Server
::PreFork
;
11 use Socket
qw(:DEFAULT :crlf);
12 require UNIVERSAL
::require;
14 use C4
::SIP
::Sip
::Constants
qw(:all);
15 use C4
::SIP
::Sip
::Configuration
;
16 use C4
::SIP
::Sip
::Checksum
qw(checksum verify_cksum);
17 use C4
::SIP
::Sip
::MsgType
qw( handle login_core );
19 use base
qw(Net::Server::PreFork);
21 use constant LOG_SIP
=> "local6"; # Local alias for the logging facility
24 # Main # not really, since package SIPServer
26 # FIXME: Is this a module or a script?
27 # A script with no MAIN namespace?
28 # A module that takes command line args?
31 RAW
=> \
&raw_transport
,
32 telnet
=> \
&telnet_transport
,
38 my $config = C4
::SIP
::Sip
::Configuration
->new( $ARGV[0] );
44 foreach my $svc (keys %{$config->{listeners
}}) {
45 push @parms, "port=" . $svc;
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...
55 # The IDENT is determined by config file 'server-params' arguments
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
64 if (defined($config->{'server-params'})) {
65 while (my ($key, $val) = each %{$config->{'server-params'}}) {
66 push @parms, $key . '=' . $val;
72 # This is the main event.
73 __PACKAGE__
->run(@parms);
79 # process_request is the callback used by Net::Server to handle
80 # an incoming connection request.
85 my ($sockaddr, $port, $proto);
88 $self->{config
} = $config;
90 my $sockname = getsockname(STDIN
);
92 # Check if socket connection is IPv6 before resolving address
93 my $family = Socket
::sockaddr_family
($sockname);
94 if ($family == AF_INET6
) {
95 ($port, $sockaddr) = sockaddr_in6
($sockname);
96 $sockaddr = Socket
::inet_ntop
(AF_INET6
, $sockaddr);
98 ($port, $sockaddr) = sockaddr_in
($sockname);
99 $sockaddr = inet_ntoa
($sockaddr);
101 $proto = $self->{server
}->{client
}->NS_proto();
103 $self->{service
} = $config->find_service($sockaddr, $port, $proto);
105 if (!defined($self->{service
})) {
106 syslog
("LOG_ERR", "process_request: Unknown recognized server connection: %s:%s/%s", $sockaddr, $port, $proto);
107 die "process_request: Bad server connection";
110 $transport = $transports{$self->{service
}->{transport
}};
112 if (!defined($transport)) {
113 syslog
("LOG_WARNING", "Unknown transport '%s', dropping", $service->{transport
});
128 my $service = $self->{service
};
129 # If using Net::Server::PreFork you may already have account set from a previous session
131 if ($self->{account
}) {
132 delete $self->{account
};
135 # Timeout the while loop if we get stuck in it
136 # In practice it should only iterate once but be prepared
137 local $SIG{ALRM
} = sub { die 'raw transport Timed Out!' };
138 my $timeout = $self->get_timeout({ transport
=> 1 });
139 syslog
('LOG_DEBUG', "raw_transport: timeout is $timeout");
141 while (!$self->{account
}) {
142 $input = read_request
();
145 syslog
("LOG_INFO", "raw_transport: shutting down: EOF during login");
148 $input =~ s/[\r\n]+$//sm; # Strip off trailing line terminator(s)
149 last if C4
::SIP
::Sip
::MsgType
::handle
($input, $self, LOGIN
);
153 syslog
("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
154 $self->{account
}->{id
},
155 $self->{account
}->{institution
});
156 if (! $self->{account
}->{id
}) {
157 syslog
("LOG_ERR","Login failed shutting down");
161 $self->sip_protocol_loop();
162 syslog
("LOG_INFO", "raw_transport: shutting down");
166 sub get_clean_string
{
168 if (defined $string) {
169 syslog
("LOG_DEBUG", "get_clean_string pre-clean(length %s): %s", length($string), $string);
171 $string =~ s/^[^A-z0-9]+//;
172 $string =~ s/[^A-z0-9]+$//;
173 syslog
("LOG_DEBUG", "get_clean_string post-clean(length %s): %s", length($string), $string);
175 syslog
("LOG_INFO", "get_clean_string called on undefined");
180 sub get_clean_input
{
183 $in = get_clean_string
($in);
184 while (my $extra = <STDIN
>){
185 syslog
("LOG_ERR", "get_clean_input got extra lines: %s", $extra);
190 sub telnet_transport
{
196 my $config = $self->{config
};
197 my $timeout = $self->get_timeout({ transport
=> 1 });
198 syslog
("LOG_DEBUG", "telnet_transport: timeout is $timeout");
201 local $SIG{ALRM
} = sub { die "telnet_transport: Timed Out ($timeout seconds)!\n"; };
202 local $| = 1; # Unbuffered output
203 $/ = "\015"; # Internet Record Separator (lax version)
204 # Until the terminal has logged in, we don't trust it
205 # so use a timeout to protect ourselves from hanging.
210 # $uid = &get_clean_input;
213 # $pwd = &get_clean_input || '';
217 syslog
("LOG_DEBUG", "telnet_transport 1: uid length %s, pwd length %s", length($uid), length($pwd));
218 $uid = get_clean_string
($uid);
219 $pwd = get_clean_string
($pwd);
220 syslog
("LOG_DEBUG", "telnet_transport 2: uid length %s, pwd length %s", length($uid), length($pwd));
222 if (exists ($config->{accounts
}->{$uid})
223 && ($pwd eq $config->{accounts
}->{$uid}->{password
})) {
224 $account = $config->{accounts
}->{$uid};
225 if ( C4
::SIP
::Sip
::MsgType
::login_core
($self,$uid,$pwd) ) {
229 syslog
("LOG_WARNING", "Invalid login attempt: '%s'", ($uid||''));
230 print("Invalid login$CRLF");
235 syslog
("LOG_ERR", "telnet_transport: Login timed out");
236 die "Telnet Login Timed out";
237 } elsif (!defined($account)) {
238 syslog
("LOG_ERR", "telnet_transport: Login Failed");
241 print "Login OK. Initiating SIP$CRLF";
244 $self->{account
} = $account;
245 syslog
("LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'", $account->{id
}, $account->{institution
});
246 $self->sip_protocol_loop();
247 syslog
("LOG_INFO", "telnet_transport: shutting down");
252 # The terminal has logged in, using either the SIP login process
253 # over a raw socket, or via the pseudo-unix login provided by the
254 # telnet transport. From that point on, both the raw and the telnet
255 # processes are the same:
256 sub sip_protocol_loop
{
258 my $service = $self->{service
};
259 my $config = $self->{config
};
260 my $timeout = $self->get_timeout({ client
=> 1 });
262 # The spec says the first message will be:
264 # SIP v2: LOGIN (or SC_STATUS via telnet?)
265 # But it might be SC_REQUEST_RESEND. As long as we get
266 # SC_REQUEST_RESEND, we keep waiting.
268 # Comprise reports that no other ILS actually enforces this
269 # constraint, so we'll relax about it too.
270 # Using the SIP "raw" login process, rather than telnet,
271 # requires the LOGIN message and forces SIP 2.00. In that
272 # case, the LOGIN message has already been processed (above).
274 # In short, we'll take any valid message here.
276 local $SIG{ALRM
} = sub {
277 syslog
( 'LOG_DEBUG', 'Inactive: timed out' );
280 my $previous_alarm = alarm($timeout);
282 while ( my $inputbuf = read_request
() ) {
283 if ( !defined $inputbuf ) {
289 syslog
( "LOG_ERR", "sip_protocol_loop: empty input skipped" );
294 my $status = C4
::SIP
::Sip
::MsgType
::handle
( $inputbuf, $self, q{} );
298 "sip_protocol_loop: failed to handle %s",
299 substr( $inputbuf, 0, 2 )
302 next if $status eq REQUEST_ACS_RESEND
;
304 alarm($previous_alarm);
307 if ( $@
=~ m/timed out/i ) {
317 # proper SPEC: (octal) \015 = (hex) x0D = (dec) 13 = (ascii) carriage return
318 my $buffer = <STDIN
>;
319 if ( defined $buffer ) {
320 STDIN
->flush(); # clear an extra linefeed
322 $raw_length = length $buffer;
323 $buffer =~ s/^\s*[^A-z0-9]+//s;
324 # Every line must start with a "real" character. Not whitespace, control chars, etc.
325 $buffer =~ s/[^A-z0-9]+$//s;
327 # Same for the end. Note this catches the problem some clients have sending empty fields at the end, like |||
328 $buffer =~ s/\015?\012//g; # Extra line breaks must die
329 $buffer =~ s/\015?\012//s; # Extra line breaks must die
330 $buffer =~ s/\015*\012*$//s;
332 # treat as one line to include the extra linebreaks we are trying to remove!
335 syslog
( 'LOG_DEBUG', 'EOF returned on read' );
338 my $len = length $buffer;
339 if ( $len != $raw_length ) {
340 my $trim = $raw_length - $len;
341 syslog
( 'LOG_DEBUG', "read_request trimmed $trim character(s) " );
344 syslog
( 'LOG_INFO', "INPUT MSG: '$buffer'" );
348 # $server->get_timeout({ $type => 1, fallback => $fallback });
349 # where $type is transport | client | policy
351 # Centralizes all timeout logic.
352 # Transport refers to login process, client to active connections.
353 # Policy timeout is transaction timeout (used in ACS status message).
355 # Fallback is optional. If you do not pass transport, client or policy,
356 # you will get fallback or hardcoded default.
359 my ( $server, $params ) = @_;
360 my $fallback = $params->{fallback
} || 30;
361 my $service = $server->{service
} // {};
362 my $config = $server->{config
} // {};
364 if( $params->{transport
} ||
365 ( $params->{client
} && !exists $service->{client_timeout
} )) {
366 # We do not allow zero values here.
367 # Note: config/timeout seems to be deprecated.
368 return $service->{timeout
} || $config->{timeout
} || $fallback;
370 } elsif( $params->{client
} ) {
371 # We know that client_timeout exists now.
372 # We do allow zero values here to indicate no timeout.
373 return 0 if $service->{client_timeout
} =~ /^0+$|\D/;
374 return $service->{client_timeout
};
376 } elsif( $params->{policy
} ) {
377 my $policy = $server->{policy
} // {};
378 my $rv = sprintf( "%03d", $policy->{timeout
} // 0 );
379 if( length($rv) != 3 ) {
380 syslog
( "LOG_ERR", "Policy timeout has wrong size: '%s'", $rv );