) {
+ chomp($host);
+ $host =~ s/(^\s+|\s+$)//g;
+ if ($host =~ /^\Q^$lonhost\E/) {
+ $is_dns_server = 1;
+ last;
+ }
+ }
+ close(HOSTS);
+ }
+ return $is_dns_server;
+}
+
#
# Called to re-init either lonc or lond.
#
@@ -1121,6 +1164,8 @@ sub establish_key_handler {
sub load_handler {
my ($cmd, $tail, $replyfd) = @_;
+
+
# Get the load average from /proc/loadavg and calculate it as a percentage of
# the allowed load limit as set by the perl global variable lonLoadLim
@@ -1666,6 +1711,15 @@ sub server_homeID_handler {
}
®ister_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);
+sub server_distarch_handler {
+ my ($cmd,$tail,$client) = @_;
+ my $userinput = "$cmd:$tail";
+ my $reply = &distro_and_arch();
+ &Reply($client,\$reply,$userinput);
+ return 1;
+}
+®ister_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0);
+
# Process a reinit request. Reinit requests that either
# lonc or lond be reinitialized so that an updated
# host.tab or domain.tab can be processed.
@@ -1789,7 +1843,11 @@ sub authenticate_handler {
unless ($clientcancheckhost) {
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
- my @intdoms = &Apache::lonnet::get_internet_names($clientname);
+ my @intdoms;
+ my $internet_names = &Apache::lonnet::get_internet_names($clientname);
+ if (ref($internet_names) eq 'ARRAY') {
+ @intdoms = @{$internet_names};
+ }
unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
my ($remote,$hosted);
my $remotesession = &get_usersession_config($udom,'remotesession');
@@ -2151,7 +2209,10 @@ sub update_resource_handler {
my $transname="$fname.in.transfer";
my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
my $response;
- alarm(120);
+# FIXME: cannot replicate files that take more than two minutes to transfer?
+# alarm(120);
+# FIXME: this should use the LWP mechanism, not internal alarms.
+ alarm(1200);
{
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"$remoteurl");
@@ -2159,11 +2220,13 @@ sub update_resource_handler {
}
alarm(0);
if ($response->is_error()) {
+# FIXME: we should probably clean up here instead of just whine
unlink($transname);
my $message=$response->status_line;
&logthis("LWP GET: $message for $fname ($remoteurl)");
} else {
if ($remoteurl!~/\.meta$/) {
+# FIXME: isn't there an internal LWP mechanism for this?
alarm(120);
{
my $ua=new LWP::UserAgent;
@@ -2413,7 +2476,6 @@ sub user_has_session_handler {
my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
- &logthis("Looking for $udom $uname");
opendir(DIR,$perlvar{'lonIDsDir'});
my $filename;
while ($filename=readdir(DIR)) {
@@ -3162,48 +3224,37 @@ sub dump_with_regexp {
}
my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());
- my $clientcheckrole;
+ my $skipcheck;
if ($hashref) {
my $qresult='';
my $count=0;
if ($extra ne '') {
$extra = &Apache::lonnet::thaw_unescape($extra);
- $clientcheckrole = $extra->{'clientcheckrole'};
+ $skipcheck = $extra->{'skipcheck'};
}
my @ids = &Apache::lonnet::current_machine_ids();
+ my (%homecourses,$major,$minor,$now);
+ if (($namespace eq 'roles') && (!$skipcheck)) {
+ my $loncaparev = $clientversion;
+ if ($loncaparev eq '') {
+ $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
+ }
+ if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
+ $major = $1;
+ $minor = $2;
+ }
+ $now = time;
+ }
while (my ($key,$value) = each(%$hashref)) {
if ($namespace eq 'roles') {
- if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)_(cc|co|in|ta|ep|ad|st|cr)}) {
+ if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
my $cdom = $1;
my $cnum = $2;
- unless ($clientcheckrole) {
- my $home = &Apache::lonnet::homeserver($cnum,$cdom);
- my $loncaparev = $clientversion;
- if ($loncaparev eq '') {
- $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
- }
- my ($major,$minor);
- if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\d.\-]+\'?/) {
- $major = $1;
- $minor = $2;
- }
- if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_community)_(co|in|ta|ep|ad|st|cr)}) {
- if ($major eq '' && $minor eq '') {
- next unless (($home ne 'no_host') && grep(/^\Q$home\E$/,@ids));
- }
- }
- unless ($home eq 'no_host') {
- my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
- if (ref($courseinfo) eq 'HASH') {
- if (exists($courseinfo->{'releaserequired'})) {
- my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
- if ($reqdmajor ne '' && $reqdminor ne '') {
- next if (($major eq '' && $minor eq '') ||
- ($major < $reqdmajor) ||
- (($major == $reqdmajor) && ($minor < $reqdminor)));
- }
- }
- }
+ unless ($skipcheck) {
+ my ($role,$end,$start) = split(/\_/,$value);
+ if (!$end || $end > $now) {
+ next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
+ $minor,\%homecourses,\@ids));
}
}
}
@@ -3224,6 +3275,12 @@ sub dump_with_regexp {
}
}
if (&untie_user_hash($hashref)) {
+ if (($namespace eq 'roles') && (!$skipcheck)) {
+ if (keys(%homecourses) > 0) {
+ $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
+ $range,$start,$end,$major,$minor);
+ }
+ }
chop($qresult);
&Reply($client, \$qresult, $userinput);
} else {
@@ -4274,6 +4331,7 @@ sub put_domain_handler {
sub get_domain_handler {
my ($cmd, $tail, $client) = @_;
+
my $userinput = "$client:$tail";
my ($udom,$namespace,$what)=split(/:/,$tail,3);
@@ -4418,7 +4476,8 @@ sub get_id_handler {
sub put_dcmail_handler {
my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";
-
+
+
my ($udom,$what)=split(/:/,$tail);
chomp($what);
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
@@ -4682,7 +4741,7 @@ sub tmp_put_handler {
}
my ($id,$store);
$tmpsnum++;
- if ($context eq 'resetpw') {
+ if (($context eq 'resetpw') || ($context eq 'createaccount')) {
$id = &md5_hex(&md5_hex(time.{}.rand().$$));
} else {
$id = $$.'_'.$clientip.'_'.$tmpsnum;
@@ -5000,10 +5059,11 @@ sub get_sections_handler {
sub validate_course_owner_handler {
my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";
- my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
-
+ my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);
+
$owner = &unescape($owner);
- my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
+ $coowners = &unescape($coowners);
+ my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
&Reply($client, \$outcome, $userinput);
@@ -5991,7 +6051,7 @@ if (-e $pidfile) {
$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
Type => SOCK_STREAM,
Proto => 'tcp',
- Reuse => 1,
+ ReuseAddr => 1,
Listen => 10 )
or die "making socket: $@\n";
@@ -6229,7 +6289,7 @@ sub logstatus {
sub initnewstatus {
my $docdir=$perlvar{'lonDocRoot'};
my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
- my $now=time;
+ my $now=time();
my $local=localtime($now);
print $fh "LOND status $local - parent $$\n\n";
opendir(DIR,"$docdir/lon-status/londchld");
@@ -6322,6 +6382,11 @@ my %iphost = &Apache::lonnet::get_iphost
my $dist=`$perlvar{'lonDaemons'}/distprobe`;
+my $arch = `uname -i`;
+if ($arch eq 'unknown') {
+ $arch = `uname -m`;
+}
+
# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated
# and if good, a child process is created to process transactions
@@ -6379,6 +6444,7 @@ sub make_new_child {
or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;
&status('Started child '.$pid);
+ close($client);
return;
} else {
# Child can *not* return from this subroutine.
@@ -6387,6 +6453,13 @@ sub make_new_child {
#don't get intercepted
$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;
+ #
+ # Block sigpipe as it gets thrownon socket disconnect and we want to
+ # deal with that as a read faiure instead.
+ #
+ my $blockset = POSIX::SigSet->new(SIGPIPE);
+ sigprocmask(SIG_BLOCK, $blockset);
+
$lastlog='Forked ';
$status='Forked';
@@ -7298,21 +7371,172 @@ sub get_usersession_config {
return;
}
-sub get_courseinfo_hash {
- my ($cnum,$cdom,$home) = @_;
+sub releasereqd_check {
+ my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
+ my $home = &Apache::lonnet::homeserver($cnum,$cdom);
+ return if ($home eq 'no_host');
+ my ($reqdmajor,$reqdminor,$displayrole);
+ if ($cnum =~ /$LONCAPA::match_community/) {
+ if ($major eq '' && $minor eq '') {
+ return unless ((ref($ids) eq 'ARRAY') &&
+ (grep(/^\Q$home\E$/,@{$ids})));
+ } else {
+ $reqdmajor = 2;
+ $reqdminor = 9;
+ return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+ }
+ }
my $hashid = $cdom.':'.$cnum;
- my ($courseinfo,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
+ my ($courseinfo,$cached) =
+ &Apache::lonnet::is_cached_new('courseinfo',$hashid);
if (defined($cached)) {
- return $courseinfo;
+ if (ref($courseinfo) eq 'HASH') {
+ if (exists($courseinfo->{'releaserequired'})) {
+ my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
+ return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+ }
+ }
+ } else {
+ if (ref($ids) eq 'ARRAY') {
+ if (grep(/^\Q$home\E$/,@{$ids})) {
+ if (ref($homecourses) eq 'HASH') {
+ if (ref($homecourses->{$hashid}) eq 'ARRAY') {
+ push(@{$homecourses->{$hashid}},{$key=>$value});
+ } else {
+ $homecourses->{$hashid} = [{$key=>$value}];
+ }
+ }
+ return;
+ }
+ }
+ my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
+ if (ref($courseinfo) eq 'HASH') {
+ if (exists($courseinfo->{'releaserequired'})) {
+ my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
+ return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+ }
+ } else {
+ return;
+ }
+ }
+ return 1;
+}
+
+sub get_courseinfo_hash {
+ my ($cnum,$cdom,$home) = @_;
+ my %info;
+ eval {
+ local($SIG{ALRM}) = sub { die "timeout\n"; };
+ local($SIG{__DIE__})='DEFAULT';
+ alarm(3);
+ %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
+ alarm(0);
+ };
+ if ($@) {
+ if ($@ eq "timeout\n") {
+ &logthis("WARNING courseiddump for $cnum:$cdom from $home timedout");
+ } else {
+ &logthis("WARNING unexpected error during eval of call for courseiddump from $home");
+ }
} else {
- my %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
+ my $hashid = $cdom.':'.$cnum;
return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
}
}
return;
}
+sub check_homecourses {
+ my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
+ my ($result,%addtocache);
+ my $yesterday = time - 24*3600;
+ if (ref($homecourses) eq 'HASH') {
+ my (%okcourses,%courseinfo,%recent);
+ my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
+ if ($hashref) {
+ while (my ($key,$value) = each(%$hashref)) {
+ my $unesc_key = &unescape($key);
+ if ($unesc_key =~ /^lasttime:(\w+)$/) {
+ my $cid = $1;
+ $cid =~ s/_/:/;
+ if ($value > $yesterday ) {
+ $recent{$cid} = 1;
+ }
+ next;
+ }
+ my $items = &Apache::lonnet::thaw_unescape($value);
+ if (ref($items) eq 'HASH') {
+ my $hashid = $unesc_key;
+ $hashid =~ s/_/:/;
+ $courseinfo{$hashid} = $items;
+ if (ref($homecourses->{$hashid}) eq 'ARRAY') {
+ my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
+ if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
+ $okcourses{$hashid} = 1;
+ }
+ }
+ }
+ }
+ unless (&untie_domain_hash($hashref)) {
+ &logthis('Failed to untie tied hash for nohist_courseids.db');
+ }
+ } else {
+ &logthis('Failed to tie hash for nohist_courseids.db');
+ return;
+ }
+ foreach my $hashid (keys(%recent)) {
+ my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
+ unless ($cached) {
+ &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
+ }
+ }
+ foreach my $hashid (keys(%{$homecourses})) {
+ next if ($recent{$hashid});
+ &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
+ }
+ foreach my $hashid (keys(%okcourses)) {
+ if (ref($homecourses->{$hashid}) eq 'ARRAY') {
+ foreach my $role (@{$homecourses->{$hashid}}) {
+ if (ref($role) eq 'HASH') {
+ while (my ($key,$value) = each(%{$role})) {
+ if ($regexp eq '.') {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
+ $result.=$key.'='.$value.'&';
+ } else {
+ my $unescapeKey = &unescape($key);
+ if (eval('$unescapeKey=~/$regexp/')) {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
+ $result.="$key=$value&";
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return $result;
+}
+
+sub useable_role {
+ my ($reqdmajor,$reqdminor,$major,$minor) = @_;
+ if ($reqdmajor ne '' && $reqdminor ne '') {
+ return if (($major eq '' && $minor eq '') ||
+ ($major < $reqdmajor) ||
+ (($major == $reqdmajor) && ($minor < $reqdminor)));
+ }
+ return 1;
+}
+
+sub distro_and_arch {
+ return $dist.':'.$arch;
+}
+
# ----------------------------------- POD (plain old documentation, CPAN style)
=head1 NAME
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.