version 1.29, 2000/09/05 13:32:31
|
version 1.32, 2000/09/26 20:07:24
|
Line 37
|
Line 37
|
# dirlist(url) : gets a directory listing |
# dirlist(url) : gets a directory listing |
# condval(index) : value of condition index based on state |
# condval(index) : value of condition index based on state |
# varval(name) : value of a variable |
# varval(name) : value of a variable |
# refreshstate() : refresh the state information string |
# refreshstate() : refresh the state information string |
|
# symblist(map,hash) : Updates symbolic storage links |
|
# rndseed() : returns a random seed |
# |
# |
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, |
# 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, |
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, |
Line 49
|
Line 51
|
# 06/26 Ben Tyszka |
# 06/26 Ben Tyszka |
# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer |
# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer |
# 08/14 Ben Tyszka |
# 08/14 Ben Tyszka |
# 08/22,08/28,08/31,09/01,09/02,09/04,09/05 Gerd Kortemeyer |
# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25 Gerd Kortemeyer |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
Line 60 use HTTP::Headers;
|
Line 62 use HTTP::Headers;
|
use vars |
use vars |
qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit); |
qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit); |
use IO::Socket; |
use IO::Socket; |
|
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
Line 406 sub log {
|
Line 409 sub log {
|
# ----------------------------------------------------------------------- Store |
# ----------------------------------------------------------------------- Store |
|
|
sub store { |
sub store { |
my %storehash=shift; |
my %storehash=@_; |
|
my $symb; |
|
unless ($symb=escape(&symbread())) { return ''; } |
|
my $namespace; |
|
unless ($namespace=$ENV{'request.course.uri'}) { return ''; } |
|
$namespace=~s/\//\_\_/g; |
|
$namespace=~s/\./\_/g; |
|
$namespace=escape($namespace); |
my $namevalue=''; |
my $namevalue=''; |
map { |
map { |
$namevalue.=escape($_).'='.escape($storehash{$_}).'&'; |
$namevalue.=escape($_).'='.escape($storehash{$_}).'&'; |
} keys %storehash; |
} keys %storehash; |
$namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
return reply("store:$ENV{'user.domain'}:$ENV{'user.name'}:" |
return reply( |
."$ENV{'user.class'}:$ENV{'request.filename'}:$namevalue", |
"store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", |
"$ENV{'user.home'}"); |
"$ENV{'user.home'}"); |
} |
} |
|
|
# --------------------------------------------------------------------- Restore |
# --------------------------------------------------------------------- Restore |
|
|
sub restore { |
sub restore { |
my $answer=reply("restore:$ENV{'user.domain'}:$ENV{'user.name'}:" |
my $symb; |
."$ENV{'user.class'}:$ENV{'request.filename'}", |
unless ($symb=escape(&symbread())) { return ''; } |
"$ENV{'user.home'}"); |
my $namespace; |
|
unless ($namespace=$ENV{'request.course.uri'}) { return ''; } |
|
$namespace=~s/\//\_\_/g; |
|
$namespace=~s/\./\_/g; |
|
$namespace=escape($namespace); |
|
my $answer=reply( |
|
"restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb", |
|
"$ENV{'user.home'}"); |
my %returnhash=(); |
my %returnhash=(); |
map { |
map { |
my ($name,$value)=split(/\=/,$_); |
my ($name,$value)=split(/\=/,$_); |
$returnhash{&unescape($name)}=&unescape($value); |
$returnhash{&unescape($name)}=&unescape($value); |
} split(/\&/,$answer); |
} split(/\&/,$answer); |
|
map { |
|
$returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_}; |
|
} split(/\:/,$returnhash{$returnhash{'version'}.':keys'}); |
return %returnhash; |
return %returnhash; |
} |
} |
|
|
Line 626 sub allowed {
|
Line 646 sub allowed {
|
return 'F'; |
return 'F'; |
} |
} |
|
|
|
# The user does not have full access at system or domain level |
# Course level access control |
# Course level access control |
|
|
# uri itself refering to a course? |
# uri itself refering to a course? |
Line 634 sub allowed {
|
Line 655 sub allowed {
|
if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) { |
if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) { |
$thisallowed.=$1; |
$thisallowed.=$1; |
} |
} |
|
# Full access on course level? Exit. |
if ($thisallowed=~/F/) { |
if ($thisallowed=~/F/) { |
return 'F'; |
return 'F'; |
} |
} |
Line 665 sub allowed {
|
Line 687 sub allowed {
|
/\&$urifile\:(\d+)\&/) { |
/\&$urifile\:(\d+)\&/) { |
$uricond=$1; |
$uricond=$1; |
} elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) { |
} elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) { |
|
my $refuri=$ENV{'HTTP_REFERER'}; |
|
$refuri=~s/^\/res//; |
|
$refuri=~s/^\///; |
|
@uriparts=split(/\//,$refuri); |
|
$urifile=$uriparts[$#uriparts]; |
|
$#uriparts--; |
|
$uripath=join('/',@uriparts); |
|
if ($ENV{'acc.res.'.$ENV{'request.course'}.'.'.$uripath}=~ |
|
/\&$urifile\:(\d+)\&/) { |
|
$uricond=$1; |
|
} |
} |
} |
|
|
|
if ($uricond>=0) { |
|
|
|
# The resource is part of the course |
|
# If user had full access on course level, go ahead |
|
|
|
if ($thisallowed=~/F/) { |
|
return 'F'; |
|
} |
|
|
|
# Restricted by state? |
|
|
|
if ($thisallowed=~/X/) { |
|
if (&condval($uricond)>1) { |
|
return '2'; |
|
} else { |
|
return ''; |
|
} |
|
} |
|
} |
} |
} |
return $thisallowed; |
return $thisallowed; |
} |
} |
Line 745 sub filedecription {
|
Line 796 sub filedecription {
|
sub assignrole { |
sub assignrole { |
my ($udom,$uname,$url,$role,$end,$start)=@_; |
my ($udom,$uname,$url,$role,$end,$start)=@_; |
my $mrole; |
my $mrole; |
$url=~s/^\///; |
$url=declutter($url); |
$url=~s/^res\///; |
|
if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
unless ($url=~/\.course$/) { return 'invalid'; } |
unless ($url=~/\.course$/) { return 'invalid'; } |
unless (allowed('ccr',$url)) { return 'refused'; } |
unless (allowed('ccr',$url)) { return 'refused'; } |
Line 899 sub varval {
|
Line 949 sub varval {
|
return $value; |
return $value; |
} |
} |
|
|
|
# ------------------------------------------------- Update symbolic store links |
|
|
|
sub symblist { |
|
my ($mapname,%newhash)=@_; |
|
$mapname=declutter($mapname); |
|
my %hash; |
|
if (($ENV{'request.course.fn'}) && (%newhash)) { |
|
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
|
&GDBM_WRCREAT,0640)) { |
|
map { |
|
$hash{declutter($_)}=$mapname.'___'.$newhash{$_}; |
|
} keys %newhash; |
|
if (untie(%hash)) { |
|
return 'ok'; |
|
} |
|
} |
|
} |
|
return 'error'; |
|
} |
|
|
|
# ------------------------------------------------------ Return symb list entry |
|
|
|
sub symbread { |
|
my %hash; |
|
my $syval; |
|
if (($ENV{'request.course.fn'}) && ($ENV{'request.filename'})) { |
|
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
|
&GDBM_READER,0640)) { |
|
my $thisfn=declutter($ENV{'request.filename'}); |
|
$syval=$hash{$thisfn}; |
|
if (untie(%hash)) { |
|
unless ($syval=~/\_\d+$/) { |
|
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { |
|
return ''; |
|
} |
|
$syval.=$1; |
|
} |
|
$syval.='___'.$thisfn; |
|
return $syval; |
|
} |
|
} |
|
} |
|
return ''; |
|
} |
|
|
|
# ---------------------------------------------------------- Return random seed |
|
|
|
sub numval { |
|
my $txt=shift; |
|
$txt=~tr/A-J/0-9/; |
|
$txt=~tr/a-j/0-9/; |
|
$txt=~tr/K-T/0-9/; |
|
$txt=~tr/k-t/0-9/; |
|
$txt=~tr/U-Z/0-5/; |
|
$txt=~tr/u-z/0-5/; |
|
$txt=~s/\D//g; |
|
return int($txt); |
|
} |
|
|
|
sub rndseed { |
|
my $symb; |
|
unless ($symb=&symbread()) { return ''; } |
|
my $symbchck=unpack("%32C*",$symb); |
|
my $symbseed=numval($symb)%$symbchck; |
|
my $namechck=unpack("%32C*",$ENV{'user.name'}); |
|
my $nameseed=numval($ENV{'user.name'})%$namechck; |
|
return int( $symbseed |
|
.$nameseed |
|
.unpack("%32C*",$ENV{'user.domain'}) |
|
.unpack("%32C*",$ENV{'request.course.uri'}) |
|
.$namechck |
|
.$symbchck); |
|
} |
|
|
|
# ------------------------------------------------------------- Declutters URLs |
|
|
|
sub declutter { |
|
my $thisfn=shift; |
|
$thisfn=~s/^$perlvar{'lonDocRoot'}//; |
|
$thisfn=~s/^\///; |
|
$thisfn=~s/^res\///; |
|
return $thisfn; |
|
} |
|
|
# -------------------------------------------------------- Escape Special Chars |
# -------------------------------------------------------- Escape Special Chars |
|
|
sub escape { |
sub escape { |