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