--- loncom/lond 2009/11/12 15:59:00 1.433
+++ loncom/lond 2011/06/11 21:10:03 1.475
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.433 2009/11/12 15:59:00 raeburn Exp $
+# $Id: lond,v 1.475 2011/06/11 21:10:03 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -15,6 +15,7 @@
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
+
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
@@ -42,7 +43,6 @@ use Crypt::IDEA;
use LWP::UserAgent();
use Digest::MD5 qw(md5_hex);
use GDBM_File;
-use Authen::Krb4;
use Authen::Krb5;
use localauth;
use localenroll;
@@ -53,13 +53,14 @@ use LONCAPA::lonlocal;
use LONCAPA::lonssl;
use Fcntl qw(:flock);
use Apache::lonnet;
+use Mail::Send;
my $DEBUG = 0; # Non zero to enable debug log entries.
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.433 $'; #' stupid emacs
+my $VERSION='$Revision: 1.475 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -67,7 +68,9 @@ my $currentdomainid;
my $client;
my $clientip; # IP address of client.
my $clientname; # LonCAPA name of client.
-my $clientversion; # LonCAPA version running on client
+my $clientversion; # LonCAPA version running on client.
+my $clienthomedom; # LonCAPA domain of homeID for client.
+ # primary library server.
my $server;
@@ -418,8 +421,11 @@ sub ReadManagerTable {
my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
if (!open (MANAGERS, $tablename)) {
- logthis('No manager table. Nobody can manage!!');
- return;
+ my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
+ if (&Apache::lonnet::is_LC_dns($hostname)) {
+ &logthis('No manager table. Nobody can manage!!');
+ }
+ return;
}
while(my $host = ) {
chomp($host);
@@ -444,7 +450,7 @@ sub ReadManagerTable {
}
} else {
logthis(' existing host'." $host\n");
- $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber
+ $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber
}
}
}
@@ -506,7 +512,8 @@ sub AdjustHostContents {
my $me = $perlvar{'lonHostID'};
foreach my $line (split(/\n/,$contents)) {
- if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
+ if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) ||
+ ($line =~ /^\s*\^/))) {
chomp($line);
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
if ($id eq $me) {
@@ -594,11 +601,8 @@ sub InstallFile {
#
# ConfigFileFromSelector: converts a configuration file selector
# into a configuration file pathname.
-# It's probably no longer necessary to preserve
-# special handling of hosts or domain as those
-# files have been superceded by dns_hosts, dns_domain.
-# The default action is just to prepend the directory
-# and append .tab
+# Supports the following file selectors:
+# hosts, domain, dns_hosts, dns_domain
#
#
# Parameters:
@@ -611,15 +615,11 @@ sub ConfigFileFromSelector {
my $tablefile;
my $tabledir = $perlvar{'lonTabDir'}.'/';
- if ($selector eq "hosts") {
- $tablefile = $tabledir."hosts.tab";
- } elsif ($selector eq "domain") {
- $tablefile = $tabledir."domain.tab";
- } else {
+ if (($selector eq "hosts") || ($selector eq "domain") ||
+ ($selector eq "dns_hosts") || ($selector eq "dns_domain")) {
$tablefile = $tabledir.$selector.'.tab';
}
return $tablefile;
-
}
#
# PushFile: Called to do an administrative push of a file.
@@ -645,6 +645,8 @@ sub PushFile {
# supported:
# hosts.tab ($filename eq host).
# domain.tab ($filename eq domain).
+ # dns_hosts.tab ($filename eq dns_host).
+ # dns_domain.tab ($filename eq dns_domain).
# Construct the destination filename or reject the request.
#
# lonManage is supposed to ensure this, however this session could be
@@ -676,11 +678,31 @@ sub PushFile {
return "error:$!";
} else {
&logthis(' Installed new '.$tablefile
- ."");
-
+ ." - transaction by: $clientname ($clientip)");
+ my $adminmail = $perlvar{'lonAdmEMail'};
+ my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
+ if ($admindom ne '') {
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
+ if (ref($domconfig{'contacts'}) eq 'HASH') {
+ if ($domconfig{'contacts'}{'adminemail'} ne '') {
+ $adminmail = $domconfig{'contacts'}{'adminemail'};
+ }
+ }
+ }
+ if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
+ my $msg = new Mail::Send;
+ $msg->to($adminmail);
+ $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
+ $msg->add('Content-type','text/plain; charset=UTF-8');
+ if (my $fh = $msg->open()) {
+ print $fh 'Update to '.$tablefile.' from Cluster Manager '.
+ "$clientname ($clientip)\n";
+ $fh->close;
+ }
+ }
}
-
# Indicate success:
return "ok";
@@ -976,6 +998,9 @@ sub read_profile {
&GDBM_READER());
if ($hashref) {
my @queries=split(/\&/,$what);
+ if ($namespace eq 'roles') {
+ @queries = map { &unescape($_); } @queries;
+ }
my $qresult='';
for (my $i=0;$i<=$#queries;$i++) {
@@ -1069,7 +1094,7 @@ sub pong_handler {
# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host
# known as.
-# $clientname - Global variable that carries the name of the hsot we're connected to.
+# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:
# 1 - Ok to continue processing.
# 0 - Program should exit.
@@ -1108,7 +1133,7 @@ sub establish_key_handler {
# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host
# known as.
-# $clientname - Global variable that carries the name of the hsot we're connected to.
+# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:
# 1 - Ok to continue processing.
# 0 - Program should exit.
@@ -1117,6 +1142,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
@@ -1145,7 +1172,7 @@ sub load_handler {
# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host
# known as.
-# $clientname - Global variable that carries the name of the hsot we're connected to.
+# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:
# 1 - Ok to continue processing.
# 0 - Program should exit
@@ -1654,6 +1681,23 @@ sub server_loncaparev_handler {
}
®ister_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);
+sub server_homeID_handler {
+ my ($cmd,$tail,$client) = @_;
+ my $userinput = "$cmd:$tail";
+ &Reply($client,\$perlvar{'lonHostID'},$userinput);
+ return 1;
+}
+®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.
@@ -1763,15 +1807,49 @@ sub authenticate_handler {
# upass - User's password.
# checkdefauth - Pass to validate_user() to try authentication
# with default auth type(s) if no user account.
+ # clientcancheckhost - Passed by clients with functionality in lonauth.pm
+ # to check if session can be hosted.
- my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);
+ my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
&Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");
chomp($upass);
$upass=&unescape($upass);
my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
if($pwdcorrect) {
- &Reply( $client, "authorized\n", $userinput);
+ my $canhost = 1;
+ unless ($clientcancheckhost) {
+ my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+ my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
+ 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');
+ if (ref($remotesession) eq 'HASH') {
+ $remote = $remotesession->{'remote'}
+ }
+ my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
+ if (ref($hostedsession) eq 'HASH') {
+ $hosted = $hostedsession->{'hosted'};
+ }
+ my $loncaparev = $clientversion;
+ if ($loncaparev eq '') {
+ $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
+ }
+ $canhost = &Apache::lonnet::can_host_session($udom,$clientname,
+ $loncaparev,
+ $remote,$hosted);
+ }
+ }
+ if ($canhost) {
+ &Reply( $client, "authorized\n", $userinput);
+ } else {
+ &Reply( $client, "not_allowed_to_host\n", $userinput);
+ }
#
# Bad credentials: Failed to authorize
#
@@ -2062,16 +2140,10 @@ sub is_home_handler {
®ister_handler("home", \&is_home_handler, 0,1,0);
#
-# Process an update request for a resource?? I think what's going on here is
-# that a resource has been modified that we hold a subscription to.
+# Process an update request for a resource.
+# A resource has been modified that we hold a subscription to.
# If the resource is not local, then we must update, or at least invalidate our
# cached copy of the resource.
-# FUTURE WORK:
-# I need to look at this logic carefully. My druthers would be to follow
-# typical caching logic, and simple invalidate the cache, drop any subscription
-# an let the next fetch start the ball rolling again... however that may
-# actually be more difficult than it looks given the complex web of
-# proxy servers.
# Parameters:
# $cmd - The command that got us here.
# $tail - Tail of the command (remaining parameters).
@@ -2095,20 +2167,30 @@ sub update_resource_handler {
my $ownership=ishome($fname);
if ($ownership eq 'not_owner') {
if (-e $fname) {
+ # Delete preview file, if exists
+ unlink("$fname.tmp");
+ # Get usage stats
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
my $now=time;
my $since=$now-$atime;
+ # If the file has not been used within lonExpire seconds,
+ # unsubscribe from it and delete local copy
if ($since>$perlvar{'lonExpire'}) {
my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
&devalidate_meta_cache($fname);
unlink("$fname");
unlink("$fname.meta");
} else {
+ # Yes, this is in active use. Get a fresh copy. Since it might be in
+ # very active use and huge (like a movie), copy it to "in.transfer" filename first.
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");
@@ -2116,11 +2198,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;
@@ -2132,6 +2216,7 @@ sub update_resource_handler {
}
alarm(0);
}
+ # we successfully transfered, copy file over to real name
rename($transname,$fname);
&devalidate_meta_cache($fname);
}
@@ -2369,7 +2454,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)) {
@@ -3100,7 +3184,7 @@ sub dump_with_regexp {
my $userinput = "$cmd:$tail";
- my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
+ my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
if (defined($regexp)) {
$regexp=&unescape($regexp);
} else {
@@ -3118,16 +3202,38 @@ sub dump_with_regexp {
}
my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());
+ my $skipcheck;
if ($hashref) {
my $qresult='';
my $count=0;
+ if ($extra ne '') {
+ $extra = &Apache::lonnet::thaw_unescape($extra);
+ $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 =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_(cc|co|in|ta|ep|ad|st|cr)/) {
- if ($clientversion =~ /^(\d+)\.(\d+)$/) {
- my $major = $1;
- my $minor = $2;
- next if (($major < 2) || (($major == 2) && ($minor < 10)));
+ if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
+ my $cdom = $1;
+ my $cnum = $2;
+ unless ($skipcheck) {
+ my ($role,$end,$start) = split(/\_/,$value);
+ if (!$end || $end > $now) {
+ next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
+ $minor,\%homecourses,\@ids));
+ }
}
}
}
@@ -3147,6 +3253,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 {
@@ -3724,6 +3836,9 @@ sub put_course_id_hash_handler {
# createdafter - include courses for which creation date followed this date.
# creationcontext - include courses created in specified context
#
+# domcloner - flag to indicate if user can create CCs in course's domain.
+# If so, ability to clone course is automatic.
+#
# $client - The socket open on the client.
# Returns:
# 1 - Continue processing.
@@ -3736,7 +3851,7 @@ sub dump_course_id_handler {
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
$caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
- $creationcontext) =split(/:/,$tail);
+ $creationcontext,$domcloner) =split(/:/,$tail);
my $now = time;
my ($cloneruname,$clonerudom,%cc_clone);
if (defined($description)) {
@@ -3809,7 +3924,6 @@ sub dump_course_id_handler {
} else {
$creationcontext = '.';
}
-
my $unpack = 1;
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
$typefilter eq '.') {
@@ -3840,7 +3954,9 @@ sub dump_course_id_handler {
next if ($since > 1);
}
$is_hash = 1;
- if (defined($clonerudom)) {
+ if ($domcloner) {
+ $canclone = 1;
+ } elsif (defined($clonerudom)) {
if ($items->{'cloners'}) {
my @cloneable = split(',',$items->{'cloners'});
if (@cloneable) {
@@ -3868,6 +3984,19 @@ sub dump_course_id_handler {
$items->{'cloners'} = $cloneruname.':'.$clonerudom;
$valchange = 1;
}
+ unless ($canclone) {
+ if ($items->{'owner'} =~ /:/) {
+ if ($items->{'owner'} eq $cloner) {
+ $canclone = 1;
+ }
+ } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
+ $canclone = 1;
+ }
+ if ($canclone) {
+ $items->{'cloners'} = $cloneruname.':'.$clonerudom;
+ $valchange = 1;
+ }
+ }
}
}
if ($unpack || !$rtn_as_hash) {
@@ -4068,6 +4197,53 @@ sub dump_course_id_handler {
}
®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
+sub course_lastaccess_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($cdom,$cnum) = split(':',$tail);
+ my (%lastaccess,$qresult);
+ my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
+ if ($hashref) {
+ while (my ($key,$value) = each(%$hashref)) {
+ my ($unesc_key,$lasttime);
+ $unesc_key = &unescape($key);
+ if ($cnum) {
+ next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/);
+ }
+ if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) {
+ $lastaccess{$1} = $value;
+ } else {
+ my $items = &Apache::lonnet::thaw_unescape($value);
+ if (ref($items) eq 'HASH') {
+ unless ($lastaccess{$unesc_key}) {
+ $lastaccess{$unesc_key} = '';
+ }
+ } else {
+ my @courseitems = split(':',$value);
+ $lastaccess{$unesc_key} = pop(@courseitems);
+ }
+ }
+ }
+ foreach my $cid (sort(keys(%lastaccess))) {
+ $qresult.=&escape($cid).'='.$lastaccess{$cid}.'&';
+ }
+ if (&untie_domain_hash($hashref)) {
+ if ($qresult) {
+ chop($qresult);
+ }
+ &Reply($client, \$qresult, $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting lastacourseaccess\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting lastcourseaccess\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
+
#
# Puts an unencrypted entry in a namespace db file at the domain level
#
@@ -4133,6 +4309,7 @@ sub put_domain_handler {
sub get_domain_handler {
my ($cmd, $tail, $client) = @_;
+
my $userinput = "$client:$tail";
my ($udom,$namespace,$what)=split(/:/,$tail,3);
@@ -4277,7 +4454,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());
@@ -4541,7 +4719,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;
@@ -4859,10 +5037,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);
@@ -5850,7 +6029,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";
@@ -5913,9 +6092,13 @@ sub HUPSMAN { # sig
# a setuid perl script that can be root for us to do this job.
#
sub ReloadApache {
- my $execdir = $perlvar{'lonDaemons'};
- my $script = $execdir."/apachereload";
- system($script);
+# --------------------------- Handle case of another apachereload process (locking)
+ if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
+ my $execdir = $perlvar{'lonDaemons'};
+ my $script = $execdir."/apachereload";
+ system($script);
+ unlink('/tmp/lock_apachereload'); # Remove the lock file.
+ }
}
#
@@ -6088,7 +6271,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");
@@ -6177,9 +6360,17 @@ $SIG{USR2} = \&UpdateHosts;
# Read the host hashes:
&Apache::lonnet::load_hosts_tab();
+my %iphost = &Apache::lonnet::get_iphost(1);
my $dist=`$perlvar{'lonDaemons'}/distprobe`;
+my $arch = `uname -i`;
+chomp($arch);
+if ($arch eq 'unknown') {
+ $arch = `uname -m`;
+ chomp($arch);
+}
+
# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated
# and if good, a child process is created to process transactions
@@ -6237,6 +6428,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.
@@ -6245,6 +6437,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';
@@ -6329,7 +6528,7 @@ sub make_new_child {
my $cipherkey = pack("H32", $key);
$cipher = new IDEA($cipherkey);
print $client "ok:local\n";
- &logthis(''
. "Successful local authentication ");
$keymode = "local"
} else {
@@ -6393,6 +6592,9 @@ sub make_new_child {
# ------------------------------------------------------------ Process requests
my $keep_going = 1;
my $user_input;
+ my $clienthost = &Apache::lonnet::hostname($clientname);
+ my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
+ $clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
while(($user_input = get_request) && $keep_going) {
alarm(120);
Debug("Main: Got $user_input\n");
@@ -6551,9 +6753,7 @@ sub rewrite_password_file {
# Returns the authorization type or nouser if there is no such user.
#
-sub get_auth_type
-{
-
+sub get_auth_type {
my ($domain, $user) = @_;
Debug("get_auth_type( $domain, $user ) \n");
@@ -6648,54 +6848,24 @@ sub validate_user {
} else {
$validated = 0;
}
- }
- elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
- if(! ($password =~ /$null/) ) {
- my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
- "",
- $contentpwd,,
- 'krbtgt',
- $contentpwd,
- 1,
- $password);
- if(!$k4error) {
- $validated = 1;
- } else {
- $validated = 0;
- &logthis('krb4: '.$user.', '.$contentpwd.', '.
- &Authen::Krb4::get_err_txt($Authen::Krb4::error));
- }
- } else {
- $validated = 0; # Password has a match with null.
- }
+ } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
+ my $checkwithkrb5 = 0;
+ if ($dist =~/^fedora(\d+)$/) {
+ if ($1 > 11) {
+ $checkwithkrb5 = 1;
+ }
+ } elsif ($dist =~ /^suse([\d.]+)$/) {
+ if ($1 > 11.1) {
+ $checkwithkrb5 = 1;
+ }
+ }
+ if ($checkwithkrb5) {
+ $validated = &krb5_authen($password,$null,$user,$contentpwd);
+ } else {
+ $validated = &krb4_authen($password,$null,$user,$contentpwd);
+ }
} elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
- if(!($password =~ /$null/)) { # Null password not allowed.
- my $krbclient = &Authen::Krb5::parse_name($user.'@'
- .$contentpwd);
- my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
- my $krbserver = &Authen::Krb5::parse_name($krbservice);
- my $credentials= &Authen::Krb5::cc_default();
- $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
- .$contentpwd));
- my $krbreturn;
- if (exists(&Authen::Krb5::get_init_creds_password)) {
- $krbreturn =
- &Authen::Krb5::get_init_creds_password($krbclient,$password,
- $krbservice);
- $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
- } else {
- $krbreturn =
- &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
- $password,$credentials);
- $validated = ($krbreturn == 1);
- }
- if (!$validated) {
- &logthis('krb5: '.$user.', '.$contentpwd.', '.
- &Authen::Krb5::error());
- }
- } else {
- $validated = 0;
- }
+ $validated = &krb5_authen($password,$null,$user,$contentpwd);
} elsif ($howpwd eq "localauth") {
# Authenticate via installation specific authentcation method:
$validated = &localauth::localauth($user,
@@ -6726,6 +6896,65 @@ sub validate_user {
return $validated;
}
+sub krb4_authen {
+ my ($password,$null,$user,$contentpwd) = @_;
+ my $validated = 0;
+ if (!($password =~ /$null/) ) { # Null password not allowed.
+ eval {
+ require Authen::Krb4;
+ };
+ if (!$@) {
+ my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
+ "",
+ $contentpwd,,
+ 'krbtgt',
+ $contentpwd,
+ 1,
+ $password);
+ if(!$k4error) {
+ $validated = 1;
+ } else {
+ $validated = 0;
+ &logthis('krb4: '.$user.', '.$contentpwd.', '.
+ &Authen::Krb4::get_err_txt($Authen::Krb4::error));
+ }
+ } else {
+ $validated = krb5_authen($password,$null,$user,$contentpwd);
+ }
+ }
+ return $validated;
+}
+
+sub krb5_authen {
+ my ($password,$null,$user,$contentpwd) = @_;
+ my $validated = 0;
+ if(!($password =~ /$null/)) { # Null password not allowed.
+ my $krbclient = &Authen::Krb5::parse_name($user.'@'
+ .$contentpwd);
+ my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
+ my $krbserver = &Authen::Krb5::parse_name($krbservice);
+ my $credentials= &Authen::Krb5::cc_default();
+ $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
+ .$contentpwd));
+ my $krbreturn;
+ if (exists(&Authen::Krb5::get_init_creds_password)) {
+ $krbreturn =
+ &Authen::Krb5::get_init_creds_password($krbclient,$password,
+ $krbservice);
+ $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
+ } else {
+ $krbreturn =
+ &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
+ $password,$credentials);
+ $validated = ($krbreturn == 1);
+ }
+ if (!$validated) {
+ &logthis('krb5: '.$user.', '.$contentpwd.', '.
+ &Authen::Krb5::error());
+ }
+ }
+ return $validated;
+}
sub addline {
my ($fname,$hostid,$ip,$newline)=@_;
@@ -7096,7 +7325,7 @@ sub sethost {
eq &Apache::lonnet::get_host_ip($hostid)) {
$currenthostid =$hostid;
$currentdomainid=&Apache::lonnet::host_domain($hostid);
- &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
+# &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
} else {
&logthis("Requested host id $hostid not an alias of ".
$perlvar{'lonHostID'}." refusing connection");
@@ -7111,6 +7340,186 @@ sub version {
return "version:$VERSION";
}
+sub get_usersession_config {
+ my ($dom,$name) = @_;
+ my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
+ if (defined($cached)) {
+ return $usersessionconf;
+ } else {
+ my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
+ if (ref($domconfig{'usersessions'}) eq 'HASH') {
+ &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
+ return $domconfig{'usersessions'};
+ }
+ }
+ return;
+}
+
+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);
+ if (defined($cached)) {
+ 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 {
+ 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)
@@ -7846,5 +8255,7 @@ string.
=back
+=back
+
=cut