--- loncom/lonnet/perl/lonnet.pm 2002/10/09 17:24:06 1.294 +++ loncom/lonnet/perl/lonnet.pm 2003/03/22 21:23:35 1.345 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.294 2002/10/09 17:24:06 matthew Exp $ +# $Id: lonnet.pm,v 1.345 2003/03/22 21:23:35 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -47,23 +47,18 @@ # 09/01 Guy Albertelli # 09/01,10/01,11/01 Gerd Kortemeyer # YEAR=2001 -# 02/27/01 Scott Harrison # 3/2 Gerd Kortemeyer -# 3/15,3/19 Scott Harrison # 3/19,3/20 Gerd Kortemeyer -# 3/22,3/27,4/2,4/16,4/17 Scott Harrison # 5/26,5/28 Gerd Kortemeyer # 5/30 H. K. Ng # 6/1 Gerd Kortemeyer # July Guy Albertelli # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, # 10/2 Gerd Kortemeyer -# 10/5,10/10,11/13,11/15 Scott Harrison # 11/17,11/20,11/22,11/29 Gerd Kortemeyer # 12/5 Matthew Hall # 12/5 Guy Albertelli # 12/6,12/7,12/12 Gerd Kortemeyer -# 12/18 Scott Harrison # 12/21,12/22,12/27,12/28 Gerd Kortemeyer # YEAR=2002 # 1/4,2/4,2/7 Gerd Kortemeyer @@ -77,10 +72,11 @@ 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); + %coursedombuf %coursehombuf %courseresdatacache + %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); @@ -142,9 +138,9 @@ sub reply { unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { - #sleep 5; - #$answer=subreply($cmd,$server); - #if ($answer eq 'con_lost') { + #sleep 5; + #$answer=subreply($cmd,$server); + #if ($answer eq 'con_lost') { # &logthis("Second attempt con_lost on $server"); # my $peerfile="$perlvar{'lonSockDir'}/$server"; # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", @@ -215,7 +211,8 @@ sub critical { $middlename=substr($middlename,0,16); $middlename=~s/\W//g; my $dfilename= - "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; + "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; + $dumpcount++; { my $dfh; if ($dfh=Apache::File->new(">$dfilename")) { @@ -591,8 +588,147 @@ sub idput { } } +# --------------------------------------------------- Assign a key to a student + +sub assign_access_key { + my ($ckey,$cdom,$cnum,$udom,$uname)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + if (($existing{$ckey}=~/^\d+$/) || # has time - new key + ($existing{$ckey} eq $udom.':'.$uname)) { # this should not happen, + # unless something went wrong + # the first time around +# ready to assign + } elsif (!$existing{$ckey}) { + if (&put('accesskey',{$ckey=>$udom.':'.$uname},$cdom,$cnum) eq 'ok') { +# key now belongs to user + my $envkey='key.'.$cdom.'.'.$cnum; + if (&put('environment',{$envkey => $ckey}) eq 'ok') { + &appenv('environment.'.$envkey => $ckey); + return 'ok'; + } else { + return + 'error: Count not permanently assign key, will need to be re-entered later.'; + } + } else { + return 'error: Could not assign key, try again later.'; + } +# the key does not exist + return 'error: The key does not exist'; + } else { +# the key is somebody else's + return 'error: The key is already in use'; + } +} + +# ------------------------------------------------------ Generate a set of keys + +sub generate_access_keys { + my ($number,$cdom,$cnum)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + unless (&allowed('ccc',$cdom)) { return 0; } + unless (($cdom) && ($cnum)) { return 0; } + if ($number>10000) { return 0; } + sleep(2); # make sure don't get same seed twice + srand(time()^($$+($$<<15))); # from "Programming Perl" + my $total=0; + for (my $i=1;$i<=$number;$i++) { + my $newkey=sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)); + $newkey=~s/1/g/g; # folks mix up 1 and l + $newkey=~s/0/h/g; # and also 0 and O + my %existing=&get('accesskeys',[$newkey],$cdom,$cnum); + if ($existing{$newkey}) { + $i--; + } else { + if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') { + $total++; + } + } + } + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); + return $total; +} + +# ------------------------------------------------------- Validate an accesskey + +sub validate_access_key { + my ($ckey,$cdom,$cnum,$udom,$uname)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + return ($existing{$ckey} eq $udom.':'.$uname); +} + # ------------------------------------- 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; @@ -674,12 +810,13 @@ sub currentversion { sub subscribe { my $fname=shift; + if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } 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 'not_found'; + if ($home eq 'no_host') { + return 'not_found'; } my $answer=reply("sub:$fname",$home); if (($answer eq 'con_lost') || ($answer eq 'rejected')) { @@ -753,6 +890,18 @@ sub repcopy { } } +# ------------------------------------------------ Get server side include body +sub ssi_body { + my $filelink=shift; + my $output=($filelink=~/^http\:/?&externalssi($filelink): + &ssi($filelink)); + $output=~s/^.*\]*\>//si; + $output=~s/\<\/body\s*\>.*$//si; + $output=~ + s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; + return $output; +} + # --------------------------------------------------------- Server Side Include sub ssi { @@ -776,6 +925,14 @@ sub ssi { return $response->content; } +sub externalssi { + my ($url)=@_; + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',$url); + my $response=$ua->request($request); + return $response->content; +} + # ------- Add a token to a remote URI's query string to vouch for access rights sub tokenwrapper { @@ -787,7 +944,8 @@ sub tokenwrapper { if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. - (($uri=~/\?/)?'&':'?').'token='.$token; + (($uri=~/\?/)?'&':'?').'token='.$token. + '&tokenissued='.$perlvar{'lonHostID'}; } else { return '/adm/notfound.html'; } @@ -800,8 +958,15 @@ sub tokenwrapper { sub userfileupload { my ($formname,$coursedoc)=@_; my $fname=$ENV{'form.'.$formname.'.filename'}; +# Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; +# Get rid of everything but the actual filename $fname=~s/^.*\/([^\/]+)$/$1/; +# Replace spaces by underscores + $fname=~s/\s+/\_/g; +# Replace all other weird characters by nothing + $fname=~s/[^\w\.\-]//g; +# See if there is anything left unless ($fname) { return 'error: no uploaded file'; } chop($ENV{'form.'.$formname}); # Create the directory if not present @@ -840,13 +1005,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'; } } @@ -1042,12 +1210,16 @@ sub expirespread { # ----------------------------------------------------- Devalidate Spreadsheets sub devalidate { - my $symb=shift; + my ($symb,$uname,$udom)=@_; my $cid=$ENV{'request.course.id'}; if ($cid) { - my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; +# delete the stored spreadsheets for +# - the student level sheet of this user in course's homespace +# - the assessment level sheet for this resource +# for this user in user's homespace + my $key=$uname.':'.$udom.':'; my $status= - &del('nohist_calculatedsheet', + &del('nohist_calculatedsheets', [$key.'studentcalc'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) @@ -1056,7 +1228,7 @@ sub devalidate { [$key.'assesscalc:'.$symb]); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. + $uname.' at '.$udom.' for '. $symb.': '.$status); } } @@ -1388,7 +1560,10 @@ sub store { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - &devalidate($symb); + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); $symb=escape($symb); if (!$namespace) { @@ -1396,8 +1571,6 @@ sub store { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; foreach (keys %$storehash) { @@ -1419,7 +1592,10 @@ sub cstore { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - &devalidate($symb); + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); $symb=escape($symb); if (!$namespace) { @@ -1427,8 +1603,6 @@ sub cstore { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; @@ -1486,11 +1660,15 @@ sub coursedescription { $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); my $chome=&homeserver($cnum,$cdomain); + my $normalid=$cdomain.'_'.$cnum; + # need to always cache even if we get errors otherwise we keep + # trying and trying and trying to get the course description. + my %envhash=(); + my %returnhash=(); + $envhash{'course.'.$normalid.'.last_cache'}=time; if ($chome ne 'no_host') { - my %returnhash=&dump('environment',$cdomain,$cnum); + %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { - my $normalid=$cdomain.'_'.$cnum; - my %envhash=(); $returnhash{'home'}= $chome; $returnhash{'domain'} = $cdomain; $returnhash{'num'} = $cnum; @@ -1500,15 +1678,13 @@ sub coursedescription { $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; - $envhash{'course.'.$normalid.'.last_cache'}=time; $envhash{'course.'.$normalid.'.home'}=$chome; $envhash{'course.'.$normalid.'.domain'}=$cdomain; $envhash{'course.'.$normalid.'.num'}=$cnum; - &appenv(%envhash); - return %returnhash; } } - return (); + &appenv(%envhash); + return %returnhash; } # -------------------------------------------------------- Get user privileges @@ -1675,6 +1851,58 @@ sub dump { return %returnhash; } +# --------------------------------------------------------------- currentdump +sub currentdump { + my ($courseid,$sdom,$sname)=@_; + $courseid = $ENV{'request.course.id'} if (! defined($courseid)); + $sdom = $ENV{'user.domain'} if (! defined($sdom)); + $sname = $ENV{'user.name'} if (! defined($sname)); + my $uhome = &homeserver($sname,$sdom); + my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); + return if ($rep =~ /^(error:|no_such_host)/); + # + my %returnhash=(); + # + if ($rep eq "unknown_cmd") { + # an old lond will not know currentdump + # Do a dump and make it look like a currentdump + my @tmp = &dump($courseid,$sdom,$sname,'.'); + return if ($tmp[0] =~ /^(error:|no_such_host)/); + my %hash = @tmp; + @tmp=(); + # Code ripped from lond, essentially. The only difference + # here is the unescaping done by lonnet::dump(). Conceivably + # we might run in to problems with parameter names =~ /^v\./ + while (my ($key,$value) = each(%hash)) { + my ($v,$symb,$param) = split(/:/,$key); + next if ($v eq 'version' || $symb eq 'keys'); + next if (exists($returnhash{$symb}) && + exists($returnhash{$symb}->{$param}) && + $returnhash{$symb}->{'v.'.$param} > $v); + $returnhash{$symb}->{$param}=$value; + $returnhash{$symb}->{'v.'.$param}=$v; + } + # + # Remove all of the keys in the hashes which keep track of + # the version of the parameter. + while (my ($symb,$param_hash) = each(%returnhash)) { + # use a foreach because we are going to delete from the hash. + foreach my $key (keys(%$param_hash)) { + delete($param_hash->{$key}) if ($key =~ /^v\./); + } + } + } else { + my @pairs=split(/\&/,$rep); + foreach (@pairs) { + my ($key,$value)=split(/=/,$_); + my ($symb,$param) = split(/:/,$key); + $returnhash{&unescape($symb)}->{&unescape($param)} = + &unescape($value); + } + } + return %returnhash; +} + # --------------------------------------------------------------- put interface sub put { @@ -1728,6 +1956,37 @@ sub eget { return %returnhash; } +# ---------------------------------------------- Custom access rule evaluation + +sub customaccess { + my ($priv,$uri)=@_; + my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); + $urealm=~s/^\W//; + my ($udom,$ucrs,$usec)=split(/\//,$urealm); + my $access=0; + foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { + my ($effect,$realm,$role)=split(/\:/,$_); + if ($role) { + if ($role ne $urole) { next; } + } + foreach (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$_); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } + } + return $access; +} + # ------------------------------------------------- Check for a user privilege sub allowed { @@ -1746,7 +2005,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)) { @@ -1764,6 +2025,9 @@ sub allowed { # Library role, so allow browsing of resources in this domain. return 'F'; } + if ($copyright eq 'custom') { + unless (&customaccess($priv,$uri)) { return ''; } + } } # Domain coordinator is trying to create a course if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { @@ -1800,6 +2064,12 @@ sub allowed { $thisallowed.=$1; } +# URI is an uploaded document for this course + + if (($priv eq 'bre') && + ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) { + return 'F'; + } # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { @@ -1975,20 +2245,10 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; - my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; - if (-e $filename) { - my @content; - { - my $fh=Apache::File->new($filename); - @content=<$fh>; - } - if (join('',@content)=~ - /\]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + if (&metadata($uri,'roledeny')=~/$rolecode/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); - return ''; - - } + return ''; } } @@ -2019,6 +2279,7 @@ sub is_on_map { my $filename=$uriparts[$#uriparts]; my $pathname=$uri; $pathname=~s|/\Q$filename\E$||; + $pathname=~s/^adm\/wrapper\///; #Trying to find the conditional for the file my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ /\&\Q$filename\E\:([\d\|]+)\&/); @@ -2286,10 +2547,15 @@ sub modifyuser { } } # -------------------------------------------------------------- Add names, etc - my %names=&get('environment', + my @tmp=&get('environment', ['firstname','middlename','lastname','generation'], $udom,$uname); - if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } + my %names; + if ($tmp[0] =~ m/^error:.*/) { + %names=(); + } else { + %names = @tmp; + } if ($first) { $names{'firstname'} = $first; } if ($middle) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } @@ -2317,26 +2583,51 @@ 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 - if ($first eq '' || $last eq '' || $uid eq '') { + # + # 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 = dump('environment',$udom,$uname, + 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{'genename'} if (!defined($gene) || $gene 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); - $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. + my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. $ENV{'course.'.$cid.'.num'}.':classlist:'. &escape($uname.':'.$udom).'='. &escape(join(':',$end,$start,$uid,$usec,$fullname)), @@ -2344,7 +2635,7 @@ sub modifystudent { 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) { @@ -2632,6 +2923,8 @@ sub courseresdata { if ($tmp !~ /^(con_lost|error|no_such_host)/i) { $courseresdatacache{$hashid.'.time'}=time; $courseresdatacache{$hashid}=\%dumpreply; + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; } } foreach my $item (@which) { @@ -2648,7 +2941,6 @@ sub EXT { my ($varname,$symbparm,$udom,$uname,)=@_; unless ($varname) { return ''; } - #get real user name/domain, courseid and symb my $courseid; if (!($uname && $udom)) { @@ -2657,14 +2949,14 @@ sub EXT { } else { $courseid=$ENV{'request.course.id'}; } - my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; - if ($therest[0]) { + if (defined($therest[0])) { $rest=join('.',@therest); } else { $rest=''; } + my $qualifierrest=$qualifier; if ($rest) { $qualifierrest.='.'.$rest; } my $spacequalifierrest=$space; @@ -2672,8 +2964,12 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore(undef,undef,$udom,$uname); - return $restored{$qualifierrest}; + if (defined($Apache::lonhomework::parsing_a_problem)) { + return $Apache::lonhomework::history{$qualifierrest}; + } else { + my %restored=&restore($symbparm,$courseid,$udom,$uname); + return $restored{$qualifierrest}; + } # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { # FIXME - not supporting calls for a specific user @@ -2708,9 +3004,8 @@ sub EXT { return $uname; # ---------------------------------------------------- Any other user namespace } else { - my $item=($rest)?$qualifier.'.'.$rest:$qualifier; - my %reply=&get($space,[$item]); - return $reply{$item}; + my %reply=&get($space,[$qualifierrest],$udom,$uname); + return $reply{$qualifierrest}; } } elsif ($realm eq 'query') { # ---------------------------------------------- pull stuff out of query string @@ -2758,24 +3053,35 @@ sub EXT { my $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - my %resourcedata=&get('resourcedata', - [$courselevelr,$courselevelm,$courselevel], - $udom,$uname); - if (($resourcedata{$courselevelr}!~/^error\:/) && - ($resourcedata{$courselevelr}!~/^con_lost/)) { - - if ($resourcedata{$courselevelr}) { - return $resourcedata{$courselevelr}; } - if ($resourcedata{$courselevelm}) { - return $resourcedata{$courselevelm}; } - if ($resourcedata{$courselevel}) { - return $resourcedata{$courselevel}; } - } else { - if ($resourcedata{$courselevelr}!~/No such file/) { - &logthis("WARNING:". - " Trying to get resource data for ". - $uname." at ".$udom.": ". - $resourcedata{$courselevelr}.""); + #most student don't have any data set, check if there is some data + #every thirty minutes + if (! + (exists($ENV{'cache.studentresdata'}) + && (($ENV{'cache.studentresdata'}+1800) > time))) { + my %resourcedata=&get('resourcedata', + [$courselevelr,$courselevelm,$courselevel], + $udom,$uname); + my ($tmp)=keys(%resourcedata); + if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { + if ($resourcedata{$courselevelr}) { + return $resourcedata{$courselevelr}; } + if ($resourcedata{$courselevelm}) { + return $resourcedata{$courselevelm}; } + if ($resourcedata{$courselevel}) { + return $resourcedata{$courselevel}; } + } else { + if ($tmp!~/No such file/) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); + } elsif ($tmp=~/error:No such file/) { + $ENV{'cache.studentresdata'}=time; + &appenv(('cache.studentresdata'=> + $ENV{'cache.studentresdata'})); + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; + } } } @@ -2816,16 +3122,13 @@ sub EXT { # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { - my ($part,$id)=split(/\_/,$space); - if ($id) { - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm,$udom,$uname); - if (defined($partgeneral)) { return $partgeneral; } - } else { - my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, - $symbparm,$udom,$uname); - if (defined($resourcegeneral)) { return $resourcegeneral; } - } + my @parts=split(/_/,$space); + my $id=pop(@parts); + my $part=join('_',@parts); + if ($part eq '') { $part='0'; } + my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + $symbparm,$udom,$uname); + if (defined($partgeneral)) { return $partgeneral; } } # ---------------------------------------------------- Any other user namespace @@ -2847,6 +3150,22 @@ sub EXT { return ''; } +sub add_prefix_and_part { + my ($prefix,$part)=@_; + my $keyroot; + if (defined($prefix) && $prefix !~ /^__/) { + # prefix that has a part already + $keyroot=$prefix; + } elsif (defined($prefix)) { + # prefix that is missing a part + if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); } + } else { + # no prefix at all + if (defined($part)) { $keyroot='_'.$part; } + } + return $keyroot; +} + # ---------------------------------------------------------------- Get metadata sub metadata { @@ -2875,113 +3194,129 @@ sub metadata { } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } - my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); + my $metastring=&getfile(&filelocation('',&clutter($filename))); my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - if (defined($token->[2]->{'package'})) { + if ($token->[0] eq 'S') { + if (defined($token->[2]->{'package'})) { # # This is a package - get package info # - my $package=$token->[2]->{'package'}; - my $keyroot=''; - if ($prefix) { - $keyroot.=$prefix; - } else { - if (defined($token->[2]->{'part'})) { - $keyroot.='_'.$token->[2]->{'part'}; - } - } - if (defined($token->[2]->{'id'})) { - $keyroot.='_'.$token->[2]->{'id'}; - } - if ($metacache{$uri.':packages'}) { - $metacache{$uri.':packages'}.=','.$package.$keyroot; - } else { - $metacache{$uri.':packages'}=$package.$keyroot; - } - foreach (keys %packagetab) { - if ($_=~/^$package\&/) { - my ($pack,$name,$subp)=split(/\&/,$_); - my $value=$packagetab{$_}; - my $part=$keyroot; - $part=~s/^\_//; - if ($subp eq 'display') { - $value.=' [Part: '.$part.']'; - } - my $unikey='parameter'.$keyroot.'_'.$name; - $metathesekeys{$unikey}=1; - $metacache{$uri.':'.$unikey.'.part'}=$part; - unless - (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { - $metacache{$uri.':'.$unikey.'.'.$subp}=$value; - } - } - } - } else { + my $package=$token->[2]->{'package'}; + my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + if (defined($token->[2]->{'id'})) { + $keyroot.='_'.$token->[2]->{'id'}; + } + if ($metacache{$uri.':packages'}) { + $metacache{$uri.':packages'}.=','.$package.$keyroot; + } else { + $metacache{$uri.':packages'}=$package.$keyroot; + } + foreach (keys %packagetab) { + if ($_=~/^$package\&/) { + my ($pack,$name,$subp)=split(/\&/,$_); + my $value=$packagetab{$_}; + my $part=$keyroot; + $part=~s/^\_//; + if ($subp eq 'display') { + $value.=' [Part: '.$part.']'; + } + my $unikey='parameter'.$keyroot.'_'.$name; + if ($subp eq 'default') { $unikey='parameter_0_'.$name; } + $metathesekeys{$unikey}=1; + $metacache{$uri.':'.$unikey.'.part'}=$part; + unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { + $metacache{$uri.':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri.':'.$unikey.'.default'})) { + $metacache{$uri.':'.$unikey}= + $metacache{$uri.':'.$unikey.'.default'} + } + } + } + } else { # # This is not a package - some other kind of start tag -# - my $entry=$token->[1]; - my $unikey; - if ($entry eq 'import') { - $unikey=''; - } else { - $unikey=$entry; - } - if ($prefix) { - $unikey.=$prefix; - } else { - if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; - } - } - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; - } +# + my $entry=$token->[1]; + my $unikey; + if ($entry eq 'import') { + $unikey=''; + } else { + $unikey=$entry; + } + $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } - if ($entry eq 'import') { + if ($entry eq 'import') { # # Importing a library here -# - if ($depthcount<20) { - my $location=$parser->get_text('/import'); - my $dir=$filename; - $dir=~s|[^/]*$||; - $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,$unikey, - $depthcount+1)))) { - $metathesekeys{$_}=1; - } - } - } else { - - if (defined($token->[2]->{'name'})) { - $unikey.='_'.$token->[2]->{'name'}; - } - $metathesekeys{$unikey}=1; - foreach (@{$token->[3]}) { - $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; - } - unless ( - $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) - ) { $metacache{$uri.':'.$unikey}= - $metacache{$uri.':'.$unikey.'.default'}; - } +# + if ($depthcount<20) { + my $location=$parser->get_text('/import'); + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,$unikey, + $depthcount+1)))) { + $metathesekeys{$_}=1; + } + } + } else { + + if (defined($token->[2]->{'name'})) { + $unikey.='_'.$token->[2]->{'name'}; + } + $metathesekeys{$unikey}=1; + foreach (@{$token->[3]}) { + $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; + } + my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); + my $default=$metacache{$uri.':'.$unikey.'.default'}; + if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { + # only ws inside the tag, and not in default, so use default + # as value + $metacache{$uri.':'.$unikey}=$default; + } else { + # either something interesting inside the tag or default + # uninteresting + $metacache{$uri.':'.$unikey}=$internaltext; + } # end of not-a-package not-a-library import - } + } # end of not-a-package start tag - } + } # the next is the end of "start tag" - } - } - $metacache{$uri.':keys'}=join(',',keys %metathesekeys); + } + } +# are there custom rights to evaluate + if ($metacache{$uri.':copyright'} eq 'custom') { + + # + # Importing a rights file here + # + unless ($depthcount) { + my $location=$metacache{$uri.':customdistributionfile'}; + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,'_rights', + $depthcount+1)))) { + $metathesekeys{$_}=1; + } + } + } + $metacache{$uri.':keys'}=join(',',keys %metathesekeys); &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); - $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); - $metacache{$uri.':cachedtimestamp'}=time; + $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); + $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached } return $metacache{$uri.':'.$what}; @@ -3015,6 +3350,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 { @@ -3356,18 +3718,42 @@ BEGIN { } } +# ------------------------------------------------------------ Read domain file +{ + my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. + '/domain.tab'); + %domaindescription = (); + %domain_auth_def = (); + %domain_auth_arg_def = (); + if ($fh) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($domain, $domain_description, $def_auth, $def_auth_arg) + = split(/:/,$_,4); + $domain_auth_def{$domain}=$def_auth; + $domain_auth_arg_def{$domain}=$def_auth_arg; + $domaindescription{$domain}=$domain_description; +# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); +# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); + } + } +} + + # ------------------------------------------------------------- Read hosts file { my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); while (my $configline=<$config>) { + next if ($configline =~ /^(\#|\s*$)/); chomp($configline); my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); if ($id && $domain && $role && $name && $ip) { $hostname{$id}=$name; $hostdom{$id}=$domain; $hostip{$id}=$ip; - if ($domdescr) { $domaindescription{$domain}=$domdescr; } + $iphost{$ip}=$id; if ($role eq 'library') { $libserv{$id}=$name; } } else { if ($configline) { @@ -3429,6 +3815,12 @@ BEGIN { } } +# ------------- set up temporary directory +{ + $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; + +} + %metacache=(); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; @@ -3654,7 +4046,8 @@ The course id is resolved based on the c 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 +This call is essentially a wrapper for lonnet::modifyuser and +lonnet::modify_student_enrollment Inputs: @@ -3692,6 +4085,40 @@ Inputs: =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 * + assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign custom role; give a custom role to a user for the level given by URL. Specify name and domain of role author, and role name