View of /branches/rel-2-4-dev/webwork2/lib/WeBWorK.pm

    1 ################################################################################
    2 # WeBWorK Online Homework Delivery System
    3 # Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/
    4 # $CVSHeader: webwork2/lib/WeBWorK.pm,v 1.94 2006/09/29 19:03:00 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.
   15 ################################################################################
   16 
   17 package WeBWorK;
   18 
   19 =head1 NAME
   20 
   21 WeBWorK - 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 
   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 =cut
   36 
   37 BEGIN { $main::VERSION = "2.x"; }
   38 
   39 use strict;
   40 use warnings;
   41 use Time::HiRes qw/time/;
   42 
   43 # load WeBWorK::Constants before anything else
   44 # this sets package variables in several packages
   45 use WeBWorK::Constants;
   46 
   47 use WeBWorK::Authen;
   48 use WeBWorK::Authz;
   49 use WeBWorK::CourseEnvironment;
   50 use WeBWorK::DB;
   51 use WeBWorK::Debug;
   52 use WeBWorK::Request;
   53 use WeBWorK::Upload;
   54 use WeBWorK::URLPath;
   55 use WeBWorK::Utils qw(runtime_use writeTimingLogEntry);
   56 
   57 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     require Apache2::RequestUtil;
   66     Apache2::RequestUtil->import();
   67   }
   68 }
   69 
   70 use constant LOGIN_MODULE => "WeBWorK::ContentGenerator::Login";
   71 use constant PROCTOR_LOGIN_MODULE => "WeBWorK::ContentGenerator::LoginProctor";
   72 
   73 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 $_"; die $@ if $@ }
   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 our %SeedCE;
   88 
   89 sub dispatch($) {
   90   my ($apache) = @_;
   91   my $r = new WeBWorK::Request($apache);
   92 
   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   #my $webwork_root = $r->dir_config("webwork_root");
   99   #my $pg_root = $r->dir_config("pg_root");
  100 
  101   debug("\n\n===> Begin " . __PACKAGE__ . "::dispatch() <===\n\n");
  102   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   #debug("The WeBWorK root directory is $webwork_root\n");
  112   #debug("The PG root directory is $pg_root\n");
  113   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   my $urlPath = WeBWorK::URLPath->newFromPath($path);
  139   debug("-------------------- call to WeBWorK::URLPath::newFromPath\n");
  140 
  141   unless ($urlPath) {
  142     debug("This path is invalid... see you later!\n");
  143     die "The path '$path' is not valid.\n";
  144   }
  145 
  146   my $displayModule = $urlPath->module;
  147   my %displayArgs = $urlPath->args;
  148 
  149   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   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   debug("The URLPath looks good, we'll add it to the request.\n");
  170   $r->urlpath($urlPath);
  171 
  172   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     my @vals = $r->param($key);
  177     my $vals = join(", ", map { "'$_'" } @vals);
  178     debug("\t$key => $vals\n");
  179   }
  180 
  181   #mungeParams($r);
  182   #
  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 
  189   debug(("-" x 80) . "\n");
  190 
  191   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 ($apache_is_ssl) {
  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   debug("We need to get a course environment (with or without a courseID!)\n");
  204   my $ce = eval { new WeBWorK::CourseEnvironment({
  205     %SeedCE,
  206     courseName => $displayArgs{courseID},
  207     # 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   }) };
  214   $@ and die "Failed to initialize course environment: $@\n";
  215   debug("Here's the course environment: $ce\n");
  216   $r->ce($ce);
  217 
  218   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   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 
  240   # 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 
  246   # figure out which authentication modules to use
  247   #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 
  268   my $user_authen_module = WeBWorK::Authen::class($ce, "user_module");
  269 
  270   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   $r->authen($authen);
  274 
  275   my $db;
  276 
  277   if ($displayArgs{courseID}) {
  278     debug("We got a courseID from the URLPath, now we can do some stuff:\n");
  279 
  280     unless (-e $ce->{courseDirs}->{root}) {
  281       die "Course '$displayArgs{courseID}' not found: $!";
  282     }
  283 
  284     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     $r->db($db);
  288 
  289     my $authenOK = $authen->verify;
  290     if ($authenOK) {
  291       my $userID = $r->param("user");
  292       debug("Hi, $userID, glad you made it.\n");
  293 
  294       # tell authorizer to cache this user's permission level
  295       $authz->setCachedUser($userID);
  296 
  297       debug("Now we deal with the effective user:\n");
  298       my $eUserID = $r->param("effectiveUser") || $userID;
  299       debug("userID=$userID eUserID=$eUserID\n");
  300       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           die "You are not allowed to act as another user.\n";
  308         }
  309       }
  310 
  311       # set effectiveUser in case it was changed or not set to begin with
  312       $r->param("effectiveUser" => $eUserID);
  313 
  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       my $urlProducedPath = $urlPath->path();
  319       if ( $urlProducedPath =~ /proctored_quiz_mode/i ) {
  320         my $proctor_authen_module = WeBWorK::Authen::class($ce, "proctor_module");
  321         runtime_use $proctor_authen_module;
  322         my $authenProctor = $proctor_authen_module->new($r);
  323         debug("Using proctor_authen_module $proctor_authen_module: $authenProctor\n");
  324           my $procAuthOK = $authenProctor->verify();
  325 
  326         if (not $procAuthOK) {
  327           $displayModule = PROCTOR_LOGIN_MODULE;
  328         }
  329       }
  330     } else {
  331       debug("Bad news: authentication failed!\n");
  332       $displayModule = LOGIN_MODULE;
  333       debug("set displayModule to $displayModule\n");
  334     }
  335   }
  336 
  337   # 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   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   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   debug("returning result: " . (defined $result ? $result : "UNDEF") . "\n");
  361 
  362   return $result;
  363 }
  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 =head1 AUTHOR
  404 
  405 Written by Dennis Lambe, malsyned at math.rochester.edu. Modified by Sam
  406 Hathaway, sh002i at math.rochester.edu.
  407 
  408 =cut
  409 
  410 1;