--- loncom/lonnet/perl/lonnet.pm 2007/04/05 22:04:49 1.866
+++ loncom/lonnet/perl/lonnet.pm 2007/05/11 01:48:19 1.873
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.866 2007/04/05 22:04:49 raeburn Exp $
+# $Id: lonnet.pm,v 1.873 2007/05/11 01:48:19 raeburn 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);
@@ -830,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 {
@@ -1056,7 +1065,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);
}
@@ -1103,7 +1115,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;
@@ -2137,7 +2151,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)) {
@@ -2155,7 +2174,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;
@@ -2165,7 +2190,7 @@ sub get_my_roles {
if (!grep(/^\Q$role\E$/,@{$roles})) {
next;
}
- }
+ }
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}
return %returnhash;
@@ -4461,15 +4486,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);
}
@@ -5274,7 +5311,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");
}
@@ -7642,18 +7679,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();
@@ -7661,19 +7698,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
{
@@ -7703,7 +7762,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>;
@@ -7760,7 +7820,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);
@@ -7836,6 +7897,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();
@@ -7866,7 +7946,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);
@@ -7885,6 +7978,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;
}
}