version 1.153, 2001/08/18 14:58:15
|
version 1.162, 2001/10/06 20:57:45
|
Line 72
|
Line 72
|
# EXT(name) : value of a variable |
# EXT(name) : value of a variable |
# symblist(map,hash) : Updates symbolic storage links |
# symblist(map,hash) : Updates symbolic storage links |
# symbread([filename]) : returns the data handle (filename optional) |
# 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 |
# receipt() : returns a receipt to be given out to users |
# getfile(filename) : returns the contents of filename, or a -1 if it can't |
# getfile(filename) : returns the contents of filename, or a -1 if it can't |
# be found, replicates and subscribes to the file |
# be found, replicates and subscribes to the file |
Line 113
|
Line 118
|
# 05/01,06/01,09/01 Gerd Kortemeyer |
# 05/01,06/01,09/01 Gerd Kortemeyer |
# 09/01 Guy Albertelli |
# 09/01 Guy Albertelli |
# 09/01,10/01,11/01 Gerd Kortemeyer |
# 09/01,10/01,11/01 Gerd Kortemeyer |
|
# YEAR=2001 |
# 02/27/01 Scott Harrison |
# 02/27/01 Scott Harrison |
# 3/2 Gerd Kortemeyer |
# 3/2 Gerd Kortemeyer |
# 3/15,3/19 Scott Harrison |
# 3/15,3/19 Scott Harrison |
Line 122
|
Line 128
|
# 5/30 H. K. Ng |
# 5/30 H. K. Ng |
# 6/1 Gerd Kortemeyer |
# 6/1 Gerd Kortemeyer |
# July Guy Albertelli |
# July Guy Albertelli |
# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18 Gerd Kortemeyer |
# 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 Scott Harrison |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
Line 131 use Apache::File;
|
Line 139 use Apache::File;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Headers; |
use HTTP::Headers; |
use vars |
use vars |
qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab); |
qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs); |
use IO::Socket; |
use IO::Socket; |
use GDBM_File; |
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
Line 660 sub log {
|
Line 668 sub log {
|
return critical("log:$dom:$nam:$what",$hom); |
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("<font color=blue>WARNING: Buffer for ".$crsid. |
|
" exceeded maximum size, deleting.</font>"); |
|
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 |
# ----------------------------------------------------------- Check out an item |
|
|
sub checkout { |
sub checkout { |
Line 719 sub checkin {
|
Line 777 sub checkin {
|
my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
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, |
my %infohash=('resource.0.intoken' => $token, |
'resource.0.checkintime' => $now, |
'resource.0.checkintime' => $now, |
'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); |
'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); |
Line 1121 sub allowed {
|
Line 1190 sub allowed {
|
return 'F'; |
return 'F'; |
} |
} |
|
|
|
# Free bre to public access |
|
|
|
if ($priv eq 'bre') { |
|
if (&metadata($uri,'copyright') eq 'public') { return 'F'; } |
|
} |
|
|
my $thisallowed=''; |
my $thisallowed=''; |
my $statecond=0; |
my $statecond=0; |
my $courseprivid=''; |
my $courseprivid=''; |
Line 1193 sub allowed {
|
Line 1268 sub allowed {
|
map { |
map { |
if ($_=~/^httpref\..*\*/) { |
if ($_=~/^httpref\..*\*/) { |
my $pattern=$_; |
my $pattern=$_; |
|
$pattern=~s/^httpref\.\/res\///; |
$pattern=~s/\*/\[\^\/\]\+/g; |
$pattern=~s/\*/\[\^\/\]\+/g; |
$pattern=~s/\//\\\//g; |
$pattern=~s/\//\\\//g; |
if ($orguri=~/$pattern/) { |
if ($orguri=~/$pattern/) { |
Line 1559 sub modifystudent {
|
Line 1635 sub modifystudent {
|
return 'error: no such user'; |
return 'error: no such user'; |
} |
} |
# -------------------------------------------------- Add student to course list |
# -------------------------------------------------- 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:'. |
$ENV{'course.'.$cid.'.num'}.':classlist:'. |
&escape($uname.':'.$udom).'='. |
&escape($uname.':'.$udom).'='. |
&escape($end.':'.$start), |
&escape($end.':'.$start), |
Line 1624 sub createcourse {
|
Line 1700 sub createcourse {
|
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
$ENV{'user.home'}); |
$ENV{'user.home'}); |
unless ($reply eq 'ok') { return 'error: '.$reply; } |
unless ($reply eq 'ok') { return 'error: '.$reply; } |
my $uhome=&homeserver($uname,$udom); |
$uhome=&homeserver($uname,$udom); |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
return 'error: no such course'; |
return 'error: no such course'; |
} |
} |
Line 2133 sub numval {
|
Line 2209 sub numval {
|
} |
} |
|
|
sub rndseed { |
sub rndseed { |
my $symb; |
my ($symb,$courseid,$domain,$username)=@_; |
unless ($symb=&symbread()) { return time; } |
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; |
use integer; |
my $symbchck=unpack("%32C*",$symb) << 27; |
my $symbchck=unpack("%32C*",$symb) << 27; |
my $symbseed=numval($symb) << 22; |
my $symbseed=numval($symb) << 22; |
my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17; |
my $namechck=unpack("%32C*",$username) << 17; |
my $nameseed=numval($ENV{'user.name'}) << 12; |
my $nameseed=numval($username) << 12; |
my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7; |
my $domainseed=unpack("%32C*",$domain) << 7; |
my $courseseed=unpack("%32C*",$ENV{'request.course.id'}); |
my $courseseed=unpack("%32C*",$courseid); |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
#uncommenting these lines can break things! |
#uncommenting these lines can break things! |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
Line 2245 sub unescape {
|
Line 2326 sub unescape {
|
# ================================================================ Main Program |
# ================================================================ Main Program |
|
|
sub BEGIN { |
sub BEGIN { |
if ($readit ne 'done') { |
unless ($readit) { |
# ------------------------------------------------------------ Read access.conf |
# ------------------------------------------------------------ Read access.conf |
{ |
{ |
my $config=Apache::File->new("/etc/httpd/conf/access.conf"); |
my $config=Apache::File->new("/etc/httpd/conf/access.conf"); |
Line 2264 if ($readit ne 'done') {
|
Line 2345 if ($readit ne 'done') {
|
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
|
chomp($configline); |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
$hostname{$id}=$name; |
$hostname{$id}=$name; |
$hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
Line 2289 if ($readit ne 'done') {
|
Line 2371 if ($readit ne 'done') {
|
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
|
if ($configline) { |
my ($role,$perm)=split(/ /,$configline); |
my ($role,$perm)=split(/ /,$configline); |
if ($perm ne '') { $pr{$role}=$perm; } |
if ($perm ne '') { $pr{$role}=$perm; } |
|
} |
} |
} |
} |
} |
|
|
Line 2300 if ($readit ne 'done') {
|
Line 2384 if ($readit ne 'done') {
|
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
|
if ($configline) { |
my ($short,$plain)=split(/:/,$configline); |
my ($short,$plain)=split(/:/,$configline); |
if ($plain ne '') { $prp{$short}=$plain; } |
if ($plain ne '') { $prp{$short}=$plain; } |
|
} |
} |
} |
} |
} |
|
|