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

(-)a/Koha/Service.pm (+324 lines)
Line 0 Link Here
1
package Koha::Service;
2
3
# This file is part of Koha.
4
#
5
# Copyright (C) 2014 ByWater Solutions
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
=head1 NAME
21
22
Koha::Service - base class for webservices.
23
24
=head1 SYNOPSIS
25
26
package Koha::Service::Frobnicator;
27
28
use base 'Koha::Service';
29
30
sub new {
31
    my ( $class ) = @_;
32
33
    return $class::SUPER::new( { frobnicate => 1 } );
34
}
35
36
sub run {
37
    my ( $self ) = @_;
38
39
    my ( $query, $cookie ) = $self->authenticate;
40
    my ( $borrowernumber ) = $self->require_params( 'borrowernumber' );
41
42
    $self->croak( 'internal', 'Frobnication failed', { frobnicator => 'foo' } );
43
44
    $self->output({ frobnicated => 'You' });
45
}
46
47
Koha::Service::Frobnicator->new->run;
48
49
=head1 DESCRIPTION
50
51
This module serves as a base class with utility methods for JSON webservices.
52
53
=head1 METHODS
54
55
=cut
56
57
use Modern::Perl;
58
59
use base 'Class::Accessor';
60
61
use C4::Auth qw( check_api_auth );
62
use C4::Output qw( :ajax );
63
use CGI;
64
use JSON;
65
66
our $debug;
67
68
BEGIN {
69
    $debug = $ENV{DEBUG} || 0;
70
}
71
72
__PACKAGE__->mk_accessors( qw( auth_status query cookie ) );
73
74
=head2 new
75
    
76
    my $self = $class->SUPER::new( \%options );
77
78
Base constructor for a service.
79
80
C<\%options> may contain the following:
81
82
=over
83
84
=item authnotrequired
85
86
Defaults to false. If set, means that C<authenticate> will not croak if the user is not logged in.
87
88
=item needed_flags
89
90
Takes a hashref of required permissions, i.e., { circulation =>
91
'circulate_remaining_permissions' }.
92
93
=item routes
94
95
An arrayref of routes; see C<add_routes> for the required format.
96
97
=back
98
99
=cut
100
    
101
sub new {
102
    my ( $class, $options ) = @_;
103
104
    return bless {
105
        authnotrequired => 0,
106
        needed_flags => { catalogue => 1 },
107
        routes => [],
108
        %$options
109
    }, $class;
110
}
111
112
=head2 authenticate
113
114
    my ( $query, $cookie ) = $self->authenticate();
115
116
Authenticates the user and returns a C<CGI> object and cookie. May exit after sending an 'auth'
117
error if the user is not logged in or does not have the right permissions.
118
119
This must be called before the C<croak> or C<output> methods.
120
121
=cut
122
123
sub authenticate {
124
    my ( $self ) = @_;
125
126
    $self->query(CGI->new);
127
128
    my ( $status, $cookie, $sessionID ) = check_api_auth( $self->query, $self->{needed_flags} );
129
    $self->cookie($cookie);
130
    $self->auth_status($status);
131
    $self->croak( 'auth', $status ) if ( $status ne 'ok' && !$self->{authnotrequired} );
132
133
    return ( $self->query, $cookie );
134
}
135
136
=head2 output
137
    
138
    $self->output( $response[, \%options] );
139
140
Outputs C<$response>, with the correct headers.
141
142
C<\%options> may contain the following:
143
144
=over
145
146
=item status
147
148
The HTTP status line to send; defaults to '200 OK'. This parameter is ignored for JSONP, as a
149
non-200 response cannot be easily intercepted.
150
151
=item type
152
153
Either 'js', 'json', 'xml' or 'html'. Defaults to 'json'. If 'json', and the C<callback> query parameter
154
is given, outputs JSONP.
155
156
=back
157
158
=cut
159
160
sub output {
161
    my ( $self, $response, $options ) = @_;
162
163
    binmode STDOUT, ':encoding(UTF-8)';
164
165
    # Set defaults
166
    $options = {
167
        status => '200 OK',
168
        type => 'json',
169
        %{ $options || {} },
170
    };
171
172
    if ( $options->{type} eq 'json' ) {
173
        $response = encode_json($response);
174
175
        if ( $self->query->param( 'callback' ) ) {
176
            $response = $self->query->param( 'callback' ) . '(' . encode_json($response) . ');';
177
            $options->{status} = '200 OK';
178
            $options->{type} = 'js';
179
        }
180
    } 
181
182
    output_with_http_headers $self->query, $self->cookie, $response, $options->{type}, $options->{status};
183
}
184
185
=head2 croak
186
187
    $self->croak( $error, $detail, \%flags );
