Bug 30747: (follup-up) Add missing otherholdings_datelastborrowed column in settings
[koha.git] / misc / bin / connexion_import_daemon.pl
1 #!/usr/bin/perl -w
2
3 # Copyright 2012 CatalystIT
4 #
5 # This file is part of Koha.
6 #
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.
11 #
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.
16 #
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>.
19
20 use strict;
21 use warnings;
22
23 use Getopt::Long qw( GetOptions );
24
25 my ($help, $config, $daemon);
26
27 GetOptions(
28     'config|c=s'    => \$config,
29     'daemon|d'      => \$daemon,
30     'help|?'        => \$help,
31 );
32
33 if($help || !$config){
34     print <<EOF
35 $0 --config=my.conf
36 Parameters :
37   --daemon | -d  - go to background; prints pid to stdout
38   --config | -c  - config file
39   --help   | -?  - this message
40
41 Config file format:
42   Lines of the form:
43   name: value
44
45   # comments are supported
46   No quotes
47
48   Parameter Names:
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
65
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
68
69   All process related parameters (all but ip and port) have default values as
70   per Koha import process.
71 EOF
72 ;
73     exit;
74 }
75
76 my $server = ImportProxyServer->new($config);
77
78 if ($daemon) {
79     print $server->background;
80 } else {
81     $server->run;
82 }
83
84 exit;
85
86 {
87 package ImportProxyServer;
88
89 use Carp qw( croak );
90 use IO::Socket::INET qw( SOCK_STREAM );
91 # use IO::Socket::IP;
92 use IO::Select;
93 use POSIX;
94 use HTTP::Status qw( HTTP_FORBIDDEN HTTP_UNAUTHORIZED );
95 use strict;
96 use warnings;
97
98 use LWP::UserAgent;
99 use XML::Simple qw( XMLin );
100 use MARC::Record;
101 use MARC::File::XML;
102
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";
107
108 sub new {
109     my $class = shift;
110     my $config_file = shift or croak "No config file";
111
112     my $self = {time_to_die => 0, config_file => $config_file };
113     bless $self, $class;
114
115     $self->parse_config;
116     return $self;
117 }
118
119 sub parse_config {
120     my $self = shift;
121
122     my $config_file = $self->{config_file};
123
124     open (my $conf_fh, '<', $config_file) or die "Cannot open config file $config: $!";
125
126     my %param;
127     my $line = 0;
128     while (<$conf_fh>) {
129         $line++;
130         chomp;
131         s/\s*#.*//o; # remove comments
132         s/^\s+//o;   # trim leading spaces
133         s/\s+$//o;   # trim trailing spaces
134         next unless $_;
135
136         my ($p, $v) = m/(\S+?):\s*(.*)/o;
137         die "Invalid config line $line: $_" unless defined $v;
138         $param{$p} = $v;
139     }
140     close($conf_fh);
141
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";
148
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";
155     }
156
157     $self->{host} = delete( $param{host} );
158     $self->{port} = delete( $param{port} )
159       or die "Port not specified";
160
161     $self->{debug} = delete( $param{debug} );
162
163     my $log_fh;
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: $!";
167     } else {
168         $log_fh = \*STDERR;
169     }
170     $self->{log_fh} = $log_fh;
171
172     $self->{params} = \%param;
173 }
174
175 sub log {
176     my $self = shift;
177     my $log_fh = $self->{log_fh}
178       or warn "No log fh",
179          return;
180     my $t = localtime;
181     print $log_fh map "$t: $_\n", @_;
182 }
183
184 sub background {
185     my $self = shift;
186
187     my $pid = fork;
188     return ($pid) if $pid; # parent
189
190     die "Couldn't fork: $!" unless defined($pid);
191
192     POSIX::setsid() or die "Can't start a new session: $!";
193
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 };
197
198     $self->run;
199 }
200
201 sub run {
202     my $self = shift;
203
204     my $server_port = $self->{port};
205     my $server_host = $self->{host};
206
207     my $server = IO::Socket::INET->new(
208         LocalHost => $server_host,
209         LocalPort => $server_port,
210         Type      => SOCK_STREAM,
211         Proto     => "tcp",
212         Listen    => 12,
213         Blocking  => 1,
214         ReuseAddr => 1,
215     ) or die "Couldn't be a tcp server on port $server_port: $! $@";
216
217     $self->log("Started tcp listener on $server_host:$server_port");
218
219     $self->{ua} = _ua();
220
221     while ("FOREVER") {
222         my $client = $server->accept()
223           or die "Cannot accept: $!";
224         my $oldfh = select($client);
225         $self->handle_request($client);
226         select($oldfh);
227         last if $self->{time_to_die};
228     }
229
230     close($server);
231 }
232
233 sub _ua {
234     my $ua = LWP::UserAgent->new;
235     $ua->timeout(10);
236     $ua->cookie_jar({});
237     return $ua;
238 }
239
240 sub read_request {
241     my ( $self, $io ) = @_;
242
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);
248             last unless $in;
249
250             # XXX ignore after NULL
251             if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
252                 push @in_arr, $1;
253                 last;
254             }
255             push @in_arr, $in;
256         }
257         else {
258             last;
259         }
260     }
261
262     $in = join '', @in_arr;
263     $in =~ m/(.)$/;
264     my $lastchar = $1;
265     my ($xml, $user, $password, $local_user);
266     my $data = $in; # copy for diagmostic purposes
267     while () {
268         my $first = substr( $data, 0, 1 );
269         if (!defined $first) {
270            last;
271         }
272         $first eq 'U' && do {
273             ($user, $data) = _trim_identifier($data);
274             next;
275         };
276         $first eq 'A' && do {
277             ($local_user, $data) = _trim_identifier($data);
278             next;
279         };
280         $first eq 'P' && do {
281             ($password, $data) = _trim_identifier($data);
282             next;
283         };
284         $first eq ' ' && do {
285             $data = substr( $data, 1 ); # trim
286             next;
287         };
288         $data =~ m/^[0-9]/ && do {
289             # What we have here might be a MARC record...
290             my $marc_record;
291             eval { $marc_record = MARC::Record->new_from_usmarc($data); };
292             if ($@) {
293                 $bad_marc = 1;
294             }
295             else {
296                $xml = $marc_record->as_xml();
297             }
298             last;
299         };
300         last; # unexpected input
301     }
302
303     my @details;
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);
311     unless ($xml) {
312         $self->log("Invalid request", $in, @details);
313         return;
314     }
315     $user = $local_user if !$user && $local_user;
316
317     $self->log("Request", @details);
318     $self->log($in) if $self->{debug};
319     return ($xml, $user, $password);
320 }
321
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.
326        $_[0] =~ m/.(\d+)/;
327        $len = $1;
328        return ( substr( $_[0], length($len)+1 , $len ), substr( $_[0], length($len) + 1 + $len ) );
329     }
330     return ( substr( $_[0], 2 , $len ), substr( $_[0], 2 + $len ) );
331 }
332
333 sub handle_request {
334     my ( $self, $io ) = @_;
335     my ($data, $user, $password) = $self->read_request($io)
336       or return $self->error_response("Bad request");
337
338     unless(
339         !(defined $self->{connexion_user}) ||
340         ($user eq $self->{connexion_user} && $password eq $self->{connexion_password})
341     ){
342        return $self->error_response("Unauthorized request");
343     }
344
345     my $ua;
346     if ($self->{user}) {
347         $user = $self->{user};
348         $password = $self->{password};
349         $ua = $self->{ua};
350     }
351     else {
352         $ua  = _ua(); # fresh one, needs to authenticate
353     }
354
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},
363                                'xml'            => $data});
364
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},
377                                'xml'            => $data})
378           if $resp->is_success;
379     }
380     unless ($resp->is_success) {
381         $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
382         return $self->error_response("Unsuccessful request");
383     }
384
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};
392         $url         = $r->{url};
393     }
394     else {
395         $koha_status = "error";
396         $self->log("Response format error:\n$resp->content");
397         return $self->error_response("Invalid response");
398     }
399
400     if ($koha_status eq "ok") {
401         my $response_string = sprintf( "Success.  Batch number %s - biblio record number %s",
402                                         $batch_id,$bib);
403         $response_string .= $overlay eq 'no_match' ? ' added to Koha.' : ' overlaid by import.';
404         $response_string .= "\n\n$url";
405
406         return $self->response( $response_string );
407     }
408
409     return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) );
410 }
411
412 sub error_response {
413     my $self = shift;
414     $self->response(@_);
415 }
416
417 sub response {
418     my $self = shift;
419     $self->log("Response: $_[0]");
420     printf $_[0] . "\0";
421 }
422
423
424 } # package