--- loncom/lonnet/perl/lonnet.pm 2008/02/29 21:01:24 1.945 +++ loncom/lonnet/perl/lonnet.pm 2008/04/16 22:59:36 1.955 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.945 2008/02/29 21:01:24 raeburn Exp $ +# $Id: lonnet.pm,v 1.955 2008/04/16 22:59:36 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -448,27 +448,39 @@ sub timed_flock { # ---------------------------------------------------------- Append Environment sub appenv { - my %newenv=@_; - foreach my $key (keys(%newenv)) { - if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { - &logthis("<font color=\"blue\">WARNING: ". - "Attempt to modify environment ".$key." to ".$newenv{$key} - .'</font>'); - delete($newenv{$key}); - } else { - $env{$key}=$newenv{$key}; + my ($newenv,$roles) = @_; + if (ref($newenv) eq 'HASH') { + foreach my $key (keys(%{$newenv})) { + my $refused = 0; + if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { + $refused = 1; + if (ref($roles) eq 'ARRAY') { + my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./); + if (grep(/^\Q$role\E$/,@{$roles})) { + $refused = 0; + } + } + } + if ($refused) { + &logthis("<font color=\"blue\">WARNING: ". + "Attempt to modify environment ".$key." to ".$newenv->{$key} + .'</font>'); + delete($newenv->{$key}); + } else { + $env{$key}=$newenv->{$key}; + } + } + my $opened = open(my $env_file,'+<',$env{'user.environment'}); + if ($opened + && &timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { + while (my ($key,$value) = each(%{$newenv})) { + $disk_env{$key} = $value; + } + untie(%disk_env); } - } - my $opened = open(my $env_file,'+<',$env{'user.environment'}); - if ($opened - && &timed_flock($env_file,LOCK_EX) - && - tie(my %disk_env,'GDBM_File',$env{'user.environment'}, - (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { - while (my ($key,$value) = each(%newenv)) { - $disk_env{$key} = $value; - } - untie(%disk_env); } return 'ok'; } @@ -693,24 +705,38 @@ sub queryauthenticate { # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { - my ($uname,$upass,$udom)=@_; + my ($uname,$upass,$udom,$checkdefauth)=@_; $upass=&escape($upass); $uname= &LONCAPA::clean_username($uname); my $uhome=&homeserver($uname,$udom,1); + my $newhome; if ((!$uhome) || ($uhome eq 'no_host')) { # Maybe the machine was offline and only re-appeared again recently? &reconlonc(); # One more - my $uhome=&homeserver($uname,$udom,1); + $uhome=&homeserver($uname,$udom,1); + if (($uhome eq 'no_host') && $checkdefauth) { + if (defined(&domain($udom,'primary'))) { + $newhome=&domain($udom,'primary'); + } + if ($newhome ne '') { + $uhome = $newhome; + } + } if ((!$uhome) || ($uhome eq 'no_host')) { &logthis("User $uname at $udom is unknown in authenticate"); - } - return 'no_host'; + return 'no_host'; + } } - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); + my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome); if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by $uhome"); - return $uhome; + if ($newhome) { + &logthis("User $uname at $udom authorized by $uhome, but needs account"); + return 'no_account_on_host'; + } else { + &logthis("User $uname at $udom authorized by $uhome"); + return $uhome; + } } if ($answer eq 'non_authorized') { &logthis("User $uname at $udom rejected by $uhome"); @@ -1183,7 +1209,7 @@ sub assign_access_key { # key now belongs to user my $envkey='key.'.$cdom.'_'.$cnum; if (&put('environment',{$envkey => $ckey}) eq 'ok') { - &appenv('environment.'.$envkey => $ckey); + &appenv({'environment.'.$envkey => $ckey}); return 'ok'; } else { return @@ -1667,12 +1693,21 @@ sub ssi_body { if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { $form{'LONCAPA_INTERNAL_no_discussion'}='true'; } - my $output=($filelink=~/^http\:/?&externalssi($filelink): - &ssi($filelink,%form)); + my $output=''; + my $response; + if ($filelink=~/^http\:/) { + ($output,$response)=&externalssi($filelink); + } else { + ($output,$response)=&ssi($filelink,%form); + } $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs; $output=~s/^.*?\<body[^\>]*\>//si; $output=~s/\<\/body\s*\>.*?$//si; - return $output; + if (wantarray) { + return ($output, $response); + } else { + return $output; + } } # --------------------------------------------------------- Server Side Include @@ -1693,19 +1728,13 @@ sub absolute_url { # form Hash that describes how the rendering should be done # and other things. # Returns: -# Scalar context: The content of the reply. -# Array context: 2 element list of the content and the full response variable. +# Scalar context: The content of the response. +# Array context: 2 element list of the content and the full response object. # -# Returns: -# The content of the response. sub ssi { my ($fn,%form)=@_; - my $count = scalar(@_); - - my $ua=new LWP::UserAgent; - my $request; $form{'no_update_last_known'}=1; @@ -1719,7 +1748,6 @@ sub ssi { $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $response=$ua->request($request); - my $status = $response->code; if (wantarray) { return ($response->content, $response); @@ -1733,7 +1761,11 @@ sub externalssi { my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',$url); my $response=$ua->request($request); - return $response->content; + if (wantarray) { + return ($response->content, $response); + } else { + return $response->content; + } } # -------------------------------- Allow a /uploaded/ URI to be vouched for @@ -1746,7 +1778,7 @@ sub allowuploaded { my %httpref=(); my $httpurl=&hreflocation('',$url); $httpref{'httpref.'.$httpurl}=$srcurl; - &Apache::lonnet::appenv(%httpref); + &Apache::lonnet::appenv(\%httpref); } # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course @@ -2449,7 +2481,7 @@ sub userrolelog { } sub get_course_adv_roles { - my $cid=shift; + my ($cid,$codes) = @_; $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); my %nothide=(); @@ -2474,14 +2506,23 @@ sub get_course_adv_roles { if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } - my $key=&plaintext($role); - if ($section) { $key.=' (Sec/Grp '.$section.')'; } - if ($returnhash{$key}) { - $returnhash{$key}.=','.$username.':'.$domain; + if ($codes) { + if ($section) { $role .= ':'.$section; } + if ($returnhash{$role}) { + $returnhash{$role}.=','.$username.':'.$domain; + } else { + $returnhash{$role}=$username.':'.$domain; + } } else { - $returnhash{$key}=$username.':'.$domain; + my $key=&plaintext($role); + if ($section) { $key.=' (Section '.$section.')'; } + if ($returnhash{$key}) { + $returnhash{$key}.=','.$username.':'.$domain; + } else { + $returnhash{$key}=$username.':'.$domain; + } } - } + } return %returnhash; } @@ -2643,7 +2684,8 @@ sub courseidput { sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, - $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; + $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, + $selfenrollonly)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -2660,7 +2702,8 @@ sub courseiddump { $sincefilter.':'.&escape($descfilter).':'. &escape($instcodefilter).':'.&escape($ownerfilter). ':'.&escape($coursefilter).':'.&escape($typefilter). - ':'.&escape($regexp_ok).':'.$as_hash,$tryserver); + ':'.&escape($regexp_ok).':'.$as_hash.':'. + &escape($selfenrollonly),$tryserver); my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -3397,7 +3440,7 @@ sub coursedescription { } } if (!$args->{'one_time'}) { - &appenv(%envhash); + &appenv(\%envhash); } return %returnhash; } @@ -3946,6 +3989,7 @@ sub tmpget { my %returnhash; foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); + next if ($key =~ /^error: 2 /); $returnhash{&unescape($key)}=&thaw_unescape($value); } return %returnhash; @@ -5312,7 +5356,7 @@ sub plaintext { # ----------------------------------------------------------------- Assign Role sub assignrole { - my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; + my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_; my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; @@ -5346,11 +5390,15 @@ sub assignrole { } else { $refused = 1; } - if ($refused) { - &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. - ' '.$role.' '.$end.' '.$start.' by '. - $env{'user.name'}.' at '.$env{'user.domain'}); - return 'refused'; + if ($refused) { + if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + $refused = ''; + } else { + &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. + ' '.$role.' '.$end.' '.$start.' by '. + $env{'user.name'}.' at '.$env{'user.domain'}); + return 'refused'; + } } } $mrole=$role; @@ -5544,7 +5592,7 @@ sub modifystudent { } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -5602,7 +5650,7 @@ sub modify_student_enrollment { if ($usec) { $uurl.='/'.$usec; } - return &assignrole($udom,$uname,$uurl,'st',$end,$start); + return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll); } sub format_name { @@ -5721,7 +5769,7 @@ ENDINITMAP sub is_course { my ($cdom,$cnum) = @_; my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, - undef,'.',undef,1); + undef,'.'); if (exists($courses{$cdom.'_'.$cnum})) { return 1; } @@ -5755,9 +5803,17 @@ sub revokecustomrole { # ------------------------------------------------------------ Disk usage sub diskusage { - my ($udom,$uname,$directoryRoot)=@_; - $directoryRoot =~ s/\/$//; - my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); + my ($udom,$uname,$directorypath,$getpropath)=@_; + $directorypath =~ s/\/$//; + my $listing=&reply('du2:'.&escape($directorypath).':' + .&escape($getpropath).':'.&escape($uname).':' + .&escape($udom),homeserver($uname,$udom)); + if ($listing eq 'unknown_cmd') { + if ($getpropath) { + $directorypath = &propath($udom,$uname).'/'.$directorypath; + } + $listing = &reply('du:'.$directorypath,homeserver($uname,$udom)); + } return $listing; } @@ -6174,30 +6230,49 @@ sub unmark_as_readonly { # ------------------------------------------------------------ Directory lister sub dirlist { - my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; - + my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_; $uri=~s/^\///; $uri=~s/\/$//; my ($udom, $uname); - (undef,$udom,$uname)=split(/\//,$uri); - if(defined($userdomain)) { + if ($getuserdir) { $udom = $userdomain; - } - if(defined($username)) { $uname = $username; + } else { + (undef,$udom,$uname)=split(/\//,$uri); + if(defined($userdomain)) { + $udom = $userdomain; + } + if(defined($username)) { + $uname = $username; + } } + my ($dirRoot,$listing,@listing_results); - my $dirRoot = $perlvar{'lonDocRoot'}; - if(defined($alternateDirectoryRoot)) { - $dirRoot = $alternateDirectoryRoot; + $dirRoot = $perlvar{'lonDocRoot'}; + if (defined($getpropath)) { + $dirRoot = &propath($udom,$uname); $dirRoot =~ s/\/$//; + } elsif (defined($getuserdir)) { + my $subdir=$uname.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'} + ."/$udom/$subdir/$uname"; + } elsif (defined($alternateRoot)) { + $dirRoot = $alternateRoot; } if($udom) { if($uname) { - my $listing = &reply('ls2:'.$dirRoot.'/'.$uri, - &homeserver($uname,$udom)); - my @listing_results; + $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' + .$getuserdir.':'.&escape($alternateRoot) + .':'.&escape($uname).':'.&escape($udom), + &homeserver($uname,$udom)); + if ($listing eq 'unknown_cmd') { + $listing = &reply('ls2:'.$dirRoot.'/'.$uri, + &homeserver($uname,$udom)); + } else { + @listing_results = map { &unescape($_); } split(/:/,$listing); + } if ($listing eq 'unknown_cmd') { $listing = &reply('ls:'.$dirRoot.'/'.$uri, &homeserver($uname,$udom)); @@ -6206,13 +6281,18 @@ sub dirlist { @listing_results = map { &unescape($_); } split(/:/,$listing); } return @listing_results; - } elsif(!defined($alternateDirectoryRoot)) { + } elsif(!$alternateRoot) { my %allusers; my %servers = &get_servers($udom,'library'); - foreach my $tryserver (keys(%servers)) { - my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); - my @listing_results; + foreach my $tryserver (keys(%servers)) { + $listing = &reply('ls3:'.&escape("/res/$udom").':::::'. + &escape($udom),$tryserver); + if ($listing eq 'unknown_cmd') { + $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + } else { + @listing_results = map { &unescape($_); } split(/:/,$listing); + } if ($listing eq 'unknown_cmd') { $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. $udom, $tryserver); @@ -6239,13 +6319,13 @@ sub dirlist { } else { return ('missing user name'); } - } elsif(!defined($alternateDirectoryRoot)) { + } elsif(!defined($getpropath)) { my @all_domains = sort(&all_domains()); - foreach my $domain (@all_domains) { - $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; - } - return @all_domains; - } else { + foreach my $domain (@all_domains) { + $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; + } + return @all_domains; + } else { return ('missing domain'); } } @@ -6255,23 +6335,13 @@ sub dirlist { # when it was last modified. It will also return an error of -1 # if an error occurs -## -## FIXME: This subroutine assumes its caller knows something about the -## directory structure of the home server for the student ($root). -## Not a good assumption to make. Since this is for looking up files -## in user directories, the full path should be constructed by lond, not -## whatever machine we request data from. -## sub GetFileTimestamp { - my ($studentDomain,$studentName,$filename,$root)=@_; + my ($studentDomain,$studentName,$filename,$getuserdir)=@_; $studentDomain = &LONCAPA::clean_domain($studentDomain); $studentName = &LONCAPA::clean_username($studentName); - my $subdir=$studentName.'__'; - $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; - my $proname="$studentDomain/$subdir/$studentName"; - $proname .= '/'.$filename; - my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, - $studentName, $root); + my ($fileStat) = + &Apache::lonnet::dirlist($filename,$studentDomain,$studentName, + undef,$getuserdir); my @stats = split('&', $fileStat); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { # @stats contains first the filename, then the stat output @@ -6285,12 +6355,11 @@ sub stat_file { my ($uri) = @_; $uri = &clutter_with_no_wrapper($uri); - my ($udom,$uname,$file,$dir); + my ($udom,$uname,$file); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; - $dir = &propath($udom,$uname); } if ($uri =~ m-^/res/-) { ($udom,$uname) = @@ -6303,7 +6372,8 @@ sub stat_file { return (); } - my ($result) = &dirlist($file,$udom,$uname,$dir); + my $getpropath = 1; + my ($result) = &dirlist($file,$udom,$uname,$getpropath); my @stats = split('&', $result); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { @@ -6336,7 +6406,7 @@ sub directcondval { untie(%bighash); } my $value = &docondval($sub_condition); - &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value); + &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value}); return $value; } if ($env{'user.state.'.$env{'request.course.id'}}) { @@ -6522,7 +6592,7 @@ sub EXT_cache_status { sub EXT_cache_set { my ($target_domain,$target_user) = @_; my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; - #&appenv($cachename => time); + #&appenv({$cachename => time}); } # --------------------------------------------------------- Value of a Variable @@ -7424,7 +7494,7 @@ sub symbread { if ($syval) { #unless ($syval=~/\_\d+$/) { #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { - #&appenv('request.ambiguous' => $thisfn); + #&appenv({'request.ambiguous' => $thisfn}); #return $env{$cache_str}=''; #} #$syval.=$1; @@ -7476,7 +7546,7 @@ sub symbread { return $env{$cache_str}=$syval; } } - &appenv('request.ambiguous' => $thisfn); + &appenv({'request.ambiguous' => $thisfn}); return $env{$cache_str}=''; } @@ -7990,7 +8060,7 @@ sub tokenwrapper { my (undef,$udom,$uname,$file)=split('/',$uri,4); if ($udom && $uname && $file) { $file=~s|(\?\.*)*$||; - &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); + &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; @@ -8056,8 +8126,7 @@ sub filelocation { my @ids=¤t_machine_ids(); foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } if ($is_me) { - $location=&propath($udom,$uname). - '/userfiles/'.$filename; + $location=&propath($udom,$uname).'/userfiles/'.$filename; } else { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. $udom.'/'.$uname.'/'.$filename; @@ -8835,10 +8904,12 @@ that was requested =item * X<appenv()> -B<appenv(%hash)>: the value of %hash is written to +B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to the user envirnoment file, and will be restored for each access this user makes during this session, also modifies the %env for the current -process +process. Optional rolesarrayref - if defined contains a reference to an array +of roles which are exempt from the restriction on modifying user.role entries +in the user's environment.db and in %env. =item * X<delenv()>