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

Revision 25097, 13.8 KB (checked in by sjm84, 8 years ago)

More changes to metadataaction as well as sorting the keys when printing

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