--- loncom/lonnet/perl/lonnet.pm 2007/06/25 18:12:24 1.894 +++ loncom/lonnet/perl/lonnet.pm 2007/10/01 21:52:57 1.916 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.894 2007/06/25 18:12:24 albertel Exp $ +# $Id: lonnet.pm,v 1.916 2007/10/01 21:52:57 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -320,7 +320,10 @@ sub convert_and_load_session_env { my ($lonidsdir,$handle)=@_; my @profile; { - open(my $idf,"$lonidsdir/$handle.id"); + open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$idf) { + return 0; + } flock($idf,LOCK_SH); @profile=<$idf>; close($idf); @@ -359,7 +362,10 @@ sub transfer_profile_to_env { my $convert; { - open(my $idf,"$lonidsdir/$handle.id"); + open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$idf) { + return; + } flock($idf,LOCK_SH); if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", &GDBM_READER(),0640)) { @@ -391,6 +397,34 @@ sub transfer_profile_to_env { } } +# ---------------------------------------------------- Check for valid session +sub check_for_valid_session { + my ($r) = @_; + my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); + my $lonid=$cookies{'lonID'}; + return undef if (!$lonid); + + my $handle=&LONCAPA::clean_handle($lonid->value); + my $lonidsdir=$r->dir_config('lonIDsDir'); + return undef if (!-e "$lonidsdir/$handle.id"); + + open(my $idf,'+<',"$lonidsdir/$handle.id"); + return undef if (!$idf); + + flock($idf,LOCK_SH); + my %disk_env; + if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id", + &GDBM_READER(),0640)) { + return undef; + } + + if (!defined($disk_env{'user.name'}) + || !defined($disk_env{'user.domain'})) { + return undef; + } + return $handle; +} + sub timed_flock { my ($file,$lock_type) = @_; my $failed=0; @@ -425,8 +459,9 @@ sub appenv { $env{$key}=$newenv{$key}; } } - open(my $env_file,$env{'user.environment'}); - if (&timed_flock($env_file,LOCK_EX) + open(my $env_file,'+<',$env{'user.environment'}); + if ($env_file + && &timed_flock($env_file,LOCK_EX) && tie(my %disk_env,'GDBM_File',$env{'user.environment'}, (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { @@ -446,16 +481,17 @@ sub delenv { "Attempt to delete from environment ".$delthis); return 'error'; } - open(my $env_file,$env{'user.environment'}); - if (&timed_flock($env_file,LOCK_EX) + open(my $env_file,'+<',$env{'user.environment'}); + if ($env_file + && &timed_flock($env_file,LOCK_EX) && tie(my %disk_env,'GDBM_File',$env{'user.environment'}, (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { foreach my $key (keys(%disk_env)) { if ($key=~/^$delthis/) { - delete($env{$key}); - delete($disk_env{$key}); - } + delete($env{$key}); + delete($disk_env{$key}); + } } untie(%disk_env); } @@ -582,6 +618,27 @@ sub compare_server_load { } return ($spare_server,$lowest_load); } + +# --------------------------- ask offload servers if user already has a session +sub find_existing_session { + my ($udom,$uname) = @_; + foreach my $try_server (@{ $spareid{'primary'} }, + @{ $spareid{'default'} }) { + return $try_server if (&has_user_session($try_server, $udom, $uname)); + } + return; +} + +# -------------------------------- ask if server already has a session for user +sub has_user_session { + my ($lonid,$udom,$uname) = @_; + my $result = &reply(join(':','userhassession', + map {&escape($_)} ($udom,$uname)),$lonid); + return 1 if ($result eq 'ok'); + + return 0; +} + # --------------------------------------------- Try to change a user's password sub changepass { @@ -856,6 +913,194 @@ sub is_domainimage { return; } +sub inst_directory_query { + my ($srch) = @_; + my $udom = $srch->{'srchdomain'}; + my %results; + my $homeserver = &domain($udom,'primary'); + my $outcome; + if ($homeserver ne '') { + my $queryid=&reply("querysend:instdirsearch:". + &escape($srch->{'srchby'}).':'. + &escape($srch->{'srchterm'}).':'. + &escape($srch->{'srchtype'}),$homeserver); + my $host=&hostname($homeserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + return; + } + my $response = &get_query_reply($queryid); + my $maxtries = 5; + my $tries = 1; + while (($response=~/^timeout/) && ($tries < $maxtries)) { + $response = &get_query_reply($queryid); + $tries ++; + } + + if (!&error($response) && $response ne 'refused') { + if ($response eq 'unavailable') { + $outcome = $response; + } else { + $outcome = 'ok'; + my @matches = split(/\n/,$response); + foreach my $match (@matches) { + my ($key,$value) = split(/=/,$match); + $results{&unescape($key).':'.$udom} = &thaw_unescape($value); + } + } + } + } + return ($outcome,%results); +} + +sub usersearch { + my ($srch) = @_; + my $dom = $srch->{'srchdomain'}; + my %results; + my %libserv = &all_library(); + my $query = 'usersearch'; + foreach my $tryserver (keys(%libserv)) { + if (&host_domain($tryserver) eq $dom) { + my $host=&hostname($tryserver); + my $queryid= + &reply("querysend:".&escape($query).':'. + &escape($srch->{'srchby'}).':'. + &escape($srch->{'srchtype'}).':'. + &escape($srch->{'srchterm'}),$tryserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver); + next; + } + my $reply = &get_query_reply($queryid); + my $maxtries = 1; + my $tries = 1; + while (($reply=~/^timeout/) && ($tries < $maxtries)) { + $reply = &get_query_reply($queryid); + $tries ++; + } + if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries); + } else { + my @matches; + if ($reply =~ /\n/) { + @matches = split(/\n/,$reply); + } else { + @matches = split(/\&/,$reply); + } + foreach my $match (@matches) { + my ($uname,$udom,%userhash); + foreach my $entry (split(/:/,$match)) { + my ($key,$value) = + map {&unescape($_);} split(/=/,$entry); + $userhash{$key} = $value; + if ($key eq 'username') { + $uname = $value; + } elsif ($key eq 'domain') { + $udom = $value; + } + } + $results{$uname.':'.$udom} = \%userhash; + } + } + } + } + return %results; +} + +sub get_instuser { + my ($udom,$uname,$id) = @_; + my $homeserver = &domain($udom,'primary'); + my ($outcome,%results); + if ($homeserver ne '') { + my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'. + &escape($id).':'.&escape($udom),$homeserver); + my $host=&hostname($homeserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + return; + } + my $response = &get_query_reply($queryid); + my $maxtries = 5; + my $tries = 1; + while (($response=~/^timeout/) && ($tries < $maxtries)) { + $response = &get_query_reply($queryid); + $tries ++; + } + if (!&error($response) && $response ne 'refused') { + if ($response eq 'unavailable') { + $outcome = $response; + } else { + $outcome = 'ok'; + my @matches = split(/\n/,$response); + foreach my $match (@matches) { + my ($key,$value) = split(/=/,$match); + $results{&unescape($key)} = &thaw_unescape($value); + } + } + } + } + my %userinfo; + if (ref($results{$uname}) eq 'HASH') { + %userinfo = %{$results{$uname}}; + } + return ($outcome,%userinfo); +} + +sub inst_rulecheck { + my ($udom,$uname,$rules) = @_; + my %returnhash; + if ($udom ne '') { + if (ref($rules) eq 'ARRAY') { + @{$rules} = map {&escape($_);} (@{$rules}); + my $rulestr = join(':',@{$rules}); + my $homeserver=&domain($udom,'primary'); + if (($homeserver ne '') && ($homeserver ne 'no_host')) { + my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'. + &escape($uname).':'.$rulestr, + $homeserver)); + if ($response ne 'refused') { + my @pairs=split(/\&/,$response); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + } + } + } + } + return %returnhash; +} + +sub inst_userrules { + my ($udom) = @_; + my (%ruleshash,@ruleorder); + if ($udom ne '') { + my $homeserver=&domain($udom,'primary'); + if (($homeserver ne '') && ($homeserver ne 'no_host')) { + my $response=&reply('instuserrules:'.&escape($udom), + $homeserver); + if (($response ne 'refused') && ($response ne 'error') && + ($response ne 'no_such_host')) { + my ($hashitems,$orderitems) = split(/:/,$response); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $ruleshash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@ruleorder,&unescape($item)); + } + } + } + } + return (\%ruleshash,\@ruleorder); +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -1132,8 +1377,10 @@ sub do_cache_new { $time=600; } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } - if (!($memcache->set($id,$setvalue,$time))) { + my $result = $memcache->set($id,$setvalue,$time); + if (! $result) { &logthis("caching of id -> $id failed"); + $memcache->disconnect_all(); } # need to make a copy of $value #&make_room($id,$value,$debug); @@ -1396,7 +1643,7 @@ sub ssi { my $request; $form{'no_update_last_known'}=1; - + &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); @@ -2008,7 +2255,7 @@ sub flushcourselogs { # my %domrolebuffer = (); foreach my $entry (keys %domainrolehash) { - my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry; + my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); if ($domrolebuffer{$rudom}) { $domrolebuffer{$rudom}.='&'.&escape($entry). '='.&escape($domainrolehash{$entry}); @@ -2113,6 +2360,14 @@ sub userrolelog { {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} =$tend.':'.$tstart; } + if (($env{'request.role'} =~ /dc\./) && + (($trole=~/^au/) || ($trole=~/^in/) || + ($trole=~/^cc/) || ($trole=~/^ep/) || + ($trole=~/^cr/) || ($trole=~/^ta/))) { + $userrolehash + {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} + =$tend.':'.$tstart; + } if (($trole=~/^dc/) || ($trole=~/^ad/) || ($trole=~/^li/) || ($trole=~/^li/) || ($trole=~/^au/) || ($trole=~/^dg/) || @@ -3807,12 +4062,12 @@ sub customaccess { my ($effect,$realm,$role,$type)=split(/\:/,$right); if ($type eq 'user') { foreach my $scope (split(/\s*\,\s*/,$realm)) { - my ($tdom,$tcrs)=split(/\_/,$scope); + my ($tdom,$tuname)=split(m{/},$scope); if ($tdom) { if ($tdom ne $env{'user.domain'}) { next; } } - if ($tcrs) { - if ($tcrs ne $env{'user.name'}) { next; } + if ($tuname) { + if ($tuname ne $env{'user.name'}) { next; } } $access=($effect eq 'allow'); last; @@ -4366,6 +4621,23 @@ sub update_portfolio_table { return $reply; } +# -------------------------- Update MySQL allusers table + +sub update_allusers_table { + my ($uname,$udom,$names) = @_; + my $homeserver = &homeserver($uname,$udom); + my $queryid= + &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'. + 'lastname='.&escape($names->{'lastname'}).'%%'. + 'firstname='.&escape($names->{'firstname'}).'%%'. + 'middlename='.&escape($names->{'middlename'}).'%%'. + 'generation='.&escape($names->{'generation'}).'%%'. + 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. + 'id='.&escape($names->{'id'}),$homeserver); + my $reply = &get_query_reply($queryid); + return $reply; +} + # ------- Request retrieval of institutional classlists for course(s) sub fetch_enrollment_query { @@ -4400,7 +4672,7 @@ sub fetch_enrollment_query { if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); } else { - my @responses = split/:/,$reply; + my @responses = split(/:/,$reply); if ($homeserver eq $perlvar{'lonHostID'}) { foreach my $line (@responses) { my ($key,$value) = split(/=/,$line,2); @@ -4443,8 +4715,8 @@ sub get_query_reply { sleep 2; if (-e $replyfile.'.end') { if (open(my $fh,$replyfile)) { - $reply.=<$fh>; - close($fh); + $reply = join('',<$fh>); + close($fh); } else { return 'error: reply_file_error'; } return &unescape($reply); } @@ -4510,7 +4782,7 @@ sub auto_get_sections { my @secs = (); my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); unless ($response eq 'refused') { - @secs = split/:/,$response; + @secs = split(/:/,$response); } return @secs; } @@ -4549,7 +4821,7 @@ sub auto_create_password { if ($response eq 'refused') { $authchk = 'refused'; } else { - ($authparam,$create_passwd,$authchk) = split/:/,$response; + ($authparam,$create_passwd,$authchk) = split(/:/,$response); } } return ($authparam,$create_passwd,$authchk); @@ -4657,7 +4929,7 @@ sub auto_instcode_format { $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); if ($response !~ /(con_lost|error|no_such_host|refused)/) { my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = - split/:/,$response; + split(/:/,$response); %{$codes} = (%{$codes},&str2hash($codes_str)); push(@{$codetitles},&str2array($codetitles_str)); %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); @@ -5037,7 +5309,8 @@ sub modifyuser { } # -------------------------------------------------------------- Add names, etc my @tmp=&get('environment', - ['firstname','middlename','lastname','generation'], + ['firstname','middlename','lastname','generation','id', + 'permanentemail'], $udom,$uname); my %names; if ($tmp[0] =~ m/^error:.*/) { @@ -5059,8 +5332,10 @@ sub modifyuser { $names{'critnotification'} = $email; $names{'permanentemail'} = $email; } } + if ($uid) { $names{'id'} = $uid; } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } + my $sqlresult = &update_allusers_table($uname,$udom,\%names); &devalidate_cache_new('namescache',$uname.':'.$udom); &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. @@ -6204,6 +6479,12 @@ sub EXT { my ($map) = &decode_symb($symbparm); return &symbread($map); } + if ($space eq 'filename') { + if ($symbparm) { + return &clutter((&decode_symb($symbparm))[2]); + } + return &hreflocation('',$env{'request.filename'}); + } my ($section, $group, @groups); my ($courselevelm,$courselevel); @@ -6577,10 +6858,11 @@ sub metadata { # only ws inside the tag, and not in default, so use default # as value $metaentry{':'.$unikey}=$default; - } else { - # either something interesting inside the tag or default - # uninteresting + } elsif ( $internaltext =~ /\S/ ) { + # something interesting inside the tag $metaentry{':'.$unikey}=$internaltext; + } else { + # no interesting values, don't set a default } # end of not-a-package not-a-library import } @@ -6720,12 +7002,15 @@ sub gettitle { } my ($map,$resid,$url)=&decode_symb($symb); my $title=''; - my %bighash; - if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', - &GDBM_READER(),0640)) { - my $mapid=$bighash{'map_pc_'.&clutter($map)}; - $title=$bighash{'title_'.$mapid.'.'.$resid}; - untie %bighash; + if (!$map && $resid == 0 && $url =~/default\.sequence$/) { + $title = $env{'course.'.$env{'request.course.id'}.'.description'}; + } else { + if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $mapid=$bighash{'map_pc_'.&clutter($map)}; + $title=$bighash{'title_'.$mapid.'.'.$resid}; + untie(%bighash); + } } $title=~s/\&colon\;/\:/gs; if ($title) { @@ -7098,7 +7383,7 @@ sub getCODE { sub rndseed { my ($symb,$courseid,$domain,$username)=@_; my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); - if (!$symb) { + if (!defined($symb)) { unless ($symb=$wsymb) { return time; } } if (!$courseid) { $courseid=$wcourseid; } @@ -7604,6 +7889,9 @@ sub hreflocation { $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ -/uploaded/$1/$2/-x; } + if ($file=~ m{^/userfiles/}) { + $file =~ s{^/userfiles/}{/uploaded/}; + } return $file; } @@ -7884,6 +8172,7 @@ sub get_dns { } sub reset_hosts_info { + &purge_remembered(); &reset_domain_info(); &reset_hosts_ip_info(); undef(%name_to_host); @@ -8448,7 +8737,7 @@ explanation of a user role term get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : All arguments are optional. Returns a hash of a roles, either for co-author/assistant author roles for a user's Construction Space -(default), or if $context is 'user', roles for the user himself, +(default), or if $context is 'userroles', roles for the user himself, In the hash, keys are set to colon-sparated $uname,$udom,and $role, and value is set to colon-separated start and end times for the role. If no username and domain are specified, will default to current