source: main/trunk/greenstone2/perllib/cgiactions/baseaction.pm@ 27261

Last change on this file since 27261 was 27261, checked in by ak19, 8 years ago

Adding in 2 basic JSON examples for the metadata-server.pl help/usage string that can be pasted in the browser. Still to add help strings for other metadata-server actions that take a JSON parameter.

File size: 14.4 KB
Line 
1###########################################################################
2#
3# baseaction.pm --
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 2009 New Zealand Digital Library Project
9#
10# This program is free software; you can redistr te it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26
27package baseaction;
28
29use strict;
30use util;
31use inexport;
32
33our $authenication_enabled = 0;
34our $mail_enabled = 0;
35
36
37# change this to get these values from a config file
38my $mail_to_address = "user\@server"; # Set this appropriately
39my $mail_from_address = "user\@server"; # Set this appropriately
40my $mail_smtp_server = "smtp.server"; # Set this appropriately
41
42
43
44# Required CGI arguments: "a" for action
45# "c" for collection
46# Optional CGI arguemnts: "ts" for timestamp (auto generated is missing)
47# "site" (used by Greenstone3)
48
49# allow "un" for username to be optional for now
50
51sub new
52{
53 my $class = shift (@_);
54 my ($action_table,$gsdl_cgi,$iis6_mode) = @_;
55
56 my $self = { 'gsdl_cgi' => $gsdl_cgi,
57 'iis6_mode' => $iis6_mode,
58 'gsdlhome' => $ENV{'GSDLHOME'} };
59
60 # Retrieve the (required) command CGI argument
61 my $action = $gsdl_cgi->clean_param("a");
62
63 if (!defined $action) {
64 my $err_mess = "No action (a=...) specified.\n";
65 $err_mess .= "\nPossible actions are:\n";
66
67 $err_mess .= " check-installation\n\n";
68
69 foreach my $a (sort keys %$action_table) {
70 $err_mess .= " $a:\n";
71 $err_mess .= " Compulsory args: ";
72 my @comp_args = ("c");
73 push(@comp_args,"un") if ($authenication_enabled);
74 push(@comp_args,@{$action_table->{$a}->{'compulsory-args'}});
75 $err_mess .= join(", ", @comp_args);
76
77 $err_mess .= "\n";
78
79 my @opt_args = ();
80 push(@opt_args,"un") if (!$authenication_enabled);
81 push(@opt_args,@{$action_table->{$a}->{'optional-args'}});
82
83 if (scalar(@opt_args)>0) {
84
85 $err_mess .= " Optional args : ";
86 $err_mess .= join(", ", @opt_args);
87 $err_mess .= "\n";
88 }
89
90 my @help_examples = ();
91 if(defined $action_table->{$a}->{'help-string'}) {
92 push(@help_examples, @{$action_table->{$a}->{'help-string'}});
93 }
94 if (scalar(@help_examples)>0) {
95
96 if (scalar(@help_examples)>1) {
97 $err_mess .= " Example(s) :\n";
98 } else {
99 $err_mess .= " Example :\n";
100 }
101 $err_mess .= join(", \n\n", @help_examples);
102 $err_mess .= "\n\nTo be strictly CGI-compliant special chars like double-quotes,&,?,<,> must be URL encoded.\n";
103 }
104
105 $err_mess .= "\n";
106 }
107
108 $gsdl_cgi->generate_message($err_mess);
109 exit(-1);
110
111 }
112 $gsdl_cgi->delete("a");
113
114 $self = bless $self, $class;
115
116 # The check-installation command has no arguments
117 if ($action eq "check-installation") {
118 $self->check_installation($gsdl_cgi,$iis6_mode);
119 exit 0;
120 }
121
122
123 if (!defined $action_table->{$action}) {
124 my $valid_actions = join(", ", keys %$action_table);
125
126 my $err_mess = "Unrecognised action (a=$action) specified.\n";
127 $err_mess .= "Valid actions are: $valid_actions\n";
128
129 $gsdl_cgi->generate_error($err_mess);
130 }
131
132
133 my $collect = $gsdl_cgi->clean_param("c");
134 if ((!defined $collect) || ($collect =~ m/^\s*$/)) {
135 $gsdl_cgi->generate_error("No collection specified.");
136 }
137 $gsdl_cgi->delete("c");
138
139 # allow un to be optional for now
140 my $username = $gsdl_cgi->clean_param("un");
141
142
143 # Get then remove the ts (timestamp) argument (since this can mess up
144 # other scripts)
145 my $timestamp = $gsdl_cgi->clean_param("ts");
146 if ((!defined $timestamp) || ($timestamp =~ m/^\s*$/)) {
147 # Fall back to using the Perl time() function to generate a timestamp
148 $timestamp = time();
149 }
150 $gsdl_cgi->delete("ts");
151
152 my $site = undef;
153 if($gsdl_cgi->greenstone_version() != 2) {
154 # all GS versions after 2 may define site
155 $site = $gsdl_cgi->clean_param("site");
156 if (!defined $site) {
157 $gsdl_cgi->generate_error("No site specified.");
158 }
159 $gsdl_cgi->delete("site");
160 }
161
162
163 $self->{'action'} = $action;
164 $self->{'collect'} = $collect;
165 $self->{'username'} = $username;
166 $self->{'timestamp'} = $timestamp;
167 $self->{'site'} = $site;
168
169 # Locate and store compulsory arguments
170 my $comp_args = $action_table->{$action}->{'compulsory-args'};
171 foreach my $ca (@$comp_args) {
172 if (!defined $gsdl_cgi->param($ca)) {
173 $gsdl_cgi->generate_error("Compulsory argument '$ca' missing");
174 }
175 else {
176 $self->{$ca} = $gsdl_cgi->clean_param($ca);
177 $gsdl_cgi->delete($ca);
178 }
179 }
180
181 # Locate and store optional args if present
182 my $opt_args = $action_table->{$action}->{'optional-args'};
183 foreach my $oa (@$opt_args) {
184 if (defined $gsdl_cgi->param($oa)) {
185 $self->{$oa} = $gsdl_cgi->clean_param($oa);
186 $gsdl_cgi->delete($oa);
187 }
188 }
189
190
191
192 # Retrieve infodb-type
193 if (defined $collect) {
194
195 my $opt_site = $self->{'site'} || "";
196
197 my $inexport = newCGI inexport(ref $self,$collect,$gsdl_cgi,$opt_site);
198 my ($config_filename,$collect_cfg) = $inexport->read_collection_cfg($collect);
199 $self->{'infodbtype'} = $collect_cfg->{'infodbtype'};
200
201 }
202
203
204 return $self;
205}
206
207
208sub do_action
209{
210 my $self = shift @_;
211 my $action = $self->{'action'};
212
213 $action =~ s/-/_/g;
214
215
216 $self->$action();
217
218}
219
220
221sub authenticate_user
222{
223 my $self = shift @_;
224 my $username = shift(@_);
225 my $collection = shift(@_);
226
227 my $gsdl_cgi = $self->{'gsdl_cgi'};
228
229 # Remove the pw argument (since this can mess up other scripts)
230 my $user_password = $gsdl_cgi->clean_param("pw");
231 $gsdl_cgi->delete("pw");
232
233 if ((!defined $user_password) || ($user_password =~ m/^\s*$/)) {
234 $gsdl_cgi->generate_error("Authentication failed: no password specified.");
235 }
236
237 my $gsdlhome = $ENV{'GSDLHOME'};
238 my $etc_directory = &util::filename_cat($gsdlhome, "etc");
239 my $users_db_file_path = &util::filename_cat($etc_directory, "users.db");
240
241 # Use db2txt to get the user accounts information
242 my $users_db_content = "";
243 open(USERS_DB, "db2txt \"$users_db_file_path\" |");
244 while (<USERS_DB>) {
245 $users_db_content .= $_;
246 }
247
248 # Get the user account information from the users.db database
249 my %users_db_data = ();
250 foreach my $users_db_entry (split(/-{70}/, $users_db_content)) {
251 if ($users_db_entry =~ /\n?\[(.+)\]\n/) {
252 $users_db_data{$1} = $users_db_entry;
253 }
254 }
255
256 # Check username
257 my $user_data = $users_db_data{$username};
258 if (!defined $user_data) {
259 $gsdl_cgi->generate_error("Authentication failed: no account for user '$username'.");
260 }
261
262 # Check password
263 my ($valid_user_password) = ($user_data =~ /\<password\>(.*)/);
264 if ($user_password ne $valid_user_password) {
265 $gsdl_cgi->generate_error("Authentication failed: incorrect password.");
266 }
267
268 # Check group
269 my ($user_groups) = ($user_data =~ /\<groups\>(.*)/);
270 if ($collection eq "") {
271 # If we're not editing a collection then the user doesn't need to be in a particular group
272 return $user_groups; # Authentication successful
273 }
274 foreach my $user_group (split(/\,/, $user_groups)) {
275 # Does this user have access to all collections?
276 if ($user_group eq "all-collections-editor") {
277 return $user_groups; # Authentication successful
278 }
279 # Does this user have access to personal collections, and is this one?
280 if ($user_group eq "personal-collections-editor" && $collection =~ /^$username\-/) {
281 return $user_groups; # Authentication successful
282 }
283 # Does this user have access to this collection
284 if ($user_group eq "$collection-collection-editor") {
285 return $user_groups; # Authentication successful
286 }
287 }
288
289 $gsdl_cgi->generate_error("Authentication failed: user is not in the required group.");
290}
291
292
293
294sub check_installation
295{
296 my $self = shift @_;
297 my $iis6_mode = shift(@_);
298
299 my $gsdl_cgi = $self->{'gsdl_cgi'};
300
301 my $installation_ok = 1;
302 my $installation_status = "";
303
304 print STDOUT "Content-type:text/plain\n\n";
305
306 # Check that Java is installed and accessible
307 my $java = $gsdl_cgi->get_java_path();
308 my $java_command = "$java -version 2>&1";
309
310 # IIS 6: redirecting output from STDERR to STDOUT just doesn't work, so we have to let it go
311 # directly out to the page
312 if ($iis6_mode)
313 {
314 $java_command = "java -version";
315 }
316
317 my $java_output = `$java_command`;
318 my $java_status = $?;
319 if ($java_status < 0) {
320 # The Java command failed
321 $installation_status = "Java failed -- do you have the Java run-time installed?\n" . $gsdl_cgi->check_java_home() . "\n";
322 $installation_ok = 0;
323 }
324 else {
325 $installation_status = "Java found: $java_output";
326 }
327
328 # Show the values of some important environment variables
329 $installation_status .= "\n";
330 $installation_status .= "GSDLHOME: " . $ENV{'GSDLHOME'} . "\n";
331 $installation_status .= "GSDLOS: " . $ENV{'GSDLOS'} . "\n";
332 $installation_status .= "PATH: " . $ENV{'PATH'} . "\n";
333
334 if ($installation_ok) {
335 print STDOUT $installation_status . "\nInstallation OK!";
336 }
337 else {
338 print STDOUT $installation_status;
339 }
340}
341
342sub lock_collection
343{
344 my $self = shift @_;
345 my $username = shift(@_);
346 my $collection = shift(@_);
347
348 my $gsdl_cgi = $self->{'gsdl_cgi'};
349
350 my $steal_lock = $gsdl_cgi->clean_param("steal_lock");
351 $gsdl_cgi->delete("steal_lock");
352
353 if (!defined $username) {
354 # don't have any user details for current user to compare with
355 # even if there is a lock file
356 # For now, allow the current user access. Might want to
357 # revisit this in the future.
358 return;
359 }
360
361 #my $gsdlhome = $ENV{'GSDLHOME'};
362 #my $collection_directory = &util::filename_cat($gsdlhome, "collect", $collection);
363 my $site = $self->{'site'};
364 my $collection_directory = $gsdl_cgi->get_collection_dir($site, $collection);
365 $gsdl_cgi->checked_chdir($collection_directory);
366
367 # Check if a lock file already exists for this collection
368 my $lock_file_name = "gli.lck";
369 if (-e $lock_file_name) {
370 # A lock file already exists... check if it's ours
371 my $lock_file_content = "";
372 open(LOCK_FILE, "<$lock_file_name");
373 while (<LOCK_FILE>) {
374 $lock_file_content .= $_;
375 }
376 close(LOCK_FILE);
377
378 # Pick out the owner of the lock file
379 $lock_file_content =~ /\<User\>(.*?)\<\/User\>/;
380 my $lock_file_owner = $1;
381
382 # The lock file is ours, so there is no problem
383 if ($lock_file_owner eq $username) {
384 return;
385 }
386
387 # The lock file is not ours, so throw an error unless "steal_lock" is set
388 unless (defined $steal_lock) {
389 $gsdl_cgi->generate_error("Collection is locked by: $lock_file_owner");
390 }
391 }
392
393 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
394 my $current_time = sprintf("%02d/%02d/%d %02d:%02d:%02d", $mday, $mon + 1, $year + 1900, $hour, $min, $sec);
395
396 # Create a lock file for us (in the same format as the GLI) and we're done
397 open(LOCK_FILE, ">$lock_file_name");
398 print LOCK_FILE "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
399 print LOCK_FILE "<LockFile>\n";
400 print LOCK_FILE " <User>" . $username . "</User>\n";
401 print LOCK_FILE " <Machine>(Remote)</Machine>\n";
402 print LOCK_FILE " <Date>" . $current_time . "</Date>\n";
403 print LOCK_FILE "</LockFile>\n";
404 close(LOCK_FILE);
405}
406
407
408# Release the gli.lck otherwise no one else will be able to use the collection again.
409sub unlock_collection
410{
411 my $self = shift @_;
412 my ($username, $collection) = @_;
413 my $gsdl_cgi = $self->{'gsdl_cgi'};
414
415 # Obtain the path to the collection GLI lock file
416 my $lock_file_path = &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection, "gli.lck");
417
418 # If the lock file does exist, check if it is ours
419 if (-e $lock_file_path)
420 {
421 my $lock_file_content = "";
422 open(LOCK_FILE, "<$lock_file_path");
423 while (<LOCK_FILE>) {
424 $lock_file_content .= $_;
425 }
426 close(LOCK_FILE);
427
428 # Pick out the owner of the lock file
429 $lock_file_content =~ /\<User\>(.*?)\<\/User\>/;
430 my $lock_file_owner = $1;
431
432 # If we are the owner of this lock, we have the right to delete it
433 if ($lock_file_owner eq $username) {
434 unlink($lock_file_path );
435 }
436 else {
437 $gsdl_cgi->generate_error("Collection is locked by: $lock_file_owner. Cannot be unlocked");
438 }
439 }
440}
441
442
443sub send_mail
444{
445 my $self = shift @_;
446
447 my ($mail_subject,$mail_content) = @_;
448
449 my $gsdl_cgi = $self->{'gsdl_cgi'};
450
451 my $sendmail_command = "\"".&util::get_perl_exec()."\" -S sendmail.pl";
452 $sendmail_command .= " -to \"" . $mail_to_address . "\"";
453 $sendmail_command .= " -from \"" . $mail_from_address . "\"";
454 $sendmail_command .= " -smtp \"" . $mail_smtp_server . "\"";
455 $sendmail_command .= " -subject \"" . $mail_subject . "\"";
456
457 if (!open(POUT, "| $sendmail_command")) {
458 $gsdl_cgi->generate_error("Unable to execute command: $sendmail_command");
459 }
460 print POUT $mail_content . "\n";
461 close(POUT);
462}
463
464
465sub run_script
466{
467 my $self = shift @_;
468
469 my ($collect, $site, $script) = @_;
470
471 my $gsdl_cgi = $self->{'gsdl_cgi'};
472
473 my $perl_args = $collect;
474
475 my $collect_dir = $gsdl_cgi->get_collection_dir($site);
476 $perl_args = "-collectdir \"$collect_dir\" " . $perl_args;
477
478 my $perl_command = "\"".&util::get_perl_exec()."\" -S $script $perl_args";
479
480
481 # IIS 6: redirecting output from STDERR to STDOUT just doesn't work, so
482 # we have to let it go directly out to the page
483
484 if (!$self->{'iis6_mode'})
485 {
486 $perl_command .= " 2>&1";
487 }
488
489 if (!open(PIN, "$perl_command |")) {
490 $gsdl_cgi->generate_error("Unable to execute command: $perl_command");
491 }
492
493 print STDOUT "Content-type:text/plain\n\n";
494 print "$perl_command \n";
495
496 while (defined (my $perl_output_line = <PIN>)) {
497 print STDOUT $perl_output_line;
498 }
499 close(PIN);
500
501 my $perl_status = $?;
502 if ($perl_status > 0) {
503 $gsdl_cgi->generate_error("Perl failed: $perl_command\n--\nExit status: " . ($perl_status / 256));
504 }
505}
506
5071;
Note: See TracBrowser for help on using the repository browser.