--- loncom/lonnet/perl/lonnet.pm 2002/05/13 09:32:56 1.219 +++ loncom/lonnet/perl/lonnet.pm 2002/06/15 19:45:26 1.238 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.219 2002/05/13 09:32:56 albertel Exp $ +# $Id: lonnet.pm,v 1.238 2002/06/15 19:45:26 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)) { @@ -1496,7 +1501,21 @@ sub allowed { # Free bre to public access if ($priv eq 'bre') { - if (&metadata($uri,'copyright') eq 'public') { return 'F'; } + my $copyright=&metadata($uri,'copyright'); + if ($copyright eq 'public') { return 'F'; } + if ($copyright eq 'priv') { + $uri=~/([^\/]+)\/([^\/]+)\//; + unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { + return ''; + } + } + if ($copyright eq 'domain') { + $uri=~/([^\/]+)\/([^\/]+)\//; + unless (($ENV{'user.domain'} eq $1) || + ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) { + return ''; + } + } } my $thisallowed=''; @@ -1544,19 +1563,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 +1582,6 @@ sub allowed { if ($checkreferer) { my $refuri=$ENV{'httpref.'.$orguri}; - unless ($refuri) { foreach (keys %ENV) { if ($_=~/^httpref\..*\*/) { @@ -1580,15 +1595,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; @@ -1686,6 +1698,7 @@ sub allowed { if ($thisallowed=~/C/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/$rolecode/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, @@ -1693,6 +1706,14 @@ sub allowed { $ENV{'request.course.id'}); return ''; } + + if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} + =~/$unamedom/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. + $ENV{'request.course.id'}); + return ''; + } } # Resource preferences @@ -1729,6 +1750,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 +1913,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 +1943,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 +2050,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 +2063,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'; } @@ -2263,7 +2301,11 @@ sub EXT { 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}; @@ -2758,6 +2800,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; @@ -2771,6 +2814,7 @@ sub declutter { $thisfn=~s/^$perlvar{'lonDocRoot'}//; $thisfn=~s/^\///; $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; return $thisfn; } @@ -2799,12 +2843,10 @@ sub goodbye { } BEGIN { -# ------------------------------------------- Read access.conf and loncapa.conf -# (eventually access.conf will become deprecated) +# ----------------------------------- 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/) { @@ -2815,7 +2857,7 @@ 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>) { if ($configline =~ /^[^\#]*PerlSetVar/) { @@ -3287,7 +3329,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 *