bug_7613: OCLC Connexion gateway
[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 under the
8 # terms of the GNU General Public License as published by the Free Software
9 # Foundation; either version 2 of the License, or (at your option) any later
10 # version.
11 #
12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
15 #
16 # You should have received a copy of the GNU General Public License along
17 # with Koha; if not, write to the Free Software Foundation, Inc.,
18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20 use strict;
21 use warnings;
22
23 use Getopt::Long;
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
64   All process related parameters (all but ip and port) have default values as
65   per Koha import process.
66 EOF
67 ;
68     exit;
69 }
70
71 my $server = ImportProxyServer->new($config);
72
73 if ($daemon) {
74     print $server->background;
75 } else {
76     $server->run;
77 }
78
79 exit;
80
81 {
82 package ImportProxyServer;
83
84 use Carp;
85 use IO::Socket::INET;
86 # use IO::Socket::IP;
87 use IO::Select;
88 use POSIX;
89 use HTTP::Status qw(:constants);
90
91 use LWP::UserAgent;
92 use XML::Simple;
93
94 use constant CLIENT_READ_TIMEOUT     => 5;
95 use constant CLIENT_READ_BUFFER_SIZE => 4 * 1024;
96 use constant AUTH_URI       => "/cgi-bin/koha/mainpage.pl";
97 use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib";
98
99 sub new {
100     my $class = shift;
101     my $config_file = shift or croak "No config file";
102
103     my $self = {time_to_die => 0, config_file => $config_file };
104     bless $self, $class;
105
106     $self->parse_config;
107     return $self;
108 }
109
110 sub parse_config {
111     my $self = shift;
112
113     my $config_file = $self->{config_file};
114
115     open CONF, $config_file or die "Cannot open config file $config: $!";
116
117     my %param;
118     my $line = 0;
119     while (<CONF>) {
120         $line++;
121         chomp;
122         s/\s*#.*//o; # remove comments
123         s/^\s+//o;   # trim leading spaces
124         s/\s+$//o;   # trim trailing spaces
125         next unless $_;
126
127         my ($p, $v) = m/(\S+?):\s*(.*)/o;
128         die "Invalid config line $line: $_" unless defined $v;
129         $param{$p} = $v;
130     }
131
132     $self->{koha} = delete( $param{koha} )
133       or die "No koha base url in config file";
134     $self->{user} = delete( $param{user} )
135       or die "No koha user in config file";
136     $self->{password} = delete( $param{password} )
137       or die "No koha user password in config file";
138
139     $self->{host} = delete( $param{host} );
140     $self->{port} = delete( $param{port} )
141       or die "Port not specified";
142
143     $self->{debug} = delete( $param{debug} );
144
145     my $log_fh;
146     close $self->{log_fh} if $self->{log_fh};
147     if (my $logfile = delete $param{log}) {
148         open $log_fh, ">>$logfile" or die "Cannot open $logfile for write: $!";
149     } else {
150         $log_fh = \*STDERR;
151     }
152     $self->{log_fh} = $log_fh;
153
154     $self->{params} = \%param;
155 }
156
157 sub log {
158     my $self = shift;
159     my $log_fh = $self->{log_fh}
160       or warn "No log fh",
161          return;
162     my $t = localtime;
163     print $log_fh map "$t: $_\n", @_;
164 }
165
166 sub background {
167     my $self = shift;
168
169     my $pid = fork;
170     return ($pid) if $pid; # parent
171
172     die "Couldn't fork: $!" unless defined($pid);
173
174     POSIX::setsid() or die "Can't start a new session: $!";
175
176     $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 };
177     # trap or ignore $SIG{PIPE}
178     $SIG{USR1} = sub { $self->parse_config };
179
180     $self->run;
181 }
182
183 sub run {
184     my $self = shift;
185
186     my $server_port = $self->{port};
187     my $server_host = $self->{host};
188
189     my $server = IO::Socket::INET->new(
190         LocalHost => $server_host,
191         LocalPort => $server_port,
192         Type      => SOCK_STREAM,
193         Proto     => "tcp",
194         Listen    => 12,
195         Blocking  => 1,
196         ReuseAddr => 1,
197     ) or die "Couldn't be a tcp server on port $server_port: $! $@";
198
199     $self->log("Started tcp listener on $server_host:$server_port");
200
201     $self->{ua} = _ua();
202
203     while ("FOREVER") {
204         my $client = $server->accept()
205           or die "Cannot accept: $!";
206         my $oldfh = select($client);
207         $self->handle_request($client);
208         select($oldfh);
209         last if $self->{time_to_die};
210     }
211
212     close($server);
213 }
214
215 sub _ua {
216     my $ua = LWP::UserAgent->new;
217     $ua->timeout(10);
218     $ua->cookie_jar({});
219     return $ua;
220 }
221
222 sub read_request {
223     my ( $self, $io ) = @_;
224
225     my ($in, @in, $timeout);
226     my $select = IO::Select->new($io) ;
227     while ( "FOREVER" ) {
228         if ( $select->can_read(CLIENT_READ_TIMEOUT) ){
229             $io->recv($in, CLIENT_READ_BUFFER_SIZE);
230             last unless $in;
231
232             # XXX ignore after NULL
233             if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
234                 push @in, $1;
235                 last;
236             }
237             push @in, $in;
238         }
239         else {
240             $timeout = 1;
241             last;
242         }
243     }
244
245     $in = join '', @in;
246
247     my ($xml, $user, $password, $local_user);
248     my $data = $in; # copy for diagmostic purposes
249     while ( my $first = substr( $data, 0, 1 ) ) {
250         $first eq 'U' && do {
251             ($user, $data) = _trim_identifier($data);
252             next;
253         };
254         $first eq 'A' && do {
255             ($local_user, $data) = _trim_identifier($data);
256             next;
257         };
258         $first eq 'P' && do {
259             ($password,, $data) = _trim_identifier($data);
260             next;
261         };
262         $first eq ' ' && do {
263             $data = substr( $data, 1 ); # trim
264             next;
265         };
266         $first eq '<' && do {
267             $xml = $data;
268             last;
269         };
270
271         last; # unexpected input
272     }
273
274     my @details;
275     push @details, "Timeout" if $timeout;
276     push @details, "User: $user" if $user;
277     push @details, "Password: " . ( $self->{debug} ? $password : ("x" x length($password)) ) if $password;
278     push @details, "Local user: $local_user" if $local_user;
279     unless ($xml) {
280         $self->log("Invalid request", $in, @details);
281         return;
282     }
283
284     $self->log("Request", @details);
285     $self->log($in) if $self->{debug};
286     return ($xml, $user, $password);
287 }
288
289 sub _trim_identifier {
290     my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );
291
292     return ( substr( $_[0], 2, $len ), substr( $_[0], 2 + $len ) );
293 }
294
295 sub handle_request {
296     my ( $self, $io ) = @_;
297
298     my ($data, $user, $password) = $self->read_request($io)
299       or return $self->error_response("Bad request");
300
301     my $ua;
302     if ($self->{user}) {
303         $user = $self->{user};
304         $password = $self->{password};
305         $ua = $self->{ua};
306     }
307     else {
308         $ua  = _ua(); # fresh one, needs to authenticate
309     }
310
311     my $base_url = $self->{koha};
312     my $resp = $ua->post( $base_url.IMPORT_SVC_URI, $self->{params}, 'Content-Type' => 'text/plain', Content => $data );
313     my $status = $resp->code;
314     if ($status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN) {
315         my $user = $self->{user};
316         my $password = $self->{password};
317         $resp = $ua->post( $base_url.AUTH_URI, { userid => $user, password => $password } );
318         $resp = $ua->post( $base_url.IMPORT_SVC_URI, $self->{params}, 'Content-Type' => 'text/plain', Content => $data )
319           if $resp->is_success;
320     }
321     unless ($resp->is_success) {
322         $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
323         return $self->error_response("Unsuccessful request");
324     }
325
326     my ($koha_status, $bib, $batch_id, $error);
327     if ( my $r = eval { XMLin($resp->content) } ) {
328         $koha_status = $r->{status};
329         $batch_id    = $r->{import_batch_id};
330         $error       = $r->{error};
331     }
332     else {
333         $koha_status = "error";
334         $self->log("Response format error:\n$resp->content");
335         return $self->error_response("Invalid response");
336     }
337
338     if ($koha_status eq "ok") {
339         return $self->response( sprintf( "Success. Import batch id: %s", $batch_id ) );
340     }
341
342     return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) );
343 }
344
345 sub error_response {
346     my $self = shift;
347     $self->response(@_);
348 }
349
350 sub response {
351     my $self = shift;
352     $self->log("Response: $_[0]");
353     printf $_[0] . "\0";
354 }
355
356
357 } # package