188
189
Outputs an error as JSON, then exits the service with HTTP status 400.
190
191
C<$error> should be a short, lower case code for the generic type of error (such
192
as 'auth' or 'input').
193
194
C<$detail> should be a more specific code giving information on the error. If
195
multiple errors of the same type occurred, they should be joined by '|'; i.e.,
196
'expired|different_ip'. Information in C<$error> does not need to be
197
human-readable, as its formatting should be handled by the client.
198
199
Any additional information to be given in the response should be passed in \%flags.
200
201
The final result of this is a JSON structure like so:
202
203
    { "error": "$error", "detail": "$detail", ... }
204
205
=cut
206
207
sub croak {
208
    my ( $self, $type, $error, $flags ) = @_;
209
210
    my $response = $flags || {};
211
212
    $response->{message} = $error;
213
    $response->{error} = $type;
214
215
    $self->output( $response, { status => '400 Bad Request' } );
216
    exit;
217
}
218
219
=head2 require_params
220
221
    my @values = $self->require_params( @params );
222
223
Check that each of of the parameters specified in @params was sent in the
224
request, then return their values in that order.
225
226
If a required parameter is not found, send a 'param' error to the browser.
227
228
=cut
229
230
sub require_params {
231
    my ( $self, @params ) = @_;
232
233
    my @values;
234
235
    for my $param ( @params ) {
236
        $self->croak( 'params', "missing_$param" ) if ( !defined( $self->query->param( $param ) ) );
237
        push @values, $self->query->param( $param );
238
    }
239
240
    return @values;
241
}
242
243
=head2 add_routes
244
245
    $self->add_routes(
246
        [ $path_regex, $handler[, \@required_params] ],
247
        ...
248
    );
249
250
Adds several routes, each described by an arrayref.
251
252
$path_regex should be a regex passed through qr//, describing which methods and
253
paths this route handles. Each route is tested in order, from the top down, so
254
put more specific handlers first. Also, the regex is tested on the request
255
method, plus the path. For instance, you might use the route [ qr'POST /', ... ]
256
to handle POST requests to your service.
257
258
$handler should be the name of a method in the current class.
259
260
If \@required_params is passed, each named parameter in it is tested to make sure the route matches.
261
No error is raised if one is missing; it simply tests the next route. If you would prefer to raise
262
an error, instead use C<require_params> inside your handler.
263
264
=cut
265
266
sub add_routes {
267
    my $self = shift;
268
269
    push @{ $self->{routes} }, @_;
270
}
271
272
=sub dispatch
273
274
    $self->dispatch();
275
276
Dispatches to the correct route for the current URL and parameters, or raises a 'no_handler' error.
277
278
$self->$handler is called with each matched group in $path_regex in its arguments. For
279
example, if your service is accessed at the path /blah/123, and you call
280
C<dispatch> with the route [ qr'GET /blah/(\d+)', ... ], your handler will be called
281
with the arguments '123'. The original C<CGI> object and cookie are available as C<$self->query> and C<$self->cookie>.
282
283
Returns the result of the matching handler.
284
285
=cut
286
287
sub dispatch {
288
    my $self = shift;
289
290
    my $path_info = $self->query->path_info || '/';
291
292
    ROUTE: foreach my $route ( @{ $self->{routes} } ) {
293
        my ( $path, $handler, $params ) = @$route;
294
295
        next unless ( my @match = ( ($self->query->request_method . ' ' . $path_info) =~ m,^$path$, ) );
296
297
        for my $param ( @{ $params || [] } ) {
298
            next ROUTE if ( !defined( $self->query->param ( $param ) ) );
299
        }
300
301
        $debug and warn "Using $handler for $path";
302
        return $self->$handler( @match );
303
    }
304
305
    $self->croak( 'no_handler' );
306
}
307
308
=sub run
309
310
    $service->run();
