--- loncom/lonnet/perl/lonnet.pm 2007/04/04 18:01:11 1.865 +++ loncom/lonnet/perl/lonnet.pm 2007/05/17 09:31:13 1.879 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.865 2007/04/04 18:01:11 raeburn Exp $ +# $Id: lonnet.pm,v 1.879 2007/05/17 09:31:13 foxr 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); @@ -745,7 +744,7 @@ sub get_dom { if (defined(&domain($udom,'primary'))) { $uhome=&domain($udom,'primary'); } else { - $uhome eq ''; + undef($uhome); } } else { if (!$uhome) { @@ -756,11 +755,14 @@ sub get_dom { } 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]); @@ -781,7 +783,7 @@ sub put_dom { if (defined(&domain($udom,'primary'))) { $uhome=&domain($udom,'primary'); } else { - $uhome eq ''; + undef($uhome); } } else { if (!$uhome) { @@ -826,6 +828,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 { @@ -1052,7 +1064,10 @@ my $kicks=0; my $hits=0; sub make_key { my ($name,$id) = @_; - if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); } + if (length($id) > 65 + && length(&escape($id)) > 200) { + $id=length($id).':'.&Digest::MD5::md5_hex($id); + } return &escape($name.':'.$id); } @@ -1099,7 +1114,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; @@ -2133,7 +2150,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)) { @@ -2151,7 +2173,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; @@ -2161,7 +2189,7 @@ sub get_my_roles { if (!grep(/^\Q$role\E$/,@{$roles})) { next; } - } + } $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; } return %returnhash; @@ -4426,8 +4454,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; } @@ -4457,15 +4495,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); } @@ -5270,7 +5320,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"); } @@ -5862,6 +5912,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)=@_; @@ -5920,7 +5977,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; @@ -7638,18 +7709,18 @@ 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(); @@ -7657,19 +7728,41 @@ sub goodbye { } 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 { @@ -7699,7 +7792,8 @@ sub get_dns { } 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>; @@ -7756,7 +7850,8 @@ sub get_dns { } 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); @@ -7832,6 +7927,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(); @@ -7862,7 +7976,20 @@ 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); @@ -7881,6 +8008,10 @@ 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; } } @@ -8420,6 +8551,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 @@ -9102,3 +9241,4 @@ symblist($mapname,%newhash) : update sym =back =cut +