root/main/trunk/greenstone2/perllib/cgiactions/baseaction.pm @ 27775

Revision 27775, 18.0 KB (checked in by ak19, 7 years ago)

Commented out message on GS3 still not having authentication implemented since this appears before content-type declaration.

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
229    my $gsdl_cgi = $self->{'gsdl_cgi'};
230
231    # For now, we don't authenticate for GS3 as this still needs to be implemented for it.
232    if($gsdl_cgi->greenstone_version() == 3) {
233    #$gsdl_cgi->generate_message("**** To do: still need to authenticate for GS3.");
234    return;
235    }   
236
237    my $username = shift(@_);
238    my $collection = shift(@_);
239
240    my $keydecay = 1800; # 30 mins same as in runtime-src/recpt/authentication.cpp
241
242
243    # Remove the pw argument (since this can mess up other scripts)
244    my $user_password = $gsdl_cgi->clean_param("pw");
245    my $user_key = $gsdl_cgi->clean_param("ky");
246
247    $gsdl_cgi->delete("pw");
248    $gsdl_cgi->delete("ky");
249
250    if ((!defined $user_password || $user_password =~ m/^\s*$/) && (!defined $user_key || $user_key =~ m/^\s*$/)) {
251    $gsdl_cgi->generate_error("Authentication failed: no password or key specified.");
252    }
253
254    my $gsdlhome = $ENV{'GSDLHOME'};
255    my $etc_directory = &util::filename_cat($gsdlhome, "etc");
256    my $users_db_file_path = &util::filename_cat($etc_directory, "users.gdb");
257
258    # Use dbutil to get the user accounts information
259    # infodbtype can be different for different collections, but the userDB and keyDB are gdbm
260
261    my $user_rec = &dbutil::read_infodb_entry("gdbm", $users_db_file_path, $username);
262    # Check username
263    if (!defined $user_rec) {
264    $gsdl_cgi->generate_error("Authentication failed: no account for user '$username'.");
265    }
266   
267    # Check password
268    if(defined $user_password) {
269    my $valid_user_password = $user_rec->{"password"}->[0];
270    if ($user_password ne $valid_user_password) {
271        $gsdl_cgi->generate_error("Authentication failed: incorrect password.");
272    }
273    }
274    else { # check $user_key #if(!defined $user_password && defined $user_key) {
275   
276    # check to see if there is a key for this particular user in the database that hasn't decayed.
277    # if the key validates, refresh the key again by setting its timestamp to the present time.
278
279    # Use dbutil to get the key accounts information
280    my $key_db_file_path = &util::filename_cat($etc_directory, "key.gdb");
281    my $key_rec = &dbutil::read_infodb_entry("gdbm", $key_db_file_path, $user_key);
282
283    if (!defined $key_rec) {
284       
285        #$gsdl_cgi->generate_error("Authentication failed: invalid key $user_key. Does not exist.");
286        $gsdl_cgi->generate_error("Authentication failed: invalid key. No entry for the given key.");
287    }
288    else {
289        my $valid_username = $key_rec->{"user"}->[0];
290        if ($username ne $valid_username) {
291        $gsdl_cgi->generate_error("Authentication failed: key does not belong to user.");
292        }
293       
294        # http://stackoverflow.com/questions/12644322/how-to-write-the-current-timestamp-in-a-file-perl
295        # http://stackoverflow.com/questions/2149532/how-can-i-format-a-timestamp-in-perl
296        # http://stackoverflow.com/questions/7726514/how-to-convert-text-date-to-timestamp
297       
298        my $current_timestamp = time; #localtime(time);
299       
300        my $keycreation_time = $key_rec->{"time"}->[0]; # of the form: 2013/05/06 14:39:23
301        if ($keycreation_time !~ m/^\s*$/) { # not empty
302       
303        my ($year,$mon,$mday,$hour,$min,$sec) = split(/[\s\/:]+/, $keycreation_time); # split by space, /, :
304                           # (also ensures whitespace surrounding keycreateion_time is trimmed)
305        my $key_timestamp = timelocal($sec,$min,$hour,$mday,$mon-1,$year);
306       
307        if(($current_timestamp - $key_timestamp) > $keydecay) {
308            $gsdl_cgi->generate_error("Authentication failed: key has expired.");
309        } else {
310            # succeeded, update the key's time in the database
311           
312            # beware http://community.activestate.com/forum/posixstrftime-problem-e-numeric-day-month
313            my $current_time = strftime("%Y/%m/%d %H:%M:%S", localtime($current_timestamp)); # POSIX
314           
315            # infodbtype can be different for different collections, but the key DB is gdbm
316            my $key_rec = &dbutil::read_infodb_entry("gdbm", $key_db_file_path, $user_key);
317            $key_rec->{"time"}->[0] = $current_time;
318            my $status = &dbutil::set_infodb_entry("gdbm", $key_db_file_path, $user_key, $key_rec);
319           
320            if ($status != 0) {
321            $gsdl_cgi->generate_error("Error updating authentication key.");
322            }
323        }
324        } else {
325        $gsdl_cgi->generate_error("Authentication failed: Invalid key entry. No time stored for key.");
326        }       
327    }
328    }
329
330    # The following code which tests whether the user is in the required group
331    # seems to have been copied over from gliserver.pl.
332    # But when user comments are added through the set-metadata functions for metadata-server.pl
333    # (which is the first feature for which baseaction::authenticate_user() is actually used)
334    # the user doesn't need to be a specific collection's editor in order to add comments to that collection.
335    # So we no longer check the user is in the group here.
336#    $self->check_group($collection, $username, $user_data);
337}
338
339
340sub check_group
341{
342    my $self = shift @_;
343    my $collection = shift @_;
344    my $username = shift @_;
345    my $user_data = shift @_;
346
347
348    my $gsdl_cgi = $self->{'gsdl_cgi'};
349
350    # Check group
351    my ($user_groups) = ($user_data =~ /\<groups\>(.*)/);
352    if ($collection eq "") {
353    # If we're not editing a collection then the user doesn't need to be in a particular group
354    return $user_groups;  # Authentication successful
355    }
356    foreach my $user_group (split(/\,/, $user_groups)) {
357    # Does this user have access to all collections?
358    if ($user_group eq "all-collections-editor") {
359        return $user_groups;  # Authentication successful
360    }
361    # Does this user have access to personal collections, and is this one?
362    if ($user_group eq "personal-collections-editor" && $collection =~ /^$username\-/) {
363        return $user_groups;  # Authentication successful
364    }
365    # Does this user have access to this collection
366    if ($user_group eq "$collection-collection-editor") {
367        return $user_groups;  # Authentication successful
368    }
369    }
370   
371    $gsdl_cgi->generate_error("Authentication failed: user is not in the required group.");
372}
373
374sub check_installation
375{
376    my $self = shift @_;
377    my $iis6_mode = shift(@_);
378
379    my $gsdl_cgi = $self->{'gsdl_cgi'};
380
381    my $installation_ok = 1;
382    my $installation_status = "";
383
384    print STDOUT "Content-type:text/plain\n\n";
385
386    # Check that Java is installed and accessible
387    my $java = $gsdl_cgi->get_java_path();
388    my $java_command = "$java -version 2>&1";
389
390    # IIS 6: redirecting output from STDERR to STDOUT just doesn't work, so we have to let it go
391    #   directly out to the page
392    if ($iis6_mode)
393    {
394    $java_command = "java -version";
395    }
396
397    my $java_output = `$java_command`;
398    my $java_status = $?;
399    if ($java_status < 0) {
400    # The Java command failed
401    $installation_status = "Java failed -- do you have the Java run-time installed?\n" . $gsdl_cgi->check_java_home() . "\n";
402    $installation_ok = 0;
403    }
404    else {
405    $installation_status = "Java found: $java_output";
406    }
407
408    # Show the values of some important environment variables
409    $installation_status .= "\n";
410    $installation_status .= "GSDLHOME: " . $ENV{'GSDLHOME'} . "\n";
411    $installation_status .= "GSDLOS: " . $ENV{'GSDLOS'} . "\n";
412    $installation_status .= "PATH: " . $ENV{'PATH'} . "\n";
413
414    if ($installation_ok) {
415    print STDOUT $installation_status . "\nInstallation OK!";
416    }
417    else {
418    print STDOUT $installation_status;
419    }
420}
421
422sub lock_collection
423{
424    my $self = shift @_;
425    my $username = shift(@_);
426    my $collection = shift(@_);
427
428    my $gsdl_cgi = $self->{'gsdl_cgi'};
429
430    my $steal_lock = $gsdl_cgi->clean_param("steal_lock");
431    $gsdl_cgi->delete("steal_lock");
432
433    if (!defined $username) {
434    # don't have any user details for current user to compare with
435    # even if there is a lock file
436    # For now, allow the current user access.  Might want to
437    # revisit this in the future.
438    return;
439    }
440
441    #my $gsdlhome = $ENV{'GSDLHOME'};
442    #my $collection_directory = &util::filename_cat($gsdlhome, "collect", $collection);
443    my $site = $self->{'site'};
444    my $collection_directory = $gsdl_cgi->get_collection_dir($site, $collection);
445    $gsdl_cgi->checked_chdir($collection_directory);
446
447    # Check if a lock file already exists for this collection
448    my $lock_file_name = "gli.lck";
449    if (-e $lock_file_name) {
450    # A lock file already exists... check if it's ours
451    my $lock_file_content = "";
452    open(LOCK_FILE, "<$lock_file_name");
453    while (<LOCK_FILE>) {
454        $lock_file_content .= $_;
455    }
456    close(LOCK_FILE);
457
458    # Pick out the owner of the lock file
459    $lock_file_content =~ /\<User\>(.*?)\<\/User\>/;
460    my $lock_file_owner = $1;
461
462    # The lock file is ours, so there is no problem
463    if ($lock_file_owner eq $username) {
464        return;
465    }
466
467    # The lock file is not ours, so throw an error unless "steal_lock" is set
468    unless (defined $steal_lock) {
469        $gsdl_cgi->generate_error("Collection is locked by: $lock_file_owner");
470    }
471    }
472
473    my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
474    my $current_time = sprintf("%02d/%02d/%d %02d:%02d:%02d", $mday, $mon + 1, $year + 1900, $hour, $min, $sec);
475
476    # Create a lock file for us (in the same format as the GLI) and we're done
477    open(LOCK_FILE, ">$lock_file_name");
478    print LOCK_FILE "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
479    print LOCK_FILE "<LockFile>\n";
480    print LOCK_FILE "    <User>" . $username . "</User>\n";
481    print LOCK_FILE "    <Machine>(Remote)</Machine>\n";
482    print LOCK_FILE "    <Date>" . $current_time . "</Date>\n";
483    print LOCK_FILE "</LockFile>\n";
484    close(LOCK_FILE);
485}
486
487
488# Release the gli.lck otherwise no one else will be able to use the collection again.
489sub unlock_collection
490{
491    my $self = shift @_;
492    my ($username, $collection) = @_;
493    my $gsdl_cgi = $self->{'gsdl_cgi'};
494
495    # Obtain the path to the collection GLI lock file
496    my $lock_file_path = &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection, "gli.lck");
497
498    # If the lock file does exist, check if it is ours
499    if (-e $lock_file_path)
500    {
501    my $lock_file_content = "";
502    open(LOCK_FILE, "<$lock_file_path");
503    while (<LOCK_FILE>) {
504        $lock_file_content .= $_;
505    }
506    close(LOCK_FILE);
507
508    # Pick out the owner of the lock file
509    $lock_file_content =~ /\<User\>(.*?)\<\/User\>/;
510    my $lock_file_owner = $1;
511
512    # If we are the owner of this lock, we have the right to delete it
513    if ($lock_file_owner eq $username) {
514            unlink($lock_file_path );
515    }
516        else {
517        $gsdl_cgi->generate_error("Collection is locked by: $lock_file_owner. Cannot be unlocked");
518        }
519    }
520}
521
522
523sub send_mail
524{
525    my $self = shift @_;
526
527    my ($mail_subject,$mail_content) = @_;
528
529    my $gsdl_cgi = $self->{'gsdl_cgi'};
530
531    my $sendmail_command = "\"".&util::get_perl_exec()."\" -S sendmail.pl";
532    $sendmail_command .= " -to \"" . $mail_to_address . "\"";
533    $sendmail_command .= " -from \"" . $mail_from_address . "\"";
534    $sendmail_command .= " -smtp \"" . $mail_smtp_server . "\"";
535    $sendmail_command .= " -subject \"" . $mail_subject . "\"";
536
537    if (!open(POUT, "| $sendmail_command")) {
538    $gsdl_cgi->generate_error("Unable to execute command: $sendmail_command");
539    }
540    print POUT $mail_content . "\n";
541    close(POUT);
542}
543
544
545sub run_script
546{
547    my $self = shift @_;
548
549    my ($collect, $site, $script) = @_;
550
551    my $gsdl_cgi = $self->{'gsdl_cgi'};
552
553    my $perl_args = $collect;
554
555    my $collect_dir = $gsdl_cgi->get_collection_dir($site);
556    $perl_args = "-collectdir \"$collect_dir\" " . $perl_args;
557
558    my $perl_command = "\"".&util::get_perl_exec()."\" -S $script $perl_args";
559
560
561    # IIS 6: redirecting output from STDERR to STDOUT just doesn't work, so
562    # we have to let it go directly out to the page
563
564    if (!$self->{'iis6_mode'})
565    {
566    $perl_command .= " 2>&1";
567    }
568
569    if (!open(PIN, "$perl_command |")) {
570    $gsdl_cgi->generate_error("Unable to execute command: $perl_command");
571    }
572
573    print STDOUT "Content-type:text/plain\n\n";
574    print "$perl_command  \n";
575
576    while (defined (my $perl_output_line = <PIN>)) {
577    print STDOUT $perl_output_line;
578    }
579    close(PIN);
580
581    my $perl_status = $?;
582    if ($perl_status > 0) {
583    $gsdl_cgi->generate_error("Perl failed: $perl_command\n--\nExit status: " . ($perl_status / 256));
584    }
585}
586
5871;
Note: See TracBrowser for help on using the browser.