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

Revision 23401, 13.5 KB (checked in by max, 9 years ago)

Tested using this action under windows using Sqlite as the database. Code needed a variety of updates to support this.

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