3 # Copyright 2012 CatalystIT
5 # This file is part of Koha.
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
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.
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.
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
64 All process related parameters (all but ip and port) have default values as
65 per Koha import process.
71 my $server = ImportProxyServer
->new($config);
74 print $server->background;
82 package ImportProxyServer
;
89 use HTTP
::Status
qw(:constants);
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";
101 my $config_file = shift or croak
"No config file";
103 my $self = {time_to_die
=> 0, config_file
=> $config_file };
113 my $config_file = $self->{config_file
};
115 open (my $conf_fh, '<', $config_file) or die "Cannot open config file $config: $!";
122 s/\s*#.*//o; # remove comments
123 s/^\s+//o; # trim leading spaces
124 s/\s+$//o; # trim trailing spaces
127 my ($p, $v) = m/(\S+?):\s*(.*)/o;
128 die "Invalid config line $line: $_" unless defined $v;
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";
139 $self->{host
} = delete( $param{host
} );
140 $self->{port
} = delete( $param{port
} )
141 or die "Port not specified";
143 $self->{debug
} = delete( $param{debug
} );
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: $!";
152 $self->{log_fh
} = $log_fh;
154 $self->{params
} = \
%param;
159 my $log_fh = $self->{log_fh
}
163 print $log_fh map "$t: $_\n", @_;
170 return ($pid) if $pid; # parent
172 die "Couldn't fork: $!" unless defined($pid);
174 POSIX
::setsid
() or die "Can't start a new session: $!";
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 };
186 my $server_port = $self->{port
};
187 my $server_host = $self->{host
};
189 my $server = IO
::Socket
::INET
->new(
190 LocalHost
=> $server_host,
191 LocalPort
=> $server_port,
197 ) or die "Couldn't be a tcp server on port $server_port: $! $@";
199 $self->log("Started tcp listener on $server_host:$server_port");
204 my $client = $server->accept()
205 or die "Cannot accept: $!";
206 my $oldfh = select($client);
207 $self->handle_request($client);
209 last if $self->{time_to_die
};
216 my $ua = LWP
::UserAgent
->new;
223 my ( $self, $io ) = @_;
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
);
232 # XXX ignore after NULL
233 if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
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);
254 $first eq 'A' && do {
255 ($local_user, $data) = _trim_identifier
($data);
258 $first eq 'P' && do {
259 ($password,, $data) = _trim_identifier
($data);
262 $first eq ' ' && do {
263 $data = substr( $data, 1 ); # trim
266 $first eq '<' && do {
271 last; # unexpected input
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;
280 $self->log("Invalid request", $in, @details);
284 $self->log("Request", @details);
285 $self->log($in) if $self->{debug
};
286 return ($xml, $user, $password);
289 sub _trim_identifier
{
290 my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );
292 return ( substr( $_[0], 2, $len ), substr( $_[0], 2 + $len ) );
296 my ( $self, $io ) = @_;
298 my ($data, $user, $password) = $self->read_request($io)
299 or return $self->error_response("Bad request");
303 $user = $self->{user
};
304 $password = $self->{password
};
308 $ua = _ua
(); # fresh one, needs to authenticate
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;
321 unless ($resp->is_success) {
322 $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
323 return $self->error_response("Unsuccessful request");
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
};
333 $koha_status = "error";
334 $self->log("Response format error:\n$resp->content");
335 return $self->error_response("Invalid response");
338 if ($koha_status eq "ok") {
339 return $self->response( sprintf( "Success. Import batch id: %s", $batch_id ) );
342 return $self->error_response( sprintf( "%s. Please contact administrator.", $error ) );
352 $self->log("Response: $_[0]");