311
312
Runs the service. By default, calls authenticate, dispatch then output, but can be overridden.
313
314
=cut
315
316
sub run {
317
    my ( $self ) = @_;
318
319
    $self->authenticate;
320
    my $result = $self->dispatch;
321
    $self->output($result) if ($result);
322
}
323
324
1;
(-)a/svc/bib (-24 / +3 lines)
Lines 22-28 Link Here
22
use strict;
22
use strict;
23
use warnings;
23
use warnings;
24
24
25
use CGI qw ( -utf8 );
25
use CGI;
26
use C4::Auth qw/check_api_auth/;
26
use C4::Auth qw/check_api_auth/;
27
use C4::Biblio;
27
use C4::Biblio;
28
use C4::Items;
28
use C4::Items;
Lines 48-64 if ($path_info =~ m!^/(\d+)$!) { Link Here
48
    print $query->header(-type => 'text/xml', -status => '400 Bad Request');
48
    print $query->header(-type => 'text/xml', -status => '400 Bad Request');
49
}
49
}
50
50
51
# are we retrieving, updating or deleting a bib?
51
# are we retrieving or updating a bib?
52
if ($query->request_method eq "GET") {
52
if ($query->request_method eq "GET") {
53
    fetch_bib($query, $biblionumber);
53
    fetch_bib($query, $biblionumber);
54
} elsif ($query->request_method eq "POST") {
55
    update_bib($query, $biblionumber);
56
} elsif ($query->request_method eq "DELETE") {
57
    delete_bib($query, $biblionumber);
58
} else {
54
} else {
59
    print $query->header(-type => 'text/xml', -status => '405 Method not allowed');
55
    update_bib($query, $biblionumber);
60
    print XMLout({ error => 'Method not allowed' }, NoAttr => 1, RootName => 'response', XMLDecl => 1);
61
    exit 0;
62
}
56
}
63
57
64
exit 0;
58
exit 0;
Lines 126-143 sub update_bib { Link Here
126
   
120
   
127
    print XMLout($result, NoAttr => 1, RootName => 'response', XMLDecl => 1, NoEscape => $do_not_escape); 
121
    print XMLout($result, NoAttr => 1, RootName => 'response', XMLDecl => 1, NoEscape => $do_not_escape); 
128
}
122
}
129
130
sub delete_bib {
131
    my $query = shift;
132
    my $biblionumber = shift;
133
    my $error = DelBiblio($biblionumber);
134
135
    if (defined $error) {
136
        print $query->header(-type => 'text/xml', -status => '400 Bad request');
137
        print XMLout({ error => $error }, NoAttr => 1, RootName => 'response', XMLDecl => 1);
138
        exit 0;
139
    }
140
141
    print $query->header(-type => 'text/xml');
142
    print XMLout({ status => 'OK, biblio deleted' }, NoAttr => 1, RootName => 'response', XMLDecl => 1);
143
}
(-)a/svc/bib_profile (-28 / +17 lines)
Lines 1-23 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
2
3
# Copyright 2007 LibLime
4
#
5
# This file is part of Koha.
3
# This file is part of Koha.
6
#
4
#
7
# Koha is free software; you can redistribute it and/or modify it under the
5
# Copyright (C) 2014 ByWater Solutions
8
# terms of the GNU General Public License as published by the Free Software
9
# Foundation; either version 2 of the License, or (at your option) any later
10
# version.
11
#
6
#
12
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
7
# Koha is free software; you can redistribute it and/or modify it
13
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
8
# under the terms of the GNU General Public License as published by
14
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
9
# the Free Software Foundation; either version 3 of the License, or
10
# (at your option) any later version.
15
#
11
#
16
# You should have received a copy of the GNU General Public License along
12
# Koha is distributed in the hope that it will be useful, but
17
# with Koha; if not, write to the Free Software Foundation, Inc.,
13
# WITHOUT ANY WARRANTY; without even the implied warranty of
18
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
14
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15
# GNU General Public License for more details.
19
#
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>.
20
19
20
<<<<<<< HEAD
21
use strict;
21
use strict;
22
use warnings;
22
use warnings;
23
23
Lines 110-129 sub _get_bib_number_tag { Link Here
110
    }
110
    }
111
    $result->{'bib_number'} = \@tags;
111
    $result->{'bib_number'} = \@tags;
