--- loncom/lonnet/perl/lonnet.pm 2002/05/08 17:40:03 1.216 +++ loncom/lonnet/perl/lonnet.pm 2002/06/05 20:40:10 1.236 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.216 2002/05/08 17:40:03 www Exp $ +# $Id: lonnet.pm,v 1.236 2002/06/05 20:40:10 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -77,7 +77,7 @@ use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars -qw(%perlvar %hostname %homecache %hostip %spareid %hostdom +qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom %libserv %pr %prp %metacache %packagetab %courselogs %accesshash $processmarker $dumpcount %coursedombuf %coursehombuf %courseresdatacache); @@ -140,20 +140,20 @@ 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') { - &logthis("Second attempt con_lost on $server"); - my $peerfile="$perlvar{'lonSockDir'}/$server"; - my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - Type => SOCK_STREAM, - Timeout => 10) - or return "con_lost"; - &logthis("Killing socket"); - print $client "close_connection_exit\n"; - sleep 5; - $answer=subreply($cmd,$server); - } + #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", + # Type => SOCK_STREAM, + # Timeout => 10) + # or return "con_lost"; + # &logthis("Killing socket"); + # print $client "close_connection_exit\n"; + #sleep 5; + # $answer=subreply($cmd,$server); + #} } if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". @@ -481,19 +481,23 @@ sub authenticate { # ---------------------- Find the homebase for a user from domain's lib servers sub homeserver { - my ($uname,$udom)=@_; - + my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - if ($homecache{$index}) { return "$homecache{$index}"; } - + if ($homecache{$index}) { + return "$homecache{$index}"; + } my $tryserver; foreach $tryserver (keys %libserv) { + next if ($ignoreBadCache ne 'true' && + exists($badServerCache{$tryserver})); if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - $homecache{$index}=$tryserver; + $homecache{$index}=$tryserver; return $tryserver; - } + } elsif ($answer eq 'no_host') { + $badServerCache{$tryserver}=1; + } } } return 'no_host'; @@ -795,6 +799,7 @@ sub checkout { my $now=time; my $lonhost=$perlvar{'lonHostID'}; my $infostr=&escape( + 'CHECKOUTTOKEN&'. $tuname.'&'. $tudom.'&'. $tcrsid.'&'. @@ -844,7 +849,7 @@ sub checkin { $lonhost=~tr/A-Z/a-z/; my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; $dtoken=~s/\W/\_/g; - my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= + my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); unless (($tuname) && ($tudom)) { @@ -1544,19 +1549,16 @@ sub allowed { # the course if ($ENV{'request.course.id'}) { + $courseprivid=$ENV{'request.course.id'}; if ($ENV{'request.course.sec'}) { $courseprivid.='/'.$ENV{'request.course.sec'}; } $courseprivid=~s/\_/\//; my $checkreferer=1; - my @uriparts=split(/\//,$uri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$uri; - $pathname=~s/\/$filename$//; - if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/) { - $statecond=$1; + my ($match,$cond)=&is_on_map($uri); + if ($match) { + $statecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; @@ -1566,7 +1568,6 @@ sub allowed { if ($checkreferer) { my $refuri=$ENV{'httpref.'.$orguri}; - unless ($refuri) { foreach (keys %ENV) { if ($_=~/^httpref\..*\*/) { @@ -1580,15 +1581,12 @@ sub allowed { } } } + if ($refuri) { $refuri=&declutter($refuri); - my @uriparts=split(/\//,$refuri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$refuri; - $pathname=~s/\/$filename$//; - if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/) { - my $refstatecond=$1; + my ($match,$cond)=&is_on_map($refuri); + if ($match) { + my $refstatecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; @@ -1729,6 +1727,23 @@ sub allowed { 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\|]+)\&/); + if ($match) { + return (1,$1); + } else { + return (0,0); + } +} + # ----------------------------------------------------------------- Define Role sub definerole { @@ -1875,7 +1890,7 @@ sub modifyuser { (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); - my $uhome=&homeserver($uname,$udom); + my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && ($umode) && ($upass)) { my $unhome=''; @@ -1905,7 +1920,7 @@ sub modifyuser { unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { return 'error: verify home'; } @@ -2012,11 +2027,11 @@ sub createcourse { my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; # ----------------------------------------------- Make sure that does not exist - my $uhome=&homeserver($uname,$udom); + my $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). 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')) { return 'error: unable to generate unique course-ID'; } @@ -2025,7 +2040,7 @@ sub createcourse { my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', $ENV{'user.home'}); unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } @@ -2196,8 +2211,19 @@ sub courseresdata { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm)=@_; + my ($varname,$symbparm,$udom,$uname)=@_; + unless ($varname) { return ''; } + + #get real user name/domain, courseid and symb + my $courseid; + if (!($uname && $udom)) { + (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + if (!$symbparm) { $symbparm=$cursymb; } + } else { + $courseid=$ENV{'request.course.id'}; + } + my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; if ($therest[0]) { @@ -2212,19 +2238,28 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore(); + my %restored=&restore(undef,undef,$udom,$uname); return $restored{$qualifierrest}; # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { + # FIXME - not supporting calls for a specific user return &allowed($qualifier,$rest); # ------------------------------------------ user.preferences, user.environment } elsif (($space eq 'preferences') || ($space eq 'environment')) { - return $ENV{join('.',('environment',$qualifierrest))}; + if (($uname eq $ENV{'user.name'}) && + ($udom eq $ENV{'user.domain'})) { + return $ENV{join('.',('environment',$qualifierrest))}; + } else { + my %returnhash=&userenvironment($udom,$uname,$qualifierrest); + return $returnhash{$qualifierrest}; + } # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { + # FIXME - not supporting calls for a specific user return $ENV{join('.',('request.course',$qualifier))}; # ------------------------------------------------------------------- user.role } elsif ($space eq 'role') { + # FIXME - not supporting calls for a specific user my ($role,$where)=split(/\./,$ENV{'request.role'}); if ($qualifier eq 'value') { return $role; @@ -2233,17 +2268,21 @@ sub EXT { } # ----------------------------------------------------------------- user.domain } elsif ($space eq 'domain') { - return $ENV{'user.domain'}; + return $udom; # ------------------------------------------------------------------- user.name } elsif ($space eq 'name') { - return $ENV{'user.name'}; + return $uname; # ---------------------------------------------------- Any other user namespace } else { my $item=($rest)?$qualifier.'.'.$rest:$qualifier; my %reply=&get($space,[$item]); return $reply{$item}; } - } elsif ($realm eq 'request') { + } elsif ($realm eq 'query') { +# ---------------------------------------------- pull stuff out of query string + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); + return $ENV{'form.'.$space}; + } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { return $ENV{'browser.'.$qualifier}; @@ -2253,112 +2292,112 @@ sub EXT { } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - return $ENV{'course.'.$ENV{'request.course.id'}.'.'. - $spacequalifierrest}; + return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($ENV{'request.course.id'}) { -# print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; + if ($courseid eq $ENV{'request.course.id'}) { + #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme - my $symbp; - if ($symbparm) { - $symbp=$symbparm; - } else { - $symbp=&symbread(); - } - my $mapp=(split(/\_\_\_/,$symbp))[0]; - - my $symbparm=$symbp.'.'.$spacequalifierrest; - my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - - my $seclevel= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$spacequalifierrest; - my $seclevelr= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$symbparm; - my $seclevelm= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$mapparm; - - my $courselevel= - $ENV{'request.course.id'}.'.'.$spacequalifierrest; - my $courselevelr= - $ENV{'request.course.id'}.'.'.$symbparm; - my $courselevelm= - $ENV{'request.course.id'}.'.'.$mapparm; + if (!$symbparm) { $symbparm=&symbread(); } + my $symbp=$symbparm; + my $mapp=(split(/\_\_\_/,$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'}; + } else { + $section=&usection($udom,$uname,$courseid); + } -# ----------------------------------------------------------- first, check user - my %resourcedata=get('resourcedata', - [$courselevelr,$courselevelm,$courselevel]); - 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}; } + my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; + my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; + my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; + + my $courselevel=$courseid.'.'.$spacequalifierrest; + my $courselevelr=$courseid.'.'.$symbparm; + my $courselevelm=$courseid.'.'.$mapparm; - } else { - if ($resourcedata{$courselevelr}!~/No such file/) { - &logthis("WARNING:". - " Trying to get resource data for ".$ENV{'user.name'}." at " - .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}. - ""); - } - } +# ----------------------------------------------------------- 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}.""); + } + } # -------------------------------------------------------- second, check course - my $coursereply=&courseresdata( - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}, - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm,$courselevel)); - if ($coursereply) { return $coursereply; } + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr,$courselevelm, + $courselevel)); + if ($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)) { - $thisparm=$parmhash{$symbparm}; - untie(%parmhash); - } - if ($thisparm) { return $thisparm; } - } - + my %parmhash=(); + my $thisparm=''; + if (tie(%parmhash,'GDBM_File', + $ENV{'request.course.fn'}.'_parms.db', + &GDBM_READER,0640)) { + $thisparm=$parmhash{$symbparm}; + untie(%parmhash); + } + if ($thisparm) { return $thisparm; } + } # --------------------------------------------- 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; } + $spacequalifierrest=~s/\./\_/; + my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); + if ($metadata) { return $metadata; } + $metadata=&metadata($ENV{'request.filename'}, + '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; } - } - } + 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; } + } + } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - return $ENV{'environment.'.$spacequalifierrest}; + if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { + return $ENV{'environment.'.$spacequalifierrest}; + } else { + my %returnhash=&userenvironment($udom,$uname, + $spacequalifierrest); + return $returnhash{$spacequalifierrest}; + } } elsif ($realm eq 'system') { # ----------------------------------------------------------------- system.time if ($space eq 'time') { @@ -2738,6 +2777,7 @@ sub hreflocation { unless (($file=~/^http:\/\//i) || ($file=~/^\//)) { my $finalpath=filelocation($dir,$file); $finalpath=~s/^\/home\/httpd\/html//; + $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; return $finalpath; } else { return $file; @@ -2751,6 +2791,7 @@ sub declutter { $thisfn=~s/^$perlvar{'lonDocRoot'}//; $thisfn=~s/^\///; $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; return $thisfn; } @@ -2779,13 +2820,24 @@ sub goodbye { } BEGIN { -# ------------------------------------------------------------ Read access.conf +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { - my $config=Apache::File->new("/etc/httpd/conf/access.conf"); + my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); + + while (my $configline=<$config>) { + if ($configline =~ /^[^\#]*PerlSetVar/) { + my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); + $perlvar{$varname}=$varvalue; + } + } +} +{ + my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); while (my $configline=<$config>) { - if ($configline =~ /PerlSetVar/) { + if ($configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; @@ -3254,7 +3306,7 @@ replicates and subscribes to the file =item * filelocation($dir,$file) : returns file system location of a file based on URI; -meant to be "fairly clean" absolute reference +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 *