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 (my $conf_fh, '<', $config_file) or die "Cannot open config file $config: $!";
 116
 117     my %param;
 118     my $line = 0;
 119     while (<$conf_fh>) {
 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