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;
  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 use strict;
  91 use warnings;
  92
  93 use LWP::UserAgent;
  94 use XML::Simple;
  95 use MARC::Record;
  96 use MARC::File::XML;
  97
  98 use constant CLIENT_READ_TIMEOUT     => 5;
  99 use constant CLIENT_READ_BUFFER_SIZE => 100000;
 100 use constant AUTH_URI       => "/cgi-bin/koha/mainpage.pl";
 101 use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib";
 102
 103 sub new {
 104     my $class = shift;
 105     my $config_file = shift or croak "No config file";
 106
 107     my $self = {time_to_die => 0, config_file => $config_file };
 108     bless $self, $class;
 109
 110     $self->parse_config;
 111     return $self;
 112 }
 113
 114 sub parse_config {
 115     my $self = shift;
 116
 117     my $config_file = $self->{config_file};
 118
 119     open (my $conf_fh, '<', $config_file) or die "Cannot open config file $config: $!";
 120
 121     my %param;
 122     my $line = 0;
 123     while (<$conf_fh>) {
 124         $line++;
 125         chomp;
 126         s/\s*#.*//o; # remove comments
 127         s/^\s+//o;   # trim leading spaces
 128         s/\s+$//o;   # trim trailing spaces
 129         next unless $_;
 130
 131         my ($p, $v) = m/(\S+?):\s*(.*)/o;
 132         die "Invalid config line $line: $_" unless defined $v;
 133         $param{$p} = $v;
 134     }
 135
 136     $self->{koha} = delete( $param{koha} )
 137       or die "No koha base url in config file";
 138     $self->{user} = delete( $param{user} )
 139       or die "No koha user in config file";
 140     $self->{password} = delete( $param{password} )
 141       or die "No koha user password in config file";
 142
 143     $self->{host} = delete( $param{host} );
 144     $self->{port} = delete( $param{port} )
 145       or die "Port not specified";
 146
 147     $self->{debug} = delete( $param{debug} );
 148
 149     my $log_fh;
 150     close $self->{log_fh} if $self->{log_fh};
 151     if (my $logfile = delete $param{log}) {
 152         open ($log_fh, '>>', $logfile) or die "Cannot open $logfile for write: $!";
 153     } else {
 154         $log_fh = \*STDERR;
 155     }
 156     $self->{log_fh} = $log_fh;
 157
 158     $self->{params} = \%param;
 159 }
 160
 161 sub log {
 162     my $self = shift;
 163     my $log_fh = $self->{log_fh}
 164       or warn "No log fh",
 165          return;
 166     my $t = localtime;
 167     print $log_fh map "$t: $_\n", @_;
 168 }
 169
 170 sub background {
 171     my $self = shift;
 172
 173     my $pid = fork;
 174     return ($pid) if $pid; # parent
 175
 176     die "Couldn't fork: $!" unless defined($pid);
 177
 178     POSIX::setsid() or die "Can't start a new session: $!";
 179
 180     $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 };
 181     # trap or ignore $SIG{PIPE}
 182     $SIG{USR1} = sub { $self->parse_config };
 183
 184     $self->run;
 185 }
 186
 187 sub run {
 188     my $self = shift;
 189
 190     my $server_port = $self->{port};
 191     my $server_host = $self->{host};
 192
 193     my $server = IO::Socket::INET->new(
 194         LocalHost => $server_host,
 195         LocalPort => $server_port,
 196         Type      => SOCK_STREAM,
 197         Proto     => "tcp",
 198         Listen    => 12,
 199         Blocking  => 1,
 200         ReuseAddr => 1,
 201     ) or die "Couldn't be a tcp server on port $server_port: $! $@";
 202
 203     $self->log("Started tcp listener on $server_host:$server_port");
 204
 205     $self->{ua} = _ua();
 206
 207     while ("FOREVER") {
 208         my $client = $server->accept()
 209           or die "Cannot accept: $!";
 210         my $oldfh = select($client);
 211         $self->handle_request($client);
 212         select($oldfh);
 213         last if $self->{time_to_die};
 214     }
 215
 216     close($server);
 217 }
 218
 219 sub _ua {
 220     my $ua = LWP::UserAgent->new;
 221     $ua->timeout(10);
 222     $ua->cookie_jar({});
 223     return $ua;
 224 }
 225
 226 sub read_request {
 227     my ( $self, $io ) = @_;
 228
 229     my ($in, @in_arr, $timeout, $bad_marc);
 230     my $select = IO::Select->new($io) ;
 231     while ( "FOREVER" ) {
 232         if ( $select->can_read(CLIENT_READ_TIMEOUT) ){
 233             $io->recv($in, CLIENT_READ_BUFFER_SIZE);
 234             last unless $in;
 235
 236             # XXX ignore after NULL
 237             if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
 238                 push @in_arr, $1;
 239                 last;
 240             }
 241             push @in_arr, $in;
 242         }
 243         else {
 244             last;
 245         }
 246     }
 247
 248     $in = join '', @in_arr;
 249
 250     $in =~ m/(.)$/;
 251     my $lastchar = $1;
 252     my ($xml, $user, $password, $local_user);
 253     my $data = $in; # copy for diagmostic purposes
 254     while () {
 255         my $first = substr( $data, 0, 1 );
 256         if (!defined $first) {
 257            last;
 258         }
 259         $first eq 'U' && do {
 260             ($user, $data) = _trim_identifier($data);
 261             next;
 262         };
 263         $first eq 'A' && do {
 264             ($local_user, $data) = _trim_identifier($data);
 265             next;
 266         };
 267         $first eq 'P' && do {
 268             ($password, $data) = _trim_identifier($data);
 269             next;
 270         };
 271         $first eq ' ' && do {
 272             $data = substr( $data, 1 ); # trim
 273             next;
 274         };
 275         $data =~ m/^[0-9]/ && do {
 276             # What we have here might be a MARC record...
 277             my $marc_record;
 278             eval { $marc_record = MARC::Record->new_from_usmarc($data); };
 279             if ($@) {
 280                 $bad_marc = 1;
 281             }
 282             else {
 283                $xml = $marc_record->as_xml();
 284             }
 285             last;
 286         };
 287         last; # unexpected input
 288     }
 289
 290     my @details;
 291     push @details, "Timeout" if $timeout;
 292     push @details, "Bad MARC" if $bad_marc;
 293     push @details, "User: $user" if $user;
 294     push @details, "Password: " . ( $self->{debug} ? $password : ("x" x length($password)) ) if $password;
 295     push @details, "Local user: $local_user" if $local_user;
 296     push @details, "XML: $xml" if $xml;
 297     push @details, "Remaining data: $data" if ($data && !$xml);
 298     unless ($xml) {
 299         $self->log("Invalid request", $in, @details);
 300         return;
 301     }
 302
 303     $self->log("Request", @details);
 304     $self->log($in) if $self->{debug};
 305     return ($xml, $user, $password);
 306 }
 307
 308 sub _trim_identifier {
 309     #my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );
 310     my $len=ord(substr ($_[0], 1, 1)) - 64;
 311     if ($len <0) {  #length is numeric, and thus comes from the web client, not the desktop client.
 312        $_[0] =~ m/.(\d+)/;
 313        $len = $1;
 314        return ( substr( $_[0], length($len)+1 , $len ), substr( $_[0], length($len) + 1 + $len ) );
 315     }
 316     return ( substr( $_[0], 2 , $len ), substr( $_[0], 2 + $len ) );
 317 }
 318
 319 sub handle_request {
 320     my ( $self, $io ) = @_;
 321
 322     my ($data, $user, $password) = $self->read_request($io)
 323       or return $self->error_response("Bad request");
 324
 325     my $ua;
 326     if ($self->{user}) {
 327         $user = $self->{user};
 328         $password = $self->{password};
 329         $ua = $self->{ua};
 330     }
 331     else {
 332         $ua  = _ua(); # fresh one, needs to authenticate
 333     }
 334
 335     my $base_url = $self->{koha};
 336     my $resp = $ua->post( $base_url.IMPORT_SVC_URI,
 337                               {'nomatch_action' => $self->{params}->{nomatch_action},
 338                                'overlay_action' => $self->{params}->{overlay_action},
 339                                'match'          => $self->{params}->{match},
 340                                'import_mode'    => $self->{params}->{import_mode},
 341                                'framework'      => $self->{params}->{framework},
 342                                'item_action'    => $self->{params}->{item_action},
 343                                'xml'            => $data});
 344
 345     my $status = $resp->code;
 346     if ($status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN) {
 347         my $user = $self->{user};
 348         my $password = $self->{password};
 349         $resp = $ua->post( $base_url.AUTH_URI, { userid => $user, password => $password } );
 350         $resp = $ua->post( $base_url.IMPORT_SVC_URI,
 351                               {'nomatch_action' => $self->{params}->{nomatch_action},
 352                                'overlay_action' => $self->{params}->{overlay_action},
 353                                'match'          => $self->{params}->{match},
 354                                'import_mode'    => $self->{params}->{import_mode},
 355                                'framework'      => $self->{params}->{framework},
 356                                'item_action'    => $self->{params}->{item_action},
 357                                'xml'            => $data})
 358           if $resp->is_success;
 359     }
 360     unless ($resp->is_success) {
 361         $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
 362         return $self->error_response("Unsuccessful request");
 363     }
 364
 365     my ($koha_status, $bib, $overlay, $batch_id, $error, $url);
 366     if ( my $r = eval { XMLin($resp->content) } ) {
 367         $koha_status = $r->{status};
 368         $batch_id    = $r->{import_batch_id};
 369         $error       = $r->{error};
 370         $bib         = $r->{biblionumber};
 371         $overlay     = $r->{match_status};
 372         $url         = $r->{url};
 373     }
 374     else {
 375         $koha_status = "error";
 376         $self->log("Response format error:\n$resp->content");
 377         return $self->error_response("Invalid response");
 378     }
 379
 380     if ($koha_status eq "ok") {
 381         my $response_string = sprintf( "Success.  Batch number %s - biblio record number %s",
 382                                         $batch_id,$bib);
 383         $response_string .= $overlay eq 'no_match' ? ' added to Koha.' : ' overlaid by import.';
 384         $response_string .= "\n\n$url";
 385
 386         return $self->response( $response_string );
 387     }
 388
 389     return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) );
 390 }
 391
 392 sub error_response {
 393     my $self = shift;
 394     $self->response(@_);
 395 }
 396
 397 sub response {
 398     my $self = shift;
 399     $self->log("Response: $_[0]");
 400     printf $_[0] . "\0";
 401 }
 402
 403
 404 } # package