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

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

key DB is gdbm and has no way of changing the DB type. Can't use infodbtype to work out its DB type, especially as infodbtype can be different on a per collection basis.

File size: 18.2 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
33# for time conversion and formatting functions
34use Time::Local;
35use POSIX;
36
37our $authentication_enabled = 1; # debugging flag (can debug without authentication when set to 0)
38our $mail_enabled = 0;
39
40
41# change this to get these values from a config file
42my $mail_to_address = "user\@server"; # Set this appropriately
43my $mail_from_address = "user\@server"; # Set this appropriately
44my $mail_smtp_server = "smtp.server"; # Set this appropriately
45
46
47
48# Required CGI arguments: "a" for action
49# "c" for collection
50# Optional CGI arguemnts: "ts" for timestamp (auto generated is missing)
51# "site" (used by Greenstone3)
52
53# allow "un" for username to be optional for now
54
55sub new
56{
57 my $class = shift (@_);
58 my ($action_table,$gsdl_cgi,$iis6_mode) = @_;
59
60 my $self = { 'gsdl_cgi' => $gsdl_cgi,
61 'iis6_mode' => $iis6_mode,
62 'gsdlhome' => $ENV{'GSDLHOME'} };
63
64 # Retrieve the (required) command CGI argument
65 my $action = $gsdl_cgi->clean_param("a");
66
67 if (!defined $action) {
68 my $err_mess = "No action (a=...) specified.\n";
69 $err_mess .= "\nPossible actions are:\n";
70
71 $err_mess .= " check-installation\n\n";
72
73 foreach my $a (sort keys %$action_table) {
74 $err_mess .= " $a:\n";
75 $err_mess .= " Compulsory args: ";
76 my @comp_args = ("c");
77 push(@comp_args,"un") if ($authentication_enabled);
78 push(@comp_args,@{$action_table->{$a}->{'compulsory-args'}});
79 $err_mess .= join(", ", @comp_args);
80
81 $err_mess .= "\n";
82
83 my @opt_args = ();
84 push(@opt_args,"un") if (!$authentication_enabled);
85 push(@opt_args,@{$action_table->{$a}->{'optional-args'}});
86
87 if (scalar(@opt_args)>0) {
88
89 $err_mess .= " Optional args : ";
90 $err_mess .= join(", ", @opt_args);
91 $err_mess .= "\n";
92 }
93
94 my @help_examples = ();
95 if(defined $action_table->{$a}->{'help-string'}) {
96 push(@help_examples, @{$action_table->{$a}->{'help-string'}});
97 }
98 if (scalar(@help_examples)>0) {
99
100 if (scalar(@help_examples)>1) {
101 $err_mess .= " Example(s) :\n";
102 } else {
103 $err_mess .= " Example :\n";
104 }
105 $err_mess .= join(", \n\n", @help_examples);
106 $err_mess .= "\n\nTo be strictly CGI-compliant special chars like double-quotes,&,?,<,> must be URL encoded.\n";
107 }
108
109 $err_mess .= "\n";
110 }
111
112 $gsdl_cgi->generate_message($err_mess);
113 exit(-1);
114
115 }
116 $gsdl_cgi->delete("a");
117
118 $self = bless $self, $class;
119
120 # The check-installation command has no arguments
121 if ($action eq "check-installation") {
122 $self->check_installation($gsdl_cgi,$iis6_mode);
123 exit 0;
124 }
125
126
127 if (!defined $action_table->{$action}) {
128 my $valid_actions = join(", ", keys %$action_table);
129
130 my $err_mess = "Unrecognised action (a=$action) specified.\n";
131 $err_mess .= "Valid actions are: $valid_actions\n";
132
133 $gsdl_cgi->generate_error($err_mess);
134 }
135
136
137 my $collect = $gsdl_cgi->clean_param("c");
138 if ((!defined $collect) || ($collect =~ m/^\s*$/)) {
139 $gsdl_cgi->generate_error("No collection specified.");
140 }
141 $gsdl_cgi->delete("c");
142
143 # allow un to be optional for now
144 my $username = $gsdl_cgi->clean_param("un");
145
146
147 # Get then remove the ts (timestamp) argument (since this can mess up
148 # other scripts)
149 my $timestamp = $gsdl_cgi->clean_param("ts");
150 if ((!defined $timestamp) || ($timestamp =~ m/^\s*$/)) {
151 # Fall back to using the Perl time() function to generate a timestamp
152 $timestamp = time();
153 }
154 $gsdl_cgi->delete("ts");
155
156 my $site = undef;
157 if($gsdl_cgi->greenstone_version() != 2) {
158 # all GS versions after 2 may define site
159 $site = $gsdl_cgi->clean_param("site");
160 if (!defined $site) {
161 $gsdl_cgi->generate_error("No site specified.");
162 }
163 $gsdl_cgi->delete("site");
164 }
165
166
167 $self->{'action'} = $action;
168 $self->{'collect'} = $collect;
169 $self->{'username'} = $username;
170 $self->{'timestamp'} = $timestamp;
171 $self->{'site'} = $site;
172
173 # Locate and store compulsory arguments
174 my $comp_args = $action_table->{$action}->{'compulsory-args'};
175 foreach my $ca (@$comp_args) {
176 if (!defined $gsdl_cgi->param($ca)) {
177 $gsdl_cgi->generate_error("Compulsory argument '$ca' missing");
178 }
179 else {
180 $self->{$ca} = $gsdl_cgi->clean_param($ca);
181 $gsdl_cgi->delete($ca);
182 }
183 }
184
185 # Locate and store optional args if present
186 my $opt_args = $action_table->{$action}->{'optional-args'};
187 foreach my $oa (@$opt_args) {
188 if (defined $gsdl_cgi->param($oa)) {
189 $self->{$oa} = $gsdl_cgi->clean_param($oa);
190 $gsdl_cgi->delete($oa);
191 }
192 }
193
194
195
196 # Retrieve infodb-type
197 if (defined $collect) {
198
199 my $opt_site = $self->{'site'} || "";
200
201 my $inexport = newCGI inexport(ref $self,$collect,$gsdl_cgi,$opt_site);
202 my ($config_filename,$collect_cfg) = $inexport->read_collection_cfg($collect);
203 $self->{'infodbtype'} = $collect_cfg->{'infodbtype'};
204
205 }
206
207
208 return $self;
209}
210
211
212sub do_action
213{
214 my $self = shift @_;
215 my $action = $self->{'action'};
216
217 $action =~ s/-/_/g;
218
219
220 $self->$action();
221
222}
223
224
225sub authenticate_user
226{
227 my $self = shift @_;
228 my $username = shift(@_);
229 my $collection = shift(@_);
230
231 my $keydecay = 1800; # 30 mins same as in runtime-src/recpt/authentication.cpp
232
233 my $gsdl_cgi = $self->{'gsdl_cgi'};
234
235 # Remove the pw argument (since this can mess up other scripts)
236 my $user_password = $gsdl_cgi->clean_param("pw");
237 my $user_key = $gsdl_cgi->clean_param("ky");
238
239 $gsdl_cgi->delete("pw");
240 $gsdl_cgi->delete("ky");
241
242 if ((!defined $user_password || $user_password =~ m/^\s*$/) && (!defined $user_key || $user_key =~ m/^\s*$/)) {
243 $gsdl_cgi->generate_error("Authentication failed: no password or key specified.");
244 }
245
246 my $gsdlhome = $ENV{'GSDLHOME'};
247 my $etc_directory = &util::filename_cat($gsdlhome, "etc");
248 my $users_db_file_path = &util::filename_cat($etc_directory, "users.gdb");
249
250 # Use db2txt to get the user accounts information
251 my $users_db_content = "";
252 open(USERS_DB, "db2txt \"$users_db_file_path\" |");
253 while (<USERS_DB>) {
254 $users_db_content .= $_;
255 }
256
257 # Get the user account information from the users.gdb database
258 my %users_db_data = ();
259 foreach my $users_db_entry (split(/-{70}/, $users_db_content)) {
260 if ($users_db_entry =~ /\n?\[(.+)\]\n/) {
261 $users_db_data{$1} = $users_db_entry;
262 }
263 }
264
265 # Check username
266 my $user_data = $users_db_data{$username};
267 if (!defined $user_data) {
268 $gsdl_cgi->generate_error("Authentication failed: no account for user '$username'.");
269 }
270
271 # Check password
272 if(defined $user_password) {
273 my ($valid_user_password) = ($user_data =~ /\<password\>(.*)/);
274 if ($user_password ne $valid_user_password) {
275 $gsdl_cgi->generate_error("Authentication failed: incorrect password.");
276 }
277 }
278 else { # check $user_key #if(!defined $user_password && defined $user_key) {
279
280 # check to see if there is a key for this particular user in the database that hasn't decayed.
281 # if the key validates, refresh the key again by setting its timestamp to the present time.
282
283 # Use db2txt to get the key accounts information
284 my $key_db_file_path = &util::filename_cat($etc_directory, "key.gdb");
285
286 my $key_db_content = "";
287 open(USERS_DB, "db2txt \"$key_db_file_path\" |");
288 while (<USERS_DB>) {
289 $key_db_content .= $_;
290 }
291
292 my %key_db_data = ();
293 foreach my $key_db_entry (split(/-{70}/, $key_db_content)) {
294 if ($key_db_entry =~ /\n?\[(.+)\]\n/) {
295 $key_db_data{$1} = $key_db_entry;
296 }
297 }
298
299 # check key entry
300 my $key_data = $key_db_data{$user_key};
301 if (!defined $key_data) {
302
303 #$gsdl_cgi->generate_error("Authentication failed: invalid key $user_key. Does not exist.");
304 $gsdl_cgi->generate_error("Authentication failed: invalid key. No entry for the given key.");
305 }
306 else {
307 my ($valid_username) = ($key_data =~ /\<user\>(.*)/);
308 if ($username ne $valid_username) {
309 $gsdl_cgi->generate_error("Authentication failed: key does not belong to user.");
310 }
311
312 # http://stackoverflow.com/questions/12644322/how-to-write-the-current-timestamp-in-a-file-perl
313 # http://stackoverflow.com/questions/2149532/how-can-i-format-a-timestamp-in-perl
314 # http://stackoverflow.com/questions/7726514/how-to-convert-text-date-to-timestamp
315
316 my $current_timestamp = time; #localtime(time);
317
318 my ($keycreation_time) = ($key_data =~ /\<time\>(.*)/); # of the form: 2013/05/06 14:39:23
319 if ($keycreation_time !~ m/^\s*$/) { # not empty
320
321 my ($year,$mon,$mday,$hour,$min,$sec) = split(/[\s\/:]+/, $keycreation_time); # split by space, /, :
322 my $key_timestamp = timelocal($sec,$min,$hour,$mday,$mon-1,$year);
323
324 if(($current_timestamp - $key_timestamp) > $keydecay) {
325 $gsdl_cgi->generate_error("Authentication failed: key has expired.");
326 } else {
327 # succeeded, update the key's time in the database
328
329 # beware http://community.activestate.com/forum/posixstrftime-problem-e-numeric-day-month
330 my $current_time = strftime("%Y/%m/%d %H:%M:%S\n", localtime($current_timestamp)); # POSIX
331
332 # infodbtype can be different for different collections, but the key DB is gdbm
333 my $key_rec = &dbutil::read_infodb_entry("gdbm", $key_db_file_path, $user_key);
334 $key_rec->{"time"}->[0] = $current_time;
335 my $status = &dbutil::set_infodb_entry($infodbtype, $key_db_file_path, $user_key, $key_rec);
336
337 if ($status != 0) {
338 $gsdl_cgi->generate_error("Error updating authentication key.");
339 }
340 }
341 } else {
342 $gsdl_cgi->generate_error("Authentication failed: Invalid key entry. No time stored for key.");
343 }
344 }
345 }
346
347 # The following code which tests whether the user is in the required group
348 # seems to have been copied over from gliserver.pl.
349 # But for metadata-server.pl, when user comments are added through the set-metadata functions,
350 # the user doesn't need to be a specific collection's editor in order to add comments to that collection.
351 # So we no longer check the user is in the group here.
352# $self->check_group($collection, $username, $user_data);
353}
354
355
356sub check_group
357{
358 my $self = shift @_;
359 my $collection = shift @_;
360 my $username = shift @_;
361 my $user_data = shift @_;
362
363
364 my $gsdl_cgi = $self->{'gsdl_cgi'};
365
366 # Check group
367 my ($user_groups) = ($user_data =~ /\<groups\>(.*)/);
368 if ($collection eq "") {
369 # If we're not editing a collection then the user doesn't need to be in a particular group
370 return $user_groups; # Authentication successful
371 }
372 foreach my $user_group (split(/\,/, $user_groups)) {
373 # Does this user have access to all collections?
374 if ($user_group eq "all-collections-editor") {
375 return $user_groups; # Authentication successful
376 }
377 # Does this user have access to personal collections, and is this one?
378 if ($user_group eq "personal-collections-editor" && $collection =~ /^$username\-/) {
379 return $user_groups; # Authentication successful
380 }
381 # Does this user have access to this collection
382 if ($user_group eq "$collection-collection-editor") {
383 return $user_groups; # Authentication successful
384 }
385 }
386
387 $gsdl_cgi->generate_error("Authentication failed: user is not in the required group.");
388}
389
390sub check_installation
391{
392 my $self = shift @_;
393 my $iis6_mode = shift(@_);
394
395 my $gsdl_cgi = $self->{'gsdl_cgi'};
396
397 my $installation_ok = 1;
398 my $installation_status = "";
399
400 print STDOUT "Content-type:text/plain\n\n";
401
402 # Check that Java is installed and accessible
403 my $java = $gsdl_cgi->get_java_path();
404 my $java_command = "$java -version 2>&1";
405
406 # IIS 6: redirecting output from STDERR to STDOUT just doesn't work, so we have to let it go
407 # directly out to the page
408 if ($iis6_mode)
409 {
410 $java_command = "java -version";
411 }
412
413 my $java_output = `$java_command`;
414 my $java_status = $?;
415 if ($java_status < 0) {
416 # The Java command failed
417 $installation_status = "Java failed -- do you have the Java run-time installed?\n" . $gsdl_cgi->check_java_home() . "\n";
418 $installation_ok = 0;
419 }
420 else {
421 $installation_status = "Java found: $java_output";
422 }
423
424 # Show the values of some important environment variables
425 $installation_status .= "\n";
426 $installation_status .= "GSDLHOME: " . $ENV{'GSDLHOME'} . "\n";
427 $installation_status .= "GSDLOS: " . $ENV{'GSDLOS'} . "\n";
428 $installation_status .= "PATH: " . $ENV{'PATH'} . "\n";
429
430 if ($installation_ok) {
431 print STDOUT $installation_status . "\nInstallation OK!";
432 }
433 else {
434 print STDOUT $installation_status;
435 }
436}
437
438sub lock_collection
439{
440 my $self = shift @_;
441 my $username = shift(@_);
442 my $collection = shift(@_);
443
444 my $gsdl_cgi = $self->{'gsdl_cgi'};
445
446 my $steal_lock = $gsdl_cgi->clean_param("steal_lock");
447 $gsdl_cgi->delete("steal_lock");
448
449 if (!defined $username) {
450 # don't have any user details for current user to compare with
451 # even if there is a lock file
452 # For now, allow the current user access. Might want to
453 # revisit this in the future.
454 return;
455 }
456
457 #my $gsdlhome = $ENV{'GSDLHOME'};
458 #my $collection_directory = &util::filename_cat($gsdlhome, "collect", $collection);
459 my $site = $self->{'site'};
460 my $collection_directory = $gsdl_cgi->get_collection_dir($site, $collection);
461 $gsdl_cgi->checked_chdir($collection_directory);
462
463 # Check if a lock file already exists for this collection
464 my $lock_file_name = "gli.lck";
465 if (-e $lock_file_name) {
466 # A lock file already exists... check if it's ours
467 my $lock_file_content = "";
468 open(LOCK_FILE, "<$lock_file_name");
469 while (<LOCK_FILE>) {
470 $lock_file_content .= $_;
471 }
472 close(LOCK_FILE);
473
474 # Pick out the owner of the lock file
475 $lock_file_content =~ /\<User\>(.*?)\<\/User\>/;
476 my $lock_file_owner = $1;
477
478 # The lock file is ours, so there is no problem
479 if ($lock_file_owner eq $username) {
480 return;
481 }
482
483 # The lock file is not ours, so throw an error unless "steal_lock" is set
484 unless (defined $steal_lock) {
485 $gsdl_cgi->generate_error("Collection is locked by: $lock_file_owner");
486 }
487 }
488
489 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
490 my $current_time = sprintf("%02d/%02d/%d %02d:%02d:%02d", $mday, $mon + 1, $year + 1900, $hour, $min, $sec);
491
492 # Create a lock file for us (in the same format as the GLI) and we're done
493 open(LOCK_FILE, ">$lock_file_name");
494 print LOCK_FILE "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
495 print LOCK_FILE "<LockFile>\n";
496 print LOCK_FILE " <User>" . $username . "</User>\n";
497 print LOCK_FILE " <Machine>(Remote)</Machine>\n";
498 print LOCK_FILE " <Date>" . $current_time . "</Date>\n";
499 print LOCK_FILE "</LockFile>\n";
500 close(LOCK_FILE);
501}
502
503
504# Release the gli.lck otherwise no one else will be able to use the collection again.
505sub unlock_collection
506{
507 my $self = shift @_;
508 my ($username, $collection) = @_;
509 my $gsdl_cgi = $self->{'gsdl_cgi'};
510
511 # Obtain the path to the collection GLI lock file
512 my $lock_file_path = &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection, "gli.lck");
513
514 # If the lock file does exist, check if it is ours
515 if (-e $lock_file_path)
516 {
517 my $lock_file_content = "";
518 open(LOCK_FILE, "<$lock_file_path");
519 while (<LOCK_FILE>) {
520 $lock_file_content .= $_;
521 }
522 close(LOCK_FILE);
523
524 # Pick out the owner of the lock file
525 $lock_file_content =~ /\<User\>(.*?)\<\/User\>/;
526 my $lock_file_owner = $1;
527
528 # If we are the owner of this lock, we have the right to delete it
529 if ($lock_file_owner eq $username) {
530 unlink($lock_file_path );
531 }
532 else {
533 $gsdl_cgi->generate_error("Collection is locked by: $lock_file_owner. Cannot be unlocked");
534 }
535 }
536}
537
538
539sub send_mail
540{
541 my $self = shift @_;
542
543 my ($mail_subject,$mail_content) = @_;
544
545 my $gsdl_cgi = $self->{'gsdl_cgi'};
546
547 my $sendmail_command = "\"".&util::get_perl_exec()."\" -S sendmail.pl";
548 $sendmail_command .= " -to \"" . $mail_to_address . "\"";
549 $sendmail_command .= " -from \"" . $mail_from_address . "\"";
550 $sendmail_command .= " -smtp \"" . $mail_smtp_server . "\"";
551 $sendmail_command .= " -subject \"" . $mail_subject . "\"";
552
553 if (!open(POUT, "| $sendmail_command")) {
554 $gsdl_cgi->generate_error("Unable to execute command: $sendmail_command");
555 }
556 print POUT $mail_content . "\n";
557 close(POUT);
558}
559
560
561sub run_script
562{
563 my $self = shift @_;
564
565 my ($collect, $site, $script) = @_;
566
567 my $gsdl_cgi = $self->{'gsdl_cgi'};
568
569 my $perl_args = $collect;
570
571 my $collect_dir = $gsdl_cgi->get_collection_dir($site);
572 $perl_args = "-collectdir \"$collect_dir\" " . $perl_args;
573
574 my $perl_command = "\"".&util::get_perl_exec()."\" -S $script $perl_args";
575
576
577 # IIS 6: redirecting output from STDERR to STDOUT just doesn't work, so
578 # we have to let it go directly out to the page
579
580 if (!$self->{'iis6_mode'})
581 {
582 $perl_command .= " 2>&1";
583 }
584
585 if (!open(PIN, "$perl_command |")) {
586 $gsdl_cgi->generate_error("Unable to execute command: $perl_command");
587 }
588
589 print STDOUT "Content-type:text/plain\n\n";
590 print "$perl_command \n";
591
592 while (defined (my $perl_output_line = <PIN>)) {
593 print STDOUT $perl_output_line;
594 }
595 close(PIN);
596
597 my $perl_status = $?;
598 if ($perl_status > 0) {
599 $gsdl_cgi->generate_error("Perl failed: $perl_command\n--\nExit status: " . ($perl_status / 256));
600 }
601}
602
6031;
Note: See TracBrowser for help on using the repository browser.