--- loncom/lonnet/perl/lonnet.pm 2007/04/11 22:52:03 1.869 +++ loncom/lonnet/perl/lonnet.pm 2007/06/25 18:12:24 1.894 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.869 2007/04/11 22:52:03 albertel Exp $ +# $Id: lonnet.pm,v 1.894 2007/06/25 18:12:24 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; @@ -150,7 +149,7 @@ sub create_connection { Type => SOCK_STREAM, Timeout => 10); return 0 if (!$client); - print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); my $result = <$client>; chomp($result); return 1 if ($result eq 'done'); @@ -215,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")) { @@ -745,7 +762,7 @@ sub get_dom { if (defined(&domain($udom,'primary'))) { $uhome=&domain($udom,'primary'); } else { - $uhome eq ''; + undef($uhome); } } else { if (!$uhome) { @@ -757,14 +774,13 @@ sub get_dom { if ($udom && $uhome && ($uhome ne 'no_host')) { my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); my %returnhash; - if ($rep =~ /^error: 2 /) { + 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]); @@ -772,7 +788,7 @@ sub get_dom { } return %returnhash; } else { - &logthis("get_dom failed - no homeserver and/or domain"); + &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)"); } } @@ -785,7 +801,7 @@ sub put_dom { if (defined(&domain($udom,'primary'))) { $uhome=&domain($udom,'primary'); } else { - $uhome eq ''; + undef($uhome); } } else { if (!$uhome) { @@ -1066,7 +1082,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); } @@ -1113,7 +1132,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; @@ -1736,13 +1757,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'); @@ -3130,7 +3154,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; @@ -3780,26 +3804,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,$tcrs)=split(/\_/,$scope); + if ($tdom) { + if ($tdom ne $env{'user.domain'}) { next; } + } + if ($tcrs) { + if ($tcrs 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; @@ -4451,8 +4489,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; } @@ -4482,15 +4530,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); } @@ -5295,7 +5355,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"); } @@ -5887,6 +5947,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)=@_; @@ -5945,7 +6012,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; @@ -6292,7 +6373,7 @@ sub packages_tab_default { $do_default=1; } elsif ($pack_type eq 'extension') { push(@extension,[$package,$pack_type,$pack_part]); - } elsif ($pack_part eq $part) { + } 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]); } @@ -6509,13 +6590,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; } @@ -7464,6 +7550,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:; @@ -7484,6 +7571,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/:/:; @@ -7543,14 +7632,11 @@ 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 { @@ -7594,7 +7680,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|) { @@ -7663,18 +7750,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(); @@ -7711,8 +7798,9 @@ sub get_dns { return; } close($config); - &logthis("unable to contact DNS defaulting to on disk file\n"); - open($config,"<$perlvar{'lonTabDir'}/dns_hosts.tab"); + 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; @@ -7776,6 +7864,7 @@ sub get_dns { my %hostdom; my %libserv; my $loaded; + my %name_to_host; sub parse_hosts_tab { my ($file) = @_; @@ -7787,6 +7876,7 @@ sub get_dns { $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; } } @@ -7796,6 +7886,7 @@ sub get_dns { sub reset_hosts_info { &reset_domain_info(); &reset_hosts_ip_info(); + undef(%name_to_host); undef(%hostname); undef(%hostdom); undef(%libserv); @@ -7825,6 +7916,12 @@ sub get_dns { return %hostname; } + sub all_names { + &load_hosts_tab() if (!$loaded); + + return %name_to_host; + } + sub is_library { &load_hosts_tab() if (!$loaded); @@ -7881,24 +7978,6 @@ sub get_dns { 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(); @@ -7930,6 +8009,7 @@ sub get_dns { sub get_iphost { my ($ignore_cache) = @_; + if (!$ignore_cache) { if (%iphost) { return %iphost; @@ -7943,27 +8023,43 @@ sub get_dns { return %iphost; } } - my %hostname = &all_hostnames(); - foreach my $id (keys(%hostname)) { - my $name=&hostname($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) { - &logthis("Skipping host $id name $name no IP found"); - next; + 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); } - $ip=inet_ntoa($ip); $name_to_ip{$name} = $ip; } else { $ip = $name_to_ip{$name}; } - $lonid_to_ip{$id} = $ip; - push(@{$iphost{$ip}},$id); + 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], - 24*60*60); + 48*60*60); return %iphost; } @@ -8504,6 +8600,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 @@ -9186,3 +9290,4 @@ symblist($mapname,%newhash) : update sym =back =cut +