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