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

Revision 24192, 13.8 KB (checked in by ak19, 8 years ago)

Sam discovered that using dollar-Config{perlpath} in place of dollar-hat-X is the better way to obtain the path to the perl that is being used. We hope this will not be a relative path on the Mac as dollar-hat-x was on Professor Witten's Mac when we tried it there today.

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