--- loncom/lonnet/perl/lonnet.pm 2002/09/16 20:09:47 1.283 +++ loncom/lonnet/perl/lonnet.pm 2002/11/18 15:16:35 1.301 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.283 2002/09/16 20:09:47 www Exp $ +# $Id: lonnet.pm,v 1.301 2002/11/18 15:16:35 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -77,8 +77,8 @@ use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars -qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom - %libserv %pr %prp %metacache %packagetab +qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom + %libserv %pr %prp %metacache %packagetab %titlecache %courselogs %accesshash $processmarker $dumpcount %coursedombuf %coursehombuf %courseresdatacache %domaindescription); use IO::Socket; @@ -86,6 +86,8 @@ use GDBM_File; use Apache::Constants qw(:common :http); use HTML::LCParser; use Fcntl qw(:flock); +use Apache::loncoursedata; + my $readit; # --------------------------------------------------------------------- Logging @@ -358,12 +360,13 @@ sub overloaderror { my $loadfile=Apache::File->new('/proc/loadavg'); $loadavg=<$loadfile>; $loadavg =~ s/\s.*//g; + $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; } else { $loadavg=&reply('load',$checkserver); } - my $overload=$loadavg-$perlvar{'lonLoadLim'}; + my $overload=$loadavg-100; if ($overload>0) { - $r->err_headers_out->{'Retry-After'}=$overload*30; + $r->err_headers_out->{'Retry-After'}=$overload; $r->log_error('Overload of '.$overload.' on '.$checkserver); return 413; } @@ -373,9 +376,10 @@ sub overloaderror { # ------------------------------ Find server with least workload from spare.tab sub spareserver { + my $loadpercent = shift; my $tryserver; my $spareserver=''; - my $lowestserver=100; + my $lowestserver=$loadpercent; foreach $tryserver (keys %spareid) { my $answer=reply('load',$tryserver); if (($answer =~ /\d/) && ($answer<$lowestserver)) { @@ -589,6 +593,59 @@ sub idput { # ------------------------------------- Find the section of student in a course +sub getsection { + my ($udom,$unam,$courseid)=@_; + $courseid=~s/\_/\//g; + $courseid=~s/^(\w)/\/$1/; + my %Pending; + my %Expired; + # + # Each role can either have not started yet (pending), be active, + # or have expired. + # + # If there is an active role, we are done. + # + # If there is more than one role which has not started yet, + # choose the one which will start sooner + # If there is one role which has not started yet, return it. + # + # If there is more than one expired role, choose the one which ended last. + # If there is a role which has expired, return it. + # + foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', + &homeserver($unam,$udom)))) { + my ($key,$value)=split(/\=/,$_); + $key=&unescape($key); + next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/); + my $section=$1; + if ($key eq $courseid.'_st') { $section=''; } + my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my $now=time; + if (defined($end) && ($now > $end)) { + $Expired{$end}=$section; + next; + } + if (defined($start) && ($now < $start)) { + $Pending{$start}=$section; + next; + } + return $section; + } + # + # Presumedly there will be few matching roles from the above + # loop and the sorting time will be negligible. + if (scalar(keys(%Pending))) { + my ($time) = sort {$a <=> $b} keys(%Pending); + return $Pending{$time}; + } + if (scalar(keys(%Expired))) { + my @sorted = sort {$a <=> $b} keys(%Expired); + my $time = pop(@sorted); + return $Expired{$time}; + } + return '-1'; +} + sub usection { my ($udom,$unam,$courseid)=@_; $courseid=~s/\_/\//g; @@ -642,6 +699,30 @@ sub chatsend { &escape($newentry)),$chome); } +# ------------------------------------------ Find current version of a resource + +sub getversion { + my $fname=&clutter(shift); + unless ($fname=~/^\/res\//) { return -1; } + return ¤tversion(&filelocation('',$fname)); +} + +sub currentversion { + my $fname=shift; + my $author=$fname; + $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + my ($udom,$uname)=split(/\//,$author); + my $home=homeserver($uname,$udom); + if ($home eq 'no_host') { + return -1; + } + my $answer=reply("currentversion:$fname",$home); + if (($answer eq 'con_lost') || ($answer eq 'rejected')) { + return -1; + } + return $answer; +} + # ----------------------------- Subscribe to a resource, return URL if possible sub subscribe { @@ -650,7 +731,7 @@ sub subscribe { $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); my $home=homeserver($uname,$udom); - if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { + if ($home eq 'no_host') { return 'not_found'; } my $answer=reply("sub:$fname",$home); @@ -681,6 +762,11 @@ sub repcopy { } elsif ($remoteurl eq 'directory') { return OK; } else { + my $author=$filename; + $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + my ($udom,$uname)=split(/\//,$author); + my $home=homeserver($uname,$udom); + unless ($home eq $perlvar{'lonHostID'}) { my @parts=split(/\//,$filename); my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; if ($path ne "$perlvar{'lonDocRoot'}/res") { @@ -716,6 +802,7 @@ sub repcopy { rename($transname,$filename); return OK; } + } } } @@ -806,13 +893,16 @@ sub finishuserfileupload { } # Notify homeserver to grep it # - if -(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok') - { + + my $fetchresult= + &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome); + if ($fetchresult eq 'ok') { # # Return the URL to it return '/uploaded/'.$path.$fname; } else { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname. + ' to host '.$docuhome.': '.$fetchresult); return '/adm/notfound.html'; } } @@ -1013,7 +1103,7 @@ sub devalidate { if ($cid) { my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; my $status= - &del('nohist_calculatedsheet', + &del('nohist_calculatedsheets', [$key.'studentcalc'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) @@ -1712,7 +1802,9 @@ sub allowed { if ($priv eq 'bre') { my $copyright=&metadata($uri,'copyright'); - if ($copyright eq 'public') { return 'F'; } + if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { + return 'F'; + } if ($copyright eq 'priv') { $uri=~/([^\/]+)\/([^\/]+)\//; unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { @@ -1984,14 +2076,15 @@ sub is_on_map { my @uriparts=split(/\//,$uri); my $filename=$uriparts[$#uriparts]; my $pathname=$uri; - $pathname=~s/\/$filename$//; + $pathname=~s|/\Q$filename\E$||; + #Trying to find the conditional for the file my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/); + /\&\Q$filename\E\:([\d\|]+)\&/); if ($match) { - return (1,$1); - } else { - return (0,0); - } + return (1,$1); + } else { + return (0,0); + } } # ----------------------------------------------------------------- Define Role @@ -2282,20 +2375,59 @@ sub modifystudent { ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, $desiredhome); unless ($reply eq 'ok') { return $reply; } + # This will cause &modify_student_enrollment to get the uid from the + # students environment + $uid = undef if (!$forceid); + $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle, + $last,$gene,$usec,$end,$start); + return $reply; +} + +sub modify_student_enrollment { + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_; + # Get the course id from the environment + my $cid=''; + unless ($cid=$ENV{'request.course.id'}) { + return 'not_in_class'; + } + # Make sure the user exists my $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such user'; } -# -------------------------------------------------- Add student to course list - $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. + # + # Get student data if we were not given enough information + if (!defined($first) || $first eq '' || + !defined($last) || $last eq '' || + !defined($uid) || $uid eq '' || + !defined($middle) || $middle eq '' || + !defined($gene) || $gene eq '') { + # They did not supply us with enough data to enroll the student, so + # we need to pick up more information. + my %tmp = &get('environment', + ['firstname','middlename','lastname', 'generation','id'] + ,$udom,$uname); + + foreach (keys(%tmp)) { + &logthis("key $_ = ".$tmp{$_}); + } + $first = $tmp{'firstname'} if (!defined($first) || $first eq ''); + $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); + $last = $tmp{'lastname'} if (!defined($last) || $last eq ''); + $gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); + $uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); + } + my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, + $first,$middle); + my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. $ENV{'course.'.$cid.'.num'}.':classlist:'. &escape($uname.':'.$udom).'='. - &escape($end.':'.$start), + &escape(join(':',$end,$start,$uid,$usec,$fullname)), $ENV{'course.'.$cid.'.home'}); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; } -# ---------------------------------------------------- Add student role to user + # Add student role to user my $uurl='/'.$cid; $uurl=~s/\_/\//g; if ($usec) { @@ -2586,11 +2718,11 @@ sub courseresdata { } } foreach my $item (@which) { - if ($courseresdatacache{$hashid}->{$item}) { + if (defined($courseresdatacache{$hashid}->{$item})) { return $courseresdatacache{$hashid}->{$item}; } } - return ''; + return undef; } # --------------------------------------------------------- Value of a Variable @@ -2737,7 +2869,7 @@ sub EXT { ($seclevelr,$seclevelm,$seclevel, $courselevelr,$courselevelm, $courselevel)); - if ($coursereply) { return $coursereply; } + if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms my %parmhash=(); @@ -2761,9 +2893,9 @@ sub EXT { $filename=$ENV{'request.filename'}; } my $metadata=&metadata($filename,$spacequalifierrest); - if ($metadata) { return $metadata; } + if (defined($metadata)) { return $metadata; } $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); - if ($metadata) { return $metadata; } + if (defined($metadata)) { return $metadata; } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { @@ -2771,11 +2903,11 @@ sub EXT { if ($id) { my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, $symbparm,$udom,$uname); - if ($partgeneral) { return $partgeneral; } + if (defined($partgeneral)) { return $partgeneral; } } else { my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, $symbparm,$udom,$uname); - if ($resourcegeneral) { return $resourcegeneral; } + if (defined($resourcegeneral)) { return $resourcegeneral; } } } @@ -2804,6 +2936,11 @@ sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); + # if it is a non metadata possible uri return quickly + if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) { + return ''; + } my $filename=$uri; $uri=~s/\.meta$//; # @@ -2961,6 +3098,33 @@ sub metadata_generate_part0 { } } +# ------------------------------------------------- Get the title of a resource + +sub gettitle { + my $urlsymb=shift; + my $symb=&symbread($urlsymb); + unless ($symb) { + unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } + return &metadata($urlsymb,'title'); + } + if ($titlecache{$symb}) { return $titlecache{$symb}; } + my ($map,$resid,$url)=split(/\_\_\_/,$symb); + my $title=''; + my %bighash; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $mapid=$bighash{'map_pc_'.&clutter($map)}; + $title=$bighash{'title_'.$mapid.'.'.$resid}; + untie %bighash; + } + if ($title) { + $titlecache{$symb}=$title; + return $title; + } else { + return &metadata($urlsymb,'title'); + } +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -3313,6 +3477,7 @@ BEGIN { $hostname{$id}=$name; $hostdom{$id}=$domain; $hostip{$id}=$ip; + $iphost{$ip}=$id; if ($domdescr) { $domaindescription{$domain}=$domdescr; } if ($role eq 'library') { $libserv{$id}=$name; } } else { @@ -3329,7 +3494,7 @@ BEGIN { while (my $configline=<$config>) { chomp($configline); - if (($configline) && ($configline ne $perlvar{'lonHostID'})) { + if ($configline) { $spareid{$configline}=1; } } @@ -3593,7 +3758,83 @@ modify user =item * -modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,$end,$start) : modify student +modifystudent + +modify a students enrollment and identification information. +The course id is resolved based on the current users environment. +This means the envoking user must be a course coordinator or otherwise +associated with a course. + +This call is essentially a wrapper for lonnet::modifyuser and +lonnet::modify_student_enrollment + +Inputs: + +=over 4 + +=item B<$udom> Students loncapa domain + +=item B<$uname> Students loncapa login name + +=item B<$uid> Students id/student number + +=item B<$umode> Students authentication mode + +=item B<$upass> Students password + +=item B<$first> Students first name + +=item B<$middle> Students middle name + +=item B<$last> Students last name + +=item B<$gene> Students generation + +=item B<$usec> Students section in course + +=item B<$end> Unix time of the roles expiration + +=item B<$start> Unix time of the roles start date + +=item B<$forceid> If defined, allow $uid to be changed + +=item B<$desiredhome> server to use as home server for student + +=back + +=item * + +modify_student_enrollment + +Change a students enrollment status in a class. The environment variable +'role.request.course' must be defined for this function to proceed. + +Inputs: + +=over 4 + +=item $udom, students domain + +=item $uname, students name + +=item $uid, students user id + +=item $first, students first name + +=item $middle + +=item $last + +=item $gene + +=item $usec + +=item $end + +=item $start + +=back + =item *