+#!/usr/bin/perl -w
+
+# Copyright 2012 CatalystIT
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with Koha; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+
+my ($help, $config, $daemon);
+
+GetOptions(
+ 'config|c=s' => \$config,
+ 'daemon|d' => \$daemon,
+ 'help|?' => \$help,
+);
+
+if($help || !$config){
+ print <<EOF
+$0 --config=my.conf
+Parameters :
+ --daemon | -d - go to background; prints pid to stdout
+ --config | -c - config file
+ --help | -? - this message
+
+Config file format:
+ Lines of the form:
+ name: value
+
+ # comments are supported
+ No quotes
+
+ Parameter Names:
+ host - ip address or hostname to bind to, defaults all available
+ port - port to bind to, mandatory
+ log - log file path, stderr if omitted
+ debug - dumps requests to the log file, passwords inclusive
+ koha - koha intranet base url, eg http://librarian.koha
+ user - koha user, authentication
+ password - koha user password, authentication
+ match - marc_matchers.code: ISBN or ISSN
+ overlay_action - import_batches.overlay_action: replace, create_new or ignore
+ nomatch_action - import_batches.nomatch_action: create_new or ignore
+ item_action - import_batches.item_action: always_add,
+ add_only_for_matches, add_only_for_new or ignore
+ import_mode - stage or direct
+ framework - to be used if import_mode is direct
+
+ All process related parameters (all but ip and port) have default values as
+ per Koha import process.
+EOF
+;
+ exit;
+}
+
+my $server = ImportProxyServer->new($config);
+
+if ($daemon) {
+ print $server->background;
+} else {
+ $server->run;
+}
+
+exit;
+
+{
+package ImportProxyServer;
+
+use Carp;
+use IO::Socket::INET;
+# use IO::Socket::IP;
+use IO::Select;
+use POSIX;
+use HTTP::Status qw(:constants);
+
+use LWP::UserAgent;
+use XML::Simple;
+
+use constant CLIENT_READ_TIMEOUT => 5;
+use constant CLIENT_READ_BUFFER_SIZE => 4 * 1024;
+use constant AUTH_URI => "/cgi-bin/koha/mainpage.pl";
+use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib";
+
+sub new {
+ my $class = shift;
+ my $config_file = shift or croak "No config file";
+
+ my $self = {time_to_die => 0, config_file => $config_file };
+ bless $self, $class;
+
+ $self->parse_config;
+ return $self;
+}
+
+sub parse_config {
+ my $self = shift;
+
+ my $config_file = $self->{config_file};
+
+ open CONF, $config_file or die "Cannot open config file $config: $!";
+
+ my %param;
+ my $line = 0;
+ while (<CONF>) {
+ $line++;
+ chomp;
+ s/\s*#.*//o; # remove comments
+ s/^\s+//o; # trim leading spaces
+ s/\s+$//o; # trim trailing spaces
+ next unless $_;
+
+ my ($p, $v) = m/(\S+?):\s*(.*)/o;
+ die "Invalid config line $line: $_" unless defined $v;
+ $param{$p} = $v;
+ }
+
+ $self->{koha} = delete( $param{koha} )
+ or die "No koha base url in config file";
+ $self->{user} = delete( $param{user} )
+ or die "No koha user in config file";
+ $self->{password} = delete( $param{password} )
+ or die "No koha user password in config file";
+
+ $self->{host} = delete( $param{host} );
+ $self->{port} = delete( $param{port} )
+ or die "Port not specified";
+
+ $self->{debug} = delete( $param{debug} );
+
+ my $log_fh;
+ close $self->{log_fh} if $self->{log_fh};
+ if (my $logfile = delete $param{log}) {
+ open $log_fh, ">>$logfile" or die "Cannot open $logfile for write: $!";
+ } else {
+ $log_fh = \*STDERR;
+ }
+ $self->{log_fh} = $log_fh;
+
+ $self->{params} = \%param;
+}
+
+sub log {
+ my $self = shift;
+ my $log_fh = $self->{log_fh}
+ or warn "No log fh",
+ return;
+ my $t = localtime;
+ print $log_fh map "$t: $_\n", @_;
+}
+
+sub background {
+ my $self = shift;
+
+ my $pid = fork;
+ return ($pid) if $pid; # parent
+
+ die "Couldn't fork: $!" unless defined($pid);
+
+ POSIX::setsid() or die "Can't start a new session: $!";
+
+ $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 };
+ # trap or ignore $SIG{PIPE}
+ $SIG{USR1} = sub { $self->parse_config };
+
+ $self->run;
+}
+
+sub run {
+ my $self = shift;
+
+ my $server_port = $self->{port};
+ my $server_host = $self->{host};
+
+ my $server = IO::Socket::INET->new(
+ LocalHost => $server_host,
+ LocalPort => $server_port,
+ Type => SOCK_STREAM,
+ Proto => "tcp",
+ Listen => 12,
+ Blocking => 1,
+ ReuseAddr => 1,
+ ) or die "Couldn't be a tcp server on port $server_port: $! $@";
+
+ $self->log("Started tcp listener on $server_host:$server_port");
+
+ $self->{ua} = _ua();
+
+ while ("FOREVER") {
+ my $client = $server->accept()
+ or die "Cannot accept: $!";
+ my $oldfh = select($client);
+ $self->handle_request($client);
+ select($oldfh);
+ last if $self->{time_to_die};
+ }
+
+ close($server);
+}
+
+sub _ua {
+ my $ua = LWP::UserAgent->new;
+ $ua->timeout(10);
+ $ua->cookie_jar({});
+ return $ua;
+}
+
+sub read_request {
+ my ( $self, $io ) = @_;
+
+ my ($in, @in, $timeout);
+ my $select = IO::Select->new($io) ;
+ while ( "FOREVER" ) {
+ if ( $select->can_read(CLIENT_READ_TIMEOUT) ){
+ $io->recv($in, CLIENT_READ_BUFFER_SIZE);
+ last unless $in;
+
+ # XXX ignore after NULL
+ if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
+ push @in, $1;
+ last;
+ }
+ push @in, $in;
+ }
+ else {
+ $timeout = 1;
+ last;
+ }
+ }
+
+ $in = join '', @in;
+
+ my ($xml, $user, $password, $local_user);
+ my $data = $in; # copy for diagmostic purposes
+ while ( my $first = substr( $data, 0, 1 ) ) {
+ $first eq 'U' && do {
+ ($user, $data) = _trim_identifier($data);
+ next;
+ };
+ $first eq 'A' && do {
+ ($local_user, $data) = _trim_identifier($data);
+ next;
+ };
+ $first eq 'P' && do {
+ ($password,, $data) = _trim_identifier($data);
+ next;
+ };
+ $first eq ' ' && do {
+ $data = substr( $data, 1 ); # trim
+ next;
+ };
+ $first eq '<' && do {
+ $xml = $data;
+ last;
+ };
+
+ last; # unexpected input
+ }
+
+ my @details;
+ push @details, "Timeout" if $timeout;
+ push @details, "User: $user" if $user;
+ push @details, "Password: " . ( $self->{debug} ? $password : ("x" x length($password)) ) if $password;
+ push @details, "Local user: $local_user" if $local_user;
+ unless ($xml) {
+ $self->log("Invalid request", $in, @details);
+ return;
+ }
+
+ $self->log("Request", @details);
+ $self->log($in) if $self->{debug};
+ return ($xml, $user, $password);
+}
+
+sub _trim_identifier {
+ my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );
+
+ return ( substr( $_[0], 2, $len ), substr( $_[0], 2 + $len ) );
+}
+
+sub handle_request {
+ my ( $self, $io ) = @_;
+
+ my ($data, $user, $password) = $self->read_request($io)
+ or return $self->error_response("Bad request");
+
+ my $ua;
+ if ($self->{user}) {
+ $user = $self->{user};
+ $password = $self->{password};
+ $ua = $self->{ua};
+ }
+ else {
+ $ua = _ua(); # fresh one, needs to authenticate
+ }
+
+ my $base_url = $self->{koha};
+ my $resp = $ua->post( $base_url.IMPORT_SVC_URI, $self->{params}, 'Content-Type' => 'text/plain', Content => $data );
+ my $status = $resp->code;
+ if ($status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN) {
+ my $user = $self->{user};
+ my $password = $self->{password};
+ $resp = $ua->post( $base_url.AUTH_URI, { userid => $user, password => $password } );
+ $resp = $ua->post( $base_url.IMPORT_SVC_URI, $self->{params}, 'Content-Type' => 'text/plain', Content => $data )
+ if $resp->is_success;
+ }
+ unless ($resp->is_success) {
+ $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
+ return $self->error_response("Unsuccessful request");
+ }
+
+ my ($koha_status, $bib, $batch_id, $error);
+ if ( my $r = eval { XMLin($resp->content) } ) {
+ $koha_status = $r->{status};
+ $batch_id = $r->{import_batch_id};
+ $error = $r->{error};
+ }
+ else {
+ $koha_status = "error";
+ $self->log("Response format error:\n$resp->content");
+ return $self->error_response("Invalid response");
+ }
+
+ if ($koha_status eq "ok") {
+ return $self->response( sprintf( "Success. Import batch id: %s", $batch_id ) );
+ }
+
+ return $self->error_response( sprintf( "%s. Please contact administrator.", $error ) );
+}
+
+sub error_response {
+ my $self = shift;
+ $self->response(@_);
+}
+
+sub response {
+ my $self = shift;
+ $self->log("Response: $_[0]");
+ printf $_[0] . "\0";
+}
+
+
+} # package