version 1.226, 2002/05/18 18:54:29
|
version 1.233, 2002/05/23 21:24:13
|
Line 77 use Apache::File;
|
Line 77 use Apache::File;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Headers; |
use HTTP::Headers; |
use vars |
use vars |
qw(%perlvar %hostname %homecache %badhomecache %hostip %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom |
%libserv %pr %prp %metacache %packagetab |
%libserv %pr %prp %metacache %packagetab |
%courselogs %accesshash $processmarker $dumpcount |
%courselogs %accesshash $processmarker $dumpcount |
%coursedombuf %coursehombuf %courseresdatacache); |
%coursedombuf %coursehombuf %courseresdatacache); |
Line 140 sub reply {
|
Line 140 sub reply {
|
unless (defined($hostname{$server})) { return 'no_such_host'; } |
unless (defined($hostname{$server})) { return 'no_such_host'; } |
my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
sleep 5; |
#sleep 5; |
$answer=subreply($cmd,$server); |
#$answer=subreply($cmd,$server); |
if ($answer eq 'con_lost') { |
#if ($answer eq 'con_lost') { |
&logthis("Second attempt con_lost on $server"); |
# &logthis("Second attempt con_lost on $server"); |
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
# my $peerfile="$perlvar{'lonSockDir'}/$server"; |
my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
Type => SOCK_STREAM, |
# Type => SOCK_STREAM, |
Timeout => 10) |
# Timeout => 10) |
or return "con_lost"; |
# or return "con_lost"; |
&logthis("Killing socket"); |
# &logthis("Killing socket"); |
print $client "close_connection_exit\n"; |
# print $client "close_connection_exit\n"; |
sleep 5; |
#sleep 5; |
$answer=subreply($cmd,$server); |
# $answer=subreply($cmd,$server); |
} |
#} |
} |
} |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
&logthis("<font color=blue>WARNING:". |
&logthis("<font color=blue>WARNING:". |
Line 481 sub authenticate {
|
Line 481 sub authenticate {
|
# ---------------------- Find the homebase for a user from domain's lib servers |
# ---------------------- Find the homebase for a user from domain's lib servers |
|
|
sub homeserver { |
sub homeserver { |
my ($uname,$udom)=@_; |
my ($uname,$udom,$ignoreBadCache)=@_; |
my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
if ($homecache{$index}) { |
if ($homecache{$index}) { |
return "$homecache{$index}"; |
return "$homecache{$index}"; |
} |
} |
my $tryserver; |
my $tryserver; |
foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
next if (exists($badhomecache{$index}->{$tryserver})); |
next if ($ignoreBadCache ne 'true' && |
|
exists($badServerCache{$tryserver})); |
if ($hostdom{$tryserver} eq $udom) { |
if ($hostdom{$tryserver} eq $udom) { |
my $answer=reply("home:$udom:$uname",$tryserver); |
my $answer=reply("home:$udom:$uname",$tryserver); |
if ($answer eq 'found') { |
if ($answer eq 'found') { |
$homecache{$index}=$tryserver; |
$homecache{$index}=$tryserver; |
return $tryserver; |
return $tryserver; |
} else { |
} elsif ($answer eq 'no_host') { |
$badhomecache{$index}->{$tryserver}=1; |
$badServerCache{$tryserver}=1; |
} |
} |
} else { |
|
$badhomecache{$index}->{$tryserver}=1; |
|
} |
} |
} |
} |
return 'no_host'; |
return 'no_host'; |
Line 1549 sub allowed {
|
Line 1548 sub allowed {
|
# the course |
# the course |
|
|
if ($ENV{'request.course.id'}) { |
if ($ENV{'request.course.id'}) { |
|
|
$courseprivid=$ENV{'request.course.id'}; |
$courseprivid=$ENV{'request.course.id'}; |
if ($ENV{'request.course.sec'}) { |
if ($ENV{'request.course.sec'}) { |
$courseprivid.='/'.$ENV{'request.course.sec'}; |
$courseprivid.='/'.$ENV{'request.course.sec'}; |
} |
} |
$courseprivid=~s/\_/\//; |
$courseprivid=~s/\_/\//; |
my $checkreferer=1; |
my $checkreferer=1; |
my @uriparts=split(/\//,$uri); |
my ($match,$cond)=&is_on_map($uri); |
my $filename=$uriparts[$#uriparts]; |
if ($match) { |
my $pathname=$uri; |
$statecond=$cond; |
$pathname=~s/\/$filename$//; |
|
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
|
/\&$filename\:([\d\|]+)\&/) { |
|
$statecond=$1; |
|
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
=~/$priv\&([^\:]*)/) { |
=~/$priv\&([^\:]*)/) { |
$thisallowed.=$1; |
$thisallowed.=$1; |
Line 1571 sub allowed {
|
Line 1567 sub allowed {
|
|
|
if ($checkreferer) { |
if ($checkreferer) { |
my $refuri=$ENV{'httpref.'.$orguri}; |
my $refuri=$ENV{'httpref.'.$orguri}; |
|
|
unless ($refuri) { |
unless ($refuri) { |
foreach (keys %ENV) { |
foreach (keys %ENV) { |
if ($_=~/^httpref\..*\*/) { |
if ($_=~/^httpref\..*\*/) { |
Line 1585 sub allowed {
|
Line 1580 sub allowed {
|
} |
} |
} |
} |
} |
} |
|
|
if ($refuri) { |
if ($refuri) { |
$refuri=&declutter($refuri); |
$refuri=&declutter($refuri); |
my @uriparts=split(/\//,$refuri); |
my ($match,$cond)=&is_on_map($refuri); |
my $filename=$uriparts[$#uriparts]; |
if ($match) { |
my $pathname=$refuri; |
my $refstatecond=$cond; |
$pathname=~s/\/$filename$//; |
|
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
|
/\&$filename\:([\d\|]+)\&/) { |
|
my $refstatecond=$1; |
|
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
=~/$priv\&([^\:]*)/) { |
=~/$priv\&([^\:]*)/) { |
$thisallowed.=$1; |
$thisallowed.=$1; |
Line 1734 sub allowed {
|
Line 1726 sub allowed {
|
return 'F'; |
return 'F'; |
} |
} |
|
|
|
# --------------------------------------------------- Is a resource on the map? |
|
|
|
sub is_on_map { |
|
my $uri=&declutter(shift); |
|
my @uriparts=split(/\//,$uri); |
|
my $filename=$uriparts[$#uriparts]; |
|
my $pathname=$uri; |
|
$pathname=~s/\/$filename$//; |
|
my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
|
/\&$filename\:([\d\|]+)\&/); |
|
&logthis('is: '.$uri.' '.$match.' '.$1); |
|
if ($match) { |
|
return (1,$1); |
|
} else { |
|
return (0,0); |
|
} |
|
} |
|
|
# ----------------------------------------------------------------- Define Role |
# ----------------------------------------------------------------- Define Role |
|
|
sub definerole { |
sub definerole { |
Line 1880 sub modifyuser {
|
Line 1890 sub modifyuser {
|
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
' desiredhome not specified'). |
' desiredhome not specified'). |
' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom,'true'); |
# ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
my $unhome=''; |
my $unhome=''; |
Line 1910 sub modifyuser {
|
Line 1920 sub modifyuser {
|
unless ($reply eq 'ok') { |
unless ($reply eq 'ok') { |
return 'error: '.$reply; |
return 'error: '.$reply; |
} |
} |
$uhome=&homeserver($uname,$udom); |
$uhome=&homeserver($uname,$udom,'true'); |
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
return 'error: verify home'; |
return 'error: verify home'; |
} |
} |
Line 2017 sub createcourse {
|
Line 2027 sub createcourse {
|
my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
# ----------------------------------------------- Make sure that does not exist |
# ----------------------------------------------- Make sure that does not exist |
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom,'true'); |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
$uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
$uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
$uhome=&homeserver($uname,$udom); |
$uhome=&homeserver($uname,$udom,'true'); |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
return 'error: unable to generate unique course-ID'; |
return 'error: unable to generate unique course-ID'; |
} |
} |
Line 2030 sub createcourse {
|
Line 2040 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; } |
$uhome=&homeserver($uname,$udom); |
$uhome=&homeserver($uname,$udom,'true'); |
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 2805 sub goodbye {
|
Line 2815 sub goodbye {
|
} |
} |
|
|
BEGIN { |
BEGIN { |
# ---------------------------------- Read loncapa_apache.conf and loncapa.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# (eventually access.conf will become deprecated) |
|
unless ($readit) { |
unless ($readit) { |
|
|
{ |
{ |
my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); |
my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); |
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
if ($configline =~ /^[^\#]*PerlSetVar/) { |
if ($configline =~ /^[^\#]*PerlSetVar/) { |
Line 2821 BEGIN {
|
Line 2829 BEGIN {
|
} |
} |
} |
} |
{ |
{ |
my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); |
my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); |
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
if ($configline =~ /^[^\#]*PerlSetVar/) { |
if ($configline =~ /^[^\#]*PerlSetVar/) { |