Attachment #170180 for bug #37543

View | Details | Raw Unified | Return to bug 37543
Collapse All | Expand All





use Getopt::Long qw( GetOptions );

my ( $help, $config, $daemon );

GetOptions(
    'config|c=s' => \$config,
    'daemon|d'   => \$daemon,
    'help|?'     => \$help,
);

if ( $help || !$config ) {

exit;

{
package ImportProxyServer;

use Carp qw( croak );
use IO::Socket::INET qw( SOCK_STREAM );
# use IO::Socket::IP;
use IO::Select;
use POSIX;
use HTTP::Status qw( HTTP_FORBIDDEN HTTP_UNAUTHORIZED );
use strict;
use warnings;

    package ImportProxyServer;
use XML::Simple qw( XMLin );
use MARC::Record;
use MARC::File::XML;

    use Carp             qw( croak );
    use IO::Socket::INET qw( SOCK_STREAM );
use constant AUTH_URI       => "/cgi-bin/koha/svc/authentication";
use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib";

    # use IO::Socket::IP;
    use IO::Select;
    use POSIX;
    use HTTP::Status qw( HTTP_FORBIDDEN HTTP_UNAUTHORIZED );
    use strict;
    use warnings;

    use LWP::UserAgent;
    use XML::Simple qw( XMLin );
    use MARC::Record;
    use MARC::File::XML;

    use constant CLIENT_READ_TIMEOUT     => 5;
    use constant CLIENT_READ_BUFFER_SIZE => 100000;
    use constant AUTH_URI                => "/cgi-bin/koha/svc/authentication";
    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;
    while (<$conf_fh>) {
        $line++;
        chomp;
        s/\s*#.*//o; # remove comments
        s/^\s+//o;   # trim leading spaces
        s/\s+$//o;   # trim trailing spaces
        next unless $_;

        my $config_file = $self->{config_file};
        die "Invalid config line $line: $_" unless defined $v;
        $param{$p} = $v;
    }
    close($conf_fh);

    $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";

    if( defined $param{connexion_user} || defined $param{connexion_password}){
        # If either is defined we expect both
        $self->{connexion_user} = delete( $param{connexion_user} )
          or die "No koha connexion_user in config file";
        $self->{connexion_password} = delete( $param{connexion_password} )
          or die "No koha user connexion_password in config file";
    }

        open( my $conf_fh, '<', $config_file ) or die "Cannot open config file $config: $!";
    $self->{port} = delete( $param{port} )
      or die "Port not specified";

        my %param;
        my $line = 0;
        while (<$conf_fh>) {
            $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;
        }
        close($conf_fh);

        $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";

        if ( defined $param{connexion_user} || defined $param{connexion_password} ) {

            # If either is defined we expect both
            $self->{connexion_user} = delete( $param{connexion_user} )
                or die "No koha connexion_user in config file";
            $self->{connexion_password} = delete( $param{connexion_password} )
                or die "No koha user connexion_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 $self = shift;
    my $log_fh = $self->{log_fh}
      or warn "No log fh",
         return;
    my $t = localtime;
    print $log_fh map "$t: $_\n", @_;
}

        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
    $SIG{USR1} = sub { $self->parse_config };

        die "Couldn't fork: $!" unless defined($pid);
}

        POSIX::setsid() or die "Can't start a new session: $!";
    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};
    }

        $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 };
}

        # trap or ignore $SIG{PIPE}
        $SIG{USR1} = sub { $self->parse_config };
    $ua->timeout(10);
    $ua->cookie_jar({});
    return $ua;
}

        $self->run;
    }
    my $ua = $self->{ua};
    my $url = $self->{koha} . AUTH_URI;
    return $ua->get($url)->header('CSRF-TOKEN');
}

    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);
        $self->log("Authentication failed", $resp->request->as_string, $resp->as_string);
        return;
    }
    return $resp->header('CSRF-TOKEN');
}

    sub _ua {
        my $ua = LWP::UserAgent->new;
        $ua->timeout(10);
        $ua->cookie_jar( {} );
        return $ua;
    }

    sub get_current_csrf_token {
        my $self = shift;
        my $ua   = $self->{ua};
        my $url  = $self->{koha} . AUTH_URI;
        return $ua->get($url)->header('CSRF-TOKEN');
    }

    sub authenticate {
        my $self = shift;
        my $ua   = $self->{ua};
        my $url  = $self->{koha} . AUTH_URI;
        my $resp = $ua->post(
            $url,
            {
                login_userid   => $self->{user},
                login_password => $self->{password},
                csrf_token     => $self->get_current_csrf_token,
            }
        );
        if ( !$resp->is_success ) {
            $self->log( "Authentication failed", $resp->request->as_string, $resp->as_string );
            return;
        }
        return $resp->header('CSRF-TOKEN');
    }

    sub read_request {
        my ( $self, $io ) = @_;

        my ( $in, @in_arr, $timeout, $bad_marc );
        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_arr, $1;
                    last;
                }
                push @in_arr, $in;
            } else {
                last;
        $first eq 'P' && do {
            ($password, $data) = _trim_identifier($data);
            next;
        };
        $first eq ' ' && do {
            $data = substr( $data, 1 ); # trim
            next;
        };
        $data =~ m/^[0-9]/ && do {
            # What we have here might be a MARC record...
            my $marc_record;
            eval { $marc_record = MARC::Record->new_from_usmarc($data); };
            if ($@) {
                $bad_marc = 1;
            }
        }

        $in = join '', @in_arr;
        $in =~ m/(.)$/;
        my $lastchar = $1;
        my ( $xml, $user, $password, $local_user );
        my $data = $in;    # copy for diagmostic purposes
        while () {
            my $first = substr( $data, 0, 1 );
            if ( !defined $first ) {
                last;
            }
            $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;
            };
            $data =~ m/^[0-9]/ && do {

                # What we have here might be a MARC record...
                my $marc_record;
                eval { $marc_record = MARC::Record->new_from_usmarc($data); };
                if ($@) {
                    $bad_marc = 1;
                } else {
                    $xml = $marc_record->as_xml();
                }
                last;
            };
            last;    # unexpected input
        }

        my @details;
        push @details, "Timeout"                                                                   if $timeout;
        push @details, "Bad MARC"                                                                  if $bad_marc;
        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;
        push @details, "XML: $xml"                                                                 if $xml;
        push @details, "Remaining data: $data" if ( $data && !$xml );

        unless ($xml) {
            $self->log( "Invalid request", $in, @details );
            return;
        }
        $user = $local_user if !$user && $local_user;

        $self->log( "Request", @details );
        $self->log($in) if $self->{debug};
        return ( $xml, $user, $password );
    }
    $user = $local_user if !$user && $local_user;

    sub _trim_identifier {
    $self->log($in) if $self->{debug};
    return ($xml, $user, $password);
}

        #my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );
        my $len = ord( substr( $_[0], 1, 1 ) ) - 64;
        if ( $len < 0 ) {    #length is numeric, and thus comes from the web client, not the desktop client.
            $_[0] =~ m/.(\d+)/;
            $len = $1;
            return ( substr( $_[0], length($len) + 1, $len ), substr( $_[0], length($len) + 1 + $len ) );
        }
        return ( substr( $_[0], 2, $len ), substr( $_[0], 2 + $len ) );
    }
    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");

        unless ( !( defined $self->{connexion_user} )
            || ( $user eq $self->{connexion_user} && $password eq $self->{connexion_password} ) )
        {
            return $self->error_response("Unauthorized 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 $post_body = {
            'nomatch_action'    => $self->{params}->{nomatch_action},
            'overlay_action'    => $self->{params}->{overlay_action},
            'match'             => $self->{params}->{match},
            'import_mode'       => $self->{params}->{import_mode},
            'framework'         => $self->{params}->{framework},
            'overlay_framework' => $self->{params}->{overlay_framework},
            'item_action'       => $self->{params}->{item_action},
            'xml'               => $data
        };

        # If we have a token, try it, else, authenticate for the first time.
        $self->{csrf_token} = $self->authenticate unless $self->{csrf_token};
        my $resp = $ua->post(
        'overlay_action'    => $self->{params}->{overlay_action},
        'match'             => $self->{params}->{match},
        'import_mode'       => $self->{params}->{import_mode},
        'framework'         => $self->{params}->{framework},
        'overlay_framework' => $self->{params}->{overlay_framework},
        'item_action'       => $self->{params}->{item_action},
        'xml'               => $data
    };

    # If we have a token, try it, else, authenticate for the first time.
    $self->{csrf_token} = $self->authenticate unless $self->{csrf_token};
    my $resp = $ua->post(
        $base_url . IMPORT_SVC_URI,
        $post_body,
        csrf_token => $self->{csrf_token},
    );

    my $status = $resp->code;
    if ( $status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN ) {
        # Our token might have expired. Re-authenticate and post again.
        $self->{csrf_token} = $self->authenticate;
        $resp = $ua->post(
            $base_url . IMPORT_SVC_URI,
            $post_body,
            csrf_token => $self->{csrf_token},
        );

        my $status = $resp->code;
        if ( $status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN ) {

            # Our token might have expired. Re-authenticate and post again.
            $self->{csrf_token} = $self->authenticate;
            $resp = $ua->post(
                $base_url . IMPORT_SVC_URI,
                $post_body,
                csrf_token => $self->{csrf_token},
            );
        }
        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, $overlay, $batch_id, $error, $url );
        if ( my $r = eval { XMLin( $resp->content ) } ) {
            $koha_status = $r->{status};
            $batch_id    = $r->{import_batch_id};
            $error       = $r->{error};
            $bib         = $r->{biblionumber};
            $overlay     = $r->{match_status};
            $url         = $r->{url};
        } else {
            $koha_status = "error";
            $self->log("Response format error:\n$resp->content");
            return $self->error_response("Invalid response");
        }
    }

        if ( $koha_status eq "ok" ) {
            my $response_string = sprintf(
                "Success.  Batch number %s - biblio record number %s",
                $batch_id, $bib
            );
            $response_string .= $overlay eq 'no_match' ? ' added to Koha.' : ' overlaid by import.';
            $response_string .= "\n\n$url";

            return $self->response($response_string);
        }

    return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) );
}

        return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) );
    }
    $self->response(@_);
}

    sub error_response {
        my $self = shift;
        $self->response(@_);
    }
}

    sub response {
        my $self = shift;
        $self->log("Response: $_[0]");
        printf $_[0] . "\0";
    }

}    # package
- 

Return to bug 37543

Lines 22-33 use warnings; Link Here

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