| Lines 22-33
          use warnings;
      
      
        Link Here | 
        
          | 22 |  | 22 |  | 
        
          | 23 | use Getopt::Long qw( GetOptions ); | 23 | use Getopt::Long qw( GetOptions ); | 
        
          | 24 |  | 24 |  | 
          
            
              | 25 | my ($help, $config, $daemon); | 25 | my ( $help, $config, $daemon ); | 
        
          | 26 |  | 26 |  | 
        
          | 27 | GetOptions( | 27 | GetOptions( | 
          
            
              | 28 |     'config|c=s'    => \$config, | 28 |     'config|c=s' => \$config, | 
            
              | 29 |     'daemon|d'      => \$daemon, | 29 |     'daemon|d'   => \$daemon, | 
            
              | 30 |     'help|?'        => \$help, | 30 |     'help|?'     => \$help, | 
        
          | 31 | ); | 31 | ); | 
        
          | 32 |  | 32 |  | 
        
          | 33 | if ( $help || !$config ) { | 33 | if ( $help || !$config ) { | 
  
    | Lines 86-457
          if ($daemon) {
      
      
        Link Here | 
        
          | 86 | exit; | 86 | exit; | 
        
          | 87 |  | 87 |  | 
        
          | 88 | { | 88 | { | 
            
              | 89 | package ImportProxyServer; |  |  | 
            
              | 90 |  | 
            
              | 91 | use Carp qw( croak ); | 
            
              | 92 | use IO::Socket::INET qw( SOCK_STREAM ); | 
            
              | 93 | # use IO::Socket::IP; | 
            
              | 94 | use IO::Select; | 
            
              | 95 | use POSIX; | 
            
              | 96 | use HTTP::Status qw( HTTP_FORBIDDEN HTTP_UNAUTHORIZED ); | 
            
              | 97 | use strict; | 
            
              | 98 | use warnings; | 
        
          | 99 |  | 89 |  | 
          
            
              | 100 | use LWP::UserAgent; | 90 |     package ImportProxyServer; | 
            
              | 101 | use XML::Simple qw( XMLin ); |  |  | 
            
              | 102 | use MARC::Record; | 
            
              | 103 | use MARC::File::XML; | 
        
          | 104 |  | 91 |  | 
          
            
              | 105 | use constant CLIENT_READ_TIMEOUT     => 5; | 92 |     use Carp             qw( croak ); | 
            
              | 106 | use constant CLIENT_READ_BUFFER_SIZE => 100000; | 93 |     use IO::Socket::INET qw( SOCK_STREAM ); | 
            
              | 107 | use constant AUTH_URI       => "/cgi-bin/koha/svc/authentication"; |  |  | 
            
              | 108 | use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib"; | 
        
          | 109 |  | 94 |  | 
          
            
              | 110 | sub new { | 95 |     # use IO::Socket::IP; | 
            
              | 111 |     my $class = shift; | 96 |     use IO::Select; | 
            
              | 112 |     my $config_file = shift or croak "No config file"; | 97 |     use POSIX; | 
            
              |  |  | 98 |     use HTTP::Status qw( HTTP_FORBIDDEN HTTP_UNAUTHORIZED ); | 
            
              | 99 |     use strict; | 
            
              | 100 |     use warnings; | 
        
          | 113 |  | 101 |  | 
          
            
              | 114 |     my $self = {time_to_die => 0, config_file => $config_file }; | 102 |     use LWP::UserAgent; | 
            
              | 115 |     bless $self, $class; | 103 |     use XML::Simple qw( XMLin ); | 
            
              |  |  | 104 |     use MARC::Record; | 
            
              | 105 |     use MARC::File::XML; | 
        
          | 116 |  | 106 |  | 
          
            
              | 117 |     $self->parse_config; | 107 |     use constant CLIENT_READ_TIMEOUT     => 5; | 
            
              | 118 |     return $self; | 108 |     use constant CLIENT_READ_BUFFER_SIZE => 100000; | 
            
              | 119 | } | 109 |     use constant AUTH_URI                => "/cgi-bin/koha/svc/authentication"; | 
            
              |  |  | 110 |     use constant IMPORT_SVC_URI          => "/cgi-bin/koha/svc/import_bib"; | 
        
          | 120 |  | 111 |  | 
          
            
              | 121 | sub parse_config { | 112 |     sub new { | 
            
              | 122 |     my $self = shift; | 113 |         my $class       = shift; | 
            
              |  |  | 114 |         my $config_file = shift or croak "No config file"; | 
        
          | 123 |  | 115 |  | 
          
            
              | 124 |     my $config_file = $self->{config_file}; | 116 |         my $self = { time_to_die => 0, config_file => $config_file }; | 
            
              |  |  | 117 |         bless $self, $class; | 
        
          | 125 |  | 118 |  | 
          
            
              | 126 |     open (my $conf_fh, '<', $config_file) or die "Cannot open config file $config: $!"; | 119 |         $self->parse_config; | 
            
              |  |  | 120 |         return $self; | 
            
              | 121 |     } | 
        
          | 127 |  | 122 |  | 
          
            
              | 128 |     my %param; | 123 |     sub parse_config { | 
            
              | 129 |     my $line = 0; | 124 |         my $self = shift; | 
            
              | 130 |     while (<$conf_fh>) { |  |  | 
            
              | 131 |         $line++; | 
            
              | 132 |         chomp; | 
            
              | 133 |         s/\s*#.*//o; # remove comments | 
            
              | 134 |         s/^\s+//o;   # trim leading spaces | 
            
              | 135 |         s/\s+$//o;   # trim trailing spaces | 
            
              | 136 |         next unless $_; | 
        
          | 137 |  | 125 |  | 
          
            
              | 138 |         my ($p, $v) = m/(\S+?):\s*(.*)/o; | 126 |         my $config_file = $self->{config_file}; | 
            
              | 139 |         die "Invalid config line $line: $_" unless defined $v; |  |  | 
            
              | 140 |         $param{$p} = $v; | 
            
              | 141 |     } | 
            
              | 142 |     close($conf_fh); | 
            
              | 143 |  | 
            
              | 144 |     $self->{koha} = delete( $param{koha} ) | 
            
              | 145 |       or die "No koha base url in config file"; | 
            
              | 146 |     $self->{user} = delete( $param{user} ) | 
            
              | 147 |       or die "No koha user in config file"; | 
            
              | 148 |     $self->{password} = delete( $param{password} ) | 
            
              | 149 |       or die "No koha user password in config file"; | 
            
              | 150 |  | 
            
              | 151 |     if( defined $param{connexion_user} || defined $param{connexion_password}){ | 
            
              | 152 |         # If either is defined we expect both | 
            
              | 153 |         $self->{connexion_user} = delete( $param{connexion_user} ) | 
            
              | 154 |           or die "No koha connexion_user in config file"; | 
            
              | 155 |         $self->{connexion_password} = delete( $param{connexion_password} ) | 
            
              | 156 |           or die "No koha user connexion_password in config file"; | 
            
              | 157 |     } | 
        
          | 158 |  | 127 |  | 
          
            
              | 159 |     $self->{host} = delete( $param{host} ); | 128 |         open( my $conf_fh, '<', $config_file ) or die "Cannot open config file $config: $!"; | 
            
              | 160 |     $self->{port} = delete( $param{port} ) |  |  | 
            
              | 161 |       or die "Port not specified"; | 
        
          | 162 |  | 129 |  | 
          
            
              | 163 |     $self->{debug} = delete( $param{debug} ); | 130 |         my %param; | 
            
              |  |  | 131 |         my $line = 0; | 
            
              | 132 |         while (<$conf_fh>) { | 
            
              | 133 |             $line++; | 
            
              | 134 |             chomp; | 
            
              | 135 |             s/\s*#.*//o;    # remove comments | 
            
              | 136 |             s/^\s+//o;      # trim leading spaces | 
            
              | 137 |             s/\s+$//o;      # trim trailing spaces | 
            
              | 138 |             next unless $_; | 
        
          | 164 |  | 139 |  | 
          
            
              | 165 |     my $log_fh; | 140 |             my ( $p, $v ) = m/(\S+?):\s*(.*)/o; | 
            
              | 166 |     close $self->{log_fh} if $self->{log_fh}; | 141 |             die "Invalid config line $line: $_" unless defined $v; | 
            
              | 167 |     if (my $logfile = delete $param{log}) { | 142 |             $param{$p} = $v; | 
            
              | 168 |         open ($log_fh, '>>', $logfile) or die "Cannot open $logfile for write: $!"; | 143 |         } | 
            
              | 169 |     } else { | 144 |         close($conf_fh); | 
            
              | 170 |         $log_fh = \*STDERR; | 145 |  | 
            
              | 171 |     } | 146 |         $self->{koha} = delete( $param{koha} ) | 
            
              | 172 |     $self->{log_fh} = $log_fh; | 147 |             or die "No koha base url in config file"; | 
            
              |  |  | 148 |         $self->{user} = delete( $param{user} ) | 
            
              | 149 |             or die "No koha user in config file"; | 
            
              | 150 |         $self->{password} = delete( $param{password} ) | 
            
              | 151 |             or die "No koha user password in config file"; | 
            
              | 152 |  | 
            
              | 153 |         if ( defined $param{connexion_user} || defined $param{connexion_password} ) { | 
            
              | 154 |  | 
            
              | 155 |             # If either is defined we expect both | 
            
              | 156 |             $self->{connexion_user} = delete( $param{connexion_user} ) | 
            
              | 157 |                 or die "No koha connexion_user in config file"; | 
            
              | 158 |             $self->{connexion_password} = delete( $param{connexion_password} ) | 
            
              | 159 |                 or die "No koha user connexion_password in config file"; | 
            
              | 160 |         } | 
        
          | 173 |  | 161 |  | 
          
            
              | 174 |     $self->{params} = \%param; | 162 |         $self->{host} = delete( $param{host} ); | 
            
              | 175 | } | 163 |         $self->{port} = delete( $param{port} ) | 
            
              |  |  | 164 |             or die "Port not specified"; | 
        
          | 176 |  | 165 |  | 
          
            
              | 177 | sub log { | 166 |         $self->{debug} = delete( $param{debug} ); | 
            
              | 178 |     my $self = shift; |  |  | 
            
              | 179 |     my $log_fh = $self->{log_fh} | 
            
              | 180 |       or warn "No log fh", | 
            
              | 181 |          return; | 
            
              | 182 |     my $t = localtime; | 
            
              | 183 |     print $log_fh map "$t: $_\n", @_; | 
            
              | 184 | } | 
        
          | 185 |  | 167 |  | 
          
            
              | 186 | sub background { | 168 |         my $log_fh; | 
            
              | 187 |     my $self = shift; | 169 |         close $self->{log_fh} if $self->{log_fh}; | 
            
              |  |  | 170 |         if ( my $logfile = delete $param{log} ) { | 
            
              | 171 |             open( $log_fh, '>>', $logfile ) or die "Cannot open $logfile for write: $!"; | 
            
              | 172 |         } else { | 
            
              | 173 |             $log_fh = \*STDERR; | 
            
              | 174 |         } | 
            
              | 175 |         $self->{log_fh} = $log_fh; | 
        
          | 188 |  | 176 |  | 
          
            
              | 189 |     my $pid = fork; | 177 |         $self->{params} = \%param; | 
            
              | 190 |     return ($pid) if $pid; # parent | 178 |     } | 
        
          | 191 |  | 179 |  | 
          
            
              | 192 |     die "Couldn't fork: $!" unless defined($pid); | 180 |     sub log { | 
            
              |  |  | 181 |         my $self   = shift; | 
            
              | 182 |         my $log_fh = $self->{log_fh} | 
            
              | 183 |             or warn "No log fh", | 
            
              | 184 |             return; | 
            
              | 185 |         my $t = localtime; | 
            
              | 186 |         print $log_fh map "$t: $_\n", @_; | 
            
              | 187 |     } | 
        
          | 193 |  | 188 |  | 
          
            
              | 194 |     POSIX::setsid() or die "Can't start a new session: $!"; | 189 |     sub background { | 
            
              |  |  | 190 |         my $self = shift; | 
        
          | 195 |  | 191 |  | 
          
            
              | 196 |     $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 }; | 192 |         my $pid = fork; | 
            
              | 197 |     # trap or ignore $SIG{PIPE} | 193 |         return ($pid) if $pid;    # parent | 
            
              | 198 |     $SIG{USR1} = sub { $self->parse_config }; |  |  | 
        
          | 199 |  | 194 |  | 
          
            
              | 200 |     $self->run; | 195 |         die "Couldn't fork: $!" unless defined($pid); | 
            
              | 201 | } |  |  | 
        
          | 202 |  | 196 |  | 
          
            
              | 203 | sub run { | 197 |         POSIX::setsid() or die "Can't start a new session: $!"; | 
            
              | 204 |     my $self = shift; |  |  | 
            
              | 205 |  | 
            
              | 206 |     my $server_port = $self->{port}; | 
            
              | 207 |     my $server_host = $self->{host}; | 
            
              | 208 |  | 
            
              | 209 |     my $server = IO::Socket::INET->new( | 
            
              | 210 |         LocalHost => $server_host, | 
            
              | 211 |         LocalPort => $server_port, | 
            
              | 212 |         Type      => SOCK_STREAM, | 
            
              | 213 |         Proto     => "tcp", | 
            
              | 214 |         Listen    => 12, | 
            
              | 215 |         Blocking  => 1, | 
            
              | 216 |         ReuseAddr => 1, | 
            
              | 217 |     ) or die "Couldn't be a tcp server on port $server_port: $! $@"; | 
            
              | 218 |  | 
            
              | 219 |     $self->log("Started tcp listener on $server_host:$server_port"); | 
            
              | 220 |  | 
            
              | 221 |     $self->{ua} = _ua(); | 
            
              | 222 |  | 
            
              | 223 |     while ("FOREVER") { | 
            
              | 224 |         my $client = $server->accept() | 
            
              | 225 |           or die "Cannot accept: $!"; | 
            
              | 226 |         my $oldfh = select($client); | 
            
              | 227 |         $self->handle_request($client); | 
            
              | 228 |         select($oldfh); | 
            
              | 229 |         last if $self->{time_to_die}; | 
            
              | 230 |     } | 
        
          | 231 |  | 198 |  | 
          
            
              | 232 |     close($server); | 199 |         $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 }; | 
            
              | 233 | } |  |  | 
        
          | 234 |  | 200 |  | 
          
            
              | 235 | sub _ua { | 201 |         # trap or ignore $SIG{PIPE} | 
            
              | 236 |     my $ua = LWP::UserAgent->new; | 202 |         $SIG{USR1} = sub { $self->parse_config }; | 
            
              | 237 |     $ua->timeout(10); |  |  | 
            
              | 238 |     $ua->cookie_jar({}); | 
            
              | 239 |     return $ua; | 
            
              | 240 | } | 
        
          | 241 |  | 203 |  | 
          
            
              | 242 | sub get_current_csrf_token { | 204 |         $self->run; | 
            
              | 243 |     my $self = shift; | 205 |     } | 
            
              | 244 |     my $ua = $self->{ua}; |  |  | 
            
              | 245 |     my $url = $self->{koha} . AUTH_URI; | 
            
              | 246 |     return $ua->get($url)->header('CSRF-TOKEN'); | 
            
              | 247 | } | 
        
          | 248 |  | 206 |  | 
          
            
              | 249 | sub authenticate { | 207 |     sub run { | 
            
              | 250 |     my $self = shift; | 208 |         my $self = shift; | 
            
              | 251 |     my $ua = $self->{ua}; | 209 |  | 
            
              | 252 |     my $url = $self->{koha} . AUTH_URI; | 210 |         my $server_port = $self->{port}; | 
            
              | 253 |     my $resp = $ua->post( | 211 |         my $server_host = $self->{host}; | 
            
              | 254 |         $url, | 212 |  | 
            
              | 255 |         { | 213 |         my $server = IO::Socket::INET->new( | 
            
              | 256 |             login_userid => $self->{user}, | 214 |             LocalHost => $server_host, | 
            
              | 257 |             login_password => $self->{password}, | 215 |             LocalPort => $server_port, | 
            
              | 258 |             csrf_token => $self->get_current_csrf_token, | 216 |             Type      => SOCK_STREAM, | 
            
              |  |  | 217 |             Proto     => "tcp", | 
            
              | 218 |             Listen    => 12, | 
            
              | 219 |             Blocking  => 1, | 
            
              | 220 |             ReuseAddr => 1, | 
            
              | 221 |         ) or die "Couldn't be a tcp server on port $server_port: $! $@"; | 
            
              | 222 |  | 
            
              | 223 |         $self->log("Started tcp listener on $server_host:$server_port"); | 
            
              | 224 |  | 
            
              | 225 |         $self->{ua} = _ua(); | 
            
              | 226 |  | 
            
              | 227 |         while ("FOREVER") { | 
            
              | 228 |             my $client = $server->accept() | 
            
              | 229 |                 or die "Cannot accept: $!"; | 
            
              | 230 |             my $oldfh = select($client); | 
            
              | 231 |             $self->handle_request($client); | 
            
              | 232 |             select($oldfh); | 
            
              | 233 |             last if $self->{time_to_die}; | 
        
          | 259 |         } | 234 |         } | 
          
            
              | 260 |     ); | 235 |  | 
            
              | 261 |     if ( !$resp->is_success ) { | 236 |         close($server); | 
            
              | 262 |         $self->log("Authentication failed", $resp->request->as_string, $resp->as_string); |  |  | 
            
              | 263 |         return; | 
        
          | 264 |     } | 237 |     } | 
            
              | 265 |     return $resp->header('CSRF-TOKEN'); |  |  | 
            
              | 266 | } | 
        
          | 267 |  | 238 |  | 
          
            
              | 268 | sub read_request { | 239 |     sub _ua { | 
            
              | 269 |     my ( $self, $io ) = @_; | 240 |         my $ua = LWP::UserAgent->new; | 
            
              |  |  | 241 |         $ua->timeout(10); | 
            
              | 242 |         $ua->cookie_jar( {} ); | 
            
              | 243 |         return $ua; | 
            
              | 244 |     } | 
        
          | 270 |  | 245 |  | 
          
            
              | 271 |     my ($in, @in_arr, $timeout, $bad_marc); | 246 |     sub get_current_csrf_token { | 
            
              | 272 |     my $select = IO::Select->new($io) ; | 247 |         my $self = shift; | 
            
              | 273 |     while ( "FOREVER" ) { | 248 |         my $ua   = $self->{ua}; | 
            
              | 274 |         if ( $select->can_read(CLIENT_READ_TIMEOUT) ){ | 249 |         my $url  = $self->{koha} . AUTH_URI; | 
            
              | 275 |             $io->recv($in, CLIENT_READ_BUFFER_SIZE); | 250 |         return $ua->get($url)->header('CSRF-TOKEN'); | 
            
              | 276 |             last unless $in; | 251 |     } | 
        
          | 277 |  | 252 |  | 
          
            
              | 278 |             # XXX ignore after NULL | 253 |     sub authenticate { | 
            
              | 279 |             if ( $in =~ m/^(.*)\000/so ) { # null received, EOT | 254 |         my $self = shift; | 
            
              | 280 |                 push @in_arr, $1; | 255 |         my $ua   = $self->{ua}; | 
            
              | 281 |                 last; | 256 |         my $url  = $self->{koha} . AUTH_URI; | 
            
              |  |  | 257 |         my $resp = $ua->post( | 
            
              | 258 |             $url, | 
            
              | 259 |             { | 
            
              | 260 |                 login_userid   => $self->{user}, | 
            
              | 261 |                 login_password => $self->{password}, | 
            
              | 262 |                 csrf_token     => $self->get_current_csrf_token, | 
        
          | 282 |             } | 263 |             } | 
          
            
              | 283 |             push @in_arr, $in; | 264 |         ); | 
            
              | 284 |         } | 265 |         if ( !$resp->is_success ) { | 
            
              | 285 |         else { | 266 |             $self->log( "Authentication failed", $resp->request->as_string, $resp->as_string ); | 
            
              | 286 |             last; | 267 |             return; | 
        
          | 287 |         } | 268 |         } | 
            
              |  |  | 269 |         return $resp->header('CSRF-TOKEN'); | 
        
          | 288 |     } | 270 |     } | 
        
          | 289 |  | 271 |  | 
          
            
              | 290 |     $in = join '', @in_arr; | 272 |     sub read_request { | 
            
              | 291 |     $in =~ m/(.)$/; | 273 |         my ( $self, $io ) = @_; | 
            
              | 292 |     my $lastchar = $1; | 274 |  | 
            
              | 293 |     my ($xml, $user, $password, $local_user); | 275 |         my ( $in, @in_arr, $timeout, $bad_marc ); | 
            
              | 294 |     my $data = $in; # copy for diagmostic purposes | 276 |         my $select = IO::Select->new($io); | 
            
              | 295 |     while () { | 277 |         while ("FOREVER") { | 
            
              | 296 |         my $first = substr( $data, 0, 1 ); | 278 |             if ( $select->can_read(CLIENT_READ_TIMEOUT) ) { | 
            
              | 297 |         if (!defined $first) { | 279 |                 $io->recv( $in, CLIENT_READ_BUFFER_SIZE ); | 
            
              | 298 |            last; | 280 |                 last unless $in; | 
            
              | 299 |         } | 281 |  | 
            
              | 300 |         $first eq 'U' && do { | 282 |                 # XXX ignore after NULL | 
            
              | 301 |             ($user, $data) = _trim_identifier($data); | 283 |                 if ( $in =~ m/^(.*)\000/so ) {    # null received, EOT | 
            
              | 302 |             next; | 284 |                     push @in_arr, $1; | 
            
              | 303 |         }; | 285 |                     last; | 
            
              | 304 |         $first eq 'A' && do { | 286 |                 } | 
            
              | 305 |             ($local_user, $data) = _trim_identifier($data); | 287 |                 push @in_arr, $in; | 
            
              | 306 |             next; | 288 |             } else { | 
            
              | 307 |         }; | 289 |                 last; | 
            
              | 308 |         $first eq 'P' && do { |  |  | 
            
              | 309 |             ($password, $data) = _trim_identifier($data); | 
            
              | 310 |             next; | 
            
              | 311 |         }; | 
            
              | 312 |         $first eq ' ' && do { | 
            
              | 313 |             $data = substr( $data, 1 ); # trim | 
            
              | 314 |             next; | 
            
              | 315 |         }; | 
            
              | 316 |         $data =~ m/^[0-9]/ && do { | 
            
              | 317 |             # What we have here might be a MARC record... | 
            
              | 318 |             my $marc_record; | 
            
              | 319 |             eval { $marc_record = MARC::Record->new_from_usmarc($data); }; | 
            
              | 320 |             if ($@) { | 
            
              | 321 |                 $bad_marc = 1; | 
        
          | 322 |             } | 290 |             } | 
          
            
              | 323 |             else { | 291 |         } | 
            
              | 324 |                $xml = $marc_record->as_xml(); | 292 |  | 
            
              |  |  | 293 |         $in = join '', @in_arr; | 
            
              | 294 |         $in =~ m/(.)$/; | 
            
              | 295 |         my $lastchar = $1; | 
            
              | 296 |         my ( $xml, $user, $password, $local_user ); | 
            
              | 297 |         my $data = $in;    # copy for diagmostic purposes | 
            
              | 298 |         while () { | 
            
              | 299 |             my $first = substr( $data, 0, 1 ); | 
            
              | 300 |             if ( !defined $first ) { | 
            
              | 301 |                 last; | 
        
          | 325 |             } | 302 |             } | 
          
            
              | 326 |             last; | 303 |             $first eq 'U' && do { | 
            
              | 327 |         }; | 304 |                 ( $user, $data ) = _trim_identifier($data); | 
            
              | 328 |         last; # unexpected input | 305 |                 next; | 
            
              | 329 |     } | 306 |             }; | 
            
              |  |  | 307 |             $first eq 'A' && do { | 
            
              | 308 |                 ( $local_user, $data ) = _trim_identifier($data); | 
            
              | 309 |                 next; | 
            
              | 310 |             }; | 
            
              | 311 |             $first eq 'P' && do { | 
            
              | 312 |                 ( $password, $data ) = _trim_identifier($data); | 
            
              | 313 |                 next; | 
            
              | 314 |             }; | 
            
              | 315 |             $first eq ' ' && do { | 
            
              | 316 |                 $data = substr( $data, 1 );    # trim | 
            
              | 317 |                 next; | 
            
              | 318 |             }; | 
            
              | 319 |             $data =~ m/^[0-9]/ && do { | 
            
              | 320 |  | 
            
              | 321 |                 # What we have here might be a MARC record... | 
            
              | 322 |                 my $marc_record; | 
            
              | 323 |                 eval { $marc_record = MARC::Record->new_from_usmarc($data); }; | 
            
              | 324 |                 if ($@) { | 
            
              | 325 |                     $bad_marc = 1; | 
            
              | 326 |                 } else { | 
            
              | 327 |                     $xml = $marc_record->as_xml(); | 
            
              | 328 |                 } | 
            
              | 329 |                 last; | 
            
              | 330 |             }; | 
            
              | 331 |             last;    # unexpected input | 
            
              | 332 |         } | 
        
          | 330 |  | 333 |  | 
          
            
              | 331 |     my @details; | 334 |         my @details; | 
            
              | 332 |     push @details, "Timeout" if $timeout; | 335 |         push @details, "Timeout"                                                                   if $timeout; | 
            
              | 333 |     push @details, "Bad MARC" if $bad_marc; | 336 |         push @details, "Bad MARC"                                                                  if $bad_marc; | 
            
              | 334 |     push @details, "User: $user" if $user; | 337 |         push @details, "User: $user"                                                               if $user; | 
            
              | 335 |     push @details, "Password: " . ( $self->{debug} ? $password : ("x" x length($password)) ) if $password; | 338 |         push @details, "Password: " . ( $self->{debug} ? $password : ( "x" x length($password) ) ) if $password; | 
            
              | 336 |     push @details, "Local user: $local_user" if $local_user; | 339 |         push @details, "Local user: $local_user"                                                   if $local_user; | 
            
              | 337 |     push @details, "XML: $xml" if $xml; | 340 |         push @details, "XML: $xml"                                                                 if $xml; | 
            
              | 338 |     push @details, "Remaining data: $data" if ($data && !$xml); | 341 |         push @details, "Remaining data: $data" if ( $data && !$xml ); | 
            
              | 339 |     unless ($xml) { | 342 |  | 
            
              | 340 |         $self->log("Invalid request", $in, @details); | 343 |         unless ($xml) { | 
            
              | 341 |         return; | 344 |             $self->log( "Invalid request", $in, @details ); | 
            
              |  |  | 345 |             return; | 
            
              | 346 |         } | 
            
              | 347 |         $user = $local_user if !$user && $local_user; | 
            
              | 348 |  | 
            
              | 349 |         $self->log( "Request", @details ); | 
            
              | 350 |         $self->log($in) if $self->{debug}; | 
            
              | 351 |         return ( $xml, $user, $password ); | 
        
          | 342 |     } | 352 |     } | 
            
              | 343 |     $user = $local_user if !$user && $local_user; |  |  | 
        
          | 344 |  | 353 |  | 
          
            
              | 345 |     $self->log("Request", @details); | 354 |     sub _trim_identifier { | 
            
              | 346 |     $self->log($in) if $self->{debug}; |  |  | 
            
              | 347 |     return ($xml, $user, $password); | 
            
              | 348 | } | 
        
          | 349 |  | 355 |  | 
          
            
              | 350 | sub _trim_identifier { | 356 |         #my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 ); | 
            
              | 351 |     #my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 ); | 357 |         my $len = ord( substr( $_[0], 1, 1 ) ) - 64; | 
            
              | 352 |     my $len=ord(substr ($_[0], 1, 1)) - 64; | 358 |         if ( $len < 0 ) {    #length is numeric, and thus comes from the web client, not the desktop client. | 
            
              | 353 |     if ($len <0) {  #length is numeric, and thus comes from the web client, not the desktop client. | 359 |             $_[0] =~ m/.(\d+)/; | 
            
              | 354 |        $_[0] =~ m/.(\d+)/; | 360 |             $len = $1; | 
            
              | 355 |        $len = $1; | 361 |             return ( substr( $_[0], length($len) + 1, $len ), substr( $_[0], length($len) + 1 + $len ) ); | 
            
              | 356 |        return ( substr( $_[0], length($len)+1 , $len ), substr( $_[0], length($len) + 1 + $len ) ); | 362 |         } | 
            
              |  |  | 363 |         return ( substr( $_[0], 2, $len ), substr( $_[0], 2 + $len ) ); | 
        
          | 357 |     } | 364 |     } | 
            
              | 358 |     return ( substr( $_[0], 2 , $len ), substr( $_[0], 2 + $len ) ); |  |  | 
            
              | 359 | } | 
        
          | 360 |  | 365 |  | 
          
            
              | 361 | sub handle_request { | 366 |     sub handle_request { | 
            
              | 362 |     my ( $self, $io ) = @_; | 367 |         my ( $self, $io ) = @_; | 
            
              | 363 |     my ($data, $user, $password) = $self->read_request($io) | 368 |         my ( $data, $user, $password ) = $self->read_request($io) | 
            
              | 364 |       or return $self->error_response("Bad request"); | 369 |             or return $self->error_response("Bad request"); | 
        
          | 365 |  | 370 |  | 
          
            
              | 366 |     unless( | 371 |         unless ( !( defined $self->{connexion_user} ) | 
            
              | 367 |         !(defined $self->{connexion_user}) || | 372 |             || ( $user eq $self->{connexion_user} && $password eq $self->{connexion_password} ) ) | 
            
              | 368 |         ($user eq $self->{connexion_user} && $password eq $self->{connexion_password}) | 373 |         { | 
            
              | 369 |     ){ | 374 |             return $self->error_response("Unauthorized request"); | 
            
              | 370 |        return $self->error_response("Unauthorized request"); | 375 |         } | 
            
              | 371 |     } |  |  | 
        
          | 372 |  | 376 |  | 
          
            
              | 373 |     my $ua; | 377 |         my $ua; | 
            
              | 374 |     if ($self->{user}) { | 378 |         if ( $self->{user} ) { | 
            
              | 375 |         $user = $self->{user}; | 379 |             $user     = $self->{user}; | 
            
              | 376 |         $password = $self->{password}; | 380 |             $password = $self->{password}; | 
            
              | 377 |         $ua = $self->{ua}; | 381 |             $ua       = $self->{ua}; | 
            
              | 378 |     } | 382 |         } else { | 
            
              | 379 |     else { | 383 |             $ua = _ua();    # fresh one, needs to authenticate | 
            
              | 380 |         $ua  = _ua(); # fresh one, needs to authenticate | 384 |         } | 
            
              | 381 |     } | 385 |  | 
            
              |  |  | 386 |         my $base_url  = $self->{koha}; | 
            
              | 387 |         my $post_body = { | 
            
              | 388 |             'nomatch_action'    => $self->{params}->{nomatch_action}, | 
            
              | 389 |             'overlay_action'    => $self->{params}->{overlay_action}, | 
            
              | 390 |             'match'             => $self->{params}->{match}, | 
            
              | 391 |             'import_mode'       => $self->{params}->{import_mode}, | 
            
              | 392 |             'framework'         => $self->{params}->{framework}, | 
            
              | 393 |             'overlay_framework' => $self->{params}->{overlay_framework}, | 
            
              | 394 |             'item_action'       => $self->{params}->{item_action}, | 
            
              | 395 |             'xml'               => $data | 
            
              | 396 |         }; | 
        
          | 382 |  | 397 |  | 
          
            
              | 383 |     my $base_url = $self->{koha}; | 398 |         # If we have a token, try it, else, authenticate for the first time. | 
            
              | 384 |     my $post_body = { | 399 |         $self->{csrf_token} = $self->authenticate unless $self->{csrf_token}; | 
            
              | 385 |         'nomatch_action'    => $self->{params}->{nomatch_action}, | 400 |         my $resp = $ua->post( | 
            
              | 386 |         'overlay_action'    => $self->{params}->{overlay_action}, |  |  | 
            
              | 387 |         'match'             => $self->{params}->{match}, | 
            
              | 388 |         'import_mode'       => $self->{params}->{import_mode}, | 
            
              | 389 |         'framework'         => $self->{params}->{framework}, | 
            
              | 390 |         'overlay_framework' => $self->{params}->{overlay_framework}, | 
            
              | 391 |         'item_action'       => $self->{params}->{item_action}, | 
            
              | 392 |         'xml'               => $data | 
            
              | 393 |     }; | 
            
              | 394 |  | 
            
              | 395 |     # If we have a token, try it, else, authenticate for the first time. | 
            
              | 396 |     $self->{csrf_token} = $self->authenticate unless $self->{csrf_token}; | 
            
              | 397 |     my $resp = $ua->post( | 
            
              | 398 |         $base_url . IMPORT_SVC_URI, | 
            
              | 399 |         $post_body, | 
            
              | 400 |         csrf_token => $self->{csrf_token}, | 
            
              | 401 |     ); | 
            
              | 402 |  | 
            
              | 403 |     my $status = $resp->code; | 
            
              | 404 |     if ( $status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN ) { | 
            
              | 405 |         # Our token might have expired. Re-authenticate and post again. | 
            
              | 406 |         $self->{csrf_token} = $self->authenticate; | 
            
              | 407 |         $resp = $ua->post( | 
        
          | 408 |             $base_url . IMPORT_SVC_URI, | 401 |             $base_url . IMPORT_SVC_URI, | 
        
          | 409 |             $post_body, | 402 |             $post_body, | 
        
          | 410 |             csrf_token => $self->{csrf_token}, | 403 |             csrf_token => $self->{csrf_token}, | 
          
            
              | 411 |         ) | 404 |         ); | 
            
              | 412 |     } | 405 |  | 
            
              | 413 |     unless ($resp->is_success) { | 406 |         my $status = $resp->code; | 
            
              | 414 |         $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string); | 407 |         if ( $status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN ) { | 
            
              | 415 |         return $self->error_response("Unsuccessful request"); | 408 |  | 
            
              | 416 |     } | 409 |             # Our token might have expired. Re-authenticate and post again. | 
            
              |  |  | 410 |             $self->{csrf_token} = $self->authenticate; | 
            
              | 411 |             $resp = $ua->post( | 
            
              | 412 |                 $base_url . IMPORT_SVC_URI, | 
            
              | 413 |                 $post_body, | 
            
              | 414 |                 csrf_token => $self->{csrf_token}, | 
            
              | 415 |             ); | 
            
              | 416 |         } | 
            
              | 417 |         unless ( $resp->is_success ) { | 
            
              | 418 |             $self->log( "Unsuccessful request", $resp->request->as_string, $resp->as_string ); | 
            
              | 419 |             return $self->error_response("Unsuccessful request"); | 
            
              | 420 |         } | 
        
          | 417 |  | 421 |  | 
          
            
              | 418 |     my ($koha_status, $bib, $overlay, $batch_id, $error, $url); | 422 |         my ( $koha_status, $bib, $overlay, $batch_id, $error, $url ); | 
            
              | 419 |     if ( my $r = eval { XMLin($resp->content) } ) { | 423 |         if ( my $r = eval { XMLin( $resp->content ) } ) { | 
            
              | 420 |         $koha_status = $r->{status}; | 424 |             $koha_status = $r->{status}; | 
            
              | 421 |         $batch_id    = $r->{import_batch_id}; | 425 |             $batch_id    = $r->{import_batch_id}; | 
            
              | 422 |         $error       = $r->{error}; | 426 |             $error       = $r->{error}; | 
            
              | 423 |         $bib         = $r->{biblionumber}; | 427 |             $bib         = $r->{biblionumber}; | 
            
              | 424 |         $overlay     = $r->{match_status}; | 428 |             $overlay     = $r->{match_status}; | 
            
              | 425 |         $url         = $r->{url}; | 429 |             $url         = $r->{url}; | 
            
              | 426 |     } | 430 |         } else { | 
            
              | 427 |     else { | 431 |             $koha_status = "error"; | 
            
              | 428 |         $koha_status = "error"; | 432 |             $self->log("Response format error:\n$resp->content"); | 
            
              | 429 |         $self->log("Response format error:\n$resp->content"); | 433 |             return $self->error_response("Invalid response"); | 
            
              | 430 |         return $self->error_response("Invalid response"); | 434 |         } | 
            
              | 431 |     } |  |  | 
        
          | 432 |  | 435 |  | 
          
            
              | 433 |     if ($koha_status eq "ok") { | 436 |         if ( $koha_status eq "ok" ) { | 
            
              | 434 |         my $response_string = sprintf( "Success.  Batch number %s - biblio record number %s", | 437 |             my $response_string = sprintf( | 
            
              | 435 |                                         $batch_id,$bib); | 438 |                 "Success.  Batch number %s - biblio record number %s", | 
            
              | 436 |         $response_string .= $overlay eq 'no_match' ? ' added to Koha.' : ' overlaid by import.'; | 439 |                 $batch_id, $bib | 
            
              | 437 |         $response_string .= "\n\n$url"; | 440 |             ); | 
            
              |  |  | 441 |             $response_string .= $overlay eq 'no_match' ? ' added to Koha.' : ' overlaid by import.'; | 
            
              | 442 |             $response_string .= "\n\n$url"; | 
        
          | 438 |  | 443 |  | 
          
            
              | 439 |         return $self->response( $response_string ); | 444 |             return $self->response($response_string); | 
            
              | 440 |     } | 445 |         } | 
            
              | 441 |  |  |  | 
            
              | 442 |     return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) ); | 
            
              | 443 | } | 
        
          | 444 |  | 446 |  | 
          
            
              | 445 | sub error_response { | 447 |         return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) ); | 
            
              | 446 |     my $self = shift; | 448 |     } | 
            
              | 447 |     $self->response(@_); |  |  | 
            
              | 448 | } | 
        
          | 449 |  | 449 |  | 
          
            
              | 450 | sub response { | 450 |     sub error_response { | 
            
              | 451 |     my $self = shift; | 451 |         my $self = shift; | 
            
              | 452 |     $self->log("Response: $_[0]"); | 452 |         $self->response(@_); | 
            
              | 453 |     printf $_[0] . "\0"; | 453 |     } | 
            
              | 454 | } |  |  | 
        
          | 455 |  | 454 |  | 
            
              |  |  | 455 |     sub response { | 
            
              | 456 |         my $self = shift; | 
            
              | 457 |         $self->log("Response: $_[0]"); | 
            
              | 458 |         printf $_[0] . "\0"; | 
            
              | 459 |     } | 
        
          | 456 |  | 460 |  | 
          
            
              | 457 | } # package | 461 | }    # package | 
            
              | 458 | -  |  |  |