--- loncom/lonnet/perl/lonnet.pm 2007/03/03 01:54:13 1.842 +++ loncom/lonnet/perl/lonnet.pm 2007/08/31 12:33:29 1.909 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.842 2007/03/03 01:54:13 albertel Exp $ +# $Id: lonnet.pm,v 1.909 2007/08/31 12:33:29 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,24 +31,21 @@ package Apache::lonnet; use strict; use LWP::UserAgent(); -use HTTP::Headers; use HTTP::Date; # use Date::Parse; -use vars -qw(%perlvar %badServerCache %iphost %spareid %hostdom - %libserv %pr %prp $memcache %packagetab - %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf - %domaindescription %domain_auth_def %domain_auth_arg_def - %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary - $tmpdir $_64bit %env); +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir + $_64bit %env); + +my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, + %userrolehash, $processmarker, $dumpcount, %coursedombuf, + %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, + %courseownerbuf, %coursetypebuf); use IO::Socket; use GDBM_File; use HTML::LCParser; -use HTML::Parser; use Fcntl qw(:flock); -use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); +use Storable qw(thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; @@ -146,6 +143,20 @@ sub logperm { return 1; } +sub create_connection { + my ($hostname,$lonid) = @_; + my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, + Type => SOCK_STREAM, + Timeout => 10); + return 0 if (!$client); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); + my $result = <$client>; + chomp($result); + return 1 if ($result eq 'done'); + return 0; +} + + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; @@ -170,10 +181,12 @@ sub subreply { $client=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10); - if($client) { + if ($client) { last; # Connected! + } else { + &create_connection(&hostname($server),$server); } - sleep(1); # Try again later if failed connection. + sleep(1); # Try again later if failed connection. } my $answer; if ($client) { @@ -201,6 +214,24 @@ sub reply { # ----------------------------------------------------------- Send USR1 to lonc sub reconlonc { + my ($lonid) = @_; + my $hostname = &hostname($lonid); + if ($lonid) { + my $peerfile="$perlvar{'lonSockDir'}/$hostname"; + if ($hostname && -e $peerfile) { + &logthis("Trying to reconnect lonc for $lonid ($hostname)"); + my $client=IO::Socket::UNIX->new(Peer => $peerfile, + Type => SOCK_STREAM, + Timeout => 10); + if ($client) { + print $client ("reset_retries\n"); + my $answer=<$client>; + #reset just this one. + } + } + return; + } + &logthis("Trying to reconnect lonc"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; if (open(my $fh,"<$loncfile")) { @@ -720,21 +751,36 @@ sub idput { # ------------------------------------------- get items from domain db files sub get_dom { - my ($namespace,$storearr,$udom)=@_; + my ($namespace,$storearr,$udom,$uhome)=@_; my $items=''; foreach my $item (@$storearr) { $items.=&escape($item).'&'; } $items=~s/\&$//; - if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + undef($uhome); + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + my %returnhash; + if ($rep eq '' || $rep =~ /^error: 2 /) { + return %returnhash; + } my @pairs=split(/\&/,$rep); if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { return @pairs; } - my %returnhash=(); my $i=0; foreach my $item (@$storearr) { $returnhash{$item}=&thaw_unescape($pairs[$i]); @@ -742,17 +788,29 @@ sub get_dom { } return %returnhash; } else { - &logthis("get_dom failed - no primary domain server for $udom"); + &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)"); } } # -------------------------------------------- put items in domain db files sub put_dom { - my ($namespace,$storehash,$udom)=@_; - if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + my ($namespace,$storehash,$udom,$uhome)=@_; + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + undef($uhome); + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { my $items=''; foreach my $item (keys(%$storehash)) { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; @@ -760,15 +818,15 @@ sub put_dom { $items=~s/\&$//; return &reply("putdom:$udom:$namespace:$items",$uhome); } else { - &logthis("put_dom failed - no primary domain server for $udom"); + &logthis("put_dom failed - no homeserver and/or domain"); } } sub retrieve_inst_usertypes { my ($udom) = @_; my (%returnhash,@order); - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); my $rep=&reply("inst_usertypes:$udom",$uhome); my ($hashitems,$orderitems) = split(/:/,$rep); my @pairs=split(/\&/,$hashitems); @@ -788,6 +846,107 @@ sub retrieve_inst_usertypes { return (\%returnhash,\@order); } +sub is_domainimage { + my ($url) = @_; + if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { + if (&domain($1) ne '') { + return '1'; + } + } + 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($dom).':'. + &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 = split(/&/,$reply); + foreach my $match (@matches) { + my @items = split(/:/,$match); + my ($uname,$udom,%userhash); + foreach my $entry (@items) { + my ($key,$value) = split(/=/,$entry); + $key = &unescape($key); + $value = &unescape($value); + $userhash{$key} = $value; + if ($key eq 'username') { + $uname = $value; + } elsif ($key eq 'domain') { + $udom = $value; + } + } + $results{$uname.':'.$udom} = \%userhash; + } + } + } + } + return %results; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -1012,10 +1171,19 @@ my %remembered; my %accessed; my $kicks=0; my $hits=0; +sub make_key { + my ($name,$id) = @_; + if (length($id) > 65 + && length(&escape($id)) > 200) { + $id=length($id).':'.&Digest::MD5::md5_hex($id); + } + return &escape($name.':'.$id); +} + sub devalidate_cache_new { my ($name,$id,$debug) = @_; if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); $memcache->delete($id); delete($remembered{$id}); delete($accessed{$id}); @@ -1023,7 +1191,7 @@ sub devalidate_cache_new { sub is_cached_new { my ($name,$id,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); if (exists($remembered{$id})) { if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } $accessed{$id}=[&gettimeofday()]; @@ -1046,7 +1214,7 @@ sub is_cached_new { sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); my $setvalue=$value; if (!defined($setvalue)) { $setvalue='__undef__'; @@ -1055,7 +1223,9 @@ sub do_cache_new { $time=600; } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } - $memcache->set($id,$setvalue,$time); + if (!($memcache->set($id,$setvalue,$time))) { + &logthis("caching of id -> $id failed"); + } # need to make a copy of $value #&make_room($id,$value,$debug); return $value; @@ -1317,7 +1487,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)); @@ -1496,14 +1666,21 @@ sub clean_filename { # $coursedoc - if true up to the current course # if false # $subdir - directory in userfile to store the file into -# $parser, $allfiles, $codebase - unknown -# +# $parser - instruction to parse file for objects ($parser = parse) +# $allfiles - reference to hash for embedded objects +# $codebase - reference to hash for codebase of java objects +# $desuname - username for permanent storage of uploaded file +# $dsetudom - domain for permanaent storage of uploaded file +# $thumbwidth - width (pixels) of thumbnail to make for uploaded image +# $thumbheight - height (pixels) of thumbnail to make for uploaded image +# # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse sub userfileupload { - my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, + $destudom,$thumbwidth,$thumbheight)=@_; if (!defined($subdir)) { $subdir='unknown'; } my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); @@ -1550,7 +1727,7 @@ sub userfileupload { if ($env{'form.folder'} =~ m/^(default|supplemental)/) { return &finishuserfileupload($docuname,$docudom, $formname,$fname,$parser,$allfiles, - $codebase); + $codebase,$thumbwidth,$thumbheight); } else { $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, @@ -1560,8 +1737,9 @@ sub userfileupload { } elsif (defined($destuname)) { my $docuname=$destuname; my $docudom=$destudom; - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } else { my $docuname=$env{'user.name'}; @@ -1570,16 +1748,18 @@ sub userfileupload { $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; } - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } } sub finishuserfileupload { - my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; + my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, + $thumbwidth,$thumbheight) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; - my ($fnamepath,$file); + my ($fnamepath,$file,$fetchthumb); $file=$fname; if ($fname=~m|/|) { ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); @@ -1615,11 +1795,28 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } + if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { + my $input = $filepath.'/'.$file; + my $output = $filepath.'/'.'tn-'.$file; + my $thumbsize = $thumbwidth.'x'.$thumbheight; + system("convert -sample $thumbsize $input $output"); + if (-e $filepath.'/'.'tn-'.$file) { + $fetchthumb = 1; + } + } + # Notify homeserver to grep it # my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { + if ($fetchthumb) { + my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); + if ($thumbresult ne 'ok') { + &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. + $docuhome.': '.$thumbresult); + } + } # # Return the URL to it return '/uploaded/'.$path.$file; @@ -1627,7 +1824,7 @@ sub finishuserfileupload { &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. ': '.$fetchresult); return '/adm/notfound.html'; - } + } } sub extract_embedded_items { @@ -1651,13 +1848,16 @@ sub extract_embedded_items { while (my $t=$p->get_token()) { if ($t->[0] eq 'S') { my ($tagname, $attr) = ($t->[1],$t->[2]); - push (@state, $tagname); + push(@state, $tagname); if (lc($tagname) eq 'allow') { &add_filetype($allfiles,$attr->{'src'},'src'); } if (lc($tagname) eq 'img') { &add_filetype($allfiles,$attr->{'src'},'src'); } + if (lc($tagname) eq 'a') { + &add_filetype($allfiles,$attr->{'href'},'href'); + } if (lc($tagname) eq 'script') { if ($attr->{'archive'} =~ /\.jar$/i) { &add_filetype($allfiles,$attr->{'archive'},'archive'); @@ -1842,7 +2042,7 @@ sub flushcourselogs { # Is used in pickcourse # foreach my $crs_home (keys(%courseidbuffer)) { - &courseidput($hostdom{$crs_home},$courseidbuffer{$crs_home}, + &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home}, $crs_home); } # @@ -1899,7 +2099,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}); @@ -2004,6 +2204,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/) || @@ -2049,15 +2257,25 @@ sub get_course_adv_roles { } sub get_my_roles { - my ($uname,$udom,$types,$roles,$roledoms)=@_; + my ($uname,$udom,$context,$types,$roles,$roledoms)=@_; unless (defined($uname)) { $uname=$env{'user.name'}; } unless (defined($udom)) { $udom=$env{'user.domain'}; } - my %dumphash= + my %dumphash; + if ($context eq 'userroles') { + %dumphash = &dump('roles',$udom,$uname); + } else { + %dumphash= &dump('nohist_userroles',$udom,$uname); + } my %returnhash=(); my $now=time; foreach my $entry (keys(%dumphash)) { - my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); + my ($role,$tend,$tstart); + if ($context eq 'userroles') { + ($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); + } else { + ($tend,$tstart)=split(/\:/,$dumphash{$entry}); + } if (($tstart) && ($tstart<0)) { next; } my $status = 'active'; if (($tend) && ($tend<$now)) { @@ -2075,7 +2293,13 @@ sub get_my_roles { next; } } - my ($role,$username,$domain,$section)=split(/\:/,$entry); + my ($rolecode,$username,$domain,$section,$area); + if ($context eq 'userroles') { + ($area,$rolecode) = split(/_/,$entry); + (undef,$domain,$username,$section) = split(/\//,$area); + } else { + ($role,$username,$domain,$section) = split(/\:/,$entry); + } if (ref($roledoms) eq 'ARRAY') { if (!grep(/^\Q$domain\E$/,@{$roledoms})) { next; @@ -2085,7 +2309,7 @@ sub get_my_roles { if (!grep(/^\Q$role\E$/,@{$roles})) { next; } - } + } $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; } return %returnhash; @@ -2097,7 +2321,7 @@ sub get_my_roles { sub postannounce { my ($server,$text)=@_; - unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless (&allowed('psa',&host_domain($server))) { return 'refused'; } unless ($text=~/\w/) { $text=''; } return &reply('setannounce:'.&escape($text),$server); } @@ -2133,11 +2357,16 @@ sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } - foreach my $tryserver (keys %libserv) { - if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { - if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + my %libserv = &all_library(); + foreach my $tryserver (keys(%libserv)) { + if ( ( $hostidflag == 1 + && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) + || (!defined($hostidflag)) ) { + + if ($domfilter eq '' + || (&host_domain($tryserver) eq $domfilter)) { foreach my $line ( - split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'. $sincefilter.':'.&escape($descfilter).':'. &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), $tryserver))) { @@ -2165,12 +2394,13 @@ sub dcmailput { sub dcmaildump { my ($dom,$startdate,$enddate,$senders) = @_; my %returnhash=(); - if (exists($domain_primary{$dom})) { + + if (defined(&domain($dom,'primary'))) { my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. &escape($enddate).':'; my @esc_senders=map { &escape($_)} @$senders; $cmd.=&escape(join('&',@esc_senders)); - foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { + foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) { my ($key,$value) = split(/\=/,$line,2); if (($key) && ($value)) { $returnhash{&unescape($key)} = &unescape($value); @@ -3023,7 +3253,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { my ($trole,$area,$sec,$extendedarea); - if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) { + if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { $trole = $1; $area = $2; $sec = $3; @@ -3504,9 +3734,16 @@ sub get_portfolio_access { } if (@users > 0) { foreach my $userkey (@users) { - if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { - return 'ok'; - } + if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { + foreach my $item (@{$access_hash->{$userkey}{'users'}}) { + if (ref($item) eq 'HASH') { + if (($item->{'uname'} eq $env{'user.name'}) && + ($item->{'udom'} eq $env{'user.domain'})) { + return 'ok'; + } + } + } + } } } my %roleshash; @@ -3666,26 +3903,40 @@ sub customaccess { $ucrs = &LONCAPA::clean_username($ucrs); my $access=0; foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { - my ($effect,$realm,$role)=split(/\:/,$right); - if ($role) { - if ($role ne $urole) { next; } - } - foreach my $scope (split(/\s*\,\s*/,$realm)) { - my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); - if ($tdom) { - if ($tdom ne $udom) { next; } - } - if ($tcrs) { - if ($tcrs ne $ucrs) { next; } - } - if ($tsec) { - if ($tsec ne $usec) { next; } - } - $access=($effect eq 'allow'); - last; - } - if ($realm eq '' && $role eq '') { - $access=($effect eq 'allow'); + my ($effect,$realm,$role,$type)=split(/\:/,$right); + if ($type eq 'user') { + foreach my $scope (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tuname)=split(m{/},$scope); + if ($tdom) { + if ($tdom ne $env{'user.domain'}) { next; } + } + if ($tuname) { + if ($tuname ne $env{'user.name'}) { next; } + } + $access=($effect eq 'allow'); + last; + } + } else { + if ($role) { + if ($role ne $urole) { next; } + } + foreach my $scope (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } } } return $access; @@ -4170,6 +4421,7 @@ sub definerole { sub metadata_query { my ($query,$custom,$customshow,$server_array)=@_; my %rhash; + my %libserv = &all_library(); my @server_list = (defined($server_array) ? @$server_array : keys(%libserv) ); for my $server (@server_list) { @@ -4213,6 +4465,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 { @@ -4247,7 +4516,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); @@ -4290,8 +4559,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); } @@ -4322,6 +4591,12 @@ sub courselog_query { } sub userlog_query { +# +# possible filters: +# action: log check role +# start: timestamp +# end: timestamp +# my ($uname,$udom,%filters)=@_; return &log_query($uname,$udom,'userlog',%filters); } @@ -4330,8 +4605,18 @@ sub userlog_query { sub auto_run { my ($cnum,$cdom) = @_; - my $homeserver = &homeserver($cnum,$cdom); - my $response = &reply('autorun:'.$cdom,$homeserver); + my $response = 0; + my $settings; + my %domconfig = &get_dom('configuration',['autoenroll'],$cdom); + if (ref($domconfig{'autoenroll'}) eq 'HASH') { + $settings = $domconfig{'autoenroll'}; + if ($settings->{'run'} eq '1') { + $response = 1; + } + } else { + my $homeserver = &homeserver($cnum,$cdom); + $response = &reply('autorun:'.$cdom,$homeserver); + } return $response; } @@ -4341,7 +4626,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; } @@ -4361,15 +4646,27 @@ sub auto_validate_courseID { } sub auto_create_password { - my ($cnum,$cdom,$authparam) = @_; - my $homeserver = &homeserver($cnum,$cdom); + my ($cnum,$cdom,$authparam,$udom) = @_; + my ($homeserver,$response); my $create_passwd = 0; my $authchk = ''; - my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); - if ($response eq 'refused') { - $authchk = 'refused'; + if ($udom =~ /^$match_domain$/) { + $homeserver = &domain($udom,'primary'); + } + if ($homeserver eq '') { + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + } + if ($homeserver eq '') { + $authchk = 'nodomain'; } else { - ($authparam,$create_passwd,$authchk) = split/:/,$response; + $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); + if ($response eq 'refused') { + $authchk = 'refused'; + } else { + ($authparam,$create_passwd,$authchk) = split(/:/,$response); + } } return ($authparam,$create_passwd,$authchk); } @@ -4476,7 +4773,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)); @@ -4811,7 +5108,7 @@ sub modifyuser { if (($uhome eq 'no_host') && (($umode && $upass) || ($umode eq 'localauth'))) { my $unhome=''; - if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { + if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { $unhome = $desiredhome; } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { $unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; @@ -4856,7 +5153,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:.*/) { @@ -4878,8 +5176,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.', '. @@ -5038,7 +5338,7 @@ sub createcourse { } # ------------------------------------------------ Check supplied server name $course_server = $env{'user.homeserver'} if (! defined($course_server)); - if (! exists($libserv{$course_server})) { + if (! &is_library($course_server)) { return 'error:bad server name '.$course_server; } # ------------------------------------------------------------- Make the course @@ -5174,7 +5474,7 @@ sub save_selected_files { my ($user, $path, @files) = @_; my $filename = $user."savedfiles"; my @other_files = &files_not_in_path($user, $path); - open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + open (OUT, '>'.$tmpdir.$filename); foreach my $file (@files) { print (OUT $env{'form.currentpath'}.$file."\n"); } @@ -5766,6 +6066,13 @@ sub devalidatecourseresdata { # --------------------------------------------------- Course Resourcedata Query +# +# Parameters: +# $coursenum - Number of the course. +# $coursedomain - Domain at which the course was created. +# Returns: +# A hash of the course parameters along (I think) with timestamps +# and version info. sub get_courseresdata { my ($coursenum,$coursedomain)=@_; @@ -5824,7 +6131,21 @@ sub get_userresdata { } return $tmp; } - +#----------------------------------------------- resdata - return resource data +# Purpose: +# Return resource data for either users or for a course. +# Parameters: +# $name - Course/user name. +# $domain - Name of the domain the user/course is registered on. +# $type - Type of thing $name is (must be 'course' or 'user' +# @which - Array of names of resources desired. +# Returns: +# The value of the first reasource in @which that is found in the +# resource hash. +# Exceptional Conditions: +# If the $type passed in is not valid (not the string 'course' or +# 'user', an undefined reference is returned. +# If none of the resources are found, an undef is returned sub resdata { my ($name,$domain,$type,@which)=@_; my $result; @@ -6002,6 +6323,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); @@ -6171,7 +6498,8 @@ sub packages_tab_default { $do_default=1; } elsif ($pack_type eq 'extension') { push(@extension,[$package,$pack_type,$pack_part]); - } else { + } elsif ($pack_part eq $part || $pack_type eq 'part') { + # only look at packages defaults for packages that this id is push(@specifics,[$package,$pack_type,$pack_part]); } } @@ -6374,10 +6702,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 } @@ -6387,13 +6716,18 @@ sub metadata { } } my ($extension) = ($uri =~ /\.(\w+)$/); + $extension = lc($extension); + if ($extension eq 'htm') { $extension='html'; } + foreach my $key (keys(%packagetab)) { #no specific packages #how's our extension if ($key!~/^extension_\Q$extension\E&/) { next; } &metadata_create_package_def($uri,$key,'extension_'.$extension, \%metathesekeys); } - if (!exists($metaentry{':packages'})) { + + if (!exists($metaentry{':packages'}) + || $packagetab{"import_defaults&extension_$extension"}) { foreach my $key (keys(%packagetab)) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } @@ -6512,12 +6846,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) { @@ -6889,9 +7226,8 @@ 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; } @@ -7343,6 +7679,7 @@ sub filelocation { $file=~s-^/adm/wrapper/-/-; $file=~s-^/adm/coursedocs/showdoc/-/-; } + if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; @@ -7363,6 +7700,8 @@ sub filelocation { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. $udom.'/'.$uname.'/'.$filename; } + } elsif ($file =~ m-^/adm/-) { + $location = $perlvar{'lonDocRoot'}.'/'.$file; } else { $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; $file=~s:^/res/:/:; @@ -7398,29 +7737,35 @@ sub hreflocation { } sub current_machine_domains { - my $hostname=&hostname($perlvar{'lonHostID'}); + return &machine_domains(&hostname($perlvar{'lonHostID'})); +} + +sub machine_domains { + my ($hostname) = @_; my @domains; my %hostname = &all_hostnames(); while( my($id, $name) = each(%hostname)) { # &logthis("-$id-$name-$hostname-"); if ($hostname eq $name) { - push(@domains,$hostdom{$id}); + push(@domains,&host_domain($id)); } } return @domains; } sub current_machine_ids { - my $hostname=&hostname($perlvar{'lonHostID'}); + return &machine_ids(&hostname($perlvar{'lonHostID'})); +} + +sub machine_ids { + my ($hostname) = @_; + $hostname ||= &hostname($perlvar{'lonHostID'}); my @ids; - my %hostname = &all_hostnames(); - while( my($id, $name) = each(%hostname)) { -# &logthis("-$id-$name-$hostname-"); - if ($hostname eq $name) { - push(@ids,$id); - } + my %name_to_host = &all_names(); + if (ref($name_to_host{$hostname}) eq 'ARRAY') { + return @{ $name_to_host{$hostname} }; } - return @ids; + return; } sub additional_machine_domains { @@ -7464,7 +7809,8 @@ sub declutter { sub clutter { my $thisfn='/'.&declutter(shift); - unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { + if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/} + || $thisfn =~ m{^/adm/(includes|pages)} ) { $thisfn='/res'.$thisfn; } if ($thisfn !~m|/adm|) { @@ -7533,97 +7879,201 @@ sub correct_line_ends { sub goodbye { &logthis("Starting Shut down"); #not converted to using infrastruture and probably shouldn't be - &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); + &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache)))); #converted # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); - &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); -# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); -# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); + &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache)))); +# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache)))); +# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache)))); #1.1 only -# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); -# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); -# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); -# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); - &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); +# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache)))); +# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache)))); +# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache)))); +# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache)))); + &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered)))); &logthis(sprintf("%-20s is %s",'kicks',$kicks)); &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); } -BEGIN { -# ----------------------------------- Read loncapa.conf and loncapa_apache.conf - unless ($readit) { -{ - my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); - %perlvar = (%perlvar,%{$configvars}); -} +sub get_dns { + my ($url,$func,$ignore_cache) = @_; + if (!$ignore_cache) { + my ($content,$cached)= + &Apache::lonnet::is_cached_new('dns',$url); + if ($cached) { + &$func($content); + return; + } + } + my %alldns; + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + $alldns{$1} = 1; + } + while (%alldns) { + my ($dns) = keys(%alldns); + delete($alldns{$dns}); + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"http://$dns$url"); + my $response=$ua->request($request); + next if ($response->is_error()); + my @content = split("\n",$response->content); + &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); + &$func(\@content); + return; + } + close($config); + my $which = (split('/',$url))[3]; + &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); + open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); + my @content = <$config>; + &$func(\@content); + return; +} # ------------------------------------------------------------ Read domain file { - %domaindescription = (); - %domain_auth_def = (); - %domain_auth_arg_def = (); - my $fh; - if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { - while (my $line = <$fh>) { - next if ($line =~ /^(\#|\s*$)/); -# next if /^\#/; - chomp $line; - my ($domain, $domain_description, $def_auth, $def_auth_arg, - $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9); - $domain_auth_def{$domain}=$def_auth; - $domain_auth_arg_def{$domain}=$def_auth_arg; - $domaindescription{$domain}=$domain_description; - $domain_lang_def{$domain}=$def_lang; - $domain_city{$domain}=$city; - $domain_longi{$domain}=$longi; - $domain_lati{$domain}=$lati; - $domain_primary{$domain}=$primary; + my $loaded; + my %domain; + + sub parse_domain_tab { + my ($lines) = @_; + foreach my $line (@$lines) { + next if ($line =~ /^(\#|\s*$ )/x); + + chomp($line); + my ($name,@elements) = split(/:/,$line,9); + my %this_domain; + foreach my $field ('description', 'auth_def', 'auth_arg_def', + 'lang_def', 'city', 'longi', 'lati', + 'primary') { + $this_domain{$field} = shift(@elements); + } + $domain{$name} = \%this_domain; + } + } + + sub reset_domain_info { + undef($loaded); + undef(%domain); + } - # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); -# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); + sub load_domain_tab { + my ($ignore_cache) = @_; + &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); + my $fh; + if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { + my @lines = <$fh>; + &parse_domain_tab(\@lines); } + close($fh); + $loaded = 1; + } + + sub domain { + &load_domain_tab() if (!$loaded); + + my ($name,$what) = @_; + return if ( !exists($domain{$name}) ); + + if (!$what) { + return $domain{$name}{'description'}; + } + return $domain{$name}{$what}; } - close ($fh); } # ------------------------------------------------------------- Read hosts file { my %hostname; - open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); - - while (my $configline=<$config>) { - next if ($configline =~ /^(\#|\s*$)/); - chomp($configline); - my ($id,$domain,$role,$name)=split(/:/,$configline); - $name=~s/\s//g; - if ($id && $domain && $role && $name) { - $hostname{$id}=$name; - $hostdom{$id}=$domain; - if ($role eq 'library') { $libserv{$id}=$name; } - } + my %hostdom; + my %libserv; + my $loaded; + my %name_to_host; + + sub parse_hosts_tab { + my ($file) = @_; + foreach my $configline (@$file) { + next if ($configline =~ /^(\#|\s*$ )/x); + next if ($configline =~ /^\^/); + chomp($configline); + my ($id,$domain,$role,$name)=split(/:/,$configline); + $name=~s/\s//g; + if ($id && $domain && $role && $name) { + $hostname{$id}=$name; + push(@{$name_to_host{$name}}, $id); + $hostdom{$id}=$domain; + if ($role eq 'library') { $libserv{$id}=$name; } + } + } + } + + sub reset_hosts_info { + &purge_remembered(); + &reset_domain_info(); + &reset_hosts_ip_info(); + undef(%name_to_host); + undef(%hostname); + undef(%hostdom); + undef(%libserv); + undef($loaded); + } + + sub load_hosts_tab { + my ($ignore_cache) = @_; + &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + my @config = <$config>; + &parse_hosts_tab(\@config); + close($config); + $loaded=1; } - close($config); - # FIXME: dev server don't want this, production servers _do_ want this - #&get_iphost(); sub hostname { + &load_hosts_tab() if (!$loaded); + my ($lonid) = @_; return $hostname{$lonid}; } + sub all_hostnames { + &load_hosts_tab() if (!$loaded); + return %hostname; } + + sub all_names { + &load_hosts_tab() if (!$loaded); + + return %name_to_host; + } + + sub is_library { + &load_hosts_tab() if (!$loaded); + + return exists($libserv{$_[0]}); + } + + sub all_library { + &load_hosts_tab() if (!$loaded); + + return %libserv; + } + sub get_servers { + &load_hosts_tab() if (!$loaded); + my ($domain,$type) = @_; my %possible_hosts = ($type eq 'library') ? %libserv : %hostname; my %result; if (ref($domain) eq 'ARRAY') { while ( my ($host,$hostname) = each(%possible_hosts)) { - if (grep(/\Q$hostdom{$host}\E/,@$domain)) { + if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) { $result{$host} = $hostname; } } @@ -7636,45 +8086,125 @@ BEGIN { } return %result; } + + sub host_domain { + &load_hosts_tab() if (!$loaded); + + my ($lonid) = @_; + return $hostdom{$lonid}; + } + sub all_domains { + &load_hosts_tab() if (!$loaded); + my %seen; my @uniq = grep(!$seen{$_}++, values(%hostdom)); return @uniq; } } -sub get_hosts_from_ip { - my ($ip) = @_; - my %iphosts = &get_iphost(); - if (ref($iphosts{$ip})) { - return @{$iphosts{$ip}}; +{ + my %iphost; + my %name_to_ip; + my %lonid_to_ip; + + sub get_hosts_from_ip { + my ($ip) = @_; + my %iphosts = &get_iphost(); + if (ref($iphosts{$ip})) { + return @{$iphosts{$ip}}; + } + return; + } + + sub reset_hosts_ip_info { + undef(%iphost); + undef(%name_to_ip); + undef(%lonid_to_ip); } - return; -} -sub get_iphost { - if (%iphost) { return %iphost; } - my %name_to_ip; - my %hostname = &all_hostnames(); - foreach my $id (keys(%hostname)) { - my $name=$hostname{$id}; - my $ip; - if (!exists($name_to_ip{$name})) { - $ip = gethostbyname($name); - if (!$ip || length($ip) ne 4) { - &logthis("Skipping host $id name $name no IP found"); - next; + sub get_host_ip { + my ($lonid) = @_; + if (exists($lonid_to_ip{$lonid})) { + return $lonid_to_ip{$lonid}; + } + my $name=&hostname($lonid); + my $ip = gethostbyname($name); + return if (!$ip || length($ip) ne 4); + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + $lonid_to_ip{$lonid} = $ip; + return $ip; + } + + sub get_iphost { + my ($ignore_cache) = @_; + + if (!$ignore_cache) { + if (%iphost) { + return %iphost; + } + my ($ip_info,$cached)= + &Apache::lonnet::is_cached_new('iphost','iphost'); + if ($cached) { + %iphost = %{$ip_info->[0]}; + %name_to_ip = %{$ip_info->[1]}; + %lonid_to_ip = %{$ip_info->[2]}; + return %iphost; } - $ip=inet_ntoa($ip); - $name_to_ip{$name} = $ip; - } else { - $ip = $name_to_ip{$name}; } - push(@{$iphost{$ip}},$id); + + # get yesterday's info for fallback + my %old_name_to_ip; + my ($ip_info,$cached)= + &Apache::lonnet::is_cached_new('iphost','iphost'); + if ($cached) { + %old_name_to_ip = %{$ip_info->[1]}; + } + + my %name_to_host = &all_names(); + foreach my $name (keys(%name_to_host)) { + my $ip; + if (!exists($name_to_ip{$name})) { + $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + if (defined($old_name_to_ip{$name})) { + $ip = $old_name_to_ip{$name}; + &logthis("Can't find $name defaulting to old $ip"); + } else { + &logthis("Name $name no IP found"); + next; + } + } else { + $ip=inet_ntoa($ip); + } + $name_to_ip{$name} = $ip; + } else { + $ip = $name_to_ip{$name}; + } + foreach my $id (@{ $name_to_host{$name} }) { + $lonid_to_ip{$id} = $ip; + } + push(@{$iphost{$ip}},@{$name_to_host{$name}}); + } + &Apache::lonnet::do_cache_new('iphost','iphost', + [\%iphost,\%name_to_ip,\%lonid_to_ip], + 48*60*60); + + return %iphost; } - return %iphost; } +BEGIN { + +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf + unless ($readit) { +{ + my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar = (%perlvar,%{$configvars}); +} + + # ------------------------------------------------------ Read spare server file { open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); @@ -8006,6 +8536,16 @@ X B: gets the values of the keys passed in @what from the requested user's environment, returns a hash +=item * +X +B: retrieves data from a user's +activity.log file. %filters defines filters applied when parsing the +log file. These can be start or end timestamps, or the type of action +- log to look for Login or Logout events, check for Checkin or +Checkout, role for role selection. The response is in the form +timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are +escaped strings of the action recorded in the activity.log file. + =back =head2 User Roles @@ -8035,16 +8575,18 @@ explanation of a user role term =item * -get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are -optional. Returns a hash of a user's roles, with keys set to -colon-sparated $uname,$udom,and $role, and value set to -colon-separated start and end times for the role. If no username and -domain are specified, will default to current user/domain. Types, -roles, and roledoms are references to arrays, of role statuses -(active, future or previous), roles (e.g., cc,in, st etc.) and domains -of the roles which can be used to restrict the list if roles -reported. If no array ref is provided for types, will default to -return only active roles. +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 '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 +user/domain. Types, roles, and roledoms are references to arrays, +of role statuses (active, future or previous), roles +(e.g., cc,in, st etc.) and domains of the roles which can be used +to restrict the list of roles reported. If no array ref is +provided for types, will default to return only active roles. =back @@ -8188,6 +8730,14 @@ setting for a specific $type, where $typ @what should be a list of parameters to ask about. This routine caches answers for 5 minutes. +=item * + +get_courseresdata($courseid, $domain) : dump the entire course resource +data base, returning a hash that is keyed by the resource name and has +values that are the resource value. I believe that the timestamps and +versions are also returned. + + =back =head2 Course Modification @@ -8469,12 +9019,15 @@ critical subroutine =item * -get_dom($namespace,$storearr,$udomain) : returns hash with keys from array -reference filled in from namespace found in domain level on primary domain server ($udomain is optional) +get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from +array reference filled in from namespace found in domain level on either +specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). =item * -put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) +put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at +domain level either on specified domain server ($uhome) or primary domain +server ($udom and $uhome are optional) =back @@ -8867,3 +9420,4 @@ symblist($mapname,%newhash) : update sym =back =cut +