--- loncom/lonnet/perl/lonnet.pm 2001/07/27 20:17:14 1.134
+++ loncom/lonnet/perl/lonnet.pm 2001/12/04 17:00:38 1.181
@@ -1,6 +1,70 @@
# The LearningOnline Network
# TCP networking package
#
+# $Id: lonnet.pm,v 1.181 2001/12/04 17:00:38 matthew Exp $
+#
+# Copyright Michigan State University Board of Trustees
+#
+# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
+#
+# LON-CAPA is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# LON-CAPA is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with LON-CAPA; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+#
+# /home/httpd/html/adm/gpl.txt
+#
+# 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
+#
+# $Id: lonnet.pm,v 1.181 2001/12/04 17:00:38 matthew Exp $
+#
+###
+
# Functions for use by content handlers:
#
# metadata_query(sql-query-string,custom-metadata-regex) :
@@ -72,7 +136,12 @@
# EXT(name) : value of a variable
# symblist(map,hash) : Updates symbolic storage links
# symbread([filename]) : returns the data handle (filename optional)
-# rndseed() : returns a random seed
+# rndseed([symb,courseid,domain,uname])
+# : returns a random seed, all arguments are optional,
+# if they aren't sent it use 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 it's return
# receipt() : returns a receipt to be given out to users
# getfile(filename) : returns the contents of filename, or a -1 if it can't
# be found, replicates and subscribes to the file
@@ -92,36 +161,6 @@
# metadata(file,entry): returns the metadata entry for a file. entry='keys'
# returns a comma separated list of keys
#
-# 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
-# 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
-#
package Apache::lonnet;
@@ -130,7 +169,7 @@ use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
use vars
-qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);
+qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs);
use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
@@ -139,6 +178,16 @@ use Fcntl qw(:flock);
# --------------------------------------------------------------------- Logging
+sub logtouch {
+ my $execdir=$perlvar{'lonDaemons'};
+ unless (-e "$execdir/logs/lonnet.log") {
+ my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
+ close $fh;
+ }
+ my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
+ chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
+}
+
sub logthis {
my $message=shift;
my $execdir=$perlvar{'lonDaemons'};
@@ -275,7 +324,8 @@ sub appenv {
map {
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
&logthis("WARNING: ".
- "Attempt to modify environment ".$_." to ".$newenv{$_});
+ "Attempt to modify environment ".$_." to ".$newenv{$_}
+ .'');
delete($newenv{$_});
} else {
$ENV{$_}=$newenv{$_};
@@ -386,6 +436,44 @@ sub spareserver {
return $spareserver;
}
+# ----------------------- Try to determine user's current authentication scheme
+
+sub queryauthenticate {
+ my ($uname,$udom)=@_;
+ if (($perlvar{'lonRole'} eq 'library') &&
+ ($udom eq $perlvar{'lonDefDomain'})) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",
+ $perlvar{'lonHostID'});
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+
+ my $tryserver;
+ foreach $tryserver (keys %libserv) {
+ if ($hostdom{$tryserver} eq $udom) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+ }
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+}
+
# --------- Try to authenticate user from domain's lib servers (first this one)
sub authenticate {
@@ -658,6 +746,142 @@ sub log {
return critical("log:$dom:$nam:$what",$hom);
}
+# ------------------------------------------------------------------ Course Log
+
+sub flushcourselogs {
+ &logthis('Flushing course log buffers');
+ map {
+ my $crsid=$_;
+ if (&reply('log:'.$ENV{'course.'.$crsid.'.domain'}.':'.
+ $ENV{'course.'.$crsid.'.num'}.':'.
+ &escape($courselogs{$crsid}),
+ $ENV{'course.'.$crsid.'.home'}) eq 'ok') {
+ delete $courselogs{$crsid};
+ } else {
+ &logthis('Failed to flush log buffer for '.$crsid);
+ if (length($courselogs{$crsid})>40000) {
+ &logthis("WARNING: Buffer for ".$crsid.
+ " exceeded maximum size, deleting.");
+ delete $courselogs{$crsid};
+ }
+ }
+ } keys %courselogs;
+}
+
+sub courselog {
+ my $what=shift;
+ $what=time.':'.$what;
+ unless ($ENV{'request.course.id'}) { return ''; }
+ if (defined $courselogs{$ENV{'request.course.id'}}) {
+ $courselogs{$ENV{'request.course.id'}}.='&'.$what;
+ } else {
+ $courselogs{$ENV{'request.course.id'}}.=$what;
+ }
+ if (length($courselogs{$ENV{'request.course.id'}})>4048) {
+ &flushcourselogs();
+ }
+}
+
+sub courseacclog {
+ my $fnsymb=shift;
+ unless ($ENV{'request.course.id'}) { return ''; }
+ my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
+ if ($what=~/(problem|exam|quiz|assess|survey|form)$/) {
+ map {
+ if ($_=~/^form\.(.*)/) {
+ $what.=':'.$1.'='.$ENV{$_};
+ }
+ } keys %ENV;
+ }
+ &courselog($what);
+}
+
+# ----------------------------------------------------------- Check out an item
+
+sub checkout {
+ my ($symb,$tuname,$tudom,$tcrsid)=@_;
+ my $now=time;
+ my $lonhost=$perlvar{'lonHostID'};
+ my $infostr=&escape(
+ $tuname.'&'.
+ $tudom.'&'.
+ $tcrsid.'&'.
+ $symb.'&'.
+ $now.'&'.$ENV{'REMOTE_ADDR'});
+ my $token=&reply('tmpput:'.$infostr,$lonhost);
+ if ($token=~/^error\:/) {
+ &logthis("WARNING: ".
+ "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "");
+ return '';
+ }
+
+ $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
+ $token=~tr/a-z/A-Z/;
+
+ my %infohash=('resource.0.outtoken' => $token,
+ 'resource.0.checkouttime' => $now,
+ 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
+
+ unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+ return '';
+ } else {
+ &logthis("WARNING: ".
+ "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "");
+ }
+
+ if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+ &escape('Checkout '.$infostr.' - '.
+ $token)) ne 'ok') {
+ return '';
+ } else {
+ &logthis("WARNING: ".
+ "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "");
+ }
+ return $token;
+}
+
+# ------------------------------------------------------------ Check in an item
+
+sub checkin {
+ my $token=shift;
+ my $now=time;
+ my ($ta,$tb,$lonhost)=split(/\*/,$token);
+ $lonhost=~tr/A-Z/a-z/;
+ my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
+ $dtoken=~s/\W/\_/g;
+ my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
+ split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
+
+ unless (($tuname) && ($tudom)) {
+ &logthis('Check in '.$token.' ('.$dtoken.') failed');
+ return '';
+ }
+
+ unless (&allowed('mgr',$tcrsid)) {
+ &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
+ $ENV{'user.name'}.' - '.$ENV{'user.domain'});
+ return '';
+ }
+
+ my %infohash=('resource.0.intoken' => $token,
+ 'resource.0.checkintime' => $now,
+ 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
+
+ unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+ return '';
+ }
+
+ if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+ &escape('Checkin - '.$token)) ne 'ok') {
+ return '';
+ }
+
+ return ($symb,$tuname,$tudom,$tcrsid);
+}
+
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -698,15 +922,155 @@ sub devalidate {
}
}
+sub hash2str {
+ my (%hash)=@_;
+ my $result='';
+ map { $result.=escape($_).'='.escape($hash{$_}).'&'; } keys %hash;
+ $result=~s/\&$//;
+ return $result;
+}
+
+sub str2hash {
+ my ($string) = @_;
+ my %returnhash;
+ map {
+ my ($name,$value)=split(/\=/,$_);
+ $returnhash{&unescape($name)}=&unescape($value);
+ } split(/\&/,$string);
+ return %returnhash;
+}
+
+# -------------------------------------------------------------------Temp Store
+
+sub tmpreset {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my %hash;
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ foreach my $key (keys %hash) {
+ if ($key=~ /:$symb/) {
+ delete($hash{$key});
+ }
+ }
+ }
+}
+
+sub tmpstore {
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) {
+ # I don't think we would ever want to store this for a course.
+ # it seems this will only be used if we don't have a course.
+ #$namespace=$ENV{'request.course.id'};
+ #if (!$namespace) {
+ $namespace=$ENV{'request.state'};
+ #}
+ }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+#FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $now=time;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ $hash{"version:$symb"}++;
+ my $version=$hash{"version:$symb"};
+ my $allkeys='';
+ foreach my $key (keys(%$storehash)) {
+ $allkeys.=$key.':';
+ $hash{"$version:$symb:$key"}=$$storehash{$key};
+ }
+ $hash{"$version:$symb:timestamp"}=$now;
+ $allkeys.='timestamp';
+ $hash{"$version:keys:$symb"}=$allkeys;
+ if (untie(%hash)) {
+ return 'ok';
+ } else {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+}
+
+# -----------------------------------------------------------------Temp Restore
+
+sub tmprestore {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+
+ my %returnhash;
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_READER,0640)) {
+ my $version=$hash{"version:$symb"};
+ $returnhash{'version'}=$version;
+ my $scope;
+ for ($scope=1;$scope<=$version;$scope++) {
+ my $vkeys=$hash{"$scope:keys:$symb"};
+ my @keys=split(/:/,$vkeys);
+ my $key;
+ $returnhash{"$scope:keys"}=$vkeys;
+ foreach $key (@keys) {
+ $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
+ $returnhash{"$key"}=$hash{"$scope:$symb:$key"};
+ }
+ }
+ if (!(untie(%hash))) {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+ return %returnhash;
+}
+
# ----------------------------------------------------------------------- Store
sub store {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
@@ -731,9 +1095,7 @@ sub cstore {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
@@ -759,9 +1121,7 @@ sub restore {
my ($symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) {
unless ($symb=escape(&symbread())) { return ''; }
@@ -895,7 +1255,7 @@ sub rolesinit {
my $author=0;
map {
%thesepriv=();
- if ($_!~/^st/) { $adv=1; }
+ if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
map {
if ($_ ne '') {
@@ -1034,6 +1394,8 @@ sub eget {
sub allowed {
my ($priv,$uri)=@_;
+
+ my $orguri=$uri;
$uri=&declutter($uri);
# Free bre access to adm and meta resources
@@ -1042,6 +1404,12 @@ sub allowed {
return 'F';
}
+# Free bre to public access
+
+ if ($priv eq 'bre') {
+ if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
+ }
+
my $thisallowed='';
my $statecond=0;
my $courseprivid='';
@@ -1077,7 +1445,7 @@ sub allowed {
# If this is generating or modifying users, exit with special codes
- if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
+ if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
return $thisallowed;
}
#
@@ -1107,16 +1475,28 @@ sub allowed {
}
}
- if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
- my $refuri=$ENV{'HTTP_REFERER'};
- $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
- $refuri=&declutter($refuri);
+ if ($checkreferer) {
+ my $refuri=$ENV{'httpref.'.$orguri};
+
+ unless ($refuri) {
+ map {
+ if ($_=~/^httpref\..*\*/) {
+ my $pattern=$_;
+ $pattern=~s/^httpref\.\/res\///;
+ $pattern=~s/\*/\[\^\/\]\+/g;
+ $pattern=~s/\//\\\//g;
+ if ($orguri=~/$pattern/) {
+ $refuri=$ENV{$_};
+ }
+ }
+ } keys %ENV;
+ }
+ if ($refuri) {
+ $refuri=&declutter($refuri);
my @uriparts=split(/\//,$refuri);
my $filename=$uriparts[$#uriparts];
my $pathname=$refuri;
$pathname=~s/\/$filename$//;
- my @filenameparts=split(/\./,$uri);
- if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
/\&$filename\:([\d\|]+)\&/) {
my $refstatecond=$1;
@@ -1126,8 +1506,8 @@ sub allowed {
$uri=$refuri;
$statecond=$refstatecond;
}
- }
}
+ }
}
}
@@ -1306,7 +1686,6 @@ sub definerole {
sub metadata_query {
my ($query,$custom,$customshow)=@_;
- # need to put in a library server loop here and return a hash
my %rhash;
for my $server (keys %libserv) {
unless ($custom or $customshow) {
@@ -1333,14 +1712,14 @@ sub plaintext {
# ------------------------------------------------------------------ Plain Text
sub fileembstyle {
- my $ending=shift;
+ my $ending=lc(shift);
return $fe{$ending};
}
# ------------------------------------------------------------ Description Text
sub filedescription {
- my $ending=shift;
+ my $ending=lc(shift);
return $fd{$ending};
}
@@ -1381,6 +1760,20 @@ sub assignrole {
return &reply($command,&homeserver($uname,$udom));
}
+# -------------------------------------------------- Modify user authentication
+sub modifyuserauth {
+ my ($udom,$uname,$umode,$upass)=@_;
+ my $uhome=&homeserver($uname,$udom);
+ &logthis('Call to modify user authentication'.$udom.', '.$uname.', '.
+ $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
+ &escape($upass),$uhome);
+ unless ($reply eq 'ok') {
+ return 'error: '.$reply;
+ }
+ return 'ok';
+}
+
# --------------------------------------------------------------- Modify a user
@@ -1469,7 +1862,7 @@ sub modifystudent {
return 'error: no such user';
}
# -------------------------------------------------- Add student to course list
- my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
+ $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
$ENV{'course.'.$cid.'.num'}.':classlist:'.
&escape($uname.':'.$udom).'='.
&escape($end.':'.$start),
@@ -1534,7 +1927,7 @@ sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$ENV{'user.home'});
unless ($reply eq 'ok') { return 'error: '.$reply; }
- my $uhome=&homeserver($uname,$udom);
+ $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such course';
}
@@ -1673,7 +2066,7 @@ sub condval {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my $varname=shift;
+ my ($varname,$symbparm)=@_;
unless ($varname) { return ''; }
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;
@@ -1734,8 +2127,17 @@ sub EXT {
$spacequalifierrest};
} elsif ($realm eq 'resource') {
if ($ENV{'request.course.id'}) {
+
+# print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
+
+
# ----------------------------------------------------- Cascading lookup scheme
- my $symbp=&symbread();
+ my $symbp;
+ if ($symbparm) {
+ $symbp=$symbparm;
+ } else {
+ $symbp=&symbread();
+ }
my $mapp=(split(/\_\_\_/,$symbp))[0];
my $symbparm=$symbp.'.'.$spacequalifierrest;
@@ -1823,6 +2225,21 @@ sub EXT {
'parameter_'.$spacequalifierrest);
if ($metadata) { return $metadata; }
+# ------------------------------------------------------------------ Cascade up
+
+ unless ($space eq '0') {
+ my ($part,$id)=split(/\_/,$space);
+ if ($id) {
+ my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+ $symbparm);
+ if ($partgeneral) { return $partgeneral; }
+ } else {
+ my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
+ $symbparm);
+ if ($resourcegeneral) { return $resourcegeneral; }
+ }
+ }
+
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
@@ -1839,32 +2256,113 @@ sub EXT {
# ---------------------------------------------------------------- Get metadata
sub metadata {
- my ($uri,$what)=@_;
+ my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
my $filename=$uri;
$uri=~s/\.meta$//;
- unless ($metacache{$uri.':keys'}) {
+#
+# Is the metadata already cached?
+# Look at timestamp of caching
+# Everything is cached by the main uri, libraries are never directly cached
+#
+ unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
+#
+# Is this a recursive call for a library?
+#
+ if ($liburi) {
+ $liburi=&declutter($liburi);
+ $filename=$liburi;
+ }
+ my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
my $parser=HTML::TokeParser->new(\$metastring);
my $token;
+ undef %metathesekeys;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
- my $entry=$token->[1];
- my $unikey=$entry;
- if (defined($token->[2]->{'part'})) {
- $unikey.='_'.$token->[2]->{'part'};
+ 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]->{'name'})) {
- $unikey.='_'.$token->[2]->{'name'};
+ if (defined($token->[2]->{'id'})) {
+ $keyroot.='_'.$token->[2]->{'id'};
}
- if ($metacache{$uri.':keys'}) {
- $metacache{$uri.':keys'}.=','.$unikey;
+ if ($metacache{$uri.':packages'}) {
+ $metacache{$uri.':packages'}.=','.$package.$keyroot;
} else {
- $metacache{$uri.':keys'}=$unikey;
+ $metacache{$uri.':packages'}=$package.$keyroot;
}
map {
+ 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;
+ }
+ }
+ } keys %packagetab;
+ } 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'};
+ }
+
+ if ($entry eq 'import') {
+#
+# Importing a library here
+#
+ if (defined($depthcount)) { $depthcount++; } else
+ { $depthcount=0; }
+ if ($depthcount<20) {
+ map {
+ $metathesekeys{$_}=1;
+ } split(/\,/,&metadata($uri,'keys',
+ $parser->get_text('/import'),$unikey,
+ $depthcount));
+ }
+ } else {
+
+ if (defined($token->[2]->{'name'})) {
+ $unikey.='_'.$token->[2]->{'name'};
+ }
+ $metathesekeys{$unikey}=1;
+ map {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
} @{$token->[3]};
unless (
@@ -1872,8 +2370,16 @@ sub metadata {
) { $metacache{$uri.':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};
}
- }
+# 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;
+# this is the end of "was not already recently cached
}
return $metacache{$uri.':'.$what};
}
@@ -1903,6 +2409,7 @@ sub symblist {
sub symbread {
my $thisfn=shift;
unless ($thisfn) {
+ if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; }
$thisfn=$ENV{'request.filename'};
}
$thisfn=declutter($thisfn);
@@ -1983,16 +2490,21 @@ sub numval {
}
sub rndseed {
- my $symb;
- unless ($symb=&symbread()) { return time; }
- {
+ my ($symb,$courseid,$domain,$username)=@_;
+ if (!$symb) {
+ unless ($symb=&symbread()) { return time; }
+ }
+ if (!$courseid) { $courseid=$ENV{'request.course.id'};}
+ if (!$domain) {$domain=$ENV{'user.domain'};}
+ if (!$username) {$username=$ENV{'user.name'};}
+ {
use integer;
my $symbchck=unpack("%32C*",$symb) << 27;
my $symbseed=numval($symb) << 22;
- my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;
- my $nameseed=numval($ENV{'user.name'}) << 12;
- my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;
- my $courseseed=unpack("%32C*",$ENV{'request.course.id'});
+ 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");
@@ -2094,8 +2606,7 @@ sub unescape {
# ================================================================ Main Program
-sub BEGIN {
-if ($readit ne 'done') {
+BEGIN {
# ------------------------------------------------------------ Read access.conf
{
my $config=Apache::File->new("/etc/httpd/conf/access.conf");
@@ -2114,9 +2625,11 @@ if ($readit ne 'done') {
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
while (my $configline=<$config>) {
+ 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; }
}
}
@@ -2138,8 +2651,10 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($role,$perm)=split(/ /,$configline);
if ($perm ne '') { $pr{$role}=$perm; }
+ }
}
}
@@ -2149,8 +2664,25 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }
+ }
+ }
+}
+
+# ---------------------------------------------------------- Read package table
+{
+ my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
+
+ while (my $configline=<$config>) {
+ chomp($configline);
+ my ($short,$plain)=split(/:/,$configline);
+ my ($pack,$name)=split(/\&/,$short);
+ if ($plain ne '') {
+ $packagetab{$pack.'&'.$name.'&name'}=$name;
+ $packagetab{$short}=$plain;
+ }
}
}
@@ -2162,7 +2694,7 @@ if ($readit ne 'done') {
chomp($configline);
my ($ending,$emb,@descr)=split(/\s+/,$configline);
if ($descr[0] ne '') {
- $fe{$ending}=$emb;
+ $fe{$ending}=lc($emb);
$fd{$ending}=join(' ',@descr);
}
}
@@ -2171,7 +2703,8 @@ if ($readit ne 'done') {
%metacache=();
$readit='done';
+&logtouch();
&logthis('INFO: Read configuration');
}
-}
+
1;
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.