[system] / trunk / webwork2 / lib / WeBWorK.pm Repository:
ViewVC logotype

Diff of /trunk/webwork2/lib/WeBWorK.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 986 Revision 1663
1################################################################################ 1################################################################################
2# WeBWorK mod_perl (c) 2000-2002 WeBWorK Project 2# WeBWorK Online Homework Delivery System
3# $Id$ 3# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
4# $CVSHeader$
5#
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.
4################################################################################ 15################################################################################
5 16
6package WeBWorK; 17package WeBWorK;
7 18
8=head1 NAME 19=head1 NAME
9 20
10WeBWorK - Dispatch requests to the appropriate ContentGenerator. 21WeBWorK - Dispatch requests to the appropriate content generator.
11 22
23
24=head1 SYNOPSIS
25
26 my $r = Apache->request;
27 my $result = eval { WeBWorK::dispatch($r) };
28 die "something bad happened: $@" if $@;
29
30=head1 DESCRIPTION
31
32C<WeBWorK> is the dispatcher for the WeBWorK system. Given an Apache request
33object, it performs authentication and determines which subclass of
34C<WeBWorK::ContentGenerator> to call.
35
36=head1 REQUEST FORMAT
37
38 FIXME: write this part
39 summary: the URI controls
40
12=cut 41=cut
42
43
44BEGIN { $main::VERSION = "2.0"; }
45
46my $timingON = 0;
13 47
14use strict; 48use strict;
15use warnings; 49use warnings;
16use Apache::Constants qw(:common REDIRECT); 50use Apache::Constants qw(:common REDIRECT DONE);
17use Apache::Request; 51use Apache::Request;
18use WeBWorK::Authen; 52use WeBWorK::Authen;
19use WeBWorK::Authz; 53use WeBWorK::Authz;
20use WeBWorK::ContentGenerator::Feedback;
21use WeBWorK::ContentGenerator::Hardcopy;
22use WeBWorK::ContentGenerator::Instructor::Index;
23use WeBWorK::ContentGenerator::Instructor::PGProblemEditor;
24use WeBWorK::ContentGenerator::Instructor::ProblemSetEditor;
25use WeBWorK::ContentGenerator::Instructor::ProblemSetList;
26use WeBWorK::ContentGenerator::Instructor::UserList;
27use WeBWorK::ContentGenerator::Login;
28use WeBWorK::ContentGenerator::Logout;
29use WeBWorK::ContentGenerator::Options;
30use WeBWorK::ContentGenerator::Problem;
31use WeBWorK::ContentGenerator::ProblemSet;
32use WeBWorK::ContentGenerator::ProblemSets;
33use WeBWorK::ContentGenerator::Test;
34use WeBWorK::CourseEnvironment; 54use WeBWorK::CourseEnvironment;
35use WeBWorK::DB; 55use WeBWorK::DB;
56use WeBWorK::Timing;
57use WeBWorK::Upload;
58use WeBWorK::Utils qw(runtime_use);
59
60=head1 THE C<&dispatch> FUNCTION
61
62The C<&dispatch> function takes an Apache request object (REQUEST) and returns
63an apache status code. Below is an overview of its operation:
64
65=over
66
67=cut
36 68
37sub dispatch($) { 69sub dispatch($) {
38 my ($apache) = @_; 70 my ($apache) = @_;
39 my $r = Apache::Request->new($apache); 71 my $r = Apache::Request->new($apache);
40 # have to deal with unpredictable GET or POST data, and sift 72 # have to deal with unpredictable GET or POST data, and sift
… …
42 74
43 # This stuff is pretty much copied out of the O'Reilly mod_perl book. 75 # This stuff is pretty much copied out of the O'Reilly mod_perl book.
44 # It's for figuring out the basepath. I may change this up if I find a 76 # It's for figuring out the basepath. I may change this up if I find a
45 # better way to do it. 77 # better way to do it.
46 my $path_info = $r->path_info || ""; 78 my $path_info = $r->path_info || "";
79 $path_info =~ s!/+!/!g; # strip multiple forward slashes
47 my $current_uri = $r->uri; 80 my $current_uri = $r->uri;
48 my $args = $r->args; 81 my $args = $r->args;
49 82
50 $current_uri =~ m/^(.*)$path_info/; 83 my ($urlRoot) = $current_uri =~ m/^(.*)$path_info/;
51 my $urlRoot = $1; 84
52 85=item Ensure that the URI ends with a "/"
86
87Parts of WeBWorK assume that the current URI of a request ends with a "/". If
88this is not the case, a redirection is issued to add the "/". This action will
89discard any POST data associated with the request, so it is essential that all
90POST requests include a "/" at the end of the URI.
91
92=cut
93
53 # If it's a valid WeBWorK URI, it ends in a /. This is assumed 94 # If it's a valid WeBWorK URI, it ends in a /. This is assumed
54 # alllll over the place. 95 # alllll over the place.
55 unless (substr($current_uri,-1) eq '/') { 96 unless (substr($current_uri,-1) eq '/') {
56 $r->header_out(Location => "$current_uri/" . ($args ? "?$args" : "")); 97 $r->header_out(Location => "$current_uri/" . ($args ? "?$args" : ""));
57 return REDIRECT; 98 return REDIRECT;
58 # *** any post data gets lost here -- fix that. 99 # *** any post data gets lost here -- fix that.
100 # (actually, it's not a problem, since all URLs generated
101 # from within the system have trailing slashes, and we don't
102 # need POST data from outside the system anyway!)
59 } 103 }
60 104
61 # Create the @components array, which contains the path specified in the URL 105 # Create the @components array, which contains the path specified in the URL
62 my($junk, @components) = split "/", $path_info; 106 my($junk, @components) = split "/", $path_info;
63 my $webwork_root = $r->dir_config('webwork_root'); # From a PerlSetVar in httpd.conf 107 my $webwork_root = $r->dir_config('webwork_root'); # From a PerlSetVar in httpd.conf
108 my $pg_root = $r->dir_config('pg_root'); # From a PerlSetVar in httpd.conf
64 my $course = shift @components; 109 my $course = shift @components;
65 110
111=item Read the course environment
112
113C<WeBWorK::CourseEnvironment> is used to read the F<global.conf> configuration
114file. If a course name was given in the request's URI, it is passed to
115C<WeBWorK::CourseEnvironment>. In this case, the course-specific configuration
116file (usually F<course.conf>) is also read by C<WeBWorK::CourseEnvironment> at
117this point.
118
119See also L<WeBWorK::CourseEnvironment>.
120
121=cut
122
66 # Try to get the course environment. 123 # Try to get the course environment.
67 my $ce = eval {WeBWorK::CourseEnvironment->new($webwork_root, $urlRoot, $course);}; 124 my $ce = eval {WeBWorK::CourseEnvironment->new($webwork_root, $urlRoot, $pg_root, $course);};
68 if ($@) { # If there was an error getting the requested course 125 if ($@) { # If there was an error getting the requested course
69 # TODO: display an error page. For now, 404 it. 126 die "Failed to read course environment for $course: $@";
70 warn $@;
71 return DECLINED;
72 } 127 }
73 128
129=item If no course was given, go to the site home page
130
131If the URI did not include the name of a course, a redirection is issued to the
132site home page, given but the course environemnt variable
133C<$ce-E<gt>{webworkURLs}-E<gt>{home}>.
134
135=cut
136
74 # If no course was specified, redirect to the home URL 137 # If no course was specified, redirect to the home URL
75 unless (defined $course) { 138 unless (defined $course) {
76 $r->header_out(Location => $ce->{webworkURLs}->{home}); 139 $r->header_out(Location => $ce->{webworkURLs}->{home});
77 return REDIRECT; 140 return REDIRECT;
78 } 141 }
79 142
143=item If the given course does not exist, fail
144
145If the URI did include the name of a course, but the course directory was not
146found, an exception is thrown.
147
148=cut
149
80 # Freak out if the requested course doesn't exist. For now, this is just a 150 # Freak out if the requested course doesn't exist. For now, this is just a
81 # check to see if the course directory exists. 151 # check to see if the course directory exists.
82 if (!-e $ce->{webworkDirs}->{courses} . "/$course") { 152 my $courseDir = $ce->{webworkDirs}->{courses} . "/$course";
83 warn "Course directory for $course not found at " 153 unless (-e $courseDir) {
84 . $ce->{webworkDirs}->{courses} . "/$course" ."\n"; 154 die "Course directory for $course ($courseDir) not found. Perhaps the course does not exist?";
85 return DECLINED;
86 } 155 }
87 156
157=item Initialize the database system
158
159A C<WeBWorK::DB> object is created from the current course environment.
160
161See also L<WeBWorK::DB>.
162
163=cut
164
88 # Bring up a connection to the database (for Authen/Authz, and eventually 165 # Bring up a connection to the database (for Authen/Authz, and eventually
89 # to be passed to content generators, when we clean this file up). 166 # to be passed to content generators, when we clean this file up).
90 my $db = WeBWorK::DB->new($ce); 167 my $db = WeBWorK::DB->new($ce);
91 168
169=item Capture any uploads
170
171Before checking authentication, we store any uploads sent by the client
172and replace them with parameters referencing the stored uploads.
173
174=cut
175
176 my @uploads = $r->upload;
177 foreach my $u (@uploads) {
178 # make sure it's a "real" upload
179 next unless $u->filename;
180
181 # store the upload
182 my $upload = WeBWorK::Upload->store($u,
183 dir => $ce->{webworkDirs}->{uploadCache}
184 );
185
186 # store the upload ID and hash in the file upload field
187 my $id = $upload->id;
188 my $hash = $upload->hash;
189 $r->param($u->name => "$id $hash");
190 }
191
192=item Check authentication
193
194Use C<WeBWorK::Authen> to verify that the remote user has authenticated.
195
196See also L<WeBWorK::Authen>.
197
198=cut
199
92 ### Begin dispatching ### 200 ### Begin dispatching ###
93 201
202 my $contentGenerator = "";
203 my @arguments = ();
204
94 # WeBWorK::Authen::verify erases the passwd field and sets the key field 205 # WeBWorK::Authen::verify erases the passwd field and sets the key field
95 # if login is successful. 206 # if login is successful.
96 if (!WeBWorK::Authen->new($r, $ce, $db)->verify) { 207 if (!WeBWorK::Authen->new($r, $ce, $db)->verify) {
97 return WeBWorK::ContentGenerator::Login->new($r, $ce, $db)->go; 208 $contentGenerator = "WeBWorK::ContentGenerator::Login";
209 @arguments = ();
210 }
98 } else { 211 else {
212
213=item Determine if the user is allowed to set C<effectiveUser>
214
215Use C<WeBWorK::Authz> to determine if the user is allowed to set
216C<effectiveUser>. If so, set it to the requested value (or set it to the real
217user name if no value is supplied). If not, set it to the real user name.
218
219See also L<WeBWorK::Authz>.
220
221=cut
222
99 # After we are authenticated, there are some things that need to be 223 # After we are authenticated, there are some things that need to be
100 # sorted out, Authorization-wize, before we start dispatching to individual 224 # sorted out, Authorization-wize, before we start dispatching to individual
101 # content generators. 225 # content generators.
102 my $user = $r->param("user"); 226 my $user = $r->param("user");
103 my $effectiveUser = $r->param("effectiveUser") || $user; 227 my $effectiveUser = $r->param("effectiveUser") || $user;
228 my $authz = WeBWorK::Authz->new($r, $ce, $db);
104 my $su_authorized = WeBWorK::Authz->new($r, $ce, $db)->hasPermissions($user, "become_student", $effectiveUser); 229 my $su_authorized = $authz->hasPermissions($user, "become_student", $effectiveUser);
105 $effectiveUser = $user unless $su_authorized; 230 $effectiveUser = $user unless $su_authorized;
106 $r->param("effectiveUser", $effectiveUser); 231 $r->param("effectiveUser", $effectiveUser);
107 232
233=item Determine the appropriate subclass of C<WeBWorK::ContentGenerator> to call based on the URI.
234
235The dispatcher implements a virtual heirarchy that looks like this:
236
237 $courseID ($courseID) - list of sets
238 hardcopy (Hardcopy Generator) - generate hardcopy for user/set pairs
239 options (User Options) - change email address and password
240 feedback (Feedback) - send feedback to professor via email
241 logout (Logout) - expire session and erase authentication tokens
242 test (Test) - display request information
243 quiz_mode (Quiz) - "quiz" containing all problems from a set
244 instructor (Instructor Tools) - main menu for instructor tools
245 add_users (Add Users) - to be removed
246 scoring (Scoring Tools) - generate scoring files for problem sets
247 scoringDownload - send a scoring file to the client
248 scoring_totals - ???
249 users (Users) - view/edit users
250 $userID ($userID) - user detail for given user
251 sets (Assigned Sets) - view/edit sets assigned to given user
252 sets (Sets) - list of sets, add new sets, delete existing sets
253 $setID - view/edit the given set
254 problems (Problems) - view/edit problems in the given set
255 $problemID - this is where the pg problem editor SHOULD be
256 users (Users Assigned) - view/edit users to whom the given set is assigned
257 pgProblemEditor (Problem Source) - edit the source of a problem
258 send_mail (Mail Merge) - send mail to users in course
259 show_answers (Answers Submitted) - show submitted answers
260 stats (Statistics) - show statistics
261 files (File Transfer) - transfer files to/from the client
262 $setID ($setID) - list of problems in the given set
263 $problemID ($problemID) - interactive display of problem
264
265=cut
266
108 my $arg = shift @components; 267 my $arg = shift @components;
109 if (!defined $arg) { # We want the list of problem sets 268 if (not defined $arg) { # We want the list of problem sets
110 return WeBWorK::ContentGenerator::ProblemSets->new($r, $ce, $db)->go; 269 $contentGenerator = "WeBWorK::ContentGenerator::ProblemSets";
270 @arguments = ();
271 }
111 } elsif ($arg eq "hardcopy") { 272 elsif ($arg eq "hardcopy") {
112 my $hardcopyArgument = shift @components; 273 my $setID = shift @components;
113 $hardcopyArgument = "" unless defined $hardcopyArgument; 274 $contentGenerator = "WeBWorK::ContentGenerator::Hardcopy";
114 return WeBWorK::ContentGenerator::Hardcopy->new($r, $ce, $db)->go($hardcopyArgument); 275 @arguments = ($setID);
276 }
277 elsif ($arg eq "options") {
278 $contentGenerator = "WeBWorK::ContentGenerator::Options";
279 @arguments = ();
280 }
281 elsif ($arg eq "feedback") {
282 $contentGenerator = "WeBWorK::ContentGenerator::Feedback";
283 @arguments = ();
284 }
285 elsif ($arg eq "logout") {
286 $contentGenerator = "WeBWorK::ContentGenerator::Logout";
287 @arguments = ();
288 }
289 elsif ($arg eq "test") {
290 $contentGenerator = "WeBWorK::ContentGenerator::Test";
291 @arguments = ();
292 }
293 elsif ($arg eq "quiz_mode" ) {
294 $contentGenerator = "WeBWorK::ContentGenerator::GatewayQuiz";
295 @arguments = @components;
296 }
115 } elsif ($arg eq "instructor") { 297 elsif ($arg eq "instructor") {
116 my $instructorArgument = shift @components; 298 my $instructorArgument = shift @components;
299
117 if (!defined $instructorArgument) { 300 if (not defined $instructorArgument) {
118 return WeBWorK::ContentGenerator::Instructor::Index->new($r, $ce, $db)->go; 301 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::Index";
302 @arguments = ();
303 }
304 elsif ($instructorArgument eq "add_users") {
305 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::AddUsers";
306 @arguments = ();
307 }
308 elsif ($instructorArgument eq "scoring") {
309 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::Scoring";
310 @arguments = ();
311 }
312# elsif ($instructorArgument eq "scoring_totals") {
313# $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ScoringTotals";
314# @arguments = ();
315# }
316 elsif ($instructorArgument eq "scoringDownload") {
317 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ScoringDownload";
318 @arguments = ();
319 }
119 } elsif ($instructorArgument eq "userList") { 320 elsif ($instructorArgument eq "users") {
120 return WeBWorK::ContentGenerator::Instructor::UserList->new($r, $ce, $db)->go; 321 my $userID = shift @components;
322
323 if (defined $userID) {
324 my $userArg = shift @components;
325 if (defined $userArg) {
326 if ($userArg eq "sets") {
327 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::SetsAssignedToUser";
328 @arguments = ($userID);
329 }
330 }
331 else {
332 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::UserDetail";
333 @arguments = ($userID);
334 }
335 }
336 else {
337 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::UserList";
338 @arguments = ();
339 }
340 }
121 } elsif ($instructorArgument eq "problemSetList") { 341 elsif ($instructorArgument eq "sets") {
122 return WeBWorK::ContentGenerator::Instructor::ProblemSetList->new($r, $ce, $db)->go; 342 my $setID = shift @components;
123 } elsif ($instructorArgument eq "problemSetEditor") { 343
124 return WeBWorK::ContentGenerator::Instructor::ProblemSetEditor->new($r, $ce, $db)->go(@components); 344 if (defined $setID) {
345 my $setArg = shift @components;
346
347 if (defined $setArg) {
348 if ($setArg eq "problems") {
349 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ProblemList";
350 @arguments = ($setID);
351 }
352 elsif ($setArg eq "users") {
353 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::Assigner";
354 @arguments = ($setID);
355 }
356 }
357 else {
358 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ProblemSetEditor";
359 @arguments = ($setID);
360 }
361 }
362 else {
363 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ProblemSetList";
364 @arguments = ();
365
366 }
367 }
125 } elsif ($instructorArgument eq "pgProblemEditor") { 368 elsif ($instructorArgument eq "pgProblemEditor") {
126 return WeBWorK::ContentGenerator::Instructor::PGProblemEditor->new($r, $ce, $db)->go(@components); 369 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::PGProblemEditor";
370 @arguments = @components;
371 }
372 elsif ($instructorArgument eq "send_mail") {
373 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::SendMail";
374 @arguments = @components;
375 }
376 elsif ($instructorArgument eq "show_answers") {
377 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::ShowAnswers";
378 @arguments = @components;
379 }
380 elsif ($instructorArgument eq "stats") {
381 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::Stats";
382 @arguments = @components;
383 }
384 elsif ($instructorArgument eq "files") {
385 $contentGenerator = "WeBWorK::ContentGenerator::Instructor::FileXfer";
386 @arguments = @components;
387 }
127 } 388 }
128 } elsif ($arg eq "options") { 389 else {
129 return WeBWorK::ContentGenerator::Options->new($r, $ce, $db)->go; 390 # $arg is a set ID
130 } elsif ($arg eq "feedback") {
131 return WeBWorK::ContentGenerator::Feedback->new($r, $ce, $db)->go;
132 } elsif ($arg eq "logout") {
133 return WeBWorK::ContentGenerator::Logout->new($r, $ce, $db)->go;
134 } elsif ($arg eq "test") {
135 return WeBWorK::ContentGenerator::Test->new($r, $ce, $db)->go;
136 } else { # We've got the name of a problem set.
137 my $problem_set = $arg; 391 my $setID = $arg;
138 my $ps_arg = shift @components; 392 my $problemID = shift @components;
139 393
140 if (!defined $ps_arg) { 394 if (defined $problemID) {
141 # list the problems in the problem set 395 $contentGenerator = "WeBWorK::ContentGenerator::Problem";
142 return WeBWorK::ContentGenerator::ProblemSet->new($r, $ce, $db)->go($problem_set); 396 @arguments = ($setID, $problemID);
397 }
143 } else { 398 else {
144 # We've got the name of a problem 399 $contentGenerator = "WeBWorK::ContentGenerator::ProblemSet";
145 my $problem = $ps_arg; 400 @arguments = ($setID);
146 return WeBWorK::ContentGenerator::Problem->new($r, $ce, $db)->go($problem_set, $problem);
147 }
148 } 401 }
149 402 }
150 } 403 }
151 404
152 # If the dispatcher doesn't know any modules that want to handle 405=item Call the selected content generator
153 # the current path, it'll claim that the path does not exist by 406
154 # declining the request. 407Instantiate the selected subclass of content generator and call its C<&go> method. Store the result.
155 return DECLINED; 408
409=cut
410
411 my $result;
412 if ($contentGenerator) {
413 runtime_use($contentGenerator);
414 my $cg = $contentGenerator->new($r, $ce, $db);
415
416 $WeBWorK::timer = WeBWorK::Timing->new("${contentGenerator}::go(@arguments)") if $timingON == 1;
417 $WeBWorK::timer->start if $timingON == 1;
418
419 $result = $cg->go(@arguments);
420
421 $WeBWorK::timer->stop if $timingON == 1;
422 $WeBWorK::timer->save if $timingON == 1;
423 } else {
424 $result = NOT_FOUND;
425 }
426
427=item Return the result of calling the content generator
428
429The return value of the content generator's C<&go> function is returned.
430
431=cut
432
433 return $result;
156} 434}
157 435
436=back
437
438=head1 AUTHOR
439
440Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam
441Hathaway, sh002i at math.rochester.edu.
442
443=cut
444
1581; 4451;
Legend:
Removed from v.986  
changed lines
  Added in v.1663
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9