[system] / branches / rel-2-4-dev / webwork-modperl / lib / WeBWorK.pm Repository:
ViewVC logotype

Annotation of /branches/rel-2-4-dev/webwork-modperl/lib/WeBWorK.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4491 - (view) (download) (as text)
Original Path: trunk/webwork-modperl/lib/WeBWorK.pm

1 : sh002i 986 ################################################################################
2 : sh002i 1663 # WeBWorK Online Homework Delivery System
3 : sh002i 3973 # Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/
4 : sh002i 4491 # $CVSHeader: webwork2/lib/WeBWorK.pm,v 1.92 2006/08/14 18:14:22 sh002i Exp $
5 : sh002i 1663 #
6 :     # This program is free software; you can redistribute it and/or modify it under
7 :     # the terms of either: (a) the GNU General Public License as published by the
8 :     # Free Software Foundation; either version 2, or (at your option) any later
9 :     # version, or (b) the "Artistic License" which comes with this package.
10 :     #
11 :     # This program is distributed in the hope that it will be useful, but WITHOUT
12 :     # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
13 :     # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the
14 :     # Artistic License for more details.
15 : sh002i 986 ################################################################################
16 :    
17 :     package WeBWorK;
18 :    
19 :     =head1 NAME
20 :    
21 : sh002i 1565 WeBWorK - Dispatch requests to the appropriate content generator.
22 : sh002i 986
23 : sh002i 1565 =head1 SYNOPSIS
24 :    
25 :     my $r = Apache->request;
26 :     my $result = eval { WeBWorK::dispatch($r) };
27 :     die "something bad happened: $@" if $@;
28 :    
29 :     =head1 DESCRIPTION
30 :    
31 :     C<WeBWorK> is the dispatcher for the WeBWorK system. Given an Apache request
32 :     object, it performs authentication and determines which subclass of
33 :     C<WeBWorK::ContentGenerator> to call.
34 :    
35 : sh002i 986 =cut
36 :    
37 : sh002i 4010 BEGIN { $main::VERSION = "2.x"; }
38 : sh002i 1548
39 : sh002i 986 use strict;
40 :     use warnings;
41 : sh002i 3535 use Time::HiRes qw/time/;
42 : sh002i 2368
43 :     # load WeBWorK::Constants before anything else
44 :     # this sets package variables in several packages
45 :     use WeBWorK::Constants;
46 :    
47 : sh002i 4304 use WeBWorK::Authen;
48 : sh002i 986 use WeBWorK::Authz;
49 :     use WeBWorK::CourseEnvironment;
50 :     use WeBWorK::DB;
51 : sh002i 2368 use WeBWorK::Debug;
52 :     use WeBWorK::Request;
53 : sh002i 1616 use WeBWorK::Upload;
54 : sh002i 1836 use WeBWorK::URLPath;
55 : sh002i 3535 use WeBWorK::Utils qw(runtime_use writeTimingLogEntry);
56 : sh002i 1836
57 : sh002i 4243 use mod_perl;
58 :     use constant MP2 => ( exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 );
59 :    
60 :     # Apache2 needs upload class
61 :     BEGIN {
62 :     if (MP2) {
63 :     require Apache2::Upload;
64 :     Apache2::Upload->import();
65 : sh002i 4262 require Apache2::RequestUtil;
66 :     Apache2::RequestUtil->import();
67 : sh002i 4243 }
68 :     }
69 :    
70 : sh002i 4046 use constant LOGIN_MODULE => "WeBWorK::ContentGenerator::Login";
71 :     use constant PROCTOR_LOGIN_MODULE => "WeBWorK::ContentGenerator::LoginProctor";
72 : sh002i 1836
73 : sh002i 4491 BEGIN {
74 :     # pre-compile all content generators
75 :     # Login and LoginProctor need to be handled separately, since they don't have paths
76 :     map { eval "require $_" }
77 :     WeBWorK::URLPath->all_modules,
78 :     LOGIN_MODULE,
79 :     PROCTOR_LOGIN_MODULE;
80 :     # other candidates for preloading:
81 :     # - DB Record, Schema, and Driver classes (esp. Driver::SQL as it loads DBI)
82 :     # - CourseManagement subclasses (ditto. sql_single.pm)
83 :     # - WeBWorK::PG::Local, which loads WeBWorK::PG::Translator
84 :     # - Authen subclasses
85 :     }
86 :    
87 : sh002i 2491 our %SeedCE;
88 :    
89 : sh002i 1879 sub dispatch($) {
90 : sh002i 1836 my ($apache) = @_;
91 : sh002i 4262 my $r = new WeBWorK::Request($apache);
92 : sh002i 1836
93 :     my $method = $r->method;
94 :     my $location = $r->location;
95 :     my $uri = $r->uri;
96 :     my $path_info = $r->path_info | "";
97 :     my $args = $r->args || "";
98 : sh002i 2491 #my $webwork_root = $r->dir_config("webwork_root");
99 :     #my $pg_root = $r->dir_config("pg_root");
100 : sh002i 1836
101 : sh002i 2638 debug("\n\n===> Begin " . __PACKAGE__ . "::dispatch() <===\n\n");
102 : sh002i 1836 debug("Hi, I'm the new dispatcher!\n");
103 :     debug(("-" x 80) . "\n");
104 :    
105 :     debug("Okay, I got some basic information:\n");
106 :     debug("The apache location is $location\n");
107 :     debug("The request method is $method\n");
108 :     debug("The URI is $uri\n");
109 :     debug("The path-info is $path_info\n");
110 :     debug("The argument string is $args\n");
111 : sh002i 2491 #debug("The WeBWorK root directory is $webwork_root\n");
112 :     #debug("The PG root directory is $pg_root\n");
113 : sh002i 1836 debug(("-" x 80) . "\n");
114 :    
115 :     debug("The first thing we need to do is munge the path a little:\n");
116 :    
117 :     my ($path) = $uri =~ m/$location(.*)/;
118 :     $path = "/" if $path eq ""; # no path at all
119 :    
120 :     debug("We can't trust the path-info, so we make our own path.\n");
121 :     debug("path-info claims: $path_info\n");
122 :     debug("but it's really: $path\n");
123 :     debug("(if it's empty, we set it to \"/\".)\n");
124 :    
125 :     $path =~ s|/+|/|g;
126 :     debug("...and here it is without repeated slashes: $path\n");
127 :    
128 :     # lookbehind assertion for "not a slash"
129 :     # matches the boundary after the last char
130 :     $path =~ s|(?<=[^/])$|/|;
131 :     debug("...and here it is with a trailing slash: $path\n");
132 :    
133 :     debug(("-" x 80) . "\n");
134 :    
135 :     debug("Now we need to look at the path a little to figure out where we are\n");
136 :    
137 :     debug("-------------------- call to WeBWorK::URLPath::newFromPath\n");
138 : sh002i 1885 my $urlPath = WeBWorK::URLPath->newFromPath($path);
139 : sh002i 1836 debug("-------------------- call to WeBWorK::URLPath::newFromPath\n");
140 :    
141 :     unless ($urlPath) {
142 :     debug("This path is invalid... see you later!\n");
143 : sh002i 2434 die "The path '$path' is not valid.\n";
144 : sh002i 1836 }
145 :    
146 :     my $displayModule = $urlPath->module;
147 :     my %displayArgs = $urlPath->args;
148 : sh002i 2434
149 : sh002i 2970 unless ($displayModule) {
150 :     debug("The display module is empty, so we can DECLINE here.\n");
151 :     die "No display module found for path '$path'.";
152 :     }
153 :    
154 : sh002i 1836 debug("The display module for this path is: $displayModule\n");
155 :     debug("...and here are the arguments we'll pass to it:\n");
156 :     foreach my $key (keys %displayArgs) {
157 :     debug("\t$key => $displayArgs{$key}\n");
158 :     }
159 :    
160 :     my $selfPath = $urlPath->path;
161 :     my $parent = $urlPath->parent;
162 :     my $parentPath = $parent ? $parent->path : "<no parent>";
163 :    
164 :     debug("Reconstructing the original path gets us: $selfPath\n");
165 :     debug("And we can generate the path to our parent, too: $parentPath\n");
166 :     debug("(We could also figure out who our children are, but we'd need to supply additional arguments.)\n");
167 :     debug(("-" x 80) . "\n");
168 :    
169 : sh002i 1885 debug("The URLPath looks good, we'll add it to the request.\n");
170 :     $r->urlpath($urlPath);
171 :    
172 : sh002i 1836 debug("Now we want to look at the parameters we got.\n");
173 :    
174 :     debug("The raw params:\n");
175 :     foreach my $key ($r->param) {
176 : sh002i 4211 my @vals = $r->param($key);
177 :     my $vals = join(", ", map { "'$_'" } @vals);
178 :     debug("\t$key => $vals\n");
179 : sh002i 1836 }
180 :    
181 : sh002i 1895 #mungeParams($r);
182 : sh002i 4211 #
183 :     #debug("The munged params:\n");
184 :     #foreach my $key ($r->param) {
185 :     # debug("\t$key\n");
186 :     # debug("\t\t$_\n") foreach $r->param($key);
187 :     #}
188 : sh002i 1836
189 :     debug(("-" x 80) . "\n");
190 :    
191 : sh002i 4374 my $apache_hostname = $r->hostname;
192 :     my $apache_port = $r->get_server_port;
193 :     my $apache_is_ssl = ($r->subprocess_env('https') ? 1 : "");
194 :     my $apache_root_url;
195 :     if ($r->subprocess_env('https')) {
196 :     $apache_root_url = "https://$apache_hostname";
197 :     $apache_root_url .= ":$apache_port" if $apache_port != 443;
198 :     } else {
199 :     $apache_root_url = "http://$apache_hostname";
200 :     $apache_root_url .= ":$apache_port" if $apache_port != 80;
201 :     }
202 :    
203 : sh002i 1836 debug("We need to get a course environment (with or without a courseID!)\n");
204 : sh002i 2491 my $ce = eval { new WeBWorK::CourseEnvironment({
205 :     %SeedCE,
206 :     courseName => $displayArgs{courseID},
207 : sh002i 4374 # this is kind of a hack, but it's really the only sane way to get this
208 :     # server information into the PG box
209 :     apache_hostname => $apache_hostname,
210 :     apache_port => $apache_port,
211 :     apache_is_ssl => $apache_is_ssl,
212 :     apache_root_url => $apache_root_url,
213 : sh002i 2491 }) };
214 : sh002i 2437 $@ and die "Failed to initialize course environment: $@\n";
215 : sh002i 1836 debug("Here's the course environment: $ce\n");
216 : sh002i 1885 $r->ce($ce);
217 : sh002i 1836
218 : sh002i 4243 my @uploads;
219 :     if (MP2) {
220 :     my $upload_table = $r->upload;
221 :     @uploads = values %$upload_table if defined $upload_table;
222 :     } else {
223 :     @uploads = $r->upload;
224 :     }
225 : sh002i 1879 foreach my $u (@uploads) {
226 :     # make sure it's a "real" upload
227 :     next unless $u->filename;
228 :    
229 :     # store the upload
230 :     my $upload = WeBWorK::Upload->store($u,
231 :     dir => $ce->{webworkDirs}->{uploadCache}
232 :     );
233 :    
234 :     # store the upload ID and hash in the file upload field
235 :     my $id = $upload->id;
236 :     my $hash = $upload->hash;
237 :     $r->param($u->name => "$id $hash");
238 :     }
239 : sh002i 1836
240 : sh002i 3833 # create these out here. they should fail if they don't have the right information
241 :     # this lets us not be so careful about whether these objects are defined when we use them.
242 :     # instead, we just create the behavior that if they don't have a valid $db they fail.
243 :     my $authz = new WeBWorK::Authz($r);
244 :     $r->authz($authz);
245 : sh002i 4080
246 :     # figure out which authentication modules to use
247 : sh002i 4304 #my $user_authen_module;
248 :     #my $proctor_authen_module;
249 :     #if (ref $ce->{authen}{user_module} eq "HASH") {
250 :     # if (exists $ce->{authen}{user_module}{$ce->{dbLayoutName}}) {
251 :     # $user_authen_module = $ce->{authen}{user_module}{$ce->{dbLayoutName}};
252 :     # } else {
253 :     # $user_authen_module = $ce->{authen}{user_module}{"*"};
254 :     # }
255 :     #} else {
256 :     # $user_authen_module = $ce->{authen}{user_module};
257 :     #}
258 :     #if (ref $ce->{authen}{proctor_module} eq "HASH") {
259 :     # if (exists $ce->{authen}{proctor_module}{$ce->{dbLayoutName}}) {
260 :     # $proctor_authen_module = $ce->{authen}{proctor_module}{$ce->{dbLayoutName}};
261 :     # } else {
262 :     # $proctor_authen_module = $ce->{authen}{proctor_module}{"*"};
263 :     # }
264 :     #} else {
265 :     # $proctor_authen_module = $ce->{authen}{proctor_module};
266 :     #}
267 : sh002i 4080
268 : sh002i 4304 my $user_authen_module = WeBWorK::Authen::class($ce, "user_module");
269 :    
270 : sh002i 4080 runtime_use $user_authen_module;
271 :     my $authen = $user_authen_module->new($r);
272 :     debug("Using user_authen_module $user_authen_module: $authen\n");
273 : sh002i 3833 $r->authen($authen);
274 : sh002i 2434
275 : sh002i 3833 my $db;
276 :    
277 : sh002i 2437 if ($displayArgs{courseID}) {
278 : sh002i 1836 debug("We got a courseID from the URLPath, now we can do some stuff:\n");
279 : sh002i 2437
280 :     unless (-e $ce->{courseDirs}->{root}) {
281 :     die "Course '$displayArgs{courseID}' not found: $!";
282 :     }
283 :    
284 : sh002i 1836 debug("...we can create a database object...\n");
285 :     $db = new WeBWorK::DB($ce->{dbLayout});
286 :     debug("(here's the DB handle: $db)\n");
287 : sh002i 1885 $r->db($db);
288 : sh002i 1836
289 :     my $authenOK = $authen->verify;
290 :     if ($authenOK) {
291 : sh002i 3003 my $userID = $r->param("user");
292 :     debug("Hi, $userID, glad you made it.\n");
293 : sh002i 1836
294 : sh002i 3058 # tell authorizer to cache this user's permission level
295 :     $authz->setCachedUser($userID);
296 :    
297 : sh002i 1836 debug("Now we deal with the effective user:\n");
298 :     my $eUserID = $r->param("effectiveUser") || $userID;
299 :     debug("userID=$userID eUserID=$eUserID\n");
300 : sh002i 3673 if ($userID ne $eUserID) {
301 :     debug("userID and eUserID differ... seeing if userID has 'become_student' permission.\n");
302 :     my $su_authorized = $authz->hasPermissions($userID, "become_student");
303 :     if ($su_authorized) {
304 :     debug("Ok, looks like you're allowed to become $eUserID. Whoopie!\n");
305 :     } else {
306 :     debug("Uh oh, you're not allowed to become $eUserID. Nice try!\n");
307 : sh002i 3705 die "You are not allowed to act as another user.\n";
308 : sh002i 3673 }
309 : sh002i 1836 }
310 : sh002i 3673
311 :     # set effectiveUser in case it was changed or not set to begin with
312 : sh002i 1836 $r->param("effectiveUser" => $eUserID);
313 : sh002i 3673
314 :     # if we're doing a proctored test, after the user has been authenticated
315 :     # we need to also check on the proctor. note that in the gateway quiz
316 :     # module we double check this, to be sure that someone isn't taking a
317 :     # proctored quiz but calling the unproctored ContentGenerator
318 : glarose 3377 my $urlProducedPath = $urlPath->path();
319 :     if ( $urlProducedPath =~ /proctored_quiz_mode/i ) {
320 : sh002i 4304 my $proctor_authen_module = WeBWorK::Authen::class($ce, "proctor_module");
321 : sh002i 4080 runtime_use $proctor_authen_module;
322 :     my $authenProctor = $proctor_authen_module->new($r);
323 : sh002i 4304 debug("Using proctor_authen_module $proctor_authen_module: $authenProctor\n");
324 : sh002i 4046 my $procAuthOK = $authenProctor->verify();
325 :    
326 :     if (not $procAuthOK) {
327 :     $displayModule = PROCTOR_LOGIN_MODULE;
328 : glarose 3377 }
329 :     }
330 : sh002i 1836 } else {
331 :     debug("Bad news: authentication failed!\n");
332 : sh002i 4046 $displayModule = LOGIN_MODULE;
333 : sh002i 1836 debug("set displayModule to $displayModule\n");
334 :     }
335 :     }
336 :    
337 : sh002i 3535 # store the time before we invoke the content generator
338 :     my $cg_start = time; # this is Time::HiRes's time, which gives floating point values
339 :    
340 : sh002i 1836 debug(("-" x 80) . "\n");
341 :     debug("Finally, we'll load the display module...\n");
342 :    
343 :     runtime_use($displayModule);
344 :    
345 :     debug("...instantiate it...\n");
346 :    
347 :     my $instance = $displayModule->new($r);
348 :    
349 :     debug("...and call it:\n");
350 :     debug("-------------------- call to ${displayModule}::go\n");
351 :    
352 :     my $result = $instance->go();
353 :    
354 :     debug("-------------------- call to ${displayModule}::go\n");
355 :    
356 : sh002i 3535 my $cg_end = time;
357 :     my $cg_duration = $cg_end - $cg_start;
358 :     writeTimingLogEntry($ce, "[".$r->uri."]", sprintf("runTime = %.3f sec", $cg_duration)." ".$ce->{dbLayoutName}, "");
359 :    
360 : sh002i 1910 debug("returning result: " . (defined $result ? $result : "UNDEF") . "\n");
361 : sh002i 2346
362 : gage 2098 return $result;
363 : sh002i 1836 }
364 :    
365 :     sub mungeParams {
366 :     my ($r) = @_;
367 :    
368 :     my @paramQueue;
369 :    
370 :     # remove all the params from the request, and store them in the param queue
371 :     foreach my $key ($r->param) {
372 :     push @paramQueue, [ $key => [ $r->param($key) ] ];
373 :     $r->parms->unset($key)
374 :     }
375 :    
376 :     # exhaust the param queue, decoding encoded params
377 :     while (@paramQueue) {
378 :     my ($key, $values) = @{ shift @paramQueue };
379 :    
380 :     if ($key =~ m/\,/) {
381 :     # we have multiple params encoded in a single param
382 :     # split them up and add them to the end of the queue
383 :     push @paramQueue, map { [ $_, $values ] } split m/\,/, $key;
384 :     } elsif ($key =~ m/\:/) {
385 :     # we have a whole param encoded in a key
386 :     # split it up and add it to the end of the queue
387 :     my ($newKey, $newValue) = split m/\:/, $key;
388 :     push @paramQueue, [ $newKey, [ $newValue ] ];
389 :     } else {
390 :     # this is a "normal" param
391 :     # add it to the param list
392 :     if (defined $r->param($key)) {
393 :     # the param already exists -- append the values we have
394 :     $r->param($key => [ $r->param($key), @$values ]);
395 :     } else {
396 :     # the param doesn't exist -- create it with the values we have
397 :     $r->param($key => $values);
398 :     }
399 :     }
400 :     }
401 :     }
402 :    
403 : sh002i 1565 =head1 AUTHOR
404 :    
405 : sh002i 1616 Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam
406 :     Hathaway, sh002i at math.rochester.edu.
407 : sh002i 1565
408 :     =cut
409 :    
410 : sh002i 986 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9