--- loncom/lonnet/perl/lonnet.pm 2002/06/24 14:16:58 1.242 +++ loncom/lonnet/perl/lonnet.pm 2003/10/30 22:52:25 1.437 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.242 2002/06/24 14:16:58 www Exp $ +# $Id: lonnet.pm,v 1.437 2003/10/30 22:52:25 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -25,49 +25,6 @@ # # http://www.lon-capa.org/ # -# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, -# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, -# 11/8,11/16,11/18,11/22,11/23,12/22, -# 01/06,01/13,02/24,02/28,02/29, -# 03/01,03/02,03/06,03/07,03/13, -# 04/05,05/29,05/31,06/01, -# 06/05,06/26 Gerd Kortemeyer -# 06/26 Ben Tyszka -# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer -# 08/14 Ben Tyszka -# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer -# 10/04 Gerd Kortemeyer -# 10/04 Guy Albertelli -# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, -# 10/30,10/31, -# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, -# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer -# 05/01/01 Guy Albertelli -# 05/01,06/01,09/01 Gerd Kortemeyer -# 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 -# ### package Apache::lonnet; @@ -77,15 +34,22 @@ use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars -qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom - %libserv %pr %prp %metacache %packagetab - %courselogs %accesshash $processmarker $dumpcount - %coursedombuf %coursehombuf %courseresdatacache); +qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom + %libserv %pr %prp %metacache %packagetab %titlecache + %courselogs %accesshash %userrolehash $processmarker $dumpcount + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache + %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); + use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); use HTML::LCParser; use Fcntl qw(:flock); +use Apache::loncoursedata; +use Apache::lonlocal; +use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); +use Time::HiRes(); my $readit; # --------------------------------------------------------------------- Logging @@ -140,9 +104,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", @@ -213,7 +177,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")) { @@ -245,6 +210,49 @@ sub critical { return $answer; } +# +# -------------- Remove all key from the env that start witha lowercase letter +# (Which is always a lon-capa value) + +sub cleanenv { +# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; } +# unless (&Apache::exists_config_define("MODPERL2")) { return; } + foreach my $key (keys(%ENV)) { + if ($key =~ /^[a-z]/) { + delete($ENV{$key}); + } + } +} + +# ------------------------------------------- Transfer profile into environment + +sub transfer_profile_to_env { + my ($lonidsdir,$handle)=@_; + my @profile; + { + my $idf=Apache::File->new("$lonidsdir/$handle.id"); + flock($idf,LOCK_SH); + @profile=<$idf>; + $idf->close(); + } + my $envi; + my %Remove; + for ($envi=0;$envi<=$#profile;$envi++) { + chomp($profile[$envi]); + my ($envname,$envvalue)=split(/=/,$profile[$envi]); + $ENV{$envname} = $envvalue; + if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { + if ($time < time-300) { + $Remove{$key}++; + } + } + } + foreach my $expired_key (keys(%Remove)) { + &delenv($expired_key); + } + $ENV{'user.environment'} = "$lonidsdir/$handle.id"; +} + # ---------------------------------------------------------- Append Environment sub appenv { @@ -348,19 +356,85 @@ sub delenv { return 'ok'; } +# ------------------------------------------ Find out current server userload +# there is a copy in lond +sub userload { + my $numusers=0; + { + opendir(LONIDS,$perlvar{'lonIDsDir'}); + my $filename; + my $curtime=time; + while ($filename=readdir(LONIDS)) { + if ($filename eq '.' || $filename eq '..') {next;} + my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 1800) { $numusers++; } + } + closedir(LONIDS); + } + my $userloadpercent=0; + my $maxuserload=$perlvar{'lonUserLoadLim'}; + if ($maxuserload) { + $userloadpercent=100*$numusers/$maxuserload; + } + $userloadpercent=sprintf("%.2f",$userloadpercent); + return $userloadpercent; +} + +# ------------------------------------------ Fight off request when overloaded + +sub overloaderror { + my ($r,$checkserver)=@_; + unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } + my $loadavg; + if ($checkserver eq $perlvar{'lonHostID'}) { + 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-100; + if ($overload>0) { + $r->err_headers_out->{'Retry-After'}=$overload; + $r->log_error('Overload of '.$overload.' on '.$checkserver); + return 413; + } + return ''; +} + # ------------------------------ Find server with least workload from spare.tab sub spareserver { + my ($loadpercent,$userloadpercent) = @_; my $tryserver; my $spareserver=''; - my $lowestserver=100; + if ($userloadpercent !~ /\d/) { $userloadpercent=0; } + my $lowestserver=$loadpercent > $userloadpercent? + $loadpercent : $userloadpercent; foreach $tryserver (keys %spareid) { - my $answer=reply('load',$tryserver); - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - $spareserver="http://$hostname{$tryserver}"; - $lowestserver=$answer; - } - } + my $loadans=reply('load',$tryserver); + my $userloadans=reply('userload',$tryserver); + if ($loadans !~ /\d/ && $userloadans !~ /\d/) { + next; #didn't get a number from the server + } + my $answer; + if ($loadans =~ /\d/) { + if ($userloadans =~ /\d/) { + #both are numbers, pick the bigger one + $answer=$loadans > $userloadans? + $loadans : $userloadans; + } else { + $answer = $loadans; + } + } else { + $answer = $userloadans; + } + if (($answer =~ /\d/) && ($answer<$lowestserver)) { + $spareserver="http://$hostname{$tryserver}"; + $lowestserver=$answer; + } + } return $spareserver; } @@ -483,9 +557,9 @@ sub authenticate { sub homeserver { my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - if ($homecache{$index}) { - return "$homecache{$index}"; - } + + my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); + if (defined($cached)) { return $result; } my $tryserver; foreach $tryserver (keys %libserv) { next if ($ignoreBadCache ne 'true' && @@ -493,8 +567,7 @@ sub homeserver { if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - $homecache{$index}=$tryserver; - return $tryserver; + return &do_cache(\%homecache,$index,$tryserver,'home'); } elsif ($answer eq 'no_host') { $badServerCache{$tryserver}=1; } @@ -565,10 +638,347 @@ sub idput { } } +# --------------------------------------------------- Assign a key to a student + +sub assign_access_key { +# +# a valid key looks like uname:udom#comments +# comments are being appended +# + my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_; + $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}=~/^\#(.*)$/) || # - new key + ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { + # assigned to this person + # - this should not happen, + # unless something went wrong + # the first time around +# ready to assign + $logentry=$1.'; '.$logentry; + if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry}, + $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.'; + } + } elsif (!$existing{$ckey}) { +# 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'; + } +} + +# ------------------------------------------ put an additional comment on a key + +sub comment_access_key { +# +# a valid key looks like uname:udom#comments +# comments are being appended +# + my ($ckey,$cdom,$cnum,$logentry)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + if ($existing{$ckey}) { + $existing{$ckey}.='; '.$logentry; +# ready to assign + if (&put('accesskeys',{$ckey=>$existing{$ckey}}, + $cdom,$cnum) eq 'ok') { + return 'ok'; + } else { + return 'error: Count not store comment.'; + } + } else { +# the key does not exist + return 'error: The key does not exist'; + } +} + +# ------------------------------------------------------ Generate a set of keys + +sub generate_access_keys { + my ($number,$cdom,$cnum,$logentry)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + unless (&allowed('mky',$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 => '# generated '.localtime(). + ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. + '; '.$logentry }, + $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}=~/^$uname\:$udom\#/); +} + # ------------------------------------- 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 devalidate_cache { + my ($cache,$id,$name) = @_; + delete $$cache{$id.'.time'}; + delete $$cache{$id}; + my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_EX); + my %hash; + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + delete($hash{$id}); + delete($hash{$id.'.time'}); + } else { + &logthis("Unable to tie hash (devalidate cache): $name"); + } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); +} + +sub is_cached { + my ($cache,$id,$name,$time) = @_; + if (!$time) { $time=300; } + if (!exists($$cache{$id.'.time'})) { + &load_cache_item($cache,$name,$id); + } + if (!exists($$cache{$id.'.time'})) { +# &logthis("Didn't find $id"); + return (undef,undef); + } else { + if (time-($$cache{$id.'.time'})>$time) { +# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); + &devalidate_cache($cache,$id,$name); + return (undef,undef); + } + } + return ($$cache{$id},1); +} + +sub do_cache { + my ($cache,$id,$value,$name) = @_; + $$cache{$id.'.time'}=time; + $$cache{$id}=$value; +# &logthis("Caching $id as :$value:"); + &save_cache_item($cache,$name,$id); + # do_cache implictly return the set value + $$cache{$id}; +} + +sub save_cache { + my ($cache,$name)=@_; + my $starttime=&Time::HiRes::time(); +# &logthis("Saving :$name:"); + eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + if ($@) { &logthis("lock_store threw a die ".$@); } +# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime)); +} + +sub load_cache { + my ($cache,$name)=@_; + my $starttime=&Time::HiRes::time(); +# &logthis("Before Loading $name size is ".scalar(%$cache)); + my $tmpcache; + eval { + $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + }; + if ($@) { &logthis("lock_retreive threw a die ".$@); return; } + if (!%$cache) { + my $count; + while (my ($key,$value)=each(%$tmpcache)) { + $count++; + $$cache{$key}=$value; + } +# &logthis("Initial load: $count"); + } else { + my $key; + my $count; + while ($key=each(%$tmpcache)) { + if ($key !~/^(.*)\.time$/) { next; } + my $name=$1; + if (exists($$cache{$key})) { + if ($$tmpcache{$key} >= $$cache{$key}) { + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } else { +# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!"); + } + } else { + $count++; + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } + } +# &logthis("Additional load: $count"); + } +# &logthis("After Loading $name size is ".scalar(%$cache)); +# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); +} + +sub save_cache_item { + my ($cache,$name,$id)=@_; + my $starttime=&Time::HiRes::time(); + # &logthis("Saving :$name:$id"); + my %hash; + my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_EX); + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + $hash{$id.'.time'}=$$cache{$id.'.time'}; + $hash{$id}=freeze({'item'=>$$cache{$id}}); + } else { + &logthis("Unable to tie hash (save cache item): $name"); + } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); +# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); +} + +sub load_cache_item { + my ($cache,$name,$id)=@_; + my $starttime=&Time::HiRes::time(); +# &logthis("Before Loading $name for $id size is ".scalar(%$cache)); + my %hash; + my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_SH); + if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { + if (!%$cache) { + my $count; + while (my ($key,$value)=each(%hash)) { + $count++; + if ($key =~ /\.time$/) { + $$cache{$key}=$value; + } else { + my $hashref=thaw($value); + $$cache{$key}=$hashref->{'item'}; + } + } +# &logthis("Initial load: $count"); + } else { + my $hashref=thaw($hash{$id}); + $$cache{$id}=$hashref->{'item'}; + $$cache{$id.'.time'}=$hash{$id.'.time'}; + } + } else { + &logthis("Unable to tie hash (load cache item): $name"); + } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); +# &logthis("After Loading $name size is ".scalar(%$cache)); +# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); +} + sub usection { my ($udom,$unam,$courseid)=@_; + my $hashid="$udom:$unam:$courseid"; + + my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection'); + if (defined($cached)) { return $result; } $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', @@ -587,10 +997,12 @@ sub usection { if ($end) { if ($now>$end) { $notactive=1; } } - unless ($notactive) { return $section; } + unless ($notactive) { + return &do_cache(\%usectioncache,$hashid,$section,'usection'); + } } } - return '-1'; + return &do_cache(\%usectioncache,$hashid,'-1','usection'); } # ------------------------------------- Read an entry from a user's environment @@ -608,16 +1020,53 @@ sub userenvironment { return %returnhash; } +# -------------------------------------------------------------------- New chat + +sub chatsend { + my ($newentry,$anon)=@_; + my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + &reply('chatsend:'.$cdom.':'.$cnum.':'. + &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. + &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 { 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') || ($home eq $perlvar{'lonHostID'})) { - 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')) { @@ -647,6 +1096,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") { @@ -682,9 +1136,22 @@ sub repcopy { rename($transname,$filename); return OK; } + } } } +# ------------------------------------------------ Get server side include body +sub ssi_body { + my ($filelink,%form)=@_; + my $output=($filelink=~/^http\:/?&externalssi($filelink): + &ssi($filelink,%form)); + $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 { @@ -708,6 +1175,100 @@ 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 { + my $uri=shift; + $uri=~s/^http\:\/\/([^\/]+)//; + $uri=~s/^\///; + $ENV{'user.environment'}=~/\/([^\/]+)\.id/; + my $token=$1; + if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { + &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); + return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. + (($uri=~/\?/)?'&':'?').'token='.$token. + '&tokenissued='.$perlvar{'lonHostID'}; + } else { + return '/adm/notfound.html'; + } +} + +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element, coursedoc=1 means this is for the course +# output: url of file in userspace + +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 + my $docuname=''; + my $docudom=''; + my $docuhome=''; + if ($coursedoc) { + $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + } else { + $docuname=$ENV{'user.name'}; + $docudom=$ENV{'user.domain'}; + $docuhome=$ENV{'user.home'}; + } + return + &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); +} + +sub finishuserfileupload { + my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; + my $path=$docudom.'/'.$docuname.'/'; + my $filepath=$perlvar{'lonDocRoot'}; + my @parts=split(/\//,$filepath.'/userfiles/'.$path); + my $count; + for ($count=4;$count<=$#parts;$count++) { + $filepath.="/$parts[$count]"; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } +# Save the file + { + my $fh=Apache::File->new('>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + } +# Notify homeserver to grep it +# + + 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'; + } +} + # ------------------------------------------------------------------------- Log sub log { @@ -716,12 +1277,24 @@ sub log { } # ------------------------------------------------------------------ Course Log +# +# This routine flushes several buffers of non-mission-critical nature +# sub flushcourselogs { - &logthis('Flushing course log buffers'); + &logthis('Flushing log buffers'); +# +# course logs +# This is a log of all transactions in a course, which can be used +# for data mining purposes +# +# It also collects the courseid database, which lists last transaction +# times and course titles for all courseids +# + my %courseidbuffer=(); foreach (keys %courselogs) { my $crsid=$_; - if (&reply('log:'.$coursedombuf{$crsid}.':'. + if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { delete $courselogs{$crsid}; @@ -732,17 +1305,48 @@ sub flushcourselogs { " exceeded maximum size, deleting."); delete $courselogs{$crsid}; } - } + } + if ($courseidbuffer{$coursehombuf{$crsid}}) { + $courseidbuffer{$coursehombuf{$crsid}}.='&'. + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } else { + $courseidbuffer{$coursehombuf{$crsid}}= + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } } - &logthis('Flushing access logs'); +# +# Write course id database (reverse lookup) to homeserver of courses +# Is used in pickcourse +# + foreach (keys %courseidbuffer) { + &courseidput($hostdom{$_},$courseidbuffer{$_},$_); + } +# +# File accesses +# Writes to the dynamic metadata of resources to get hit counts, etc. +# foreach (keys %accesshash) { my $entry=$_; $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; my %temphash=($entry => $accesshash{$entry}); - if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { + if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') { delete $accesshash{$entry}; } } +# +# Roles +# Reverse lookup of user roles for course faculty/staff and co-authorship +# + foreach (keys %userrolehash) { + my $entry=$_; + my ($role,$uname,$udom,$runame,$rudom,$rsec)= + split(/\:/,$entry); + if (&Apache::lonnet::put('nohist_userroles', + { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, + $rudom,$runame) eq 'ok') { + delete $userrolehash{$entry}; + } + } $dumpcount++; } @@ -751,10 +1355,13 @@ sub courselog { $what=time.':'.$what; unless ($ENV{'request.course.id'}) { return ''; } $coursedombuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $coursenumbuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; $coursehombuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + $coursedescrbuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; } else { @@ -769,7 +1376,7 @@ sub courseacclog { my $fnsymb=shift; unless ($ENV{'request.course.id'}) { return ''; } my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; - if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) { + if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { $what.=':POST'; foreach (keys %ENV) { if ($_=~/^form\.(.*)/) { @@ -784,14 +1391,137 @@ sub countacc { my $url=&declutter(shift); unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; - my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; + my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; if (defined($accesshash{$key})) { $accesshash{$key}++; } else { $accesshash{$key}=1; } } - + +sub linklog { + my ($from,$to)=@_; + $from=&declutter($from); + $to=&declutter($to); + $accesshash{$from.'___'.$to.'___comefrom'}=1; + $accesshash{$to.'___'.$from.'___goto'}=1; +} + +sub userrolelog { + my ($trole,$username,$domain,$area,$tstart,$tend)=@_; + if (($trole=~/^ca/) || ($trole=~/^in/) || + ($trole=~/^cc/) || ($trole=~/^ep/) || + ($trole=~/^cr/)) { + my (undef,$rudom,$runame,$rsec)=split(/\//,$area); + $userrolehash + {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} + =$tend.':'.$tstart; + } +} + +sub get_course_adv_roles { + my $cid=shift; + $cid=$ENV{'request.course.id'} unless (defined($cid)); + my %coursehash=&coursedescription($cid); + my %returnhash=(); + my %dumphash= + &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + my $key=&plaintext($role); + if ($section) { $key.=' (Sec/Grp '.$section.')'; } + if ($returnhash{$key}) { + $returnhash{$key}.=','.$username.':'.$domain; + } else { + $returnhash{$key}=$username.':'.$domain; + } + } + return %returnhash; +} + +sub get_my_roles { + my ($uname,$udom)=@_; + unless (defined($uname)) { $uname=$ENV{'user.name'}; } + unless (defined($udom)) { $udom=$ENV{'user.domain'}; } + my %dumphash= + &dump('nohist_userroles',$udom,$uname); + my %returnhash=(); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } + return %returnhash; +} + +# ----------------------------------------------------- Frontpage Announcements +# +# + +sub postannounce { + my ($server,$text)=@_; + unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless ($text=~/\w/) { $text=''; } + return &reply('setannounce:'.&escape($text),$server); +} + +sub getannounce { + if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { + my $announcement=''; + while (<$fh>) { $announcement .=$_; } + $fh->close(); + if ($announcement=~/\w/) { + return + ''. + '
'.$announcement.'
'; + } else { + return ''; + } + } else { + return ''; + } +} + +# ---------------------------------------------------------- Course ID routines +# Deal with domain's nohist_courseid.db files +# + +sub courseidput { + my ($domain,$what,$coursehome)=@_; + return &reply('courseidput:'.$domain.':'.$what,$coursehome); +} + +sub courseiddump { + my ($domfilter,$descfilter,$sincefilter)=@_; + my %returnhash=(); + unless ($domfilter) { $domfilter=''; } + foreach my $tryserver (keys %libserv) { + if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + foreach ( + split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + $sincefilter.':'.&escape($descfilter), + $tryserver))) { + my ($key,$value)=split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)}=&unescape($value); + } + } + + } + } + return %returnhash; +} + +# # ----------------------------------------------------------- Check out an item sub checkout { @@ -899,117 +1629,219 @@ 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', - [$key.'studentcalc'], + &del('nohist_calculatedsheets', + [$key.'studentcalc:'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, - [$key.'assesscalc:'.$symb]); + [$key.'assesscalc:'.$symb],$udom,$uname); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. + $uname.' at '.$udom.' for '. $symb.': '.$status); } } } +sub get_scalar { + my ($string,$end) = @_; + my $value; + if ($$string =~ s/^([^&]*?)($end)/$2/) { + $value = $1; + } elsif ($$string =~ s/^([^&]*?)&//) { + $value = $1; + } + return &unescape($value); +} + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + sub arrayref2str { my ($arrayref) = @_; - my $result='_ARRAY_REF__'; + my $result='__ARRAY_REF__'; foreach my $elem (@$arrayref) { - if (ref($elem) eq 'ARRAY') { - $result.=&escape(&arrayref2str($elem)).'&'; - } elsif (ref($elem) eq 'HASH') { - $result.=&escape(&hashref2str($elem)).'&'; - } elsif (ref($elem)) { - &logthis("Got a ref of ".(ref($elem))." skipping."); + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); } else { $result.=&escape($elem).'&'; } } $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; return $result; } sub hash2str { my (%hash) = @_; my $result=&hashref2str(\%hash); - $result=~s/^_HASH_REF__//; + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; return $result; } sub hashref2str { my ($hashref)=@_; - my $result='_HASH_REF__'; + my $result='__HASH_REF__'; foreach (keys(%$hashref)) { if (ref($_) eq 'ARRAY') { - $result.=&escape(&arrayref2str($_)).'='; + $result.=&arrayref2str($_).'='; } elsif (ref($_) eq 'HASH') { - $result.=&escape(&hashref2str($_)).'='; + $result.=&hashref2str($_).'='; } elsif (ref($_)) { - &logthis("Got a ref of ".(ref($_))." skipping."); + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); } else { - $result.=&escape($_).'='; + if ($_) {$result.=&escape($_).'=';} else { last; } } - if (ref($$hashref{$_}) eq 'ARRAY') { - $result.=&escape(&arrayref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_}) eq 'HASH') { - $result.=&escape(&hashref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_})) { - &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); } else { - $result.=&escape($$hashref{$_}).'&'; + $result.=&escape($hashref->{$_}).'&'; } } $result=~s/\&$//; + $result .= '__END_HASH_REF__'; return $result; } sub str2hash { + my ($string)=@_; + my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); + return %$hash; +} + +sub str2hashref { my ($string) = @_; - my %returnhash; - foreach (split(/\&/,$string)) { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - $returnhash{$name}=$value; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); + } + + $string =~ s/^__HASH_REF__//; + + while($string !~ /^__END_HASH_REF__/) { + #key + my $key=''; + if($string =~ /^__HASH_REF__/) { + ($key, $string)=&str2hashref($string); + if(defined($key->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($key, $string)=&str2arrayref($string); + if($key->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $string =~ s/^(.*?)=//; + $key=&unescape($1); + } + $string =~ s/^=//; + + #value + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $value=&get_scalar(\$string,'__END_HASH_REF__'); + } + $string =~ s/^&//; + + $hash{$key}=$value; } - return (%returnhash); + + $string =~ s/^__END_HASH_REF__//; + + return (\%hash, $string); } sub str2array { + my ($string)=@_; + my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); + return @$array; +} + +sub str2arrayref { my ($string) = @_; - my @returnarray; - foreach my $value (split(/\&/,$string)) { - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - push(@returnarray,$value); + my @array; + + if($string !~ /^__ARRAY_REF__/) { + if (! ($string eq '' || !defined($string))) { + $array[0]='Array reference error'; + } + return (\@array, $string); + } + + $string =~ s/^__ARRAY_REF__//; + + while($string !~ /^__END_ARRAY_REF__/) { + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } else { + $value=&get_scalar(\$string,'__END_ARRAY_REF__'); + } + $string =~ s/^&//; + + push(@array, $value); } - return (@returnarray); + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); } # -------------------------------------------------------------------Temp Store @@ -1018,7 +1850,7 @@ sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } + if (!$symb) { $symb= $ENV{'request.url'}; } } $symb=escape($symb); @@ -1033,7 +1865,7 @@ sub tmpreset { my %hash; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { foreach my $key (keys %hash) { if ($key=~ /:$symb/) { delete($hash{$key}); @@ -1069,7 +1901,7 @@ sub tmpstore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { $hash{"version:$symb"}++; my $version=$hash{"version:$symb"}; my $allkeys=''; @@ -1113,7 +1945,7 @@ sub tmprestore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { my $version=$hash{"version:$symb"}; $returnhash{'version'}=$version; my $scope; @@ -1147,7 +1979,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) { @@ -1155,8 +1990,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) { @@ -1178,7 +2011,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) { @@ -1186,8 +2022,6 @@ sub cstore { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; @@ -1245,29 +2079,31 @@ 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; while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } - $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + $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 @@ -1290,6 +2126,8 @@ sub rolesinit { my ($trole,$tend,$tstart)=split(/_/,$role); $userroles.='user.role.'.$trole.'.'.$area.'='. $tstart.'.'.$tend."\n"; +# log the associated role with the area + &userrolelog($trole,$username,$domain,$area,$tstart,$tend); if ($tend!=0) { if ($tend<$now) { $trole=''; @@ -1301,42 +2139,54 @@ sub rolesinit { } } if (($area ne '') && ($trole ne '')) { - my $spec=$trole.'.'.$area; - my ($tdummy,$tdomain,$trest)=split(/\//,$area); - if ($trole =~ /^cr\//) { - my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); - my $homsvr=homeserver($rauthor,$rdomain); - if ($hostname{$homsvr} ne '') { - my $roledef= - reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", - $homsvr); - if (($roledef ne 'con_lost') && ($roledef ne '')) { - my ($syspriv,$dompriv,$coursepriv)= - split(/\_/,unescape($roledef)); - $allroles{'cm./'}.=':'.$syspriv; - $allroles{$spec.'./'}.=':'.$syspriv; - if ($tdomain ne '') { - $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; - $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; - if ($trest ne '') { - $allroles{'cm.'.$area}.=':'.$coursepriv; - $allroles{$spec.'.'.$area}.=':'.$coursepriv; - } - } - } - } - } else { - $allroles{'cm./'}.=':'.$pr{$trole.':s'}; - $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; - if ($tdomain ne '') { - $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; - $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; - if ($trest ne '') { - $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; - $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; - } - } - } + my $spec=$trole.'.'.$area; + my ($tdummy,$tdomain,$trest)=split(/\//,$area); + if ($trole =~ /^cr\//) { + my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); + my $homsvr=homeserver($rauthor,$rdomain); + if ($hostname{$homsvr} ne '') { + my ($rdummy,$roledef)= + &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); + + if (($rdummy ne 'con_lost') && ($roledef ne '')) { + my ($syspriv,$dompriv,$coursepriv)= + split(/\_/,$roledef); + if (defined($syspriv)) { + $allroles{'cm./'}.=':'.$syspriv; + $allroles{$spec.'./'}.=':'.$syspriv; + } + if ($tdomain ne '') { + if (defined($dompriv)) { + $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; + $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; + } + if ($trest ne '') { + if (defined($coursepriv)) { + $allroles{'cm.'.$area}.=':'.$coursepriv; + $allroles{$spec.'.'.$area}.=':'.$coursepriv; + } + } + } + } + } + } else { + if (defined($pr{$trole.':s'})) { + $allroles{'cm./'}.=':'.$pr{$trole.':s'}; + $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; + } + if ($tdomain ne '') { + if (defined($pr{$trole.':d'})) { + $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + } + if ($trest ne '') { + if (defined($pr{$trole.':c'})) { + $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; + $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; + } + } + } + } } } } @@ -1384,6 +2234,9 @@ sub get { my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } my %returnhash=(); my $i=0; foreach (@$storearr) { @@ -1431,6 +2284,80 @@ sub dump { return %returnhash; } +# -------------------------------------------------------------- keys interface + +sub getkeys { + my ($namespace,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); + my @keyarray=(); + foreach (split(/\&/,$rep)) { + push (@keyarray,&unescape($_)); + } + return @keyarray; +} + +# --------------------------------------------------------------- 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=(); + %returnhash = %{&convert_dump_to_currentdump(\%hash)}; + } 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; +} + +sub convert_dump_to_currentdump{ + my %hash = %{shift()}; + my %returnhash; + # 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\./); + } + } + return \%returnhash; +} + # --------------------------------------------------------------- put interface sub put { @@ -1484,6 +2411,40 @@ 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; + } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } + } + return $access; +} + # ------------------------------------------------- Check for a user privilege sub allowed { @@ -1492,6 +2453,7 @@ sub allowed { my $orguri=$uri; $uri=&declutter($uri); + if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # Free bre access to adm and meta resources if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { @@ -1502,7 +2464,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)) { @@ -1516,6 +2480,20 @@ sub allowed { return ''; } } + if ($ENV{'request.role'}=~ /li\.\//) { + # 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\./)) { + # uri is the requested domain in this case. + # comparison to 'request.role.domain' shows if the user has selected + # a role of dc for the domain in question. + return 'F' if ($uri eq $ENV{'request.role.domain'}); } my $thisallowed=''; @@ -1545,6 +2523,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/) { @@ -1720,26 +2704,22 @@ 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 ''; } } -# Restricted by state? +# Restricted by state or randomout? if ($thisallowed=~/X/) { + if ($ENV{'acc.randomout'}) { + my $symb=&symbread($uri,1); + if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { + return ''; + } + } if (&condval($statecond)) { return '2'; } else { @@ -1754,17 +2734,43 @@ sub allowed { sub is_on_map { my $uri=&declutter(shift); + $uri=~s/\.\d+\.(\w+)$/\.$1/; my @uriparts=split(/\//,$uri); my $filename=$uriparts[$#uriparts]; my $pathname=$uri; - $pathname=~s/\/$filename$//; + $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}=~ - /\&$filename\:([\d\|]+)\&/); + /\&\Q$filename\E\:([\d\|]+)\&/); if ($match) { - return (1,$1); - } else { - return (0,0); - } + return (1,$1); + } else { + return (0,0); + } +} + +# --------------------------------------------------------- Get symb from alias + +sub get_symb_from_alias { + my $symb=shift; + my ($map,$resid,$url)=&decode_symb($symb); +# Already is a symb + if ($url) { return $symb; } +# Must be an alias + my $aliassymb=''; + my %bighash; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $rid=$bighash{'mapalias_'.$symb}; + if ($rid) { + my ($mapid,$resid)=split(/\./,$rid); + $aliassymb=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$bighash{'src_'.$rid}); + } + untie %bighash; + } + return $aliassymb; } # ----------------------------------------------------------------- Define Role @@ -1772,7 +2778,7 @@ sub is_on_map { sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - foreach (split('/',$sysrole)) { + foreach (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } if ($pr{'cr:s'}=~/$crole\&/) { @@ -1781,7 +2787,7 @@ sub definerole { } } } - foreach (split('/',$domrole)) { + foreach (split(':',$domrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } if ($pr{'cr:d'}=~/$crole\&/) { @@ -1790,7 +2796,7 @@ sub definerole { } } } - foreach (split('/',$courole)) { + foreach (split(':',$courole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } if ($pr{'cr:c'}=~/$crole\&/) { @@ -1812,9 +2818,11 @@ sub definerole { # ---------------- Make a metadata query against the network of library servers sub metadata_query { - my ($query,$custom,$customshow)=@_; + my ($query,$custom,$customshow,$server_array)=@_; my %rhash; - for my $server (keys %libserv) { + my @server_list = (defined($server_array) ? @$server_array + : keys(%libserv) ); + for my $server (@server_list) { unless ($custom or $customshow) { my $reply=&reply("querysend:".&escape($query),$server); $rhash{$server}=$reply; @@ -1891,16 +2899,18 @@ sub userlog_query { sub plaintext { my $short=shift; - return $prp{$short}; + return &mt($prp{$short}); } # ----------------------------------------------------------------- Assign Role sub assignrole { - my ($udom,$uname,$url,$role,$end,$start)=@_; + my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; my $mrole; if ($role =~ /^cr\//) { - unless (&allowed('ccr',$url)) { + my $cwosec=$url; + $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); @@ -1910,7 +2920,7 @@ sub assignrole { } else { my $cwosec=$url; $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; - unless (&allowed('c'.$role,$cwosec)) { + unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); @@ -1928,7 +2938,25 @@ sub assignrole { $command.='_0_'.$start; } } - return &reply($command,&homeserver($uname,$udom)); +# actually delete + if ($deleteflag) { + if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { +# modify command to delete the role + $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$udom:$uname:$url".'_'."$mrole"; + &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); +# set start and finish to negative values for userrolelog + $start=-1; + $end=-1; + } + } +# send command + my $answer=&reply($command,&homeserver($uname,$udom)); +# log new user role if status is ok + if ($answer eq 'ok') { + &userrolelog($mrole,$uname,$udom,$url,$start,$end); + } + return $answer; } # -------------------------------------------------- Modify user authentication @@ -1939,7 +2967,8 @@ sub modifyuserauth { my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. - $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, @@ -1962,7 +2991,7 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome)=@_; + $forceid, $desiredhome, $email)=@_; $udom=~s/\W//g; $uname=~s/\W//g; &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. @@ -1970,10 +2999,12 @@ sub modifyuser { $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). - ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User - if (($uhome eq 'no_host') && ($umode) && ($upass)) { + if (($uhome eq 'no_host') && + (($umode && $upass) || ($umode eq 'localauth'))) { my $unhome=''; if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { $unhome = $desiredhome; @@ -2003,7 +3034,7 @@ sub modifyuser { } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { - return 'error: verify home'; + return 'error: unable verify users home machine.'; } } # End of creation of new user # ---------------------------------------------------------------------- Add ID @@ -2013,21 +3044,34 @@ sub modifyuser { if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) && (!$forceid)) { unless ($uid eq $uidhash{$uname}) { - return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; + return 'error: user id "'.$uid.'" does not match '. + 'current user id "'.$uidhash{$uname}.'".'; } } else { &idput($udom,($uname => $uid)); } } # -------------------------------------------------------------- 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; + } +# +# Make sure to not trash student environment if instructor does not bother +# to supply name and email information +# if ($first) { $names{'firstname'} = $first; } - if ($middle) { $names{'middlename'} = $middle; } + if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } - if ($gene) { $names{'generation'} = $gene; } + if (defined($gene)) { $names{'generation'} = $gene; } + if ($email) { $names{'notification'} = $email; + $names{'critnotification'} = $email; } + my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -2041,7 +3085,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome)=@_; + $end,$start,$forceid,$desiredhome,$email)=@_; my $cid=''; unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; @@ -2049,22 +3093,61 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome); + $desiredhome,$email); 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) { @@ -2095,13 +3178,10 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url)=@_; + my ($udom,$description,$url,$course_server,$nonstandard)=@_; $url=&declutter($url); my $cid=''; - unless (&allowed('ccc',$ENV{'user.domain'})) { - return 'refused'; - } - unless ($udom eq $ENV{'user.domain'}) { + unless (&allowed('ccc',$udom)) { return 'refused'; } # ------------------------------------------------------------------- Create ID @@ -2117,92 +3197,177 @@ sub createcourse { return 'error: unable to generate unique course-ID'; } } +# ------------------------------------------------ Check supplied server name + $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + if (! exists($libserv{$course_server})) { + return 'error:bad server name '.$course_server; + } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', - $ENV{'user.home'}); + $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } +# ----------------------------------------------------------------- Course made +# log existance + &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), + $uhome); + &flushcourselogs(); +# set toplevel url + my $topurl=$url; + unless ($nonstandard) { +# ------------------------------------------ For standard courses, make top url + my $mapurl=&clutter($url); + if ($mapurl eq '/res/') { $mapurl=''; } + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, ('description' => $description, - 'url' => $url)); + 'url' => $topurl)); return '/'.$udom.'/'.$uname; } # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, - $end,$start); + $end,$start,$deleteflag); } # ----------------------------------------------------------------- Revoke Role sub revokerole { - my ($udom,$uname,$url,$role)=@_; + my ($udom,$uname,$url,$role,$deleteflag)=@_; my $now=time; - return &assignrole($udom,$uname,$url,$role,$now); + return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); } # ---------------------------------------------------------- Revoke Custom Role sub revokecustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; my $now=time; - return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); + return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, + $deleteflag); } # ------------------------------------------------------------ Directory lister sub dirlist { - my $uri=shift; + my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; + $uri=~s/^\///; $uri=~s/\/$//; - my ($res,$udom,$uname,@rest)=split(/\//,$uri); - if ($udom) { - if ($uname) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, - homeserver($uname,$udom)); - return split(/:/,$listing); - } else { - my $tryserver; - my %allusers=(); - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, - $tryserver); - if (($listing ne 'no_such_dir') && ($listing ne 'empty') - && ($listing ne 'con_lost')) { - foreach (split(/:/,$listing)) { - my ($entry,@stat)=split(/&/,$_); - $allusers{$entry}=1; + my ($udom, $uname); + (undef,$udom,$uname)=split(/\//,$uri); + if(defined($userdomain)) { + $udom = $userdomain; + } + if(defined($username)) { + $uname = $username; + } + + my $dirRoot = $perlvar{'lonDocRoot'}; + if(defined($alternateDirectoryRoot)) { + $dirRoot = $alternateDirectoryRoot; + $dirRoot =~ s/\/$//; + } + + if($udom) { + if($uname) { + my $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + return split(/:/,$listing); + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %allusers=(); + foreach $tryserver (keys %libserv) { + if($hostdom{$tryserver} eq $udom) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + if (($listing ne 'no_such_dir') && ($listing ne 'empty') + && ($listing ne 'con_lost')) { + foreach (split(/:/,$listing)) { + my ($entry,@stat)=split(/&/,$_); + $allusers{$entry}=1; + } + } } - } - } - } - my $alluserstr=''; - foreach (sort keys %allusers) { - $alluserstr.=$_.'&user:'; - } - $alluserstr=~s/:$//; - return split(/:/,$alluserstr); - } - } else { - my $tryserver; - my %alldom=(); - foreach $tryserver (keys %libserv) { - $alldom{$hostdom{$tryserver}}=1; - } - my $alldomstr=''; - foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; - } - $alldomstr=~s/:$//; - return split(/:/,$alldomstr); - } + } + my $alluserstr=''; + foreach (sort keys %allusers) { + $alluserstr.=$_.'&user:'; + } + $alluserstr=~s/:$//; + return split(/:/,$alluserstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing user name'); + return split(':',@emptyResults); + } + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %alldom=(); + foreach $tryserver (keys %libserv) { + $alldom{$hostdom{$tryserver}}=1; + } + my $alldomstr=''; + foreach (sort keys %alldom) { + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; + } + $alldomstr=~s/:$//; + return split(/:/,$alldomstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing domain'); + return split(':',@emptyResults); + } +} + +# --------------------------------------------- GetFileTimestamp +# This function utilizes dirlist and returns the date stamp for +# when it was last modified. It will also return an error of -1 +# if an error occurs + +## +## FIXME: This subroutine assumes its caller knows something about the +## directory structure of the home server for the student ($root). +## Not a good assumption to make. Since this is for looking up files +## in user directories, the full path should be constructed by lond, not +## whatever machine we request data from. +## +sub GetFileTimestamp { + my ($studentDomain,$studentName,$filename,$root)=@_; + $studentDomain=~s/\W//g; + $studentName=~s/\W//g; + my $subdir=$studentName.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + my $proname="$studentDomain/$subdir/$studentName"; + $proname .= '/'.$filename; + my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, + $studentName, $root); + my @stats = split('&', $fileStat); + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + # @stats contains first the filename, then the stat output + return $stats[10]; # so this is 10 instead of 9. + } else { + return -1; + } } # -------------------------------------------------------- Value of a Condition @@ -2257,61 +3422,93 @@ sub condval { return $result; } +# ---------------------------------------------------- Devalidate courseresdata + +sub devalidatecourseresdata { + my ($coursenum,$coursedomain)=@_; + my $hashid=$coursenum.':'.$coursedomain; + &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); +} + # --------------------------------------------------- Course Resourcedata Query sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - unless (defined($courseresdatacache{$hashid.'.time'})) { - unless (time-$courseresdatacache{$hashid.'.time'}<300) { - my $coursehom=&homeserver($coursenum,$coursedomain); - if ($coursehom) { - my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum. - ':resourcedata:.',$coursehom); - unless ($dumpreply=~/^error\:/) { - $courseresdatacache{$hashid.'.time'}=time; - $courseresdatacache{$hashid}=$dumpreply; - } - } - } + my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); + unless (defined($cached)) { + my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + $result=\%dumpreply; + my ($tmp) = keys(%dumpreply); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; + } elsif ($tmp =~ /^(error)/) { + $result=undef; + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + } } - my @pairs=split(/\&/,$courseresdatacache{$hashid}); - my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_); - $returnhash{unescape($key)}=unescape($value); - } - my $item; - foreach $item (@which) { - if ($returnhash{$item}) { return $returnhash{$item}; } - } - return ''; + foreach my $item (@which) { + if (defined($result->{$item})) { + return $result->{$item}; + } + } + return undef; } -# --------------------------------------------------------- Value of a Variable +# +# EXT resource caching routines +# + +sub clear_EXT_cache_status { + &delenv('cache.EXT.'); +} + +sub EXT_cache_status { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { + # We know already the user has no data + return 1; + } else { + return 0; + } +} + +sub EXT_cache_set { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + &appenv($cachename => time); +} +# --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; unless ($varname) { return ''; } - #get real user name/domain, courseid and symb my $courseid; + my $publicuser; + if ($symbparm) { + $symbparm=&get_symb_from_alias($symbparm); + } if (!($uname && $udom)) { - (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + (my $cursymb,$courseid,$udom,$uname,$publicuser)= + &Apache::lonxml::whichuser($symbparm); if (!$symbparm) { $symbparm=$cursymb; } } 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; @@ -2319,8 +3516,17 @@ 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; + if ($publicuser || $ENV{'request.state'} eq 'construct') { + %restored=&tmprestore($symbparm,$courseid,$udom,$uname); + } else { + %restored=&restore($symbparm,$courseid,$udom,$uname); + } + return $restored{$qualifierrest}; + } # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { # FIXME - not supporting calls for a specific user @@ -2331,7 +3537,11 @@ sub EXT { ($udom eq $ENV{'user.domain'})) { return $ENV{join('.',('environment',$qualifierrest))}; } else { - my %returnhash=&userenvironment($udom,$uname,$qualifierrest); + my %returnhash; + if (!$publicuser) { + %returnhash=&userenvironment($udom,$uname, + $qualifierrest); + } return $returnhash{$qualifierrest}; } # ----------------------------------------------------------------- user.course @@ -2355,18 +3565,29 @@ 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; + if (!$publicuser) { + %reply=&get($space,[$qualifierrest],$udom,$uname); + } + return $reply{$qualifierrest}; } } elsif ($realm eq 'query') { # ---------------------------------------------- pull stuff out of query string - &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); - return $ENV{'form.'.$space}; + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + [$spacequalifierrest]); + return $ENV{'form.'.$spacequalifierrest}; } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { - return $ENV{'browser.'.$qualifier}; + if ($qualifier eq 'textremote') { + if (&mt('textual_remote_display') eq 'on') { + return 1; + } else { + return 0; + } + } else { + return $ENV{'browser.'.$qualifier}; + } # ------------------------------------------------------------ request.filename } else { return $ENV{'request.'.$spacequalifierrest}; @@ -2376,24 +3597,28 @@ sub EXT { return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($courseid eq $ENV{'request.course.id'}) { + my $section; + if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme if (!$symbparm) { $symbparm=&symbread(); } my $symbp=$symbparm; - my $mapp=(split(/\_\_\_/,$symbp))[0]; + my $mapp=(&decode_symb($symbp))[0]; my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { - $section={'request.course.sec'}; + $section=$ENV{'request.course.sec'}; } else { - $section=&usection($udom,$uname,$courseid); + if (! defined($usection)) { + $section=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -2405,24 +3630,37 @@ 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 + if (! &EXT_cache_status($udom,$uname)) { + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, + 'userres'); + if (!defined($cached)) { + my %resourcedata=&get('resourcedata', + [$courselevelr,$courselevelm, + $courselevel],$udom,$uname); + $result=\%resourcedata; + &do_cache(\%userresdatacache,$hashid,$result,'userres'); + } + my ($tmp)=keys(%$result); + if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { + if ($$result{$courselevelr}) { + return $$result{$courselevelr}; } + if ($$result{$courselevelm}) { + return $$result{$courselevelm}; } + if ($$result{$courselevel}) { + return $$result{$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/) { + &EXT_cache_set($udom,$uname); + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; + } } } @@ -2433,14 +3671,14 @@ sub EXT { ($seclevelr,$seclevelm,$seclevel, $courselevelr,$courselevelm, $courselevel)); - if ($coursereply) { return $coursereply; } + if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms my %parmhash=(); my $thisparm=''; if (tie(%parmhash,'GDBM_File', $ENV{'request.course.fn'}.'_parms.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } @@ -2449,25 +3687,31 @@ sub EXT { # --------------------------------------------- last, look in resource metadata $spacequalifierrest=~s/\./\_/; - my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); - if ($metadata) { return $metadata; } - $metadata=&metadata($ENV{'request.filename'}, - 'parameter_'.$spacequalifierrest); - if ($metadata) { return $metadata; } + my $filename; + if (!$symbparm) { $symbparm=&symbread(); } + if ($symbparm) { + $filename=(&decode_symb($symbparm))[2]; + } else { + $filename=$ENV{'request.filename'}; + } + my $metadata=&metadata($filename,$spacequalifierrest); + if (defined($metadata)) { return $metadata; } + $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + if (defined($metadata)) { return $metadata; } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { - my ($part,$id)=split(/\_/,$space); - if ($id) { - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm,$udom,$uname); - if ($partgeneral) { return $partgeneral; } - } else { - my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, - $symbparm,$udom,$uname); - if ($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,$section,1); + if (defined($partgeneral)) { return $partgeneral; } } + if ($recurse) { return undef; } + my $pack_def=&packages_tab_default($filename,$varname); + if (defined($pack_def)) { return $pack_def; } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -2488,12 +3732,46 @@ sub EXT { return ''; } +sub packages_tab_default { + my ($uri,$varname)=@_; + my (undef,$part,$name)=split(/\./,$varname); + my $packages=&metadata($uri,'packages'); + foreach my $package (split(/,/,$packages)) { + my ($pack_type,$pack_part)=split(/_/,$package,2); + if ($pack_part eq $part) { + return $packagetab{"$pack_type&$name&default"}; + } + } + return undef; +} + +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 { 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$|) || ($uri =~ /^~/) || + ($uri =~ m|home/[^/]+/public_html/|)) { + return ''; + } my $filename=$uri; $uri=~s/\.meta$//; # @@ -2501,124 +3779,216 @@ sub metadata { # Look at timestamp of caching # Everything is cached by the main uri, libraries are never directly cached # - unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { + if (!defined($liburi)) { + my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); + if (defined($cached)) { return $result->{':'.$what}; } + } + { # # Is this a recursive call for a library? # + my %lcmetacache; if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; - } + } else { + &devalidate_cache(\%metacache,$uri,'meta'); + } 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 ($lcmetacache{':packages'}) { + $lcmetacache{':packages'}.=','.$package.$keyroot; + } else { + $lcmetacache{':packages'}=$package.$keyroot; + } + foreach (keys %packagetab) { + my $part=$keyroot; + $part=~s/^\_//; + if ($_=~/^\Q$package\E\&/ || + $_=~/^\Q$package\E_0\&/) { + my ($pack,$name,$subp)=split(/\&/,$_); + # ignore package.tab specified default values + # here &package_tab_default() will fetch those + if ($subp eq 'default') { next; } + my $value=$packagetab{$_}; + my $unikey; + if ($pack =~ /_0$/) { + $unikey='parameter_0_'.$name; + $part=0; + } else { + $unikey='parameter'.$keyroot.'_'.$name; + } + if ($subp eq 'display') { + $value.=' [Part: '.$part.']'; + } + $lcmetacache{':'.$unikey.'.part'}=$part; + $metathesekeys{$unikey}=1; + unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) { + $lcmetacache{':'.$unikey.'.'.$subp}=$value; + } + if (defined($lcmetacache{':'.$unikey.'.default'})) { + $lcmetacache{':'.$unikey}= + $lcmetacache{':'.$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 (defined($depthcount)) { $depthcount++; } else - { $depthcount=0; } - if ($depthcount<20) { - foreach (split(/\,/,&metadata($uri,'keys', - $parser->get_text('/import'),$unikey, - $depthcount))) { - $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]}) { + $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + } + my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); + my $default=$lcmetacache{':'.$unikey.'.default'}; + if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { + # only ws inside the tag, and not in default, so use default + # as value + $lcmetacache{':'.$unikey}=$default; + } else { + # either something interesting inside the tag or default + # uninteresting + $lcmetacache{':'.$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); - $metacache{$uri.':cachedtimestamp'}=time; + } + } +# are there custom rights to evaluate + if ($lcmetacache{':copyright'} eq 'custom') { + + # + # Importing a rights file here + # + unless ($depthcount) { + my $location=$lcmetacache{':customdistributionfile'}; + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,'_rights', + $depthcount+1)))) { + $metathesekeys{$_}=1; + } + } + } + $lcmetacache{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri); + $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache(\%metacache,$uri,\%lcmetacache,'meta'); # this is the end of "was not already recently cached } - return $metacache{$uri.':'.$what}; + return $metacache{$uri}->{':'.$what}; +} + +sub metadata_generate_part0 { + my ($metadata,$metacache,$uri) = @_; + my %allnames; + foreach my $metakey (sort keys %$metadata) { + if ($metakey=~/^parameter\_(.*)/) { + my $part=$$metacache{':'.$metakey.'.part'}; + my $name=$$metacache{':'.$metakey.'.name'}; + if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { + $allnames{$name}=$part; + } + } + } + foreach my $name (keys(%allnames)) { + $$metadata{"parameter_0_$name"}=1; + my $key=":parameter_0_$name"; + $$metacache{"$key.part"}='0'; + $$metacache{"$key.name"}=$name; + $$metacache{"$key.type"}=$$metacache{':parameter_'. + $allnames{$name}.'_'.$name. + '.type'}; + my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. + '.display'}; + my $expr='\\[Part: '.$allnames{$name}.'\\]'; + $olddis=~s/$expr/\[Part: 0\]/; + $$metacache{"$key.display"}=$olddis; + } } +# ------------------------------------------------- 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'); + } + my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); + if (defined($cached)) { return $result; } + my ($map,$resid,$url)=&decode_symb($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; + } + $title=~s/\&colon\;/\:/gs; + if ($title) { + return &do_cache(\%titlecache,$symb,$title,'title'); + } else { + return &metadata($urlsymb,'title'); + } +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -2627,7 +3997,7 @@ sub symblist { my %hash; if (($ENV{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; } @@ -2643,20 +4013,21 @@ sub symblist { sub symbverify { my ($symb,$thisfn)=@_; - $thisfn=&declutter($thisfn); + $thisfn=&symbclean(&declutter($thisfn)); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } # check URL part - my ($map,$resid,$url)=split(/\_\_\_/,$symb); - unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } + my ($map,$resid,$url)=&decode_symb($symb); + unless ($url eq $thisfn) { return 0; } $symb=&symbclean($symb); my %bighash; my $okay=0; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER,0640)) { - my $ids=$bighash{'ids_/res/'.$thisfn}; + &GDBM_READER(),0640)) { + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -2690,10 +4061,40 @@ sub symbclean { return $symb; } +# ---------------------------------------------- Split symb to find map and url + +sub encode_symb { + my ($map,$resid,$url)=@_; + return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url)); +} + +sub decode_symb { + my ($map,$resid,$url)=split(/\_\_\_/,shift); + return (&fixversion($map),$resid,&fixversion($url)); +} + +sub fixversion { + my $fn=shift; + if ($fn=~/^(adm|uploaded|public)/) { return $fn; } + my %bighash; + my $uri=&clutter($fn); + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + if ($bighash{'version_'.$uri}) { + my $version=$bighash{'version_'.$uri}; + unless ($version eq 'mostrecent') { + $uri=~s/\.(\w+)$/\.$version\.$1/; + } + } + untie %bighash; + } + return &declutter($uri); +} + # ------------------------------------------------------ Return symb list entry sub symbread { - my $thisfn=shift; + my ($thisfn,$donotrecurse)=@_; # no filename provided? try from environment unless ($thisfn) { if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } @@ -2709,7 +4110,7 @@ sub symbread { my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { $syval=$hash{$thisfn}; untie(%hash); } @@ -2725,9 +4126,9 @@ sub symbread { } else { # ------------------------------------------------------- Was not in symb table if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { # ---------------------------------------------- Get ID(s) for current resource - my $ids=$bighash{'ids_/res/'.$thisfn}; + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -2742,7 +4143,7 @@ sub symbread { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; - } else { + } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; foreach (@possibilities) { @@ -2757,6 +4158,8 @@ sub symbread { } } if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; } } untie(%bighash) @@ -2782,29 +4185,92 @@ sub numval { $txt=~tr/u-z/0-5/; $txt=~s/\D//g; return int($txt); -} +} + +sub latest_rnd_algorithm_id { + return '64bit'; +} sub rndseed { my ($symb,$courseid,$domain,$username)=@_; + + my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); if (!$symb) { - unless ($symb=&symbread()) { return time; } + unless ($symb=$wsymb) { return time; } + } + if (!$courseid) { $courseid=$wcourseid; } + if (!$domain) { $domain=$wdomain; } + if (!$username) { $username=$wusername } + my $which=$ENV{"course.$courseid.rndseed"}; + my $CODE=$ENV{'scantron.CODE'}; + if (defined($CODE)) { + &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit') { + return &rndseed_64bit($symb,$courseid,$domain,$username); + } + return &rndseed_32bit($symb,$courseid,$domain,$username); +} + +sub rndseed_32bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32C*",$symb) << 27; + my $symbseed=numval($symb) << 22; + my $namechck=unpack("%32C*",$username) << 17; + my $nameseed=numval($username) << 12; + my $domainseed=unpack("%32C*",$domain) << 7; + my $courseseed=unpack("%32C*",$courseid); + my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return $num; } - if (!$courseid) { $courseid=$ENV{'request.course.id'};} - if (!$domain) {$domain=$ENV{'user.domain'};} - if (!$username) {$username=$ENV{'user.name'};} +} + +sub rndseed_64bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb) << 21; + my $symbseed=numval($symb) << 10; + my $namechck=unpack("%32S*",$username); + + my $nameseed=numval($username) << 21; + my $domainseed=unpack("%32S*",$domain) << 10; + my $courseseed=unpack("%32S*",$courseid); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1,$num2"; + } +} + +sub rndseed_CODE_64bit { + my ($symb,$courseid,$domain,$username)=@_; { - use integer; - my $symbchck=unpack("%32C*",$symb) << 27; - my $symbseed=numval($symb) << 22; - my $namechck=unpack("%32C*",$username) << 17; - my $nameseed=numval($username) << 12; - my $domainseed=unpack("%32C*",$domain) << 7; - my $courseseed=unpack("%32C*",$courseid); - my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; - #uncommenting these lines can break things! - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num:$symb"); - return $num; + use integer; + my $symbchck=unpack("%32S*",$symb) << 16; + my $symbseed=numval($symb); + my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; + my $courseseed=unpack("%32S*",$courseid); + my $num1=$symbseed+$CODEseed; + my $num2=$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); + return "$num1,$num2"; + } +} + +sub setup_random_from_rndseed { + my ($rndseed)=@_; + if ($rndseed =~/,/) { + my ($num1,$num2)=split(/,/,$rndseed); + &Math::Random::random_set_seed(abs($num1),abs($num2)); + } else { + &Math::Random::random_set_seed_from_phrase($rndseed); } } @@ -2825,20 +4291,31 @@ sub ireceipt { } sub receipt { - return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, - $ENV{'request.course.id'},&symbread()); + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb); } - + # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or a -1 sub getfile { - my $file=shift; + my $file=shift; + if ($file=~/^\/*uploaded\//) { # user file + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $response=$ua->request($request); + if ($response->is_success()) { + return $response->content; + } else { + return -1; + } + } else { # normal file from res space &repcopy($file); if (! -e $file ) { return -1; }; my $fh=Apache::File->new($file); my $a=''; while (<$fh>) { $a .=$_; } - return $a + return $a; + } } sub filelocation { @@ -2848,6 +4325,8 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + $location=$file; } else { $file=~s/^$perlvar{'lonDocRoot'}//; $file=~s:^/*res::; @@ -2885,6 +4364,16 @@ sub declutter { return $thisfn; } +# ------------------------------------------------------------- Clutter up URLs + +sub clutter { + my $thisfn='/'.&declutter(shift); + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + $thisfn='/res'.$thisfn; + } + return $thisfn; +} + # -------------------------------------------------------- Escape Special Chars sub escape { @@ -2901,12 +4390,36 @@ sub unescape { return $str; } +sub mod_perl_version { + if (defined($perlvar{'MODPERL2'})) { + return 2; + } + return 1; +} + +sub correct_line_ends { + my ($result)=@_; + &logthis("Wha $result"); + $$result =~s/\r\n/\n/mg; + $$result =~s/\r/\n/mg; +} # ================================================================ Main Program sub goodbye { &logthis("Starting Shut down"); +#not converted to using infrastruture + &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); + &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); + &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); +#converted + &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); + &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); +#1.1 only + &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); + &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); &flushcourselogs(); &logthis("Shutting down"); + return DONE; } BEGIN { @@ -2935,17 +4448,54 @@ 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 (/^(\#|\s*$)/); +# next if /^\#/; + chomp; + my ($domain, $domain_description, $def_auth, $def_auth_arg, + $def_lang, $city, $longi, $lati) = split(/:/,$_); + $domain_auth_def{$domain}=$def_auth; + $domain_auth_arg_def{$domain}=$def_auth_arg; + $domaindescription{$domain}=$domain_description; + $domain_lang_def{$domain}=$def_lang; + $domain_city{$domain}=$city; + $domain_longi{$domain}=$longi; + $domain_lati{$domain}=$lati; + +# &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)=split(/:/,$configline); - $hostname{$id}=$name; - $hostdom{$id}=$domain; - $hostip{$id}=$ip; - if ($role eq 'library') { $libserv{$id}=$name; } + my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); + if ($id && $domain && $role && $name && $ip) { + $hostname{$id}=$name; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; + $iphost{$ip}=$id; + if ($role eq 'library') { $libserv{$id}=$name; } + } else { + if ($configline) { + &logthis("Skipping hosts.tab line -$configline-"); + } + } } } @@ -2955,7 +4505,7 @@ BEGIN { while (my $configline=<$config>) { chomp($configline); - if (($configline) && ($configline ne $perlvar{'lonHostID'})) { + if ($configline) { $spareid{$configline}=1; } } @@ -3001,9 +4551,15 @@ BEGIN { } } +# ------------- set up temporary directory +{ + $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; + +} + %metacache=(); -$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; +$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; &logtouch(); @@ -3015,405 +4571,790 @@ $readit=1; 1; __END__ +=pod + =head1 NAME -Apache::lonnet - TCP networking package +Apache::lonnet - Subroutines to ask questions about things in the network. =head1 SYNOPSIS -Invoked by other LON-CAPA modules. +Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network. &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); -=head1 INTRODUCTION +Common parameters: -This module provides subroutines which interact with the -lonc/lond (TCP) network layer of LON-CAPA. +=over 4 -This is part of the LearningOnline Network with CAPA project -described at http://www.lon-capa.org. +=item * -=head1 HANDLER SUBROUTINE +$uname : an internal username (if $cname expecting a course Id specifically) -There is no handler routine for this module. +=item * -=head1 OTHER SUBROUTINES +$udom : a domain (if $cdom expecting a course's domain specifically) + +=item * + +$symb : a resource instance identifier + +=item * + +$namespace : the name of a .db file that contains the data needed or +being set. + +=back + +=head1 OVERVIEW + +lonnet provides subroutines which interact with the +lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask +about classes, users, and resources. + +For many of these objects you can also use this to store data about +them or modify them in various ways. + +=head2 Symbs + +To identify a specific instance of a resource, LON-CAPA uses symbols +or "symbs"X. These identifiers are built from the URL of the +map, the resource number of the resource in the map, and the URL of +the resource itself. The latter is somewhat redundant, but might help +if maps change. + +An example is + + msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem + +The respective map entry is + + + + +Symbs are used by the random number generator, as well as to store and +restore data specific to a certain instance of for example a problem. + +=head2 Storing And Retrieving Data + +XXXThree of the most important functions +in C are C<&Apache::lonnet::cstore()>, +C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which +is is the non-critical message twin of cstore. These functions are for +handlers to store a perl hash to a user's permanent data space in an +easy manner, and to retrieve it again on another call. It is expected +that a handler would use this once at the beginning to retrieve data, +and then again once at the end to send only the new data back. + +The data is stored in the user's data directory on the user's +homeserver under the ID of the course. + +The hash that is returned by restore will have all of the previous +value for all of the elements of the hash. + +Example: + + #creating a hash + my %hash; + $hash{'foo'}='bar'; + + #storing it + &Apache::lonnet::cstore(\%hash); + + #changing a value + $hash{'foo'}='notbar'; + + #adding a new value + $hash{'bar'}='foo'; + &Apache::lonnet::cstore(\%hash); + + #retrieving the hash + my %history=&Apache::lonnet::restore(); + + #print the hash + foreach my $key (sort(keys(%history))) { + print("\%history{$key} = $history{$key}"); + } + +Will print out: + + %history{1:foo} = bar + %history{1:keys} = foo:timestamp + %history{1:timestamp} = 990455579 + %history{2:bar} = foo + %history{2:foo} = notbar + %history{2:keys} = foo:bar:timestamp + %history{2:timestamp} = 990455580 + %history{bar} = foo + %history{foo} = notbar + %history{timestamp} = 990455580 + %history{version} = 2 + +Note that the special hash entries C, C and +C were added to the hash. C will be equal to the +total number of versions of the data that have been stored. The +C attribute will be the UNIX time the hash was +stored. C is available in every historical section to list which +keys were added or changed at a specific historical revision of a +hash. + +B: do not store the hash that restore returns directly. This +will cause a mess since it will restore the historical keys as if the +were new keys. I.E. 1:foo will become 1:1:foo etc. + +Calling convention: + + my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); + +For more detailed information, see lonnet specific documentation. + +=head1 RETURN MESSAGES + +=over 4 + +=item * B: unable to contact remote host + +=item * B: unable to contact remote host, message will be delivered +when the connection is brought back up + +=item * B: unable to contact remote host and unable to save message +for later delivery + +=item * B: an error a occured, a description of the error follows the : + +=item * B: unable to fund a host associated with the user/domain +that was requested + +=back + +=head1 PUBLIC SUBROUTINES + +=head2 Session Environment Functions =over 4 +=item * +X +B: the value of %hash is written to +the user envirnoment file, and will be restored for each access this +user makes during this session, also modifies the %ENV for the current +process + =item * +X +B: removes all items from the session +environment file that matches the regular expression in $regexp. The +values are also delted from the current processes %ENV. -logtouch() : make sure the logfile, lonnet.log, exists +=back + +=head2 User Information + +=over 4 =item * +X +B: try to determine user's current +authentication scheme -logthis() : append message to lonnet.log +=item * +X +B: try to +authenticate user from domain's lib servers (first use the current +one). C<$upass> should be the users password. =item * +X +B: find the server which has +the user's directory and files (there must be only one), this caches +the answer, and also caches if there is a borken connection. -logperm() : append a permanent message to lonnet.perm.log +=item * +X +B: find the usernames behind a list of IDs +(IDs are a unique resource in a domain, there must be only 1 ID per +username, and only 1 username per ID in a specific domain) (returns +hash: id=>name,id=>name) =item * +X +B: find the IDs behind a list of +usernames (returns hash: name=>id,name=>id) -subreply() : non-critical communication, called by &reply +=item * +X +B: store away a list of names and associated IDs =item * +X +B: get user privileges -reply() : makes two attempts to pass message; logs refusals and rejections +=item * +X +B: finds the section of student in the +course $cname, return section name/number or '' for "not in course" +and '-1' for "no section" =item * +X +B: gets the values of the keys +passed in @what from the requested user's environment, returns a hash -reconlonc() : tries to reconnect lonc client processes. +=back + +=head2 User Roles + +=over 4 =item * -critical() : passes a critical message to another server; if cannot get -through then place message in connection buffer +allowed($priv,$uri) : check for a user privilege; returns codes for allowed +actions + F: full access + U,I,K: authentication modes (cxx only) + '': forbidden + 1: user needs to choose course + 2: browse allowed =item * -appenv(%hash) : read in current user environment, append new environment -values to make new user environment +definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom +role rolename set privileges in format of lonTabs/roles.tab for system, domain, +and course level =item * -delenv($varname) : read in current user environment, remove all values -beginning with $varname, write new user environment (note: flock is used -to prevent conflicting shared read/writes with file) +plaintext($short) : return value in %prp hash (rolesplain.tab); plain text +explanation of a user role term + +=back + +=head2 User Modification + +=over 4 =item * -spareserver() : find server with least workload from spare.tab +assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a +user for the level given by URL. Optional start and end dates (leave empty +string or zero for "no date") =item * -queryauthenticate($uname,$udom) : try to determine user's current -authentication scheme +changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to +change a users, password, possible return values are: ok, +pwchange_failure, non_authorized, auth_mode_error, unknown_user, +refused + +=item * + +modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication + +=item * + +modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : +modify user + +=item * + +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 * -authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib -servers (first use the current one) +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 * -homeserver($uname,$udom) : find the homebase for a user from domain's lib -servers +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 =item * -idget($udom,@ids) : find the usernames behind a list of IDs (returns hash: -id=>name,id=>name) +revokerole($udom,$uname,$url,$role) : revoke a role for url =item * -idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash: -name=>id,name=>id) +revokecustomrole($udom,$uname,$url,$role) : revoke a custom role + +=back + +=head2 Course Infomation + +=over 4 =item * -idput($udom,%ids) : store away a list of names and associated IDs +coursedescription($courseid) : course description =item * -usection($domain,$user,$courseid) : output of section name/number or '' for -"not in course" and '-1' for "no section" +courseresdata($coursenum,$coursedomain,@which) : request for current +parameter setting for a specific course, @what should be a list of +parameters to ask about. This routine caches answers for 5 minutes. + +=back + +=head2 Course Modification + +=over 4 =item * -userenvironment($domain,$user,$what) : puts out any environment parameter -for a user +writecoursepref($courseid,%prefs) : write preferences (environment +database) for a course =item * -subscribe($fname) : subscribe to a resource, return URL if possible +createcourse($udom,$description,$url) : make/modify course + +=back + +=head2 Resource Subroutines + +=over 4 =item * -repcopy($filename) : replicate file +subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead) =item * -ssi($url,%hash) : server side include, does a complete request cycle on url to -localhost, posts hash +repcopy($filename) : subscribes to the requested file, and attempts to +replicate from the owning library server, Might return +HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or +HTTP_BAD_REQUEST, also attempts to grab the metadata for the +resource. Expects the local filesystem pathname +(/home/httpd/html/res/....) + +=back + +=head2 Resource Information + +=over 4 =item * -log($domain,$name,$home,$message) : write to permanent log for user; use -critical subroutine +EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of +a vairety of different possible values, $varname should be a request +string, and the other parameters can be used to specify who and what +one is asking about. + +Possible values for $varname are environment.lastname (or other item +from the envirnment hash), user.name (or someother aspect about the +user), resource.0.maxtries (or some other part and parameter of a +resource) =item * -flushcourselogs() : flush (save) buffer logs and access logs +directcondval($number) : get current value of a condition; reads from a state +string =item * -courselog($what) : save message for course in hash +condval($condidx) : value of condition index based on state =item * -courseacclog($what) : save message for course using &courselog(). Perform -special processing for specific resource types (problems, exams, quizzes, etc). +metadata($uri,$what,$liburi,$prefix,$depthcount) : request a +resource's metadata, $what should be either a specific key, or either +'keys' (to get a list of possible keys) or 'packages' to get a list of +packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. + +this function automatically caches all requests =item * -countacc($url) : count the number of accesses to a given URL +metadata_query($query,$custom,$customshow) : make a metadata query against the +network of library servers; returns file handle of where SQL and regex results +will be stored for query =item * -sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item +symbread($filename) : return symbolic list entry (filename argument optional); +returns the data handle =item * -sub checkin($token) : check in an item +symbverify($symb,$thisfn) : verifies that $symb actually exists and is +a possible symb for the URL in $thisfn, returns a 1 on success, 0 on +failure, user must be in a course, as it assumes the existance of the +course initi hash, and uses $ENV('request.course.id'} + =item * -sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet +symbclean($symb) : removes versions numbers from a symb, returns the +cleaned symb =item * -devalidate($symb) : devalidate spreadsheets +is_on_map($uri) : checks if the $uri is somewhere on the current +course map, user must be in a course for it to work. =item * -hash2str(%hash) : convert a hash into a string complete with escaping and '=' -and '&' separators, supports elements that are arrayrefs and hashrefs +numval($salt) : return random seed value (addend for rndseed) =item * -hashref2str($hashref) : convert a hashref into a string complete with -escaping and '=' and '&' separators, supports elements that are -arrayrefs and hashrefs +rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns +a random seed, all arguments are optional, if they aren't sent it uses the +environment to derive them. Note: if symb isn't sent and it can't get one +from &symbread it will use the current time as its return value =item * -arrayref2str($arrayref) : convert an arrayref into a string complete -with escaping and '&' separators, supports elements that are arrayrefs -and hashrefs +ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, +unfakeable, receipt =item * -str2hash($string) : convert string to hash using unescaping and -splitting on '=' and '&', supports elements that are arrayrefs and -hashrefs +receipt() : API to ireceipt working off of ENV values; given out to users =item * -str2array($string) : convert string to hash using unescaping and -splitting on '&', supports elements that are arrayrefs and hashrefs +countacc($url) : count the number of accesses to a given URL + +=item * + +checkout($symb,$tuname,$tudom,$tcrsid) : creates a record of a user having looked at an item, most likely printed out or otherwise using a resource + +=item * + +checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid) =item * -tmpreset($symb,$namespace,$domain,$stuname) : temporary storage +expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet =item * -tmprestore($symb,$namespace,$domain,$stuname) : temporary restore +devalidate($symb) : devalidate temporary spreadsheet calculations, +forcing spreadsheet to reevaluate the resource scores next time. + +=back + +=head2 Storing/Retreiving Data + +=over 4 =item * -store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently +store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently for this url; hashref needs to be given and should be a \%hashname; the remaining args aren't required and if they aren't passed or are '' they will be derived from the ENV =item * -cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but +cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but uses critical subroutine =item * -restore($symb,$namespace,$domain,$stuname) : returns hash for this symb; +restore($symb,$namespace,$udom,$uname) : returns hash for this symb; all args are optional =item * -coursedescription($courseid) : course description +tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that +works very similar to store/cstore, but all data is stored in a +temporary location and can be reset using tmpreset, $storehash should +be a hash reference, returns nothing on success + +=item * + +tmprestore($symb,$namespace,$udom,$uname) : storage that works very +similar to restore, but all data is stored in a temporary location and +can be reset using tmpreset. Returns a hash of values on success, +error string otherwise. =item * -rolesinit($domain,$username,$authhost) : get user privileges +tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset, +deltes all keys for $symb form the temporary storage hash. =item * -get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array -reference filled in from namesp ($udomain and $uname are optional) +get($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp ($udom and $uname are optional) =item * -del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from -namesp ($udomain and $uname are optional) +del($namespace,$storearr,$udom,$uname) : deletes keys out of array from +namesp ($udom and $uname are optional) =item * -dump($namespace,$udomain,$uname,$regexp) : +dump($namespace,$udom,$uname,$regexp) : dumps the complete (or key matching regexp) namespace into a hash -($udomain, $uname and $regexp are optional) +($udom, $uname and $regexp are optional) =item * -put($namespace,$storehash,$udomain,$uname) : stores hash in namesp -($udomain and $uname are optional) +put($namespace,$storehash,$udom,$uname) : stores hash in namesp +($udom and $uname are optional) =item * -cput($namespace,$storehash,$udomain,$uname) : critical put -($udomain and $uname are optional) +cput($namespace,$storehash,$udom,$uname) : critical put +($udom and $uname are optional) =item * -eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array +eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array reference filled in from namesp (encrypts the return communication) -($udomain and $uname are optional) +($udom and $uname are optional) =item * -allowed($priv,$uri) : check for a user privilege; returns codes for allowed -actions - F: full access - U,I,K: authentication modes (cxx only) - '': forbidden - 1: user needs to choose course - 2: browse allowed +log($udom,$name,$home,$message) : write to permanent log for user; use +critical subroutine -=item * +=back -definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom -role rolename set privileges in format of lonTabs/roles.tab for system, domain, -and course level +=head2 Network Status Functions + +=over 4 =item * -metadata_query($query,$custom,$customshow) : make a metadata query against the -network of library servers; returns file handle of where SQL and regex results -will be stored for query +dirlist($uri) : return directory list based on URI =item * -plaintext($short) : return value in %prp hash (rolesplain.tab); plain text -explanation of a user role term +spareserver() : find server with least workload from spare.tab -=item * +=back -assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a -user for the level given by URL. Optional start and end dates (leave empty -string or zero for "no date") +=head2 Apache Request + +=over 4 =item * -modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication +ssi($url,%hash) : server side include, does a complete request cycle on url to +localhost, posts hash -=item * +=back -modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : -modify user +=head2 Data to String to Data + +=over 4 =item * -modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, -$end,$start) : modify student +hash2str(%hash) : convert a hash into a string complete with escaping and '=' +and '&' separators, supports elements that are arrayrefs and hashrefs =item * -writecoursepref($courseid,%prefs) : write preferences for a course +hashref2str($hashref) : convert a hashref into a string complete with +escaping and '=' and '&' separators, supports elements that are +arrayrefs and hashrefs =item * -createcourse($udom,$description,$url) : make/modify course +arrayref2str($arrayref) : convert an arrayref into a string complete +with escaping and '&' separators, supports elements that are arrayrefs +and hashrefs =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 +str2hash($string) : convert string to hash using unescaping and +splitting on '=' and '&', supports elements that are arrayrefs and +hashrefs =item * -revokerole($udom,$uname,$url,$role) : revoke a role for url +str2array($string) : convert string to hash using unescaping and +splitting on '&', supports elements that are arrayrefs and hashrefs -=item * +=back -revokecustomrole($udom,$uname,$url,$role) : revoke a custom role +=head2 Logging Routines -=item * +=over 4 -dirlist($uri) : return directory list based on URI +These routines allow one to make log messages in the lonnet.log and +lonnet.perm logfiles. =item * -directcondval($number) : get current value of a condition; reads from a state -string +logtouch() : make sure the logfile, lonnet.log, exists =item * -condval($condidx) : value of condition index based on state +logthis() : append message to the normal lonnet.log file, it gets +preiodically rolled over and deleted. =item * -EXT($varname,$symbparm) : value of a variable +logperm() : append a permanent message to lonnet.perm.log, this log +file never gets deleted by any automated portion of the system, only +messages of critical importance should go in here. + +=back + +=head2 General File Helper Routines + +=over 4 =item * -metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the -metadata entry for a file; entry='keys', returns a comma separated list of keys +getfile($file) : returns the entire contents of a file or -1; it +properly subscribes to and replicates the file if neccessary. =item * -symblist($mapname,%newhash) : update symbolic storage links +filelocation($dir,$file) : returns file system location of a file +based on URI; meant to be "fairly clean" absolute reference, $dir is a +directory that relative $file lookups are to looked in ($dir of /a/dir +and a file of ../bob will become /a/bob) =item * -symbread($filename) : return symbolic list entry (filename argument optional); -returns the data handle +hreflocation($dir,$file) : returns file system location or a URL; same as +filelocation except for hrefs =item * -numval($salt) : return random seed value (addend for rndseed) +declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) + +=back + +=head2 HTTP Helper Routines + +=over 4 =item * -rndseed($symb,$courseid,$domain,$username) : create a random sum; returns -a random seed, all arguments are optional, if they aren't sent it uses the -environment to derive them. Note: if symb isn't sent and it can't get one -from &symbread it will use the current time as its return value +escape() : unpack non-word characters into CGI-compatible hex codes =item * -ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, -unfakeable, receipt +unescape() : pack CGI-compatible hex codes into actual non-word ASCII character + +=back + +=head1 PRIVATE SUBROUTINES + +=head2 Underlying communication routines (Shouldn't call) + +=over 4 =item * -receipt() : API to ireceipt working off of ENV values; given out to users +subreply() : tries to pass a message to lonc, returns con_lost if incapable =item * -getfile($file) : serves up a file, returns the contents of a file or -1; -replicates and subscribes to the file +reply() : uses subreply to send a message to remote machine, logs all failures =item * -filelocation($dir,$file) : returns file system location of a file based on URI; -meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob) +critical() : passes a critical message to another server; if cannot +get through then place message in connection buffer directory and +returns con_delayed, if incapable of saving message, returns +con_failed =item * -hreflocation($dir,$file) : returns file system location or a URL; same as -filelocation except for hrefs +reconlonc() : tries to reconnect lonc client processes. + +=back + +=head2 Resource Access Logging + +=over 4 =item * -declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) +flushcourselogs() : flush (save) buffer logs and access logs =item * -escape() : unpack non-word characters into CGI-compatible hex codes +courselog($what) : save message for course in hash =item * -unescape() : pack CGI-compatible hex codes into actual non-word ASCII character +courseacclog($what) : save message for course using &courselog(). Perform +special processing for specific resource types (problems, exams, quizzes, etc). =item * @@ -3422,4 +5363,14 @@ as a PerlChildExitHandler =back +=head2 Other + +=over 4 + +=item * + +symblist($mapname,%newhash) : update symbolic storage links + +=back + =cut