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

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

authentication_enabled flag turned on again after accidentally committing it turned off when debugging.

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("gdbm", $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.