From 7093c7062a9ad5950d304f44cfe1067476cbba10 Mon Sep 17 00:00:00 2001 From: Robin Sheat Date: Tue, 9 Dec 2014 15:49:45 +1300 Subject: [PATCH] Bug 13607: patron management API This provides a patron management API. It allows a remote service to: * add patrons * update patron details * delete patrons It presents a simple POST-based API and returns its results as XML. This API supports fields available in the borrower table, and extended attribute types also. Full documentation will be on a wiki page linked to from the bug. To test: * construct a sequence of API requests, make sure it works. * ensure that no side effects of these changes came about, particularly dealing with unrelated things (default_messageprefs.pl, sco-patron-image.pl, systempreferences.) --- C4/Installer/PerlDependencies.pm | 5 + C4/Output/JSONStream.pm | 41 +++++ C4/Output/XMLStream.pm | 231 ++++++++++++++++++++++++++++ C4/Service.pm | 157 +++++++++++++------ Koha/Borrower/Search.pm | 149 ++++++++++++++++++ members/default_messageprefs.pl | 5 +- opac/sco/sco-patron-image.pl | 6 +- svc/config/systempreferences | 14 +- svc/members/delete | 154 +++++++++++++++++++ svc/members/upsert | 317 +++++++++++++++++++++++++++++++++++++++ t/Output_JSONStream.t | 11 +- t/Output_XMLStream.t | 70 +++++++++ t/Service.t | 71 +++++++++ t/db_dependent/Borrower_Search.t | 79 ++++++++++ t/db_dependent/Service.t | 14 -- 15 files changed, 1252 insertions(+), 72 deletions(-) create mode 100644 C4/Output/XMLStream.pm create mode 100644 Koha/Borrower/Search.pm create mode 100755 svc/members/delete create mode 100755 svc/members/upsert create mode 100644 t/Output_XMLStream.t create mode 100755 t/Service.t create mode 100755 t/db_dependent/Borrower_Search.t delete mode 100755 t/db_dependent/Service.t diff --git a/C4/Installer/PerlDependencies.pm b/C4/Installer/PerlDependencies.pm index 96557e3..c15b021 100644 --- a/C4/Installer/PerlDependencies.pm +++ b/C4/Installer/PerlDependencies.pm @@ -737,6 +737,11 @@ our $PERL_DEPS = { 'required' => '0', 'min_ver' => '5.61', }, + 'XML::Writer' => { + 'usage' => 'Core', + 'required' => '1', + 'min_ver' => '0.611', + }, }; 1; diff --git a/C4/Output/JSONStream.pm b/C4/Output/JSONStream.pm index ff321fc..5153dba 100644 --- a/C4/Output/JSONStream.pm +++ b/C4/Output/JSONStream.pm @@ -71,4 +71,45 @@ sub output { return to_json( $self->{data} ); } +=head 2 clear + + $json->clear(); + +This clears any in-progress data from the object so it can be used to create +something new. Parameters are kept, it's just the data that goes away. + +=cut + +sub clear { + my $self = shift; + $self->{data} = {}; +} + +=head2 content_type + + my $ct = $json->content_type(); + +Returns a string containing the content type of the stuff that this class +returns, suitable for passing to L. +In this case, it says 'json'. + +=cut + +sub content_type { + return 'json'; +} + +=head2 true + + my $true = $json->true(); + +This provides a 'true' value, as some format types need a special value. + +=cut + +sub true { + return JSON::true; +} + + 1; diff --git a/C4/Output/XMLStream.pm b/C4/Output/XMLStream.pm new file mode 100644 index 0000000..102540a --- /dev/null +++ b/C4/Output/XMLStream.pm @@ -0,0 +1,231 @@ +package C4::Output::XMLStream; + +# Copyright 2014 Catalyst IT +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +=head1 NAME + +C4::Output::XMLStream - progressively build XML data + +=head1 SYNOPSIS + + my $xml = C4::Output::XMLStream->new(root => 'rootnodename'); + + $json->param( issues => [ 'yes!', 'please', 'no', { emphasis = 'NO' } ] ); + $json->param( stuff => 'realia' ); + + print $json->output; + +=head1 DESCRIPTION + +This module makes it easy to progressively build up data structure that can +then be output as XML. + +The XML output is very simple, as this is an analogue to JSON output. If +params are set thus: + + my $json = C4::Output::XMLStream->new(root => 'rootnodename'); + $json->param( issues => [ 'yes!', 'please', 'no', { emphasis = 'NO' } ] ); + $json->param( stuff => 'realia' ); + +Then the XML will be: + + + + + yes! + please + no + NO + + + realia + + +It's wordy because it's XML. You can't set attributes on nodes, because you +can't do that in JSON. You can't have text elements and sub-elements at the +same time, because that's fiddly to express in Perl structures, and you can't +do that in JSON anyway. + +If you want multiple subnodes, then do this: + + $xml->param(stuff => { one => 'a', two => 'b' }); + +The resulting order of the output is not particularly deterministic, given +this more or less emulates a hash, except the bits with arrays. + +If you add a new param with the same name as an already existing one, the new +one will overwrite the old one. + +=head1 FUNCTIONS + +=cut + +use Carp; +use Modern::Perl; +use XML::Writer; + +=head2 new + + my $xml = C4::Output::XMLStream->new(root => 'rootnodename'); + +Creates a new instance of the C class. + +=cut + +sub new { + my $class = shift; + my %opts = @_; + croak "no root node specified" unless $opts{root}; + my $self = { + data => {}, + %opts, + }; + bless $self, $class; + return $self; +} + +=head2 param + + $xml->param(key1 => $value1, key2 => $value2, ...); + +This adds the supplied key/value pairs to the object for later output. See +the Description section for details on what goes in vs. what comes out. + +=cut + +sub param { + my $self = shift; + + if (@_ % 2 != 0) { + croak "param() received an odd number of args, should be a list of hashes"; + } + + my %p = @_; + # Merge the hashes, this'll overwrite any old values with new ones + @{ $self->{data} }{ keys %p } = values %p; +} + +=head2 output + + my $str = $xml->output(); + +Turns the provided params into an XML document string. + +=cut + +sub output { + my $self = shift; + + my $str; + my $writer = XML::Writer->new(OUTPUT => \$str); + $writer->xmlDecl('UTF-8'); + $writer->startTag($self->{root}); + _add_to_xml($writer, $self->{data}); + $writer->endTag($self->{root}); + $writer->end(); + return $str; +} + +=head2 clear + + $xml->clear(); + +This clears any in-progress data from the object so it can be used to create +something new. Parameters are kept, it's just the data that goes away. + +=cut + +sub clear { + my $self = shift; + $self->{data} = {}; +} + +=head2 content_type + + my $ct = $xml->content_type(); + +Returns a string containing the content type of the stuff that this class +returns, suitable for passing to L. +In this case, it says 'xml'. + +=cut + +sub content_type { + return 'xml'; +} + +=head2 true + + my $true = $xml->true(); + +This provides a 'true' value, as some format types need a special value. + +=cut + +sub true { + return '1'; +} + + +# This is an internal class sub that recurses through the provided data adding +# each layer to the writer. +sub _add_to_xml { + my ($writer, $data) = @_; + + my $r = ref $data; + + if ($r eq 'HASH') { + # data is a hashref + while (my ($k, $v) = each %$data) { + $writer->startTag($k); + _add_to_xml($writer, $v); + $writer->endTag($k); + } + } elsif ($r eq 'ARRAY') { + # data is an arrayref + $writer->startTag('array'); + foreach my $v (@$data) { + if (ref($v) eq 'HASH') { + # we don't say "item" for these ones + _add_to_xml($writer, $v); + } else { + $writer->startTag('item'); + _add_to_xml($writer, $v); + $writer->endTag('item'); + } + } + $writer->endTag('array'); + } elsif ($r eq '') { + # data is a scalar + $writer->characters($data); + } else { + confess "I got some data I can't handle: $data"; + } +} + +1; + +=head1 AUTHORS + +=over 4 + +=item Robin Sheat + +=back + +=cut diff --git a/C4/Service.pm b/C4/Service.pm index d59cd70..a649c8c 100644 --- a/C4/Service.pm +++ b/C4/Service.pm @@ -23,29 +23,32 @@ C4::Service - functions for JSON webservices. =head1 SYNOPSIS -my ( $query, $response) = C4::Service->init( { circulate => 1 } ); -my ( $borrowernumber) = C4::Service->require_params( 'borrowernumber' ); +my $response = C4::Output::XMLStream->new(...); +my $service = C4::Service->new( { needed_flags => { circulate => 1 }, + [ output_stream => $response ], + [ query => CGI->new() ] } ); +my ( $borrowernumber) = $service->require_params( 'borrowernumber' ); -C4::Service->return_error( 'internal', 'Frobnication failed', frobnicator => 'foo' ); +$service->return_error( 'internal', 'Frobnication failed', frobnicator => 'foo' ); $response->param( frobnicated => 'You' ); -C4::Service->return_success( $response ); +C4::Service->return_success(); =head1 DESCRIPTION -This module packages several useful functions for JSON webservices. +This module packages several useful functions for webservices. =cut use strict; use warnings; +use Carp; use CGI qw ( -utf8 ); use C4::Auth qw( check_api_auth ); use C4::Output qw( :ajax ); use C4::Output::JSONStream; -use JSON; our $debug; @@ -53,42 +56,65 @@ BEGIN { $debug = $ENV{DEBUG} || 0; } -our ( $query, $cookie ); - =head1 METHODS -=head2 init +=head2 new - our ( $query, $response ) = C4::Service->init( %needed_flags ); + my $service = C4::Service->new({needed_flags => { parameters => 1 }, + [ output_stream => C4::Output::XMLStream->new(...) ], + [ query => CGI->new() ]}); -Initialize the service and check for the permissions in C<%needed_flags>. +Creates a new instance of C4::Service. It verifies that the provided flags +are met by the current session, and aborts with an exit() call if they're +not. It also accepts an instance of C4::Output::* (or something with the +same interface) to use to generate the output. If none is provided, then +a new instance of L is created. Similarly, a query +may also be provided. If it's not, a new CGI one will be created. -Also, check that the user is authorized and has a current session, and return an -'auth' error if not. +This call can't be used to log a user in by providing a userid parameter, it +can only be used to check an already existing session. -init() returns a C object and a C. The latter can -be used for both flat scripts and those that use dispatch(), and should be -passed to C. +TODO: exit sucks, make a better way. =cut -sub init { - my ( $class, %needed_flags ) = @_; +sub new { + my $class = shift; + + my %opts = %{shift()}; - our $query = new CGI; + my $needed_flags = $opts{needed_flags}; + croak "needed_flags is a required option" unless $needed_flags; - my ( $status, $cookie_, $sessionID ) = check_api_auth( $query, \%needed_flags ); + my $query = $opts{query} || CGI->new(); + # We capture the userid so it doesn't upset the auth check process + # (if we don't, the auth code will try to log in with the userid + # param value.) + my $userid; + $userid = $query->param('userid'); + $query->delete('userid') if defined($userid); - our $cookie = $cookie_; # I have no desire to offend the Perl scoping gods + my ( $status, $cookie, $sessionID ) = check_api_auth( $query, $needed_flags ); - $class->return_error( 'auth', $status ) if ( $status ne 'ok' ); + # Restore userid if needed + $query->param(-name=>'userid', -value=>$userid) if defined($userid); - return ( $query, new C4::Output::JSONStream ); + my $output_stream = $opts{output_stream} || C4::Output::JSONStream->new(); + my $self = { + needed_flags => $needed_flags, + query => $query, + output_stream => $output_stream, + cookie => $cookie, + }; + bless $self, $class; + $self->return_error('auth', $status) if ($status ne 'ok'); + + return $self; } =head2 return_error - C4::Service->return_error( $type, $error, %flags ); + $service->return_error( $type, $error, %flags ); Exit the script with HTTP status 400, and return a JSON error object. @@ -106,20 +132,23 @@ param => value pairs. =cut sub return_error { - my ( $class, $type, $error, %flags ) = @_; + my ( $self, $type, $error, %flags ) = @_; - my $response = new C4::Output::JSONStream; + my $response = $self->{output_stream}; + $response->clear(); $response->param( message => $error ) if ( $error ); $response->param( type => $type, %flags ); - output_with_http_headers $query, $cookie, $response->output, 'json', '400 Bad Request'; + output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type, '400 Bad Request'; + + # Someone please delete this exit; } =head2 return_multi - C4::Service->return_multi( \@responses, %flags ); + $service->return_multi( \@responses, %flags ); return_multi is similar to return_success or return_error, but allows you to return different statuses for several requests sent at once (using HTTP status @@ -139,12 +168,13 @@ structure verbatim. =cut sub return_multi { - my ( $class, $responses, @flags ) = @_; + my ( $self, $responses, @flags ) = @_; - my $response = new C4::Output::JSONStream; + my $response = $self->{output_stream}; + $response->clear(); if ( !@$responses ) { - $class->return_success( $response ); + $self->return_success( $response ); } else { my @responses_formatted; @@ -152,14 +182,14 @@ sub return_multi { if ( ref( $response ) eq 'ARRAY' ) { my ($type, $error, @error_flags) = @$response; - push @responses_formatted, { is_error => JSON::true, type => $type, message => $error, @error_flags }; + push @responses_formatted, { is_error => $response->true(), type => $type, message => $error, @error_flags }; } else { push @responses_formatted, $response; } } - $response->param( 'multi' => JSON::true, responses => \@responses_formatted, @flags ); - output_with_http_headers $query, $cookie, $response->output, 'json', '207 Multi-Status'; + $response->param( 'multi' => $response->true(), responses => \@responses_formatted, @flags ); + output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type, '207 Multi-Status'; } exit; @@ -167,22 +197,54 @@ sub return_multi { =head2 return_success - C4::Service->return_success( $response ); + $service->return_success(); -Print out the information in the C C<$response>, then -exit with HTTP status 200. +Print out the information in the provided C, then +exit with HTTP status 200. To get access to the C, you should +either use the one that you provided, or you should use the C +accessor. =cut sub return_success { - my ( $class, $response ) = @_; + my ( $self ) = @_; - output_with_http_headers $query, $cookie, $response->output, 'json'; + my $response = $self->{output_stream}; + output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type; +} + +=head2 output_stream + + $service->output_stream(); + +Provides the output stream object that is in use so that data can be added +to it. + +=cut + +sub output_stream { + my $self = shift; + + return $self->{output_stream}; +} + +=head2 query + + $service->query(); + +Provides the query object that this class is using. + +=cut + +sub query { + my $self = shift; + + return $self->{query}; } =head2 require_params - my @values = C4::Service->require_params( @params ); + my @values = $service->require_params( @params ); Check that each of of the parameters specified in @params was sent in the request, then return their values in that order. @@ -192,13 +254,13 @@ If a required parameter is not found, send a 'param' error to the browser. =cut sub require_params { - my ( $class, @params ) = @_; + my ( $self, @params ) = @_; my @values; for my $param ( @params ) { - $class->return_error( 'params', "Missing '$param'" ) if ( !defined( $query->param( $param ) ) ); - push @values, $query->param( $param ); + $self->return_error( 'params', "Missing '$param'" ) if ( !defined( $self->{query}->param( $param ) ) ); + push @values, $self->{query}->param( $param ); } return @values; @@ -206,7 +268,7 @@ sub require_params { =head2 dispatch - C4::Service->dispatch( + $service->dispatch( [ $path_regex, \@required_params, \&handler ], ... ); @@ -233,8 +295,9 @@ with the argument '123'. =cut sub dispatch { - my $class = shift; + my $self = shift; + my $query = $self->{query}; my $path_info = $query->path_info || '/'; ROUTE: foreach my $route ( @_ ) { @@ -251,7 +314,7 @@ sub dispatch { return; } - $class->return_error( 'no_handler', '' ); + $self->return_error( 'no_handler', '' ); } 1; @@ -263,3 +326,5 @@ __END__ Koha Development Team Jesse Weaver + +Robin Sheat diff --git a/Koha/Borrower/Search.pm b/Koha/Borrower/Search.pm new file mode 100644 index 0000000..0cf60ab --- /dev/null +++ b/Koha/Borrower/Search.pm @@ -0,0 +1,149 @@ +package Koha::Borrower::Search; + +# Copyright 2015 Catalyst IT +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use Modern::Perl; + +use C4::Context; +use Carp; + +use base 'Exporter'; + +our @EXPORT_OK = qw( find_borrower find_borrower_from_ext get_borrower_fields ); + +=head1 NAME + +Koha::Borrower::Search - a simple borrower searching interface + +=head1 SYNOPSIS + + use Koha::Borrower::Search qw( find_borrower find_borrower_from_ext ); + # This will raise an exception if more than one borrower matches + my $borr_num = find_borrower('cardnumber', '123ABC'); + # This will give you a list of all the numbers + my @borr_nums = find_borrower('surname', 'Smith'); + + my $borr_num = find_borrower_from_ext('MEMBERNUM', '54321'); + my @borr_nums = find_borrower_from_ext('DEPARTMENT', 'Ministry of Silly Walks'); + +=head1 DESCRIPTION + +This provides some functions to find borrower records. + +=head1 FUNCTIONS + +=head2 find_borrower + + my $borr_num = find_borrower('cardnumber', '123ABC'); + my @borr_nums = find_borrower('surname', 'Smith'); + +Given a column in the borrower table and a value, this will find matching +borrowers. + +If called in a scalar context, an exception will be raised if there is more +than one result, or something else goes wrong, and C will be returned if +there are no results. + +If called in a list context, all borrowernumbers are returned. + +=cut + +sub find_borrower { + my ( $field, $value ) = @_; + + croak "Field value may not be safe for SQL" if $field =~ /[^A-Za-z0-9]/; + my $dbh = C4::Context->dbh(); + my $q = "SELECT borrowernumber FROM borrowers WHERE $field=?"; + my $sth = $dbh->prepare($q); + $sth->execute($value); + if (wantarray) { + my @bibs; + while (my $row = $sth->fetchrow_arrayref) { + push @bibs, $row->[0]; + } + return @bibs; + } else { + my $row = $sth->fetchrow_arrayref(); + return undef unless $row; + my $bib = $row->[0]; + die "Multiple borrowers match provided values\n" + if $sth->fetchrow_arrayref(); + return $bib; + } +} + +=head2 find_borrower_from_ext + + my $borr_num = find_borrower_from_ext('MEMBERNUM', '54321'); + my @borr_nums = find_borrower_from_ext('DEPARTMENT', 'Ministry of Silly Walks'); + +Given the code for an extended borrower attribute, and a value, this will +find the borrowers that match. + +If called in a scalar context, an exception will be raised if there is more +than one result, or something else goes wrong, and C will be returned if +there are no results. + +If called in a list context, all borrowernumbers are returned. + +=cut + +sub find_borrower_from_ext { + my ( $code, $value ) = @_; + + my $dbh = C4::Context->dbh(); + my $q = +'SELECT DISTINCT borrowernumber FROM borrower_attributes WHERE code=? AND attribute=?'; + my $sth = $dbh->prepare($q); + $sth->execute( $code, $value ); + if (wantarray) { + my @bibs; + while (my $row = $sth->fetchrow_arrayref) { + push @bibs, $row->[0]; + } + return @bibs; + } else { + my $row = $sth->fetchrow_arrayref(); + return undef unless $row; + my $bib = $row->[0]; + die "Multiple borrowers match provided values\n" + if $sth->fetchrow_arrayref(); + return $bib; + } +} + +=head2 get_borrower_fields + +Fetches the list of columns from the borrower table. Returns a list. + +=cut + +sub get_borrower_fields { + my $dbh = C4::Context->dbh(); + + my @fields; + my $q = 'SHOW COLUMNS FROM borrowers'; + my $sth = $dbh->prepare($q); + $sth->execute(); + while ( my $row = $sth->fetchrow_hashref() ) { + push @fields, $row->{Field}; + } + return @fields; +} + +1; diff --git a/members/default_messageprefs.pl b/members/default_messageprefs.pl index 2d70715..1b92772 100755 --- a/members/default_messageprefs.pl +++ b/members/default_messageprefs.pl @@ -28,8 +28,9 @@ use C4::Form::MessagingPreferences; # update the prefs if operator is creating a new patron and has # changed the patron category from its original value. -my ($query, $response) = C4::Service->init(borrowers => 1); +my $service = C4::Service->new({needed_flags => { borrowers => 1 }}); +my $response = $service->output_stream(); my ($categorycode) = C4::Service->require_params('categorycode'); C4::Form::MessagingPreferences::set_form_values({ categorycode => $categorycode }, $response); -C4::Service->return_success( $response ); +C4::Service->return_success(); diff --git a/opac/sco/sco-patron-image.pl b/opac/sco/sco-patron-image.pl index de8d8d6..b72cfb9 100755 --- a/opac/sco/sco-patron-image.pl +++ b/opac/sco/sco-patron-image.pl @@ -22,7 +22,9 @@ use warnings; use C4::Service; use C4::Members; -my ($query, $response) = C4::Service->init(circulate => 'circulate_remaining_permissions'); +my $service = C4::Service->init( + { needed_flags => { circulate => 'circulate_remaining_permissions' } } ); +my $query = $service->query(); unless (C4::Context->preference('WebBasedSelfCheck')) { print $query->header(status => '403 Forbidden - web-based self-check not enabled'); @@ -33,7 +35,7 @@ unless (C4::Context->preference('ShowPatronImageInWebBasedSelfCheck')) { exit; } -my ($borrowernumber) = C4::Service->require_params('borrowernumber'); +my ($borrowernumber) = $service->require_params('borrowernumber'); my ($imagedata, $dberror) = GetPatronImage($borrowernumber); diff --git a/svc/config/systempreferences b/svc/config/systempreferences index deeca51..65901ee 100755 --- a/svc/config/systempreferences +++ b/svc/config/systempreferences @@ -42,7 +42,7 @@ batches. =cut -our ( $query, $response ) = C4::Service->init( parameters => 1 ); +our $service = C4::Service->new( { needed_flags => { parameters => 1 } } ); =head2 set_preference @@ -62,12 +62,12 @@ sub set_preference { my ( $preference ) = @_; unless ( C4::Context->config('demo') ) { - my $value = join( ',', $query->param( 'value' ) ); + my $value = join( ',', $service->query()->param( 'value' ) ); C4::Context->set_preference( $preference, $value ); logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $preference . " | " . $value ); } - C4::Service->return_success( $response ); + $service->return_success(); } =head2 set_preferences @@ -90,22 +90,22 @@ pref_virtualshelves=0 sub set_preferences { unless ( C4::Context->config( 'demo' ) ) { - foreach my $param ( $query->param() ) { + foreach my $param ( $service->query()->param() ) { my ( $pref ) = ( $param =~ /pref_(.*)/ ); next if ( !defined( $pref ) ); - my $value = join( ',', $query->param( $param ) ); + my $value = join( ',', $service->query()->param( $param ) ); C4::Context->set_preference( $pref, $value ); logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $pref . " | " . $value ); } } - C4::Service->return_success( $response ); + $service->return_success(); } -C4::Service->dispatch( +$service->dispatch( [ 'POST /([A-Za-z0-9_-]+)', [ 'value' ], \&set_preference ], [ 'POST /', [], \&set_preferences ], ); diff --git a/svc/members/delete b/svc/members/delete new file mode 100755 index 0000000..1dce75f --- /dev/null +++ b/svc/members/delete @@ -0,0 +1,154 @@ +#!/usr/bin/perl + +# Copyright 2015 Catalyst IT +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +=head1 NAME + +svc/members/delete - web service for deleting a user + +=head1 SYNOPSIS + + POST /svc/members/delete + +The request parameters go in the POST body. + +=head1 DESCRIPTION + +This allows users to be deleted on a Koha system from another service. +Information to match on is supplied as POST parameters, a user is searched for, +and any matches are deleted. The field to search on may be an extended +attribute code. + +If any borrower that matches can't be deleted, for example it has charges +owing or items on issue, then nothing will be deleted. + +Deleted borrower records will be moved to the deletedborrowers table. + +=head1 PARAMETERS + +The request can accept a single parameter: + + fieldname=value + +The fieldname is either a column in the C table, or the code of an +extended attribute. + +=head2 Results + +On success, this will return a result in XML form containing a count of the +records deleted. No records matching the search is also considered a success. + +On failure, an error will be returned containing the borrower numbers that +caused the operation to fail and the reason. + +=cut + +use Modern::Perl; + +use C4::Context; +use C4::Members; +use C4::Output::XMLStream; +use C4::Service; +use C4::VirtualShelves (); #no import + +use Koha::Borrower::Search qw( find_borrower find_borrower_from_ext get_borrower_fields ); + +process_delete(); + +sub process_delete { + my $xml = C4::Output::XMLStream->new(root => 'response'); + my $service = C4::Service->new( { needed_flags => { borrowers => 1 }, output_stream => $xml } ); + + my $query = $service->query(); + my @supplied_fields = $query->param(); + # We only allow one supplied field. + $service->return_error('parameters', 'Only one field to search for is permitted', status=>'failed') if @supplied_fields > 1; + $service->return_error('parameters', 'A field and value to match against must be provided', status=>'failed') unless @supplied_fields; + + my $fieldname = $supplied_fields[0]; + my $fieldvalue = $query->param($fieldname); + + # Figure out if we need to check the borrower fields or the extended attribs + my @borrower_fields = get_borrower_fields(); + my @attrib_types = get_extended_attribs(); + my $is_borrower_field = grep { $_ eq $fieldname } @borrower_fields; + if (!$is_borrower_field && !grep { $_ eq $fieldname} @attrib_types) { + $service->return_error('parameters', "Invalid parameter provided: $fieldname"); + } + + # Now find who this belongs to + my @borr_nums; + eval { + if ($is_borrower_field) { + @borr_nums = find_borrower($fieldname, $fieldvalue); + } else { + @borr_nums = find_borrower_from_ext($fieldname, $fieldvalue); + } + }; + if ($@) { + $service->return_error('searchfailed', $@, status=>'failed'); + } + unless (@borr_nums) { + # no results, automatic success + $service->output_stream->param(deletedcount => 0); + $service->output_stream->param(status => 'ok'); + $service->return_success(); + return; + } + + # Check for charges, issues + my (@borr_issues, @borr_charges); + foreach my $b (@borr_nums) { + my $issues = scalar @{ GetPendingIssues($b) }; + my ($borr_data) = GetMemberDetails($b, ''); + + push @borr_issues, $b if $issues; + push @borr_charges, $b if $borr_data->{flags}->{'CHARGES'}; + } + + if (@borr_issues || @borr_charges) { + $service->return_error( + 'constraints', 'Non-returned issues or uncleared charges', + status => 'failed', + issues => join( ',', @borr_issues ), + charges => join( ',', @borr_charges ) + ); + return; + } + + # All good, so let's delete + foreach my $b (@borr_nums) { + MoveMemberToDeleted($b); + C4::VirtualShelves::HandleDelBorrower($b); + DelMember($b); + } + $service->output_stream->param(deletedcount => scalar @borr_nums); + $service->output_stream->param(status => 'ok'); + $service->return_success(); +} + +=head2 get_extended_attribs + +Fetch all the extended attributes from the system. Returns a list. + +=cut + +sub get_extended_attribs { + return map { $_->{code} } C4::Members::AttributeTypes::GetAttributeTypes(); +} + diff --git a/svc/members/upsert b/svc/members/upsert new file mode 100755 index 0000000..b826a8c --- /dev/null +++ b/svc/members/upsert @@ -0,0 +1,317 @@ +#!/usr/bin/perl + +# Copyright 2015 Catalyst IT +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +=head1 NAME + +svc/members/upsert - web service for inserting and updating user details + +=head1 SYNOPSIS + + POST /svc/members/upsert + +The request paramters go in the POST body. + +=head1 DESCRIPTION + +This allows user data to be added and updated on a Koha system from another +service. User data is supplied, and if it matches an existing user, that user +is updated. If not, then a new user is created. A field to match on must be +provided. For example, this might be an ID of the user in an employee +management system. It may be an extended attribute. + +=head1 PARAMETERS + +The request can contain any field from the borrowers table, and any extended +attribute name. It must also contain 'matchField' which specifies the field +to use to see if the user already exists. + +To clear a field, provide an empty parameter for it. If the parameter doesn't +exist, then the field will be left alone. + +Dates must be in YYYY-MM-DD form. + +Boolean values must be 1 (for true) or 0 (for false.) + +A borrowernumber field may be provided and used for matching. It will be +ignored when it comes to creating or updating however. + +If the matchField parameters returns more than one value, an error will be +raised. Care should be taken to ensure that it is unique. + +=head2 Results + +On success, this will return a result in XML form containing the +borrowernumber of the record (whether it's newly created or just updated) and +a 'createOrUpdate' element that contains either 'create' or 'update', +depending on what operation ended up happening. + +On error, an error response is returned. This may be because a matchField +was provided that didn't match anything, or because the matchField +produced multiple results. Or probably many other things. + +=cut + +use Modern::Perl; + +use C4::Context; +use C4::Members; +use C4::Members::AttributeTypes; +use C4::Output::XMLStream; +use C4::Service; + +use Koha::Borrower::Search + qw( find_borrower find_borrower_from_ext get_borrower_fields ); + +process_upsert(); + +sub process_upsert { + my $xml = C4::Output::XMLStream->new( root => 'response' ); + my $service = C4::Service->new( + { needed_flags => { borrowers => 1 }, output_stream => $xml } ); + + my $query = $service->query(); + my @supplied_fields = $query->param(); + my @borrower_fields = get_borrower_fields(); + my @attrib_types = get_extended_attribs(); + my $match_field = $query->param('matchField'); + + # Make a mapping of these so we can do fast lookups + my %borrower_fields = map { $_ => 1 } @borrower_fields; + my %attrib_types = map { $_ => 1 } @attrib_types; + + $service->return_error( + 'parameters', + 'No matchField provided', + status => 'failed' + ) unless $match_field; + my $is_borrower_field; # for matchField, as opposed to an ext attribute + $is_borrower_field = $borrower_fields{$match_field} // 0; + if ( !$is_borrower_field ) { + $service->return_error( + 'parameters', + 'Provided matchField doesn\'t match a valid field', + status => 'failed' + ) unless $attrib_types{$match_field}; + } + my $match_value = $query->param($match_field); + $service->return_error( + 'parameters', + 'The field specified by matchField wasn\'t provided.', + status => 'failed' + ) unless $match_value; + + # verify we are only given valid fields, at the same time make a mapping + # of them. + my ( %supplied_data_borr, %supplied_data_ext ); + foreach my $f (@supplied_fields) { + next if $f eq 'matchField'; + $service->return_error( 'parameters', "Invalid parameter provided: $f" ) + unless $borrower_fields{$f} || $attrib_types{$f}; + if ( $borrower_fields{$f} ) { + $supplied_data_borr{$f} = $query->param($f); + } + else { + $supplied_data_ext{$f} = $query->param($f); + } + } + + # Sanity checks and data extraction over, find our borrower. + my $borr_num; + eval { + if ($is_borrower_field) { + $borr_num = find_borrower( $match_field, $match_value ); + } + else { + $borr_num = find_borrower_from_ext( $match_field, $match_value ); + } + }; + if ($@) { + $service->return_error( 'borrower', $@, status => 'failed' ); + } + + # Now we know if we're creating a new user, or updating an existing one. + my $change_type; + eval { + if ($borr_num) { + update_borrower( $borr_num, \%supplied_data_borr, + \%supplied_data_ext ); + $change_type = 'update'; + } + else { + $borr_num = + create_borrower( \%supplied_data_borr, \%supplied_data_ext ); + $change_type = 'create'; + } + }; + if ($@) { + $service->return_error( 'data', $@, status => 'failed' ); + } + + $service->output_stream->param( 'borrowernumber', $borr_num ); + $service->output_stream->param( 'createOrUpdate', $change_type ); + $service->output_stream->param( 'status', 'ok' ); + $service->return_success(); +} + +=head2 get_extended_attribs + +Fetch all the extended attributes from the system. Returns a list. + +=cut + +sub get_extended_attribs { + return map { $_->{code} } C4::Members::AttributeTypes::GetAttributeTypes(); +} + +=head2 update_borrower + + update_borrower($borr_num, \%borrower_fields, \%ext_attrib_fields); + +This takes a borrower number, a hashref containing the fields and values for +the borrower, and a hashref containing the fields and values for the extended +attributes. It will update the borrower to set its fields to the values +supplied. + +A supplied borrowernumber will be ignored. + +=cut + +sub update_borrower { + my ( $borr_num, $borr_fields, $ext_fields ) = @_; + + # For the first phase, we build an update query for the borrower + my ( @f_borr, @v_borr ); + while ( my ( $f, $v ) = each %$borr_fields ) { + next if $f =~ /^borrowernumber$/i; + die "Invalid fieldname provided (update): $f\n" if $f =~ /[^A-Za-z0-9]/; + push @f_borr, $f; + push @v_borr, $v; + } + my $q_borr = + 'UPDATE borrowers SET ' + . ( join ',', map { $_ . '=?' } @f_borr ) + . ' WHERE borrowernumber=?'; + + # Now queries to sort out the extended fields + my @f_ext = keys %$ext_fields; + my @v_ext = values %$ext_fields; + my $q_ext_del = + 'DELETE FROM borrower_attributes WHERE borrowernumber=? AND code IN (' + . ( join ',', map { '?' } @f_ext ) . ')'; + my $q_ext_add = +'INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (?, ?, ?)'; + + my $dbh = C4::Context->dbh(); + + # Finally, run these all inside a transaction. + eval { + local $dbh->{RaiseError} = 1; + $dbh->begin_work; + + my $sth; + + if (@f_borr) { + $sth = $dbh->prepare($q_borr); + $sth->execute( @v_borr, $borr_num ); + } + + $sth = $dbh->prepare($q_ext_del); + $sth->execute( $borr_num, @f_ext ) if @f_ext; + + $sth = $dbh->prepare($q_ext_add); + while ( my ( $f, $v ) = each %$ext_fields ) { + next if $v eq ''; + $sth->execute( $borr_num, $f, $v ); + } + + $dbh->commit; + }; + if ($@) { + $dbh->rollback; + die "Failed to update borrower record: $@\n"; + } + return $borr_num; +} + +=head2 create_borrower + + my $borr_num = create_borrower(\%borrower_fields, \%ext_attrib_fields); + +This creates a new borrower using the supplied data. + +A supplied borrowernumber will be ignored. + +The borrowernumber of the new borrower will be returned. + +=cut + +sub create_borrower { + my ( $borr_fields, $ext_fields ) = @_; + + my @criticals = qw(surname branchcode categorycode); + + # Check we have the ones we need + foreach my $c (@criticals) { + die "Critical field missing (create): $c\n" unless $borr_fields->{$c}; + } + + # Borrower fields + my ( @f_borr, @v_borr ); + while ( my ( $f, $v ) = each %$borr_fields ) { + die "Invalid fieldname provided: $f\n" if $f =~ /[^A-Za-z0-9]/; + push @f_borr, $f; + push @v_borr, $v; + } + my $q_borr = + 'INSERT INTO borrowers (' + . ( join ',', @f_borr ) + . ') VALUES (' + . ( join ',', map { '?' } @f_borr ) . ')'; + + # Extended attributes + my @f_ext = keys %$ext_fields; + my @v_ext = values %$ext_fields; + my $q_ext_add = +'INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (?, ?, ?)'; + + my $dbh = C4::Context->dbh(); + + # Finally, run these all inside a transaction. + my $borr_num; + eval { + local $dbh->{RaiseError} = 1; + $dbh->begin_work; + + my $sth = $dbh->prepare($q_borr); + $sth->execute(@v_borr); + $borr_num = $dbh->last_insert_id( undef, undef, undef, undef ); + + $sth = $dbh->prepare($q_ext_add); + while ( my ( $f, $v ) = each %$ext_fields ) { + $sth->execute( $borr_num, $f, $v ); + } + + $dbh->commit; + }; + if ($@) { + $dbh->rollback; + die "Failed to create borrower record: $@\n"; + } + return $borr_num; +} diff --git a/t/Output_JSONStream.t b/t/Output_JSONStream.t index 13702a6..e4a8cfa 100755 --- a/t/Output_JSONStream.t +++ b/t/Output_JSONStream.t @@ -6,7 +6,9 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 12; + +use JSON; BEGIN { use_ok('C4::Output::JSONStream'); @@ -30,3 +32,10 @@ eval{$json->param( die => ['yes','sure','now'])}; ok(!$@,'Does not die.'); eval{$json->param( die => ['yes','sure','now'], die2 =>)}; ok($@,'Dies.'); + +$json->clear(); +is($json->output,'{}',"Making sure that clearing it clears it."); + +is($json->content_type, 'json', 'Correct content type is returned'); + +is($json->true, JSON::True, 'True is true.'); diff --git a/t/Output_XMLStream.t b/t/Output_XMLStream.t new file mode 100644 index 0000000..c65ac48 --- /dev/null +++ b/t/Output_XMLStream.t @@ -0,0 +1,70 @@ +# Copyright 2014 Catalyst IT +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use Modern::Perl; +use Test::More tests => 15; + +BEGIN { + use_ok('C4::Output::XMLStream'); +} + +my $xml = C4::Output::XMLStream->new(root => 'root'); + +is(trim($xml->output), ' + +', 'Making sure that blank XML can be output'); + +$xml->param( issues => [ 'yes!', 'please', 'no' ] ); +is(trim($xml->output),' +yes!pleaseno +',"Making sure XML output has added what we told it to."); + +$xml->param( stuff => ['realia'] ); +like($xml->output,qr|realia|,"Making sure XML output has added more params correctly."); +like($xml->output,qr|yes!pleaseno|,"Making sure the old data is still in there"); + +$xml->param( stuff => ['fun','love'] ); +like($xml->output,qr|funlove|,"Making sure XML output can overwrite params"); +like($xml->output,qr|yes!pleaseno|,"Making sure the old data is still in there"); + +$xml->param( halibut => { cod => 'bass' } ); +like($xml->output,qr|bass|,"Adding of hashes works"); +like($xml->output,qr|yes!pleaseno|,"Making sure the old data is still in there"); + + +eval{$xml->param( die )}; +ok($@,'Dies'); + +eval{$xml->param( die => ['yes','sure','now'])}; +ok(!$@,'Dosent die.'); + +eval{$xml->param( die => ['yes','sure','now'], die2 =>)}; +ok($@,'Dies.'); + +$xml->clear(); +is(trim($xml->output), ' + +', 'Making sure that clearing it clears it.'); + +is($xml->content_type, 'xml', 'Correct content type is returned'); + +is($xml->true, '1', 'True is true.'); + +sub trim { + $_ = shift; + s/^\s*(.*?)\s*$/$1/r; +} diff --git a/t/Service.t b/t/Service.t new file mode 100755 index 0000000..b3de535 --- /dev/null +++ b/t/Service.t @@ -0,0 +1,71 @@ +#!/usr/bin/perl + +# Copyright 2015 Catalyst IT +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use Modern::Perl; + +use DBD::Mock; +use Test::MockModule; + +use Test::More tests => 3; + +my $module_context = new Test::MockModule('C4::Context'); +my $_dbh; +$module_context->mock( + '_new_dbh', + sub { + my $dbh = $_dbh // DBI->connect('DBI:Mock:', '', '') || die "Cannot create handle: $DBI::errstr\n"; + $_dbh = $dbh; + return $dbh; + } +); + +# We need to mock the Auth process so that we can pretend we have a valid session +my $module_auth = new Test::MockModule('C4::Auth'); +$module_auth->mock( + 'check_api_auth', + sub { + return ('ok', '', ''); + } +); + +# Instead of actually outputting to stdout, we catch things on the way past +my @_out_params; +my $module_output = new Test::MockModule('C4::Output'); +$module_output->mock( + 'output_with_http_headers', + sub { + @_out_params = @_; + } +); + +use_ok('C4::Output::XMLStream'); +use_ok('C4::Service'); + +# Do a simple round trip test of data in to data out +my $xml_stream = C4::Output::XMLStream->new(root => 'test'); + +my $service = C4::Service->new( { needed_flags => { borrowers => 1 } , + output_stream => $xml_stream }); + +$service->output_stream->param( foo => 'bar' ); + +$service->return_success(); +like($_out_params[2], qr|bar|, 'XML output generated'); + + diff --git a/t/db_dependent/Borrower_Search.t b/t/db_dependent/Borrower_Search.t new file mode 100755 index 0000000..322d954 --- /dev/null +++ b/t/db_dependent/Borrower_Search.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +# Copyright 2015 Catalyst IT +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use C4::Context; + +use Test::More tests => 10; + +use_ok('Koha::Borrower::Search'); + +my $dbh = C4::Context->dbh; +$dbh->{RaiseError} = 1; +$dbh->{AutoCommit} = 0; + +# Insert some borrower detail to fetch later +$dbh->do(q|INSERT INTO branches (branchcode) VALUES ('TBRANCH')|); +$dbh->do(q|INSERT INTO categories (categorycode) VALUES ('TCAT')|); +$dbh->do(q|INSERT INTO borrowers (borrowernumber,cardnumber,branchcode,categorycode,surname) VALUES (200000,'test123','TBRANCH','TCAT','Surname1'), (200001,'test124','TBRANCH','TCAT','Surname2'),(200002,'test125','TBRANCH','TCAT','Surname3')|); + +# An ext attribute +$dbh->do(q|INSERT INTO borrower_attribute_types (code, description) VALUES ('TEXTATTR', 'Test Ext Attrib')|); +$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200000, 'TEXTATTR', 'TESTING')|); +$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200001, 'TEXTATTR', 'TESTING')|); +$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200002, 'TEXTATTR', 'TESTING2')|); + +# And now the actual testing + +# Check to make sure a couple of the columns come through. +my @cols = Koha::Borrower::Search::get_borrower_fields(); +ok((grep{$_ eq 'cardnumber'} @cols), 'Borrower field 1'); +ok((grep{$_ eq 'lost'} @cols), 'Borrower field 2'); +ok((grep{$_ eq 'userid'} @cols), 'Borrower field 3'); + +# Find a borrower by a value +my $num = Koha::Borrower::Search::find_borrower(surname => 'Surname2'); +is($num, 200001, 'Fetch single borrower by field'); + +my @nums = Koha::Borrower::Search::find_borrower(branchcode => 'TBRANCH'); +is_deeply(\@nums, [200000, 200001, 200002], 'Fetch multiple borrowers by field'); + +# Find by ext attr +$num = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING2'); +is ($num, 200002, 'Fetch single borrower by ext attr'); + +my @nums = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING'); +is_deeply(\@nums, [200000, 200001], 'Fetch multiple borrowers by ext attr'); + +# Check that they correctly fail + +my $fail = 1; +eval { + $num = Koha::Borrower::Search::find_borrower(branchcode => 'TBRANCH'); + $fail = 0; +}; +is($fail, 1, 'Raised exception for multiple results by field'); + +$fail = 1; +eval { + $nums = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING'); + $fail = 0; +}; +is($fail, 1, 'Raised exception for multiple results by ext attr'); + +$dbh->rollback; diff --git a/t/db_dependent/Service.t b/t/db_dependent/Service.t deleted file mode 100755 index 497cc1b..0000000 --- a/t/db_dependent/Service.t +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/perl -# -# This Koha test module is a stub! -# Add more tests here!!! - -use strict; -use warnings; - -use Test::More tests => 1; - -BEGIN { - use_ok('C4::Service'); -} - -- 2.1.0