--- loncom/lonnet/perl/lonnet.pm 2007/04/04 00:05:31 1.861 +++ loncom/lonnet/perl/lonnet.pm 2007/04/20 21:48:09 1.871 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.861 2007/04/04 00:05:31 albertel Exp $ +# $Id: lonnet.pm,v 1.871 2007/04/20 21:48:09 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,22 +31,21 @@ package Apache::lonnet; use strict; use LWP::UserAgent(); -use HTTP::Headers; use HTTP::Date; # use Date::Parse; -use vars -qw(%perlvar %badServerCache %spareid - %pr %prp $memcache %packagetab - %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf - $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; @@ -182,7 +181,7 @@ 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); @@ -671,61 +670,6 @@ sub homeserver { return 'no_host'; } -# ---------------------- Get domain configuration for a domain -sub get_domainconf { - my ($udom) = @_; - my $cachetime=1800; - my ($result,$cached)=&is_cached_new('domainconfig',$udom); - if (defined($cached)) { return %{$result}; } - - if ($udom eq '') { - $udom = &Apache::loncommon::determinedomain(); - } - my %domconfig = &get_dom('configuration',['login','rolecolors'],$udom); - my %designhash; - if (keys(%domconfig) > 0) { - if (ref($domconfig{'login'}) eq 'HASH') { - foreach my $key (keys(%{$domconfig{'login'}})) { - $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key}; - } - } - if (ref($domconfig{'rolecolors'}) eq 'HASH') { - foreach my $role (keys(%{$domconfig{'rolecolors'}})) { - if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') { - foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) { - $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item}; - } - } - } - } - } else { - my $designdir=$perlvar{'lonTabDir'}.'/lonDomColors'; - my $designfile = $designdir.'/'.$udom.'.tab'; - if (-e $designfile) { - if ( open (my $fh,"<$designfile") ) { - while (my $line = <$fh>) { - next if ($line =~ /^\#/); - chomp($line); - my ($key,$val)=(split(/\=/,$line)); - if ($val) { $designhash{$udom.'.'.$key}=$val; } - } - close($fh); - } - } - if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') { - $designhash{$udom.'.login.domlogo'} = - &lonhttpdurl("/adm/lonDomLogos/$udom.gif"); - } - } - &do_cache_new('domainconfig',$udom,\%designhash,$cachetime); - return %designhash; -} - -sub devalidate_domconfig_cache { - my ($udom)=@_; - &devalidate_cache_new('domainconfig',$udom); -} - # ------------------------------------- Find the usernames behind a list of IDs sub idget { @@ -811,6 +755,10 @@ sub get_dom { } if ($udom && $uhome && ($uhome ne 'no_host')) { my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + my %returnhash; + if ($rep =~ /^error: 2 /) { + return %returnhash; + } my @pairs=split(/\&/,$rep); if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { return @pairs; @@ -881,6 +829,16 @@ 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; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -2188,7 +2146,12 @@ sub get_my_roles { 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)) { @@ -2206,7 +2169,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; @@ -2216,7 +2185,7 @@ sub get_my_roles { if (!grep(/^\Q$role\E$/,@{$roles})) { next; } - } + } $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; } return %returnhash; @@ -3641,9 +3610,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; @@ -5318,7 +5294,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"); } @@ -7686,47 +7662,60 @@ 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) = @_; + 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); - $dns = $1; + $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 { @@ -7749,9 +7738,15 @@ sub get_dns { $domain{$name} = \%this_domain; } } - + + sub reset_domain_info { + undef($loaded); + undef(%domain); + } + sub load_domain_tab { - &get_dns('/adm/dns/domain',\&parse_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>; @@ -7797,9 +7792,19 @@ sub get_dns { } } } + + sub reset_hosts_info { + &reset_domain_info(); + &reset_hosts_ip_info(); + undef(%hostname); + undef(%hostdom); + undef(%libserv); + undef($loaded); + } sub load_hosts_tab { - &get_dns('/adm/dns/hosts',\&parse_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); @@ -7807,9 +7812,6 @@ sub get_dns { $loaded=1; } - # FIXME: dev server don't want this, production servers _do_ want this - #&get_iphost(); - sub hostname { &load_hosts_tab() if (!$loaded); @@ -7878,6 +7880,25 @@ sub get_dns { my %iphost; my %name_to_ip; my %lonid_to_ip; + + my %valid_ip; + sub valid_ip { + my ($ip) = @_; + if (exists($iphost{$ip}) || exists($valid_ip{$ip})) { + return 1; + } + my $name = gethostbyip($ip); + my $lonid = &hostname($name); + if (defined($lonid)) { + $valid_ip{$ip} = $lonid; + return 1; + } + my %iphosts = &get_iphost(); + if (ref($iphost{$ip})) { + return 1; + } + } + sub get_hosts_from_ip { my ($ip) = @_; my %iphosts = &get_iphost(); @@ -7886,6 +7907,12 @@ sub get_dns { } return; } + + sub reset_hosts_ip_info { + undef(%iphost); + undef(%name_to_ip); + undef(%lonid_to_ip); + } sub get_host_ip { my ($lonid) = @_; @@ -7902,10 +7929,23 @@ sub get_dns { } sub get_iphost { - if (%iphost) { return %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; + } + } my %hostname = &all_hostnames(); foreach my $id (keys(%hostname)) { - my $name=$hostname{$id}; + my $name=&hostname($id); my $ip; if (!exists($name_to_ip{$name})) { $ip = gethostbyname($name); @@ -7921,10 +7961,24 @@ sub get_dns { $lonid_to_ip{$id} = $ip; push(@{$iphost{$ip}},$id); } + &Apache::lonnet::do_cache_new('iphost','iphost', + [\%iphost,\%name_to_ip,\%lonid_to_ip], + 24*60*60); + 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");