3 # Copyright 2012 CatalystIT
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
23 use Getopt::Long qw( GetOptions );
25 my ($help, $config, $daemon);
28 'config|c=s' => \$config,
29 'daemon|d' => \$daemon,
33 if($help || !$config){
37 --daemon | -d - go to background; prints pid to stdout
38 --config | -c - config file
39 --help | -? - this message
45 # comments are supported
49 host - ip address or hostname to bind to, defaults all available
50 port - port to bind to, mandatory
51 log - log file path, stderr if omitted
52 debug - dumps requests to the log file, passwords inclusive
53 koha - koha intranet base url, eg http://librarian.koha
54 user - koha user, authentication
55 password - koha user password, authentication
56 match - marc_matchers.code: ISBN or ISSN
57 overlay_action - import_batches.overlay_action: replace, create_new or ignore
58 nomatch_action - import_batches.nomatch_action: create_new or ignore
59 item_action - import_batches.item_action: always_add,
60 add_only_for_matches, add_only_for_new or ignore
61 import_mode - stage or direct
62 framework - to be used if import_mode is direct
63 connexion_user - User sent from connexion client
64 connexion_password - Password sent from connexion client
66 Note: If connexion parameters are not defined request authentication will not be checked
67 You should specify a different user for connexion to protect the Koha credentials
69 All process related parameters (all but ip and port) have default values as
70 per Koha import process.
76 my $server = ImportProxyServer->new($config);
79 print $server->background;
87 package ImportProxyServer;
90 use IO::Socket::INET qw( SOCK_STREAM );
93 use POSIX qw( close exit fork localtime open printf sprintf );
94 use HTTP::Status qw( HTTP_FORBIDDEN HTTP_UNAUTHORIZED );
99 use XML::Simple qw( XMLin );
103 use constant CLIENT_READ_TIMEOUT => 5;
104 use constant CLIENT_READ_BUFFER_SIZE => 100000;
105 use constant AUTH_URI => "/cgi-bin/koha/mainpage.pl";
106 use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib";
110 my $config_file = shift or croak "No config file";
112 my $self = {time_to_die => 0, config_file => $config_file };
122 my $config_file = $self->{config_file};
124 open (my $conf_fh, '<', $config_file) or die "Cannot open config file $config: $!";
131 s/\s*#.*//o; # remove comments
132 s/^\s+//o; # trim leading spaces
133 s/\s+$//o; # trim trailing spaces
136 my ($p, $v) = m/(\S+?):\s*(.*)/o;
137 die "Invalid config line $line: $_" unless defined $v;
142 $self->{koha} = delete( $param{koha} )
143 or die "No koha base url in config file";
144 $self->{user} = delete( $param{user} )
145 or die "No koha user in config file";
146 $self->{password} = delete( $param{password} )
147 or die "No koha user password in config file";
149 if( defined $param{connexion_user} || defined $param{connexion_password}){
150 # If either is defined we expect both
151 $self->{connexion_user} = delete( $param{connexion_user} )
152 or die "No koha connexion_user in config file";
153 $self->{connexion_password} = delete( $param{connexion_password} )
154 or die "No koha user connexion_password in config file";
157 $self->{host} = delete( $param{host} );
158 $self->{port} = delete( $param{port} )
159 or die "Port not specified";
161 $self->{debug} = delete( $param{debug} );
164 close $self->{log_fh} if $self->{log_fh};
165 if (my $logfile = delete $param{log}) {
166 open ($log_fh, '>>', $logfile) or die "Cannot open $logfile for write: $!";
170 $self->{log_fh} = $log_fh;
172 $self->{params} = \%param;
177 my $log_fh = $self->{log_fh}
181 print $log_fh map "$t: $_\n", @_;
188 return ($pid) if $pid; # parent
190 die "Couldn't fork: $!" unless defined($pid);
192 POSIX::setsid() or die "Can't start a new session: $!";
194 $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 };
195 # trap or ignore $SIG{PIPE}
196 $SIG{USR1} = sub { $self->parse_config };
204 my $server_port = $self->{port};
205 my $server_host = $self->{host};
207 my $server = IO::Socket::INET->new(
208 LocalHost => $server_host,
209 LocalPort => $server_port,
215 ) or die "Couldn't be a tcp server on port $server_port: $! $@";
217 $self->log("Started tcp listener on $server_host:$server_port");
222 my $client = $server->accept()
223 or die "Cannot accept: $!";
224 my $oldfh = select($client);
225 $self->handle_request($client);
227 last if $self->{time_to_die};
234 my $ua = LWP::UserAgent->new;
241 my ( $self, $io ) = @_;
243 my ($in, @in_arr, $timeout, $bad_marc);
244 my $select = IO::Select->new($io) ;
245 while ( "FOREVER" ) {
246 if ( $select->can_read(CLIENT_READ_TIMEOUT) ){
247 $io->recv($in, CLIENT_READ_BUFFER_SIZE);
250 # XXX ignore after NULL
251 if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
262 $in = join '', @in_arr;
265 my ($xml, $user, $password, $local_user);
266 my $data = $in; # copy for diagmostic purposes
268 my $first = substr( $data, 0, 1 );
269 if (!defined $first) {
272 $first eq 'U' && do {
273 ($user, $data) = _trim_identifier($data);
276 $first eq 'A' && do {
277 ($local_user, $data) = _trim_identifier($data);
280 $first eq 'P' && do {
281 ($password, $data) = _trim_identifier($data);
284 $first eq ' ' && do {
285 $data = substr( $data, 1 ); # trim
288 $data =~ m/^[0-9]/ && do {
289 # What we have here might be a MARC record...
291 eval { $marc_record = MARC::Record->new_from_usmarc($data); };
296 $xml = $marc_record->as_xml();
300 last; # unexpected input
304 push @details, "Timeout" if $timeout;
305 push @details, "Bad MARC" if $bad_marc;
306 push @details, "User: $user" if $user;
307 push @details, "Password: " . ( $self->{debug} ? $password : ("x" x length($password)) ) if $password;
308 push @details, "Local user: $local_user" if $local_user;
309 push @details, "XML: $xml" if $xml;
310 push @details, "Remaining data: $data" if ($data && !$xml);
312 $self->log("Invalid request", $in, @details);
315 $user = $local_user if !$user && $local_user;
317 $self->log("Request", @details);
318 $self->log($in) if $self->{debug};
319 return ($xml, $user, $password);
322 sub _trim_identifier {
323 #my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );
324 my $len=ord(substr ($_[0], 1, 1)) - 64;
325 if ($len <0) { #length is numeric, and thus comes from the web client, not the desktop client.
328 return ( substr( $_[0], length($len)+1 , $len ), substr( $_[0], length($len) + 1 + $len ) );
330 return ( substr( $_[0], 2 , $len ), substr( $_[0], 2 + $len ) );
334 my ( $self, $io ) = @_;
335 my ($data, $user, $password) = $self->read_request($io)
336 or return $self->error_response("Bad request");
339 !(defined $self->{connexion_user}) ||
340 ($user eq $self->{connexion_user} && $password eq $self->{connexion_password})
342 return $self->error_response("Unauthorized request");
347 $user = $self->{user};
348 $password = $self->{password};
352 $ua = _ua(); # fresh one, needs to authenticate
355 my $base_url = $self->{koha};
356 my $resp = $ua->post( $base_url.IMPORT_SVC_URI,
357 {'nomatch_action' => $self->{params}->{nomatch_action},
358 'overlay_action' => $self->{params}->{overlay_action},
359 'match' => $self->{params}->{match},
360 'import_mode' => $self->{params}->{import_mode},
361 'framework' => $self->{params}->{framework},
362 'item_action' => $self->{params}->{item_action},
365 my $status = $resp->code;
366 if ($status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN) {
367 my $user = $self->{user};
368 my $password = $self->{password};
369 $resp = $ua->post( $base_url.AUTH_URI, { userid => $user, password => $password } );
370 $resp = $ua->post( $base_url.IMPORT_SVC_URI,
371 {'nomatch_action' => $self->{params}->{nomatch_action},
372 'overlay_action' => $self->{params}->{overlay_action},
373 'match' => $self->{params}->{match},
374 'import_mode' => $self->{params}->{import_mode},
375 'framework' => $self->{params}->{framework},
376 'item_action' => $self->{params}->{item_action},
378 if $resp->is_success;
380 unless ($resp->is_success) {
381 $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
382 return $self->error_response("Unsuccessful request");
385 my ($koha_status, $bib, $overlay, $batch_id, $error, $url);
386 if ( my $r = eval { XMLin($resp->content) } ) {
387 $koha_status = $r->{status};
388 $batch_id = $r->{import_batch_id};
389 $error = $r->{error};
390 $bib = $r->{biblionumber};
391 $overlay = $r->{match_status};
395 $koha_status = "error";
396 $self->log("Response format error:\n$resp->content");
397 return $self->error_response("Invalid response");
400 if ($koha_status eq "ok") {
401 my $response_string = sprintf( "Success. Batch number %s - biblio record number %s",
403 $response_string .= $overlay eq 'no_match' ? ' added to Koha.' : ' overlaid by import.';
404 $response_string .= "\n\n$url";
406 return $self->response( $response_string );
409 return $self->error_response( sprintf( "%s. Please contact administrator.", $error ) );
419 $self->log("Response: $_[0]");