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