source: gsdl/trunk/perllib/cgiactions/baseaction.pm@ 19293

Last change on this file since 19293 was 19293, checked in by davidb, 15 years ago

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