View | Details | Raw Unified | Return to bug 15338
Collapse All | Expand All

(-)a/bin/SIPServer (-130 / +156 lines)
Lines 4-9 use strict; Link Here
4
use warnings;
4
use warnings;
5
use FindBin qw($Bin);
5
use FindBin qw($Bin);
6
use lib "$Bin";
6
use lib "$Bin";
7
# or use Net::Server::Fork for better use of resources
7
use Net::Server::PreFork;
8
use Net::Server::PreFork;
8
use IO::Socket::INET;
9
use IO::Socket::INET;
9
use Socket qw(:DEFAULT :crlf);
10
use Socket qw(:DEFAULT :crlf);
Lines 26-39 tie *STDERR, "C4::SIP::Trapper"; Link Here
26
27
27
use base qw(Net::Server::PreFork);
28
use base qw(Net::Server::PreFork);
28
29
29
use constant LOG_SIP => "local6"; # Local alias for the logging facility
30
use constant LOG_SIP => "local6";    # Local alias for the logging facility
30
31
#
32
# Main  # not really, since package SIPServer
33
#
34
# FIXME: Is this a module or a script?  
35
# A script with no MAIN namespace?
36
# A module that takes command line args?
37
31
38
# Set interface to 'sip'
32
# Set interface to 'sip'
39
C4::Context->interface('sip');
33
C4::Context->interface('sip');
Lines 52-58 my @parms; Link Here
52
#
46
#
53
# Ports to bind
47
# Ports to bind
54
#
48
#
55
foreach my $svc (keys %{$config->{listeners}}) {
49
foreach my $svc ( keys %{ $config->{listeners} } ) {
56
    push @parms, "port=" . $svc;
50
    push @parms, "port=" . $svc;
57
}
51
}
58
52
Lines 65-87 foreach my $svc (keys %{$config->{listeners}}) { Link Here
65
#
59
#
66
# The IDENT is determined by config file 'server-params' arguments
60
# The IDENT is determined by config file 'server-params' arguments
67
61
68
69
#
62
#
70
# Server Management: set parameters for the Net::Server::PreFork
63
# Server Management: set parameters for the Net::Server::*
71
# module.  The module silently ignores parameters that it doesn't
64
# module.  The module silently ignores parameters that it doesn't
72
# recognize, and complains about invalid values for parameters
65
# recognize, and complains about invalid values for parameters
73
# that it does.
66
# that it does.
74
#
67
#
75
if (defined($config->{'server-params'})) {
68
if ( defined( $config->{'server-params'} ) ) {
76
    while (my ($key, $val) = each %{$config->{'server-params'}}) {
69
    while ( my ( $key, $val ) = each %{ $config->{'server-params'} } ) {
77
        push @parms, $key . '=' . $val;
70
        push @parms, $key . '=' . $val;
78
    }
71
    }
79
}
72
}
80
73
81
82
#
74
#
83
# This is the main event.
75
# This is the main event.
84
__PACKAGE__ ->run(@parms);
76
__PACKAGE__->run(@parms);
85
77
86
#
78
#
87
# Child
79
# Child
Lines 93-99 __PACKAGE__ ->run(@parms); Link Here
93
sub process_request {
85
sub process_request {
94
    my $self = shift;
86
    my $self = shift;
95
    my $service;
87
    my $service;
96
    my ($sockaddr, $port, $proto);
88
    my ( $sockaddr, $port, $proto );
97
    my $transport;
89
    my $transport;
98
90
99
    $self->{config} = $config;
91
    $self->{config} = $config;
Lines 101-135 sub process_request { Link Here
101
    # Flushing L1 to make sure the request will be processed using the correct data
93
    # Flushing L1 to make sure the request will be processed using the correct data
102
    Koha::Caches->flush_L1_caches();
94
    Koha::Caches->flush_L1_caches();
103
95
104
    $self->{account} = undef;  # Clear out the account from the last request, it may be different
96
    $self->{account} =
97
      undef;  # Clear out the account from the last request, it may be different
105
    $self->{logger} = set_logger( Koha::Logger->get( { interface => 'sip' } ) );
98
    $self->{logger} = set_logger( Koha::Logger->get( { interface => 'sip' } ) );
106
99
107
    my $sockname = getsockname(STDIN);
100
    my $sockname = getsockname(STDIN);
108
101
109
    # Check if socket connection is IPv6 before resolving address
102
    # Check if socket connection is IPv6 before resolving address
110
    my $family = Socket::sockaddr_family($sockname);
103
    my $family = Socket::sockaddr_family($sockname);
111
    if ($family == AF_INET6) {
104
    if ( $family == AF_INET6 ) {
112
      ($port, $sockaddr) = sockaddr_in6($sockname);
105
        ( $port, $sockaddr ) = sockaddr_in6($sockname);
113
      $sockaddr = Socket::inet_ntop(AF_INET6, $sockaddr);
106
        $sockaddr = Socket::inet_ntop( AF_INET6, $sockaddr );
114
    } else {
107
    }
115
      ($port, $sockaddr) = sockaddr_in($sockname);
108
    else {
116
      $sockaddr = inet_ntoa($sockaddr);
109
        ( $port, $sockaddr ) = sockaddr_in($sockname);
110
        $sockaddr = inet_ntoa($sockaddr);
117
    }
111
    }
118
    $proto = $self->{server}->{client}->NS_proto();
112
    $proto = $self->{server}->{client}->NS_proto();
119
113
120
    $self->{service} = $config->find_service($sockaddr, $port, $proto);
114
    $self->{service} = $config->find_service( $sockaddr, $port, $proto );
121
115
122
    if (!defined($self->{service})) {
116
    if ( !defined( $self->{service} ) ) {
123
        siplog("LOG_ERR", "process_request: Unknown recognized server connection: %s:%s/%s", $sockaddr, $port, $proto);
117
        siplog( "LOG_ERR",
118
            "process_request: Unknown recognized server connection: %s:%s/%s",
119
            $sockaddr, $port, $proto );
124
        die "process_request: Bad server connection";
120
        die "process_request: Bad server connection";
125
    }
121
    }
126
122
127
    $transport = $transports{$self->{service}->{transport}};
123
    $transport = $transports{ $self->{service}->{transport} };
128
124
129
    if (!defined($transport)) {
125
    if ( !defined($transport) ) {
130
        siplog("LOG_WARNING", "Unknown transport '%s', dropping", $service->{transport});
126
        siplog( "LOG_WARNING", "Unknown transport '%s', dropping",
127
            $service->{transport} );
131
        return;
128
        return;
132
    } else {
129
    }
130
    else {
133
        &$transport($self);
131
        &$transport($self);
134
    }
132
    }
135
    return;
133
    return;
Lines 143-171 sub raw_transport { Link Here
143
    my $self = shift;
141
    my $self = shift;
144
    my $input;
142
    my $input;
145
    my $service = $self->{service};
143
    my $service = $self->{service};
146
    # If using Net::Server::PreFork you may already have account set from a previous session
144
147
    # Ensure you dont
145
# If using Net::Server::PreFork you may already have account set from a previous session
148
    if ($self->{account}) {
146
# Ensure you dont
147
    if ( $self->{account} ) {
149
        delete $self->{account};
148
        delete $self->{account};
150
    }
149
    }
151
150
152
    # Timeout the while loop if we get stuck in it
151
    # Timeout the while loop if we get stuck in it
153
    # In practice it should only iterate once but be prepared
152
    # In practice it should only iterate once but be prepared
154
    local $SIG{ALRM} = sub { die 'raw transport Timed Out!' };
153
    local $SIG{ALRM} = sub { die 'raw transport Timed Out!' };
155
    my $timeout = $self->get_timeout({ transport => 1 });
154
    my $timeout = $self->get_timeout( { transport => 1 } );
156
    siplog('LOG_DEBUG', "raw_transport: timeout is $timeout");
155
    siplog( 'LOG_DEBUG', "raw_transport: timeout is $timeout" );
157
    alarm $timeout;
156
    alarm $timeout;
158
    while (!$self->{account}) {
157
    while ( !$self->{account} ) {
159
        $input = read_request();
158
        $input = read_request();
160
        if (!$input) {
159
        if ( !$input ) {
160
161
            # EOF on the socket
161
            # EOF on the socket
162
            siplog("LOG_INFO", "raw_transport: shutting down: EOF during login");
162
            siplog( "LOG_INFO",
163
                "raw_transport: shutting down: EOF during login" );
163
            return;
164
            return;
164
        }
165
        }
165
        $input =~ s/[\r\n]+$//sm; # Strip off trailing line terminator(s)
166
        $input =~ s/[\r\n]+$//sm;    # Strip off trailing line terminator(s)
166
        my $reg = qr/^${\(LOGIN)}/;
167
        my $reg = qr/^${\(LOGIN)}/;
167
        last if $input !~ $reg ||
168
        last
168
            C4::SIP::Sip::MsgType::handle($input, $self, LOGIN);
169
          if $input !~ $reg
170
          || C4::SIP::Sip::MsgType::handle( $input, $self, LOGIN );
169
    }
171
    }
170
    alarm 0;
172
    alarm 0;
171
173
Lines 173-206 sub raw_transport { Link Here
173
        Koha::Logger->get(
175
        Koha::Logger->get(
174
            {
176
            {
175
                interface => 'sip',
177
                interface => 'sip',
176
                category  => $self->{account}->{id}, # Add id to namespace
178
                category  => $self->{account}->{id},    # Add id to namespace
177
            }
179
            }
178
        )
180
        )
179
    );
181
    );
180
182
181
    siplog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
183
    siplog(
182
        $self->{account}->{id},
184
        "LOG_DEBUG",            "raw_transport: uname/inst: '%s/%s'",
183
        $self->{account}->{institution});
185
        $self->{account}->{id}, $self->{account}->{institution}
184
    if (! $self->{account}->{id}) {
186
    );
185
        siplog("LOG_ERR","Login failed shutting down");
187
    if ( !$self->{account}->{id} ) {
188
        siplog( "LOG_ERR", "Login failed shutting down" );
186
        return;
189
        return;
187
    }
190
    }
188
191
189
    $self->sip_protocol_loop();
192
    $self->sip_protocol_loop();
190
    siplog("LOG_INFO", "raw_transport: shutting down");
193
    siplog( "LOG_INFO", "raw_transport: shutting down" );
191
    return;
194
    return;
192
}
195
}
193
196
194
sub get_clean_string {
197
sub get_clean_string {
195
    my $string = shift;
198
    my $string = shift;
196
    if (defined $string) {
199
    if ( defined $string ) {
197
        siplog("LOG_DEBUG", "get_clean_string  pre-clean(length %s): %s", length($string), $string);
200
        siplog( "LOG_DEBUG", "get_clean_string  pre-clean(length %s): %s",
201
            length($string), $string );
198
        chomp($string);
202
        chomp($string);
199
        $string =~ s/^[^A-z0-9]+//;
203
        $string =~ s/^[^A-z0-9]+//;
200
        $string =~ s/[^A-z0-9]+$//;
204
        $string =~ s/[^A-z0-9]+$//;
201
        siplog("LOG_DEBUG", "get_clean_string post-clean(length %s): %s", length($string), $string);
205
        siplog( "LOG_DEBUG", "get_clean_string post-clean(length %s): %s",
202
    } else {
206
            length($string), $string );
203
        siplog("LOG_INFO", "get_clean_string called on undefined");
207
    }
208
    else {
209
        siplog( "LOG_INFO", "get_clean_string called on undefined" );
204
    }
210
    }
205
    return $string;
211
    return $string;
206
}
212
}
Lines 209-278 sub get_clean_input { Link Here
209
    local $/ = "\012";
215
    local $/ = "\012";
210
    my $in = <STDIN>;
216
    my $in = <STDIN>;
211
    $in = get_clean_string($in);
217
    $in = get_clean_string($in);
212
    while (my $extra = <STDIN>){
218
    while ( my $extra = <STDIN> ) {
213
        siplog("LOG_ERR", "get_clean_input got extra lines: %s", $extra);
219
        siplog( "LOG_ERR", "get_clean_input got extra lines: %s", $extra );
214
    }
220
    }
215
    return $in;
221
    return $in;
216
}
222
}
217
223
218
sub telnet_transport {
224
sub telnet_transport {
219
    my $self = shift;
225
    my $self = shift;
220
    my ($uid, $pwd);
226
    my ( $uid, $pwd );
221
    my $strikes = 3;
227
    my $strikes = 3;
222
    my $account = undef;
228
    my $account = undef;
223
    my $input;
229
    my $input;
224
    my $config  = $self->{config};
230
    my $config = $self->{config};
225
    my $timeout = $self->get_timeout({ transport => 1 });
231
    my $timeout = $self->get_timeout( { transport => 1 } );
226
    siplog("LOG_DEBUG", "telnet_transport: timeout is $timeout");
232
    siplog( "LOG_DEBUG", "telnet_transport: timeout is $timeout" );
227
233
228
    eval {
234
    eval {
229
    local $SIG{ALRM} = sub { die "telnet_transport: Timed Out ($timeout seconds)!\n"; };
235
        local $SIG{ALRM} =
230
    local $| = 1;           # Unbuffered output
236
          sub { die "telnet_transport: Timed Out ($timeout seconds)!\n"; };
231
    $/ = "\015";        # Internet Record Separator (lax version)
237
        local $| = 1;    # Unbuffered output
232
    # Until the terminal has logged in, we don't trust it
238
        $/ = "\015";     # Internet Record Separator (lax version)
233
    # so use a timeout to protect ourselves from hanging.
239
                         # Until the terminal has logged in, we don't trust it
234
240
                         # so use a timeout to protect ourselves from hanging.
235
    while ($strikes--) {
241
236
        print "login: ";
242
        while ( $strikes-- ) {
237
        alarm $timeout;
243
            print "login: ";
238
        # $uid = &get_clean_input;
244
            alarm $timeout;
239
        $uid = <STDIN>;
245
240
        print "password: ";
246
            # $uid = &get_clean_input;
241
        # $pwd = &get_clean_input || '';
247
            $uid = <STDIN>;
242
        $pwd = <STDIN>;
248
            print "password: ";
243
        alarm 0;
249
244
250
            # $pwd = &get_clean_input || '';
245
        siplog("LOG_DEBUG", "telnet_transport 1: uid length %s, pwd length %s", length($uid), length($pwd));
251
            $pwd = <STDIN>;
246
        $uid = get_clean_string ($uid);
252
            alarm 0;
247
        $pwd = get_clean_string ($pwd);
253
248
        siplog("LOG_DEBUG", "telnet_transport 2: uid length %s, pwd length %s", length($uid), length($pwd));
254
            siplog( "LOG_DEBUG",
249
255
                "telnet_transport 1: uid length %s, pwd length %s",
250
        if (exists ($config->{accounts}->{$uid})
256
                length($uid), length($pwd) );
251
        && ($pwd eq $config->{accounts}->{$uid}->{password})) {
257
            $uid = get_clean_string($uid);
252
            $account = $config->{accounts}->{$uid};
258
            $pwd = get_clean_string($pwd);
253
            if ( C4::SIP::Sip::MsgType::login_core($self,$uid,$pwd) ) {
259
            siplog( "LOG_DEBUG",
254
                last;
260
                "telnet_transport 2: uid length %s, pwd length %s",
261
                length($uid), length($pwd) );
262
263
            if ( exists( $config->{accounts}->{$uid} )
264
                && ( $pwd eq $config->{accounts}->{$uid}->{password} ) )
265
            {
266
                $account = $config->{accounts}->{$uid};
267
                if ( C4::SIP::Sip::MsgType::login_core( $self, $uid, $pwd ) ) {
268
                    last;
269
                }
255
            }
270
            }
271
            siplog(
272
                "LOG_WARNING",
273
                "Invalid login attempt: '%s'",
274
                ( $uid || '' )
275
            );
276
            print("Invalid login$CRLF");
256
        }
277
        }
257
        siplog("LOG_WARNING", "Invalid login attempt: '%s'", ($uid||''));
278
    };    # End of eval
258
        print("Invalid login$CRLF");
259
    }
260
    }; # End of eval
261
279
262
    if ($@) {
280
    if ($@) {
263
        siplog("LOG_ERR", "telnet_transport: Login timed out");
281
        siplog( "LOG_ERR", "telnet_transport: Login timed out" );
264
        die "Telnet Login Timed out";
282
        die "Telnet Login Timed out";
265
    } elsif (!defined($account)) {
283
    }
266
        siplog("LOG_ERR", "telnet_transport: Login Failed");
284
    elsif ( !defined($account) ) {
285
        siplog( "LOG_ERR", "telnet_transport: Login Failed" );
267
        die "Login Failure";
286
        die "Login Failure";
268
    } else {
287
    }
288
    else {
269
        print "Login OK.  Initiating SIP$CRLF";
289
        print "Login OK.  Initiating SIP$CRLF";
270
    }
290
    }
271
291
272
    $self->{account} = $account;
292
    $self->{account} = $account;
273
    siplog("LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'", $account->{id}, $account->{institution});
293
    siplog( "LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'",
294
        $account->{id}, $account->{institution} );
274
    $self->sip_protocol_loop();
295
    $self->sip_protocol_loop();
275
    siplog("LOG_INFO", "telnet_transport: shutting down");
296
    siplog( "LOG_INFO", "telnet_transport: shutting down" );
276
    return;
297
    return;
277
}
298
}
278
299
Lines 282-291 sub telnet_transport { Link Here
282
# telnet transport.  From that point on, both the raw and the telnet
303
# telnet transport.  From that point on, both the raw and the telnet
283
# processes are the same:
304
# processes are the same:
284
sub sip_protocol_loop {
305
sub sip_protocol_loop {
285
    my $self = shift;
306
    my $self    = shift;
286
    my $service = $self->{service};
307
    my $service = $self->{service};
287
    my $config  = $self->{config};
308
    my $config  = $self->{config};
288
    my $timeout = $self->get_timeout({ client => 1 });
309
    my $timeout = $self->get_timeout( { client => 1 } );
289
310
290
    # The spec says the first message will be:
311
    # The spec says the first message will be:
291
    #     SIP v1: SC_STATUS
312
    #     SIP v1: SC_STATUS
Lines 339-376 sub sip_protocol_loop { Link Here
339
}
360
}
340
361
341
sub read_request {
362
sub read_request {
342
      my $raw_length;
363
    my $raw_length;
343
      local $/ = "\015";
364
    local $/ = "\015";
344
365
345
    # proper SPEC: (octal) \015 = (hex) x0D = (dec) 13 = (ascii) carriage return
366
    # proper SPEC: (octal) \015 = (hex) x0D = (dec) 13 = (ascii) carriage return
346
      my $buffer = <STDIN>;
367
    my $buffer = <STDIN>;
347
      if ( defined $buffer ) {
368
    if ( defined $buffer ) {
348
          STDIN->flush();    # clear an extra linefeed
369
        STDIN->flush();    # clear an extra linefeed
349
          chomp $buffer;
370
        chomp $buffer;
350
          $raw_length = length $buffer;
371
        $raw_length = length $buffer;
351
          $buffer =~ s/^\s*[^A-z0-9]+//s;
372
        $buffer =~ s/^\s*[^A-z0-9]+//s;
373
352
# Every line must start with a "real" character.  Not whitespace, control chars, etc.
374
# Every line must start with a "real" character.  Not whitespace, control chars, etc.
353
          $buffer =~ s/[^A-z0-9]+$//s;
375
        $buffer =~ s/[^A-z0-9]+$//s;
354
376
355
# Same for the end.  Note this catches the problem some clients have sending empty fields at the end, like |||
377
# Same for the end.  Note this catches the problem some clients have sending empty fields at the end, like |||
356
          $buffer =~ s/\015?\012//g;    # Extra line breaks must die
378
        $buffer =~ s/\015?\012//g;    # Extra line breaks must die
357
          $buffer =~ s/\015?\012//s;    # Extra line breaks must die
379
        $buffer =~ s/\015?\012//s;    # Extra line breaks must die
358
          $buffer =~ s/\015*\012*$//s;
380
        $buffer =~ s/\015*\012*$//s;
359
381
360
    # treat as one line to include the extra linebreaks we are trying to remove!
382
    # treat as one line to include the extra linebreaks we are trying to remove!
361
      }
383
    }
362
      else {
384
    else {
363
          siplog( 'LOG_DEBUG', 'EOF returned on read' );
385
        siplog( 'LOG_DEBUG', 'EOF returned on read' );
364
          return;
386
        return;
365
      }
387
    }
366
      my $len = length $buffer;
388
    my $len = length $buffer;
367
      if ( $len != $raw_length ) {
389
    if ( $len != $raw_length ) {
368
          my $trim = $raw_length - $len;
390
        my $trim = $raw_length - $len;
369
          siplog( 'LOG_DEBUG', "read_request trimmed $trim character(s) " );
391
        siplog( 'LOG_DEBUG', "read_request trimmed $trim character(s) " );
370
      }
392
    }
371
393
372
      siplog( 'LOG_INFO', "INPUT MSG: '$buffer'" );
394
    siplog( 'LOG_INFO', "INPUT MSG: '$buffer'" );
373
      return $buffer;
395
    return $buffer;
374
}
396
}
375
397
376
# $server->get_timeout({ $type => 1, fallback => $fallback });
398
# $server->get_timeout({ $type => 1, fallback => $fallback });
Lines 387-416 sub get_timeout { Link Here
387
    my ( $server, $params ) = @_;
409
    my ( $server, $params ) = @_;
388
    my $fallback = $params->{fallback} || 30;
410
    my $fallback = $params->{fallback} || 30;
389
    my $service = $server->{service} // {};
411
    my $service = $server->{service} // {};
390
    my $config = $server->{config} // {};
412
    my $config  = $server->{config} //  {};
391
413
392
    if( $params->{transport} ||
414
    if ( $params->{transport}
393
        ( $params->{client} && !exists $service->{client_timeout} )) {
415
        || ( $params->{client} && !exists $service->{client_timeout} ) )
416
    {
394
        # We do not allow zero values here.
417
        # We do not allow zero values here.
395
        # Note: config/timeout seems to be deprecated.
418
        # Note: config/timeout seems to be deprecated.
396
        return $service->{timeout} || $config->{timeout} || $fallback;
419
        return $service->{timeout} || $config->{timeout} || $fallback;
397
420
398
    } elsif( $params->{client} ) {
421
    }
422
    elsif ( $params->{client} ) {
423
399
        # We know that client_timeout exists now.
424
        # We know that client_timeout exists now.
400
        # We do allow zero values here to indicate no timeout.
425
        # We do allow zero values here to indicate no timeout.
401
        return 0 if $service->{client_timeout} =~ /^0+$|\D/;
426
        return 0 if $service->{client_timeout} =~ /^0+$|\D/;
402
        return $service->{client_timeout};
427
        return $service->{client_timeout};
403
428
404
    } elsif( $params->{policy} ) {
429
    }
430
    elsif ( $params->{policy} ) {
405
        my $policy = $server->{policy} // {};
431
        my $policy = $server->{policy} // {};
406
        my $rv = sprintf( "%03d", $policy->{timeout} // 0 );
432
        my $rv = sprintf( "%03d", $policy->{timeout} // 0 );
407
        if( length($rv) != 3 ) {
433
        if ( length($rv) != 3 ) {
408
            siplog( "LOG_ERR", "Policy timeout has wrong size: '%s'", $rv );
434
            siplog( "LOG_ERR", "Policy timeout has wrong size: '%s'", $rv );
409
            return '000';
435
            return '000';
410
        }
436
        }
411
        return $rv;
437
        return $rv;
412
438
413
    } else {
439
    }
440
    else {
414
        return $fallback;
441
        return $fallback;
415
    }
442
    }
416
}
443
}
417
- 

Return to bug 15338