112
}
112
}
113
=======
114
use Modern::Perl;
115
>>>>>>> 40908d6... New Koha::Service class, several services ported
113
116
114
sub _get_biblioitem_itemtypes {
117
use Koha::Service::BibProfile;
115
    my $result = shift;
118
Koha::Service::BibProfile->new->run;
116
    my $itemtypes = GetItemTypes;
117
    my $sth = $dbh->prepare_cached("SELECT tagfield, tagsubfield
118
                                    FROM marc_subfield_structure 
119
                                    WHERE frameworkcode = '' 
120
                                    AND kohafield = 'biblioitems.itemtype'");
121
    $sth->execute();
122
    my @tags = ();
123
    while (my $row = $sth->fetchrow_arrayref) {
124
        push @tags, { tag => $row->[0], subfield => $row->[1] };
125
    }
126
    my @valid_values = map { { code => $_,  description => $itemtypes->{$_}->{'description'} } } sort keys %$itemtypes;
127
    $result->{'special_entry'} = { field => \@tags,  valid_values => \@valid_values };
128
    
129
}
(-)a/svc/config/systempreferences (-103 / +14 lines)
Lines 1-111 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
2
3
# Copyright 2009 Jesse Weaver
4
#
5
# This file is part of Koha.
3
# This file is part of Koha.
6
#
4
#
7
# Koha is free software; you can redistribute it and/or modify it under the
5
# Copyright (C) 2014 ByWater Solutions
8
# terms of the GNU General Public License as published by the Free Software
9
# Foundation; either version 2 of the License, or (at your option) any later
10
# version.
11
#
6
#
12
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
7
# Koha is free software; you can redistribute it and/or modify it
13
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
8
# under the terms of the GNU General Public License as published by
14
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
9
# the Free Software Foundation; either version 3 of the License, or
10
# (at your option) any later version.
15
#
11
#
16
# You should have received a copy of the GNU General Public License along
12
# Koha is distributed in the hope that it will be useful, but
17
# with Koha; if not, write to the Free Software Foundation, Inc.,
13
# WITHOUT ANY WARRANTY; without even the implied warranty of
18
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
14
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15
# GNU General Public License for more details.
19
#
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>.
20
19
21
use strict;
20
use Modern::Perl;
22
use warnings;
23
24
use C4::Context;
25
use C4::Service;
26
use C4::Log;
27
28
=head1 NAME
29
30
svc/config/systempreferences - Web service for setting system preferences
31
32
=head1 SYNOPSIS
33
34
  POST /svc/config/systempreferences/
35
36
=head1 DESCRIPTION
37
38
This service is used to set system preferences, either one at a time or in
39
batches.
40
41
=head1 METHODS
42
43
=cut
44
45
our ( $query, $response ) = C4::Service->init( parameters => 1 );
46
47
=head2 set_preference
48
49
=over 4
50
51
POST /svc/config/systempreferences/$preference
52
53
value=$value
54
55
=back
56
57
Used to set a single system preference.
58
59
=cut
60
61
sub set_preference {
62
    my ( $preference ) = @_;
63
64
    unless ( C4::Context->config('demo') ) {
65
        my $value = join( ',', $query->param( 'value' ) );
66
        C4::Context->set_preference( $preference, $value );
67
        logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $preference . " | " . $value );
68
    }
69
70
    C4::Service->return_success( $response );
71
}
72
73
=head2 set_preferences
74
75
=over 4
76
77
POST /svc/config/systempreferences/
78
79
pref_$pref1=$value1&pref_$pref2=$value2
80
81
=back
82
83
Used to set several system preferences at once. Each preference you want to set
84
should be sent prefixed with pref. If you wanted to turn off the
85
virtualshelves syspref, for instance, you would POST the following:
86
87
pref_virtualshelves=0
88
89
=cut
90
91
sub set_preferences {
92
    unless ( C4::Context->config( 'demo' ) ) {
93
        foreach my $param ( $query->param() ) {
94
            my ( $pref ) = ( $param =~ /pref_(.*)/ );
95
96
            next if ( !defined( $pref ) );
97
98
            my $value = join( ',', $query->param( $param ) );
99
100
            C4::Context->set_preference( $pref, $value );
101
            logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $pref . " | " . $value );
102
        }
103
    }
104
105
    C4::Service->return_success( $response );
106
}
107
21
108
C4::Service->dispatch(
22
use Koha::Service::Config::SystemPreferences;
109
    [ 'POST /([A-Za-z0-9_-]+)', [ 'value' ], \&set_preference ],
23
Koha::Service::Config::SystemPreferences->new->run;
110
    [ 'POST /', [], \&set_preferences ],
111
);
112
- 

Return to bug 12272