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

Diff of /branches/dg_dev/webwork2/lib/WeBWorK.pm

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

Revision 1395 Revision 1885
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: webwork-modperl/lib/WeBWorK.pm,v 1.51 2004/03/15 02:25:11 sh002i Exp $
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.
22
23=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
31C<WeBWorK> is the dispatcher for the WeBWorK system. Given an Apache request
32object, it performs authentication and determines which subclass of
33C<WeBWorK::ContentGenerator> to call.
11 34
12=cut 35=cut
36
37BEGIN { $main::VERSION = "2.0"; }
38
39
40my $timingON = 1;
13 41
14use strict; 42use strict;
15use warnings; 43use warnings;
16use Apache::Constants qw(:common REDIRECT DONE); 44use Apache::Constants qw(:common REDIRECT DONE);
17use Apache::Request;
18use WeBWorK::Authen; 45use WeBWorK::Authen;
19use WeBWorK::Authz; 46use WeBWorK::Authz;
20use WeBWorK::ContentGenerator::Feedback;
21use WeBWorK::ContentGenerator::GatewayQuiz;
22use WeBWorK::ContentGenerator::Hardcopy;
23use WeBWorK::ContentGenerator::Instructor::Assigner;
24use WeBWorK::ContentGenerator::Instructor::Index;
25use WeBWorK::ContentGenerator::Instructor::PGProblemEditor;
26use WeBWorK::ContentGenerator::Instructor::ProblemList;
27use WeBWorK::ContentGenerator::Instructor::ProblemSetEditor;
28use WeBWorK::ContentGenerator::Instructor::ProblemSetList;
29use WeBWorK::ContentGenerator::Instructor::UserList;
30use WeBWorK::ContentGenerator::Instructor::SendMail;
31use WeBWorK::ContentGenerator::Instructor::ShowAnswers;
32use WeBWorK::ContentGenerator::Login;
33use WeBWorK::ContentGenerator::Logout;
34use WeBWorK::ContentGenerator::Options;
35use WeBWorK::ContentGenerator::Problem;
36use WeBWorK::ContentGenerator::ProblemSet;
37use WeBWorK::ContentGenerator::ProblemSets;
38use WeBWorK::ContentGenerator::Test;
39use WeBWorK::CourseEnvironment; 47use WeBWorK::CourseEnvironment;
40use WeBWorK::DB; 48use WeBWorK::DB;
41use WeBWorK::Timing; 49#use WeBWorK::Timing;
50use WeBWorK::Upload;
51use WeBWorK::Utils qw(runtime_use);
52use WeBWorK::Request;
53use WeBWorK::URLPath;
42 54
43#sub dispatch($) { 55use constant AUTHEN_MODULE => "WeBWorK::ContentGenerator::Login";
44# print STDERR "Executing &WeBWorK::dispatch\n"; 56
45# return DECLINED; 57#sub debug(@) { print STDERR "dispatch_new: ", join("", @_) };
46#} 58sub debug(@) { };
47#1;
48#__END__
49 59
50sub dispatch($) { 60sub dispatch($) {
51 my ($apache) = @_; 61 my ($apache) = @_;
52 my $r = Apache::Request->new($apache); 62 my $r = new WeBWorK::Request $apache;
53 # have to deal with unpredictable GET or POST data, and sift
54 # through it for the key. So use Apache::Request
55 63
56 # This stuff is pretty much copied out of the O'Reilly mod_perl book. 64 my $method = $r->method;
57 # It's for figuring out the basepath. I may change this up if I find a 65 my $location = $r->location;
58 # better way to do it. 66 my $uri = $r->uri;
59 my $path_info = $r->path_info || ""; 67 my $path_info = $r->path_info | "";
60 $path_info =~ s!/+!/!g; # strip multiple forward slashes
61 my $current_uri = $r->uri;
62 my $args = $r->args; 68 my $args = $r->args || "";
69 my $webwork_root = $r->dir_config("webwork_root");
70 my $pg_root = $r->dir_config("pg_root");
63 71
64 my ($urlRoot) = $current_uri =~ m/^(.*)$path_info/; 72 #$r->send_http_header("text/html");
65 73
66 # If it's a valid WeBWorK URI, it ends in a /. This is assumed 74 #print CGI::start_pre();
67 # alllll over the place.
68 unless (substr($current_uri,-1) eq '/') {
69 $r->header_out(Location => "$current_uri/" . ($args ? "?$args" : ""));
70 return REDIRECT;
71 # *** any post data gets lost here -- fix that.
72 # (actually, it's not a problem, since all URLs generated
73 # from within the system have trailing slashes, and we don't
74 # need POST data from outside the system anyway!)
75 }
76 75
77 # Create the @components array, which contains the path specified in the URL 76 debug("Hi, I'm the new dispatcher!\n");
78 my($junk, @components) = split "/", $path_info; 77 debug(("-" x 80) . "\n");
79 my $webwork_root = $r->dir_config('webwork_root'); # From a PerlSetVar in httpd.conf
80 my $pg_root = $r->dir_config('pg_root'); # From a PerlSetVar in httpd.conf
81 my $course = shift @components;
82 78
83 # Try to get the course environment. 79 debug("Okay, I got some basic information:\n");
80 debug("The apache location is $location\n");
81 debug("The request method is $method\n");
82 debug("The URI is $uri\n");
83 debug("The path-info is $path_info\n");
84 debug("The argument string is $args\n");
85 debug("The WeBWorK root directory is $webwork_root\n");
86 debug("The PG root directory is $pg_root\n");
87 debug(("-" x 80) . "\n");
88
89 debug("The first thing we need to do is munge the path a little:\n");
90
91 my ($path) = $uri =~ m/$location(.*)/;
92 $path = "/" if $path eq ""; # no path at all
93
94 debug("We can't trust the path-info, so we make our own path.\n");
95 debug("path-info claims: $path_info\n");
96 debug("but it's really: $path\n");
97 debug("(if it's empty, we set it to \"/\".)\n");
98
99 $path =~ s|/+|/|g;
100 debug("...and here it is without repeated slashes: $path\n");
101
102 # lookbehind assertion for "not a slash"
103 # matches the boundary after the last char
104 $path =~ s|(?<=[^/])$|/|;
105 debug("...and here it is with a trailing slash: $path\n");
106
107 debug(("-" x 80) . "\n");
108
109 debug("Now we need to look at the path a little to figure out where we are\n");
110
111 debug("-------------------- call to WeBWorK::URLPath::newFromPath\n");
112 my $urlPath = WeBWorK::URLPath->newFromPath($path);
113 debug("-------------------- call to WeBWorK::URLPath::newFromPath\n");
114
115 unless ($urlPath) {
116 debug("This path is invalid... see you later!\n");
117 return DECLINED;
118 }
119
120 my $displayModule = $urlPath->module;
121 my %displayArgs = $urlPath->args;
122
123 debug("The display module for this path is: $displayModule\n");
124 debug("...and here are the arguments we'll pass to it:\n");
125 foreach my $key (keys %displayArgs) {
126 debug("\t$key => $displayArgs{$key}\n");
127 }
128
129 unless ($displayModule) {
130 debug("The display module is empty, so we can DECLINE here.\n");
131 return DECLINED;
132 }
133
134 my $selfPath = $urlPath->path;
135 my $parent = $urlPath->parent;
136 my $parentPath = $parent ? $parent->path : "<no parent>";
137
138 debug("Reconstructing the original path gets us: $selfPath\n");
139 debug("And we can generate the path to our parent, too: $parentPath\n");
140 debug("(We could also figure out who our children are, but we'd need to supply additional arguments.)\n");
141 debug(("-" x 80) . "\n");
142
143 debug("The URLPath looks good, we'll add it to the request.\n");
144 $r->urlpath($urlPath);
145
146 debug("Now we want to look at the parameters we got.\n");
147
148 debug("The raw params:\n");
149 foreach my $key ($r->param) {
150 debug("\t$key\n");
151 debug("\t\t$_\n") foreach $r->param($key);
152 }
153
154 mungeParams($r);
155
156 debug("The munged params:\n");
157 foreach my $key ($r->param) {
158 debug("\t$key\n");
159 debug("\t\t$_\n") foreach $r->param($key);
160 }
161
162 debug(("-" x 80) . "\n");
163
164 debug("We need to get a course environment (with or without a courseID!)\n");
84 my $ce = eval {WeBWorK::CourseEnvironment->new($webwork_root, $urlRoot, $pg_root, $course);}; 165 my $ce = new WeBWorK::CourseEnvironment($webwork_root, $location, $pg_root, $displayArgs{courseID});
85 if ($@) { # If there was an error getting the requested course 166 debug("Here's the course environment: $ce\n");
86 die "Failed to read course environment for $course: $@"; 167 $r->ce($ce);
87 }
88 168
89 # If no course was specified, redirect to the home URL 169 my @uploads = $r->upload;
90 unless (defined $course) { 170 foreach my $u (@uploads) {
91 $r->header_out(Location => $ce->{webworkURLs}->{home}); 171 # make sure it's a "real" upload
92 return REDIRECT; 172 next unless $u->filename;
93 }
94
95 # Freak out if the requested course doesn't exist. For now, this is just a
96 # check to see if the course directory exists.
97 my $courseDir = $ce->{webworkDirs}->{courses} . "/$course";
98 unless (-e $courseDir) {
99 die "Course directory for $course ($courseDir) not found. Perhaps the course does not exist?";
100 }
101
102 # Bring up a connection to the database (for Authen/Authz, and eventually
103 # to be passed to content generators, when we clean this file up).
104 my $db = WeBWorK::DB->new($ce);
105
106 ### Begin dispatching ###
107
108 #my $dispatchTimer = WeBWorK::Timing->new(__PACKAGE__."::dispatch");
109 #$dispatchTimer->start;
110
111 my $result;
112 # WeBWorK::Authen::verify erases the passwd field and sets the key field
113 # if login is successful.
114 if (!WeBWorK::Authen->new($r, $ce, $db)->verify) {
115 $result = WeBWorK::ContentGenerator::Login->new($r, $ce, $db)->go;
116 } else {
117 # After we are authenticated, there are some things that need to be
118 # sorted out, Authorization-wize, before we start dispatching to individual
119 # content generators.
120 my $user = $r->param("user");
121 my $effectiveUser = $r->param("effectiveUser") || $user;
122 my $su_authorized = WeBWorK::Authz->new($r, $ce, $db)->hasPermissions($user, "become_student", $effectiveUser);
123 $effectiveUser = $user unless $su_authorized;
124 $r->param("effectiveUser", $effectiveUser);
125 173
126 my $arg = shift @components; 174 # store the upload
127 if (!defined $arg) { # We want the list of problem sets 175 my $upload = WeBWorK::Upload->store($u,
128 $result = WeBWorK::ContentGenerator::ProblemSets->new($r, $ce, $db)->go; 176 dir => $ce->{webworkDirs}->{uploadCache}
129 } elsif ($arg eq "hardcopy") { 177 );
178
179 # store the upload ID and hash in the file upload field
180 my $id = $upload->id;
181 my $hash = $upload->hash;
182 $r->param($u->name => "$id $hash");
183 }
184
185 my ($db, $authz);
186
187 if ($displayArgs{courseID}) {
188 debug("We got a courseID from the URLPath, now we can do some stuff:\n");
189 debug("...we can create a database object...\n");
190 $db = new WeBWorK::DB($ce->{dbLayout});
191 debug("(here's the DB handle: $db)\n");
192 $r->db($db);
193
194 debug("...and we can authenticate the remote user...\n");
195 my $authen = new WeBWorK::Authen($r);
196 my $authenOK = $authen->verify;
197 if ($authenOK) {
198 debug("Hi, ", $r->param("user"), ", glad you made it.\n");
130 199
131 my $hardcopyArgument = shift @components; 200 debug("Authentication succeeded, so it makes sense to create an authz object...\n");
132 $hardcopyArgument = "" unless defined $hardcopyArgument; 201 $authz = new WeBWorK::Authz($r, $ce, $db);
133 $WeBWorK::timer1 = WeBWorK::Timing->new("hardcopy: $hardcopyArgument"); 202 debug("(here's the authz object: $authz)\n");
134 $WeBWorK::timer1->start; 203 $r->authz($authz);
135 204
136 my $result = WeBWorK::ContentGenerator::Hardcopy->new($r, $ce, $db)->go($hardcopyArgument); 205 debug("Now we deal with the effective user:\n");
137 $WeBWorK::timer1 ->stop; 206 my $userID = $r->param("user");
138 $WeBWorK::timer1 ->save; 207 my $eUserID = $r->param("effectiveUser") || $userID;
139 return $result; 208 debug("userID=$userID eUserID=$eUserID\n");
140 } elsif ($arg eq "instructor") { 209 my $su_authorized = $authz->hasPermissions($userID, "become_student", $eUserID);
141 my $instructorArgument = shift @components; 210 if ($su_authorized) {
142 if (!defined $instructorArgument) { 211 debug("Ok, looks like you're is allowed to become $eUserID. Whoopie!\n");
143 $result = WeBWorK::ContentGenerator::Instructor::Index->new($r, $ce, $db)->go;
144 } elsif ($instructorArgument eq "users") {
145 $result = WeBWorK::ContentGenerator::Instructor::UserList->new($r, $ce, $db)->go;
146 } elsif ($instructorArgument eq "sets") {
147 my $setID = shift @components;
148 if (defined $setID) {
149 my $setArg = shift @components;
150 if (!defined $setArg) {
151 $result = WeBWorK::ContentGenerator::Instructor::ProblemSetEditor->new($r, $ce, $db)->go($setID);
152 } elsif ($setArg eq "problems") {
153 $result = WeBWorK::ContentGenerator::Instructor::ProblemList->new($r, $ce, $db)->go($setID);
154 } elsif ($setArg eq "users") {
155 $result = WeBWorK::ContentGenerator::Instructor::Assigner->new($r, $ce, $db)->go($setID);
156 }
157 } else { 212 } else {
158 $result = WeBWorK::ContentGenerator::Instructor::ProblemSetList->new($r, $ce, $db)->go; 213 debug("Uh oh, you're isn't allowed to become $eUserID. Nice try!\n");
159 } 214 $eUserID = $userID;
160 } elsif ($instructorArgument eq "pgProblemEditor") {
161 $result = WeBWorK::ContentGenerator::Instructor::PGProblemEditor->new($r, $ce, $db)->go(@components);
162 } elsif ($instructorArgument eq "send_mail") {
163 $result = WeBWorK::ContentGenerator::Instructor::SendMail->new($r, $ce, $db)->go(@components);
164 } elsif ($instructorArgument eq "show_answers") {
165 $result = WeBWorK::ContentGenerator::Instructor::ShowAnswers->new($r, $ce, $db)->go(@components);
166 } 215 }
167 } elsif ($arg eq "options") { 216 $r->param("effectiveUser" => $eUserID);
168 $result = WeBWorK::ContentGenerator::Options->new($r, $ce, $db)->go; 217 } else {
169 } elsif ($arg eq "feedback") { 218 debug("Bad news: authentication failed!\n");
170 $result = WeBWorK::ContentGenerator::Feedback->new($r, $ce, $db)->go; 219 $displayModule = AUTHEN_MODULE;
171 } elsif ($arg eq "logout") { 220 debug("set displayModule to $displayModule\n");
172 $result = WeBWorK::ContentGenerator::Logout->new($r, $ce, $db)->go; 221 }
173 } elsif ($arg eq "test") { 222 }
174 $result = WeBWorK::ContentGenerator::Test->new($r, $ce, $db)->go; 223
175 } elsif ($arg eq "quiz_mode" ) { 224 debug(("-" x 80) . "\n");
176 # Gateway quiz capability -- very similar to problem set (initially) 225 debug("Finally, we'll load the display module...\n");
177 $result = WeBWorK::ContentGenerator::GatewayQuiz->new($r, $ce, $db)->go(@components); 226
178 } else { # We've got the name of a problem set. 227 runtime_use($displayModule);
179 my $problem_set = $arg; 228
180 my $ps_arg = shift @components; 229 debug("...instantiate it...\n");
230
231 my $instance = $displayModule->new($r);
232
233 debug("...and call it:\n");
234 debug("-------------------- call to ${displayModule}::go\n");
235
236 my $result = $instance->go();
237
238 debug("-------------------- call to ${displayModule}::go\n");
239
240 debug("returning result: $result\n");
241
242 return $result;
243}
181 244
182 if (!defined $ps_arg) { 245sub mungeParams {
183 # list the problems in the problem set 246 my ($r) = @_;
184 $WeBWorK::timer0 = WeBWorK::Timing->new("Problem $course:$problem_set"); 247
185 $WeBWorK::timer0->start; 248 my @paramQueue;
186 $result = WeBWorK::ContentGenerator::ProblemSet->new($r, $ce, $db)->go($problem_set); 249
187 $WeBWorK::timer0->continue("problem set listing is done"); 250 # remove all the params from the request, and store them in the param queue
188 $WeBWorK::timer0->stop; 251 foreach my $key ($r->param) {
189 $WeBWorK::timer0->save; 252 push @paramQueue, [ $key => [ $r->param($key) ] ];
253 $r->parms->unset($key)
254 }
255
256 # exhaust the param queue, decoding encoded params
257 while (@paramQueue) {
258 my ($key, $values) = @{ shift @paramQueue };
259
260 if ($key =~ m/\,/) {
261 # we have multiple params encoded in a single param
262 # split them up and add them to the end of the queue
263 push @paramQueue, map { [ $_, $values ] } split m/\,/, $key;
264 } elsif ($key =~ m/\:/) {
265 # we have a whole param encoded in a key
266 # split it up and add it to the end of the queue
267 my ($newKey, $newValue) = split m/\:/, $key;
268 push @paramQueue, [ $newKey, [ $newValue ] ];
269 } else {
270 # this is a "normal" param
271 # add it to the param list
272 if (defined $r->param($key)) {
273 # the param already exists -- append the values we have
274 $r->param($key => [ $r->param($key), @$values ]);
190 } else { 275 } else {
191 # We've got the name of a problem 276 # the param doesn't exist -- create it with the values we have
192 my $problem = $ps_arg; 277 $r->param($key => $values);
193
194 $WeBWorK::timer0 = WeBWorK::Timing->new("Problem $course:$problem_set/$problem");
195 $WeBWorK::timer0->start;
196# my $pid = fork();
197# if ($pid) {
198# wait;
199# } else {
200 my $result = WeBWorK::ContentGenerator::Problem->new($r, $ce, $db)->go($problem_set, $problem);
201# $WeBWorK::timer0->continue("Exiting child process");
202# #$WeBWorK::timer0->stop;
203# #$WeBWorK::timer0->save;
204# eval{ APACHE::exit(0);} || warn "Error in leaving child |$@|";
205# # We REALLY REALLY want this grandchild to exit. But not the child. How to do this
206# # cleanly???? FIXME
207# }
208 $WeBWorK::timer0->continue("Problem done)");
209 $WeBWorK::timer0->stop;
210 $WeBWorK::timer0->save;
211 return $result;
212
213
214 } 278 }
215 } 279 }
216 } 280 }
217
218 #$dispatchTimer->stop;
219
220 return $result;
221} 281}
222 282
283
284=head1 AUTHOR
285
286Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam
287Hathaway, sh002i at math.rochester.edu.
288
289=cut
290
2231; 2911;
Legend:
Removed from v.1395  
changed lines
  Added in v.1885
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9