"Fossies" - the Fresh Open Source Software Archive

Member "koha-19.11.15/C4/SIP/SIPServer.pm" (23 Feb 2021, 11917 Bytes) of package /linux/misc/koha-19.11.15.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "SIPServer.pm" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 20.05.05_vs_20.05.06.

    1 #!/usr/bin/perl
    2 package C4::SIP::SIPServer;
    3 
    4 use strict;
    5 use warnings;
    6 use FindBin qw($Bin);
    7 use lib "$Bin";
    8 use Sys::Syslog qw(syslog);
    9 use Net::Server::PreFork;
   10 use IO::Socket::INET;
   11 use Socket qw(:DEFAULT :crlf);
   12 require UNIVERSAL::require;
   13 
   14 use C4::Context;
   15 use C4::SIP::Sip::Constants qw(:all);
   16 use C4::SIP::Sip::Configuration;
   17 use C4::SIP::Sip::Checksum qw(checksum verify_cksum);
   18 use C4::SIP::Sip::MsgType qw( handle login_core );
   19 use Koha::Caches;
   20 
   21 use base qw(Net::Server::PreFork);
   22 
   23 use constant LOG_SIP => "local6"; # Local alias for the logging facility
   24 
   25 #
   26 # Main  # not really, since package SIPServer
   27 #
   28 # FIXME: Is this a module or a script?  
   29 # A script with no MAIN namespace?
   30 # A module that takes command line args?
   31 
   32 # Set interface to 'sip'
   33 C4::Context->interface('sip');
   34 
   35 my %transports = (
   36     RAW    => \&raw_transport,
   37     telnet => \&telnet_transport,
   38 );
   39 
   40 #
   41 # Read configuration
   42 #
   43 my $config = C4::SIP::Sip::Configuration->new( $ARGV[0] );
   44 my @parms;
   45 
   46 #
   47 # Ports to bind
   48 #
   49 foreach my $svc (keys %{$config->{listeners}}) {
   50     push @parms, "port=" . $svc;
   51 }
   52 
   53 #
   54 # Logging
   55 #
   56 # Log lines look like this:
   57 # Jun 16 21:21:31 server08 steve_sip[19305]: ILS::Transaction::Checkout performing checkout...
   58 # [  TIMESTAMP  ] [ HOST ] [ IDENT ]  PID  : Message...
   59 #
   60 # The IDENT is determined by config file 'server-params' arguments
   61 
   62 
   63 #
   64 # Server Management: set parameters for the Net::Server::PreFork
   65 # module.  The module silently ignores parameters that it doesn't
   66 # recognize, and complains about invalid values for parameters
   67 # that it does.
   68 #
   69 if (defined($config->{'server-params'})) {
   70     while (my ($key, $val) = each %{$config->{'server-params'}}) {
   71         push @parms, $key . '=' . $val;
   72     }
   73 }
   74 
   75 
   76 #
   77 # This is the main event.
   78 __PACKAGE__ ->run(@parms);
   79 
   80 #
   81 # Child
   82 #
   83 
   84 # process_request is the callback used by Net::Server to handle
   85 # an incoming connection request.
   86 
   87 sub process_request {
   88     my $self = shift;
   89     my $service;
   90     my ($sockaddr, $port, $proto);
   91     my $transport;
   92 
   93     $self->{config} = $config;
   94 
   95     # Flushing L1 to make sure the request will be processed using the correct data
   96     Koha::Caches->flush_L1_caches();
   97 
   98     my $sockname = getsockname(STDIN);
   99 
  100     # Check if socket connection is IPv6 before resolving address
  101     my $family = Socket::sockaddr_family($sockname);
  102     if ($family == AF_INET6) {
  103       ($port, $sockaddr) = sockaddr_in6($sockname);
  104       $sockaddr = Socket::inet_ntop(AF_INET6, $sockaddr);
  105     } else {
  106       ($port, $sockaddr) = sockaddr_in($sockname);
  107       $sockaddr = inet_ntoa($sockaddr);
  108     }
  109     $proto = $self->{server}->{client}->NS_proto();
  110 
  111     $self->{service} = $config->find_service($sockaddr, $port, $proto);
  112 
  113     if (!defined($self->{service})) {
  114         syslog("LOG_ERR", "process_request: Unknown recognized server connection: %s:%s/%s", $sockaddr, $port, $proto);
  115         die "process_request: Bad server connection";
  116     }
  117 
  118     $transport = $transports{$self->{service}->{transport}};
  119 
  120     if (!defined($transport)) {
  121         syslog("LOG_WARNING", "Unknown transport '%s', dropping", $service->{transport});
  122         return;
  123     } else {
  124         &$transport($self);
  125     }
  126     return;
  127 }
  128 
  129 #
  130 # Transports
  131 #
  132 
  133 sub raw_transport {
  134     my $self = shift;
  135     my $input;
  136     my $service = $self->{service};
  137     # If using Net::Server::PreFork you may already have account set from a previous session
  138     # Ensure you dont
  139     if ($self->{account}) {
  140         delete $self->{account};
  141     }
  142 
  143     # Timeout the while loop if we get stuck in it
  144     # In practice it should only iterate once but be prepared
  145     local $SIG{ALRM} = sub { die 'raw transport Timed Out!' };
  146     my $timeout = $self->get_timeout({ transport => 1 });
  147     syslog('LOG_DEBUG', "raw_transport: timeout is $timeout");
  148     alarm $timeout;
  149     while (!$self->{account}) {
  150         $input = read_request();
  151         if (!$input) {
  152             # EOF on the socket
  153             syslog("LOG_INFO", "raw_transport: shutting down: EOF during login");
  154             return;
  155         }
  156         $input =~ s/[\r\n]+$//sm; # Strip off trailing line terminator(s)
  157         my $reg = qr/^${\(LOGIN)}/;
  158         last if $input !~ $reg ||
  159             C4::SIP::Sip::MsgType::handle($input, $self, LOGIN);
  160     }
  161     alarm 0;
  162 
  163     syslog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
  164         $self->{account}->{id},
  165         $self->{account}->{institution});
  166     if (! $self->{account}->{id}) {
  167         syslog("LOG_ERR","Login failed shutting down");
  168         return;
  169     }
  170 
  171     $self->sip_protocol_loop();
  172     syslog("LOG_INFO", "raw_transport: shutting down");
  173     return;
  174 }
  175 
  176 sub get_clean_string {
  177     my $string = shift;
  178     if (defined $string) {
  179         syslog("LOG_DEBUG", "get_clean_string  pre-clean(length %s): %s", length($string), $string);
  180         chomp($string);
  181         $string =~ s/^[^A-z0-9]+//;
  182         $string =~ s/[^A-z0-9]+$//;
  183         syslog("LOG_DEBUG", "get_clean_string post-clean(length %s): %s", length($string), $string);
  184     } else {
  185         syslog("LOG_INFO", "get_clean_string called on undefined");
  186     }
  187     return $string;
  188 }
  189 
  190 sub get_clean_input {
  191     local $/ = "\012";
  192     my $in = <STDIN>;
  193     $in = get_clean_string($in);
  194     while (my $extra = <STDIN>){
  195         syslog("LOG_ERR", "get_clean_input got extra lines: %s", $extra);
  196     }
  197     return $in;
  198 }
  199 
  200 sub telnet_transport {
  201     my $self = shift;
  202     my ($uid, $pwd);
  203     my $strikes = 3;
  204     my $account = undef;
  205     my $input;
  206     my $config  = $self->{config};
  207     my $timeout = $self->get_timeout({ transport => 1 });
  208     syslog("LOG_DEBUG", "telnet_transport: timeout is $timeout");
  209 
  210     eval {
  211     local $SIG{ALRM} = sub { die "telnet_transport: Timed Out ($timeout seconds)!\n"; };
  212     local $| = 1;           # Unbuffered output
  213     $/ = "\015";        # Internet Record Separator (lax version)
  214     # Until the terminal has logged in, we don't trust it
  215     # so use a timeout to protect ourselves from hanging.
  216 
  217     while ($strikes--) {
  218         print "login: ";
  219         alarm $timeout;
  220         # $uid = &get_clean_input;
  221         $uid = <STDIN>;
  222         print "password: ";
  223         # $pwd = &get_clean_input || '';
  224         $pwd = <STDIN>;
  225         alarm 0;
  226 
  227         syslog("LOG_DEBUG", "telnet_transport 1: uid length %s, pwd length %s", length($uid), length($pwd));
  228         $uid = get_clean_string ($uid);
  229         $pwd = get_clean_string ($pwd);
  230         syslog("LOG_DEBUG", "telnet_transport 2: uid length %s, pwd length %s", length($uid), length($pwd));
  231 
  232         if (exists ($config->{accounts}->{$uid})
  233         && ($pwd eq $config->{accounts}->{$uid}->{password})) {
  234             $account = $config->{accounts}->{$uid};
  235             if ( C4::SIP::Sip::MsgType::login_core($self,$uid,$pwd) ) {
  236                 last;
  237             }
  238         }
  239         syslog("LOG_WARNING", "Invalid login attempt: '%s'", ($uid||''));
  240         print("Invalid login$CRLF");
  241     }
  242     }; # End of eval
  243 
  244     if ($@) {
  245         syslog("LOG_ERR", "telnet_transport: Login timed out");
  246         die "Telnet Login Timed out";
  247     } elsif (!defined($account)) {
  248         syslog("LOG_ERR", "telnet_transport: Login Failed");
  249         die "Login Failure";
  250     } else {
  251         print "Login OK.  Initiating SIP$CRLF";
  252     }
  253 
  254     $self->{account} = $account;
  255     syslog("LOG_DEBUG", "telnet_transport: uname/inst: '%s/%s'", $account->{id}, $account->{institution});
  256     $self->sip_protocol_loop();
  257     syslog("LOG_INFO", "telnet_transport: shutting down");
  258     return;
  259 }
  260 
  261 #
  262 # The terminal has logged in, using either the SIP login process
  263 # over a raw socket, or via the pseudo-unix login provided by the
  264 # telnet transport.  From that point on, both the raw and the telnet
  265 # processes are the same:
  266 sub sip_protocol_loop {
  267     my $self = shift;
  268     my $service = $self->{service};
  269     my $config  = $self->{config};
  270     my $timeout = $self->get_timeout({ client => 1 });
  271 
  272     # The spec says the first message will be:
  273     #     SIP v1: SC_STATUS
  274     #     SIP v2: LOGIN (or SC_STATUS via telnet?)
  275     # But it might be SC_REQUEST_RESEND.  As long as we get
  276     # SC_REQUEST_RESEND, we keep waiting.
  277 
  278     # Comprise reports that no other ILS actually enforces this
  279     # constraint, so we'll relax about it too.
  280     # Using the SIP "raw" login process, rather than telnet,
  281     # requires the LOGIN message and forces SIP 2.00.  In that
  282     # case, the LOGIN message has already been processed (above).
  283 
  284     # In short, we'll take any valid message here.
  285     eval {
  286         local $SIG{ALRM} = sub {
  287             syslog( 'LOG_DEBUG', 'Inactive: timed out' );
  288             die "Timed Out!\n";
  289         };
  290         my $previous_alarm = alarm($timeout);
  291 
  292         while ( my $inputbuf = read_request() ) {
  293             if ( !defined $inputbuf ) {
  294                 return;    #EOF
  295             }
  296             alarm($timeout);
  297 
  298             unless ($inputbuf) {
  299                 syslog( "LOG_ERR", "sip_protocol_loop: empty input skipped" );
  300                 print("96$CR");
  301                 next;
  302             }
  303 
  304             my $status = C4::SIP::Sip::MsgType::handle( $inputbuf, $self, q{} );
  305             if ( !$status ) {
  306                 syslog(
  307                     "LOG_ERR",
  308                     "sip_protocol_loop: failed to handle %s",
  309                     substr( $inputbuf, 0, 2 )
  310                 );
  311             }
  312             next if $status eq REQUEST_ACS_RESEND;
  313         }
  314         alarm($previous_alarm);
  315         return;
  316     };
  317     if ( $@ =~ m/timed out/i ) {
  318         return;
  319     }
  320     return;
  321 }
  322 
  323 sub read_request {
  324       my $raw_length;
  325       local $/ = "\015";
  326 
  327     # proper SPEC: (octal) \015 = (hex) x0D = (dec) 13 = (ascii) carriage return
  328       my $buffer = <STDIN>;
  329       if ( defined $buffer ) {
  330           STDIN->flush();    # clear an extra linefeed
  331           chomp $buffer;
  332           $raw_length = length $buffer;
  333           $buffer =~ s/^\s*[^A-z0-9]+//s;
  334 # Every line must start with a "real" character.  Not whitespace, control chars, etc.
  335           $buffer =~ s/[^A-z0-9]+$//s;
  336 
  337 # Same for the end.  Note this catches the problem some clients have sending empty fields at the end, like |||
  338           $buffer =~ s/\015?\012//g;    # Extra line breaks must die
  339           $buffer =~ s/\015?\012//s;    # Extra line breaks must die
  340           $buffer =~ s/\015*\012*$//s;
  341 
  342     # treat as one line to include the extra linebreaks we are trying to remove!
  343       }
  344       else {
  345           syslog( 'LOG_DEBUG', 'EOF returned on read' );
  346           return;
  347       }
  348       my $len = length $buffer;
  349       if ( $len != $raw_length ) {
  350           my $trim = $raw_length - $len;
  351           syslog( 'LOG_DEBUG', "read_request trimmed $trim character(s) " );
  352       }
  353 
  354       syslog( 'LOG_INFO', "INPUT MSG: '$buffer'" );
  355       return $buffer;
  356 }
  357 
  358 # $server->get_timeout({ $type => 1, fallback => $fallback });
  359 #     where $type is transport | client | policy
  360 #
  361 # Centralizes all timeout logic.
  362 # Transport refers to login process, client to active connections.
  363 # Policy timeout is transaction timeout (used in ACS status message).
  364 #
  365 # Fallback is optional. If you do not pass transport, client or policy,
  366 # you will get fallback or hardcoded default.
  367 
  368 sub get_timeout {
  369     my ( $server, $params ) = @_;
  370     my $fallback = $params->{fallback} || 30;
  371     my $service = $server->{service} // {};
  372     my $config = $server->{config} // {};
  373 
  374     if( $params->{transport} ||
  375         ( $params->{client} && !exists $service->{client_timeout} )) {
  376         # We do not allow zero values here.
  377         # Note: config/timeout seems to be deprecated.
  378         return $service->{timeout} || $config->{timeout} || $fallback;
  379 
  380     } elsif( $params->{client} ) {
  381         # We know that client_timeout exists now.
  382         # We do allow zero values here to indicate no timeout.
  383         return 0 if $service->{client_timeout} =~ /^0+$|\D/;
  384         return $service->{client_timeout};
  385 
  386     } elsif( $params->{policy} ) {
  387         my $policy = $server->{policy} // {};
  388         my $rv = sprintf( "%03d", $policy->{timeout} // 0 );
  389         if( length($rv) != 3 ) {
  390             syslog( "LOG_ERR", "Policy timeout has wrong size: '%s'", $rv );
  391             return '000';
  392         }
  393         return $rv;
  394 
  395     } else {
  396         return $fallback;
  397     }
  398 }
  399 
  400 1;
  401 
  402 __END__