--- loncom/lond 2009/03/03 12:08:07 1.412
+++ loncom/lond 2012/04/25 21:22:28 1.491
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.412 2009/03/03 12:08:07 foxr Exp $
+# $Id: lond,v 1.491 2012/04/25 21:22:28 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.
#
@@ -33,6 +34,7 @@ use strict;
use lib '/home/httpd/lib/perl/';
use LONCAPA;
use LONCAPA::Configuration;
+use LONCAPA::Lond;
use IO::Socket;
use IO::File;
@@ -42,7 +44,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 +54,14 @@ use LONCAPA::lonlocal;
use LONCAPA::lonssl;
use Fcntl qw(:flock);
use Apache::lonnet;
+use Mail::Send;
-my $DEBUG = 1; # Non zero to enable debug log entries.
+my $DEBUG = 0; # Non zero to enable debug log entries.
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.412 $'; #' stupid emacs
+my $VERSION='$Revision: 1.491 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -67,6 +69,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 $clienthomedom; # LonCAPA domain of homeID for client.
+ # primary library server.
my $server;
@@ -88,6 +93,8 @@ my %managers; # Ip -> manager names
my %perlvar; # Will have the apache conf defined perl vars.
+my $dist;
+
#
# The hash below is used for command dispatching, and is therefore keyed on the request keyword.
# Each element of the hash contains a reference to an array that contains:
@@ -417,8 +424,11 @@ sub ReadManagerTable {
my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
if (!open (MANAGERS, $tablename)) {
- logthis('<font color="red">No manager table. Nobody can manage!!</font>');
- return;
+ my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
+ if (&Apache::lonnet::is_LC_dns($hostname)) {
+ &logthis('<font color="red">No manager table. Nobody can manage!!</font>');
+ }
+ return;
}
while(my $host = <MANAGERS>) {
chomp($host);
@@ -443,7 +453,7 @@ sub ReadManagerTable {
}
} else {
logthis('<font color="green"> existing host'." $host</font>\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
}
}
}
@@ -505,7 +515,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) {
@@ -593,11 +604,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:
@@ -610,15 +618,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.
@@ -644,6 +648,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
@@ -675,11 +681,31 @@ sub PushFile {
return "error:$!";
} else {
&logthis('<font color="green"> Installed new '.$tablefile
- ."</font>");
-
+ ." - transaction by: $clientname ($clientip)</font>");
+ 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";
@@ -975,6 +1001,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++) {
@@ -1068,7 +1097,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.
@@ -1107,7 +1136,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.
@@ -1116,6 +1145,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
@@ -1144,7 +1175,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
@@ -1613,6 +1644,74 @@ sub ls3_handler {
}
®ister_handler("ls3", \&ls3_handler, 0, 1, 0);
+sub read_lonnet_global {
+ my ($cmd,$tail,$client) = @_;
+ my $userinput = "$cmd:$tail";
+ my $requested = &Apache::lonnet::thaw_unescape($tail);
+ my $result;
+ my %packagevars = (
+ spareid => \%Apache::lonnet::spareid,
+ perlvar => \%Apache::lonnet::perlvar,
+ );
+ my %limit_to = (
+ perlvar => {
+ lonOtherAuthen => 1,
+ lonBalancer => 1,
+ lonVersion => 1,
+ lonSysEMail => 1,
+ lonHostID => 1,
+ lonRole => 1,
+ lonDefDomain => 1,
+ lonLoadLim => 1,
+ lonUserLoadLim => 1,
+ }
+ );
+ if (ref($requested) eq 'HASH') {
+ foreach my $what (keys(%{$requested})) {
+ my $response;
+ my $items = {};
+ if (exists($packagevars{$what})) {
+ if (ref($limit_to{$what}) eq 'HASH') {
+ foreach my $varname (keys(%{$packagevars{$what}})) {
+ if ($limit_to{$what}{$varname}) {
+ $items->{$varname} = $packagevars{$what}{$varname};
+ }
+ }
+ } else {
+ $items = $packagevars{$what};
+ }
+ if ($what eq 'perlvar') {
+ if (!exists($packagevars{$what}{'lonBalancer'})) {
+ if ($dist =~ /^(centos|rhes|fedora|scientific)/) {
+ my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
+ if (ref($othervarref) eq 'HASH') {
+ $items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
+ }
+ }
+ }
+ }
+ $response = &Apache::lonnet::freeze_escape($items);
+ }
+ $result .= &escape($what).'='.$response.'&';
+ }
+ }
+ $result =~ s/\&$//;
+ &Reply($client,\$result,$userinput);
+ return 1;
+}
+®ister_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0);
+
+sub server_devalidatecache_handler {
+ my ($cmd,$tail,$client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($name,$id) = map { &unescape($_); } split(/:/,$tail);
+ &Apache::lonnet::devalidate_cache_new($name,$id);
+ my $result = 'ok';
+ &Reply($client,\$result,$userinput);
+ return 1;
+}
+®ister_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0);
+
sub server_timezone_handler {
my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";
@@ -1645,6 +1744,31 @@ sub server_timezone_handler {
}
®ister_handler("servertimezone", \&server_timezone_handler, 0, 1, 0);
+sub server_loncaparev_handler {
+ my ($cmd,$tail,$client) = @_;
+ my $userinput = "$cmd:$tail";
+ &Reply($client,\$perlvar{'lonVersion'},$userinput);
+ return 1;
+}
+®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.
@@ -1754,15 +1878,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
#
@@ -1807,8 +1965,9 @@ sub change_password_handler {
# npass - New password.
# context - Context in which this was called
# (preferences or reset_by_email).
+ # lonhost - HostID of server where request originated
- my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail);
+ my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail);
$upass=&unescape($upass);
$npass=&unescape($npass);
@@ -1817,9 +1976,13 @@ sub change_password_handler {
# First require that the user can be authenticated with their
# old password unless context was 'reset_by_email':
- my $validated;
+ my ($validated,$failure);
if ($context eq 'reset_by_email') {
- $validated = 1;
+ if ($lonhost eq '') {
+ $failure = 'invalid_client';
+ } else {
+ $validated = 1;
+ }
} else {
$validated = &validate_user($udom, $uname, $upass);
}
@@ -1833,8 +1996,11 @@ sub change_password_handler {
$salt=substr($salt,6,2);
my $ncpass=crypt($npass,$salt);
if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
- &logthis("Result of password change for "
- ."$uname: pwchange_success");
+ my $msg="Result of password change for $uname: pwchange_success";
+ if ($lonhost) {
+ $msg .= " - request originated from: $lonhost";
+ }
+ &logthis($msg);
&Reply($client, "ok\n", $userinput);
} else {
&logthis("Unable to open $uname passwd "
@@ -1855,7 +2021,10 @@ sub change_password_handler {
}
} else {
- &Failure( $client, "non_authorized\n", $userinput);
+ if ($failure eq '') {
+ $failure = 'non_authorized';
+ }
+ &Failure( $client, "$failure\n", $userinput);
}
return 1;
@@ -1905,7 +2074,7 @@ sub add_user_handler {
."makeuser";
}
unless ($fperror) {
- my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
+ my $result=&make_passwd_file($uname,$udom,$umode,$npass, $passfilename);
&Reply($client,\$result, $userinput); #BUGBUG - could be fail
} else {
&Failure($client, \$fperror, $userinput);
@@ -1980,7 +2149,7 @@ sub change_authentication_handler {
&Failure($client, \$result);
}
} else {
- my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
+ my $result=&make_passwd_file($uname,$udom,$umode,$npass,$passfilename);
#
# If the current auth mode is internal, and the old auth mode was
# unix, or krb*, and the user is an author for this domain,
@@ -2042,16 +2211,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).
@@ -2075,20 +2238,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");
@@ -2096,11 +2269,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;
@@ -2112,6 +2287,7 @@ sub update_resource_handler {
}
alarm(0);
}
+ # we successfully transfered, copy file over to real name
rename($transname,$fname);
&devalidate_meta_cache($fname);
}
@@ -2173,7 +2349,10 @@ sub fetch_user_file_handler {
my $destname=$udir.'/'.$ufile;
my $transname=$udir.'/'.$ufile.'.in.transit';
- my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
+ my $clientprotocol=$Apache::lonnet::protocol{$clientname};
+ $clientprotocol = 'http' if ($clientprotocol ne 'https');
+ my $clienthost = &Apache::lonnet::hostname($clientname);
+ my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
my $response;
Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
alarm(120);
@@ -2349,7 +2528,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)) {
@@ -3068,6 +3246,9 @@ sub dump_profile_database {
# that is matched against
# database keywords to do
# selective dumps.
+# range - optional range of entries
+# e.g., 10-20 would return the
+# 10th to 19th items, etc.
# $client - Channel open on the client.
# Returns:
# 1 - Continue processing.
@@ -3077,6 +3258,15 @@ sub dump_profile_database {
sub dump_with_regexp {
my ($cmd, $tail, $client) = @_;
+ #TODO encapsulate $clientname and $clientversion in a object.
+ my $res = LONCAPA::Lond::dump_with_regexp($cmd, $tail, $clientname, $clientversion);
+
+ if ($res =~ /^error:/) {
+ Failure($client, \$res, "$cmd:$tail");
+ } else {
+ Reply($client, \$res, "$cmd:$tail");
+ }
+ return 1;
my $userinput = "$cmd:$tail";
@@ -3101,7 +3291,58 @@ sub dump_with_regexp {
if ($hashref) {
my $qresult='';
my $count=0;
+#
+# When dump is for roles.db, determine if LON-CAPA version checking is needed.
+# Sessions on 2.10 and later do not require version checking, as that occurs
+# on the server hosting the user session, when constructing the roles/courses
+# screen).
+#
+ my $skipcheck;
+ my @ids = &Apache::lonnet::current_machine_ids();
+ my (%homecourses,$major,$minor,$now);
+#
+# If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA
+# version on the server which requested the data. For LON-CAPA 2.9, the
+# client session will have sent its LON-CAPA version when initiating the
+# connection. For LON-CAPA 2.8 and older, the version is retrieved from
+# the global %loncaparevs in lonnet.pm.
+#
+ if ($namespace eq 'roles') {
+ my $loncaparev = $clientversion;
+ if ($loncaparev eq '') {
+ $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
+ }
+ if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
+ $major = $1;
+ $minor = $2;
+ }
+ if (($major > 2) || (($major == 2) && ($minor > 9))) {
+ $skipcheck = 1;
+ }
+ $now = time;
+ }
while (my ($key,$value) = each(%$hashref)) {
+ if (($namespace eq 'roles') && (!$skipcheck)) {
+ if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
+ my $cdom = $1;
+ my $cnum = $2;
+ my ($role,$roleend,$rolestart) = split(/\_/,$value);
+ if (!$roleend || $roleend > $now) {
+#
+# For active course roles, check that requesting server is running a LON-CAPA
+# version which meets any version requirements for the course. Do not include
+# the role amongst the results returned if the requesting server's version is
+# too old.
+#
+# This determination is handled differently depending on whether the course's
+# homeserver is the current server, or whether it is a different server.
+# In both cases, the course's version requirement needs to be retrieved.
+#
+ next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
+ $minor,\%homecourses,\@ids));
+ }
+ }
+ }
if ($regexp eq '.') {
$count++;
if (defined($range) && $count >= $end) { last; }
@@ -3118,6 +3359,19 @@ sub dump_with_regexp {
}
}
if (&untie_user_hash($hashref)) {
+#
+# If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA
+# version requirements for courses for which the current server is the home
+# server permit course roles to be usable on the client server hosting the
+# user's session. If so, include those role results in the data returned to
+# the client server.
+#
+ if (($namespace eq 'roles') && (!$skipcheck)) {
+ if (keys(%homecourses) > 0) {
+ $qresult .= &check_homecourses(\%homecourses,$regexp,$count,
+ $range,$start,$end,$major,$minor);
+ }
+ }
chop($qresult);
&Reply($client, \$qresult, $userinput);
} else {
@@ -3666,8 +3920,10 @@ sub put_course_id_hash_handler {
# will be returned. Pre-2.2.0 legacy entries from
# nohist_courseiddump will only contain usernames.
# type - optional parameter for selection
-# regexp_ok - if true, allow the supplied institutional code
-# filter to behave as a regular expression.
+# regexp_ok - if 1 or -1 allow the supplied institutional code
+# filter to behave as a regular expression:
+# 1 will not exclude the course if the instcode matches the RE
+# -1 will exclude the course if the instcode matches the RE
# rtn_as_hash - whether to return the information available for
# each matched item as a frozen hash of all
# key, value pairs in the item's hash, or as a
@@ -3683,6 +3939,18 @@ sub put_course_id_hash_handler {
# caller - if set to 'coursecatalog', courses set to be hidden
# from course catalog will be excluded from results (unless
# overridden by "showhidden".
+# cloner - escaped username:domain of course cloner (if picking course to
+# clone).
+# cc_clone_list - escaped comma separated list of courses for which
+# course cloner has active CC role (and so can clone
+# automatically).
+# cloneonly - filter by courses for which cloner has rights to clone.
+# createdbefore - include courses for which creation date preceeded this date.
+# 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:
@@ -3695,8 +3963,10 @@ sub dump_course_id_handler {
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
- $caller) =split(/:/,$tail);
+ $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
+ $creationcontext,$domcloner) =split(/:/,$tail);
my $now = time;
+ my ($cloneruname,$clonerudom,%cc_clone);
if (defined($description)) {
$description=&unescape($description);
} else {
@@ -3739,8 +4009,36 @@ sub dump_course_id_handler {
if (defined($catfilter)) {
$catfilter=&unescape($catfilter);
}
+ if (defined($cloner)) {
+ $cloner = &unescape($cloner);
+ ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/);
+ }
+ if (defined($cc_clone_list)) {
+ $cc_clone_list = &unescape($cc_clone_list);
+ my @cc_cloners = split('&',$cc_clone_list);
+ foreach my $cid (@cc_cloners) {
+ my ($clonedom,$clonenum) = split(':',$cid);
+ next if ($clonedom ne $udom);
+ $cc_clone{$clonedom.'_'.$clonenum} = 1;
+ }
+ }
+ if ($createdbefore ne '') {
+ $createdbefore = &unescape($createdbefore);
+ } else {
+ $createdbefore = 0;
+ }
+ if ($createdafter ne '') {
+ $createdafter = &unescape($createdafter);
+ } else {
+ $createdafter = 0;
+ }
+ if ($creationcontext ne '') {
+ $creationcontext = &unescape($creationcontext);
+ } else {
+ $creationcontext = '.';
+ }
my $unpack = 1;
- if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
+ if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
$typefilter eq '.') {
$unpack = 0;
}
@@ -3750,7 +4048,8 @@ sub dump_course_id_handler {
if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {
my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
- %unesc_val,$selfenroll_end,$selfenroll_types);
+ %unesc_val,$selfenroll_end,$selfenroll_types,$created,
+ $context);
$unesc_key = &unescape($key);
if ($unesc_key =~ /^lasttime:/) {
next;
@@ -3761,23 +4060,86 @@ sub dump_course_id_handler {
$lasttime = $hashref->{$lasttime_key};
next if ($lasttime<$since);
}
+ my ($canclone,$valchange);
my $items = &Apache::lonnet::thaw_unescape($value);
if (ref($items) eq 'HASH') {
+ if ($hashref->{$lasttime_key} eq '') {
+ next if ($since > 1);
+ }
$is_hash = 1;
+ if ($domcloner) {
+ $canclone = 1;
+ } elsif (defined($clonerudom)) {
+ if ($items->{'cloners'}) {
+ my @cloneable = split(',',$items->{'cloners'});
+ if (@cloneable) {
+ if (grep(/^\*$/,@cloneable)) {
+ $canclone = 1;
+ } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
+ $canclone = 1;
+ } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
+ $canclone = 1;
+ }
+ }
+ unless ($canclone) {
+ if ($cloneruname ne '' && $clonerudom ne '') {
+ if ($cc_clone{$unesc_key}) {
+ $canclone = 1;
+ $items->{'cloners'} .= ','.$cloneruname.':'.
+ $clonerudom;
+ $valchange = 1;
+ }
+ }
+ }
+ } elsif (defined($cloneruname)) {
+ if ($cc_clone{$unesc_key}) {
+ $canclone = 1;
+ $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) {
$unesc_val{'descr'} = $items->{'description'};
$unesc_val{'inst_code'} = $items->{'inst_code'};
$unesc_val{'owner'} = $items->{'owner'};
$unesc_val{'type'} = $items->{'type'};
+ $unesc_val{'cloners'} = $items->{'cloners'};
+ $unesc_val{'created'} = $items->{'created'};
+ $unesc_val{'context'} = $items->{'context'};
}
$selfenroll_types = $items->{'selfenroll_types'};
$selfenroll_end = $items->{'selfenroll_end_date'};
+ $created = $items->{'created'};
+ $context = $items->{'context'};
if ($selfenrollonly) {
next if (!$selfenroll_types);
if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
next;
}
}
+ if ($creationcontext ne '.') {
+ next if (($context ne '') && ($context ne $creationcontext));
+ }
+ if ($createdbefore > 0) {
+ next if (($created eq '') || ($created > $createdbefore));
+ }
+ if ($createdafter > 0) {
+ next if (($created eq '') || ($created <= $createdafter));
+ }
if ($catfilter ne '') {
next if ($items->{'categories'} eq '');
my @categories = split('&',$items->{'categories'});
@@ -3799,7 +4161,15 @@ sub dump_course_id_handler {
}
} else {
next if ($catfilter ne '');
- next if ($selfenrollonly);
+ next if ($selfenrollonly);
+ next if ($createdbefore || $createdafter);
+ next if ($creationcontext ne '.');
+ if ((defined($clonerudom)) && (defined($cloneruname))) {
+ if ($cc_clone{$unesc_key}) {
+ $canclone = 1;
+ $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
+ }
+ }
$is_hash = 0;
my @courseitems = split(/:/,$value);
$lasttime = pop(@courseitems);
@@ -3808,6 +4178,9 @@ sub dump_course_id_handler {
}
($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
}
+ if ($cloneonly) {
+ next unless ($canclone);
+ }
my $match = 1;
if ($description ne '.') {
if (!$is_hash) {
@@ -3821,10 +4194,14 @@ sub dump_course_id_handler {
if (!$is_hash) {
$unesc_val{'inst_code'} = &unescape($val{'inst_code'});
}
- if ($regexp_ok) {
+ if ($regexp_ok == 1) {
if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
$match = 0;
}
+ } elsif ($regexp_ok == -1) {
+ if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
+ $match = 0;
+ }
} else {
if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
$match = 0;
@@ -3890,12 +4267,18 @@ sub dump_course_id_handler {
if ($match == 1) {
if ($rtn_as_hash) {
if ($is_hash) {
- $qresult.=$key.'='.$value.'&';
+ if ($valchange) {
+ my $newvalue = &Apache::lonnet::freeze_escape($items);
+ $qresult.=$key.'='.$newvalue.'&';
+ } else {
+ $qresult.=$key.'='.$value.'&';
+ }
} else {
my %rtnhash = ( 'description' => &unescape($val{'descr'}),
'inst_code' => &unescape($val{'inst_code'}),
'owner' => &unescape($val{'owner'}),
'type' => &unescape($val{'type'}),
+ 'cloners' => &unescape($val{'cloners'}),
);
my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
$qresult.=$key.'='.$items.'&';
@@ -3927,6 +4310,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
#
@@ -3992,6 +4422,7 @@ sub put_domain_handler {
sub get_domain_handler {
my ($cmd, $tail, $client) = @_;
+
my $userinput = "$client:$tail";
my ($udom,$namespace,$what)=split(/:/,$tail,3);
@@ -4019,7 +4450,6 @@ sub get_domain_handler {
}
®ister_handler("getdom", \&get_domain_handler, 0, 1, 0);
-
#
# Puts an id to a domains id database.
#
@@ -4137,7 +4567,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());
@@ -4326,27 +4757,30 @@ sub dump_domainroles_handler {
$rolesfilter=&unescape($rolesfilter);
@roles = split(/\&/,$rolesfilter);
}
-
+
my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
if ($hashref) {
my $qresult = '';
while (my ($key,$value) = each(%$hashref)) {
my $match = 1;
- my ($start,$end) = split(/:/,&unescape($value));
+ my ($end,$start) = split(/:/,&unescape($value));
my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
- unless ($startfilter eq '.' || !defined($startfilter)) {
- if ($start >= $startfilter) {
+ unless (@roles < 1) {
+ unless (grep/^\Q$trole\E$/,@roles) {
$match = 0;
+ next;
}
}
- unless ($endfilter eq '.' || !defined($endfilter)) {
- if ($end <= $endfilter) {
+ unless ($startfilter eq '.' || !defined($startfilter)) {
+ if ((defined($start)) && ($start >= $startfilter)) {
$match = 0;
+ next;
}
}
- unless (@roles < 1) {
- unless (grep/^\Q$trole\E$/,@roles) {
+ unless ($endfilter eq '.' || !defined($endfilter)) {
+ if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) {
$match = 0;
+ next;
}
}
if ($match == 1) {
@@ -4398,7 +4832,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;
@@ -4633,6 +5067,43 @@ sub enrollment_enabled_handler {
}
®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
+#
+# Validate an institutional code used for a LON-CAPA course.
+#
+# Formal Parameters:
+# $cmd - The command request that got us dispatched.
+# $tail - The tail of the command. In this case,
+# this is a colon separated set of words that will be split
+# into:
+# $dom - The domain for which the check of
+# institutional course code will occur.
+#
+# $instcode - The institutional code for the course
+# being requested, or validated for rights
+# to request.
+#
+# $owner - The course requestor (who will be the
+# course owner, in the form username:domain
+#
+# $client - Socket open on the client.
+# Returns:
+# 1 - Indicating processing should continue.
+#
+sub validate_instcode_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($dom,$instcode,$owner) = split(/:/, $tail);
+ $instcode = &unescape($instcode);
+ $owner = &unescape($owner);
+ my ($outcome,$description) =
+ &localenroll::validate_instcode($dom,$instcode,$owner);
+ my $result = &escape($outcome).'&'.&escape($description);
+ &Reply($client, \$result, $userinput);
+
+ return 1;
+}
+®ister_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0);
+
# Get the official sections for which auto-enrollment is possible.
# Since the admin people won't know about 'unofficial sections'
# we cannot auto-enroll on them.
@@ -4679,10 +5150,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);
@@ -4836,6 +5308,61 @@ sub retrieve_auto_file_handler {
}
®ister_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
+sub crsreq_checks_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my $dom = $tail;
+ my $result;
+ my @reqtypes = ('official','unofficial','community');
+ eval {
+ local($SIG{__DIE__})='DEFAULT';
+ my %validations;
+ my $response = &localenroll::crsreq_checks($dom,\@reqtypes,
+ \%validations);
+ if ($response eq 'ok') {
+ foreach my $key (keys(%validations)) {
+ $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
+ }
+ $result =~ s/\&$//;
+ } else {
+ $result = 'error';
+ }
+ };
+ if (!$@) {
+ &Reply($client, \$result, $userinput);
+ } else {
+ &Failure($client,"unknown_cmd\n",$userinput);
+ }
+ return 1;
+}
+®ister_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0);
+
+sub validate_crsreq_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = split(/:/, $tail);
+ $instcode = &unescape($instcode);
+ $owner = &unescape($owner);
+ $crstype = &unescape($crstype);
+ $inststatuslist = &unescape($inststatuslist);
+ $instcode = &unescape($instcode);
+ $instseclist = &unescape($instseclist);
+ my $outcome;
+ eval {
+ local($SIG{__DIE__})='DEFAULT';
+ $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype,
+ $inststatuslist,$instcode,
+ $instseclist);
+ };
+ if (!$@) {
+ &Reply($client, \$outcome, $userinput);
+ } else {
+ &Failure($client,"unknown_cmd\n",$userinput);
+ }
+ return 1;
+}
+®ister_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0);
+
#
# Read and retrieve institutional code format (for support form).
# Formal Parameters:
@@ -4920,6 +5447,39 @@ sub get_institutional_defaults_handler {
®ister_handler("autoinstcodedefaults",
\&get_institutional_defaults_handler,0,1,0);
+sub get_possible_instcodes_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+
+ my $reply;
+ my $cdom = $tail;
+ my (@codetitles,%cat_titles,%cat_order,@code_order);
+ my $formatreply = &localenroll::possible_instcodes($cdom,
+ \@codetitles,
+ \%cat_titles,
+ \%cat_order,
+ \@code_order);
+ if ($formatreply eq 'ok') {
+ my $result = join('&',map {&escape($_);} (@codetitles)).':';
+ $result .= join('&',map {&escape($_);} (@code_order)).':';
+ foreach my $key (keys(%cat_titles)) {
+ $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&';
+ }
+ $result =~ s/\&$//;
+ $result .= ':';
+ foreach my $key (keys(%cat_order)) {
+ $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_order{$key}).'&';
+ }
+ $result =~ s/\&$//;
+ &Reply($client,\$result,$userinput);
+ } else {
+ &Reply($client, "format_error\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("autopossibleinstcodes",
+ \&get_possible_instcodes_handler,0,1,0);
+
sub get_institutional_user_rules {
my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";
@@ -5582,7 +6142,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";
@@ -5645,9 +6205,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.
+ }
}
#
@@ -5758,6 +6322,9 @@ sub Debug {
# reply - Text to send to client.
# request - Original request from client.
#
+#NOTE $reply must be terminated by exactly *one* \n. If $reply is a reference
+#this is done automatically ($$reply must not contain any \n in this case).
+#If $reply is a string the caller has to ensure this.
sub Reply {
my ($fd, $reply, $request) = @_;
if (ref($reply)) {
@@ -5820,7 +6387,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");
@@ -5909,8 +6476,16 @@ $SIG{USR2} = \&UpdateHosts;
# Read the host hashes:
&Apache::lonnet::load_hosts_tab();
+my %iphost = &Apache::lonnet::get_iphost(1);
-my $dist=`$perlvar{'lonDaemons'}/distprobe`;
+$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
@@ -5969,6 +6544,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.
@@ -5977,6 +6553,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';
@@ -6005,7 +6588,7 @@ sub make_new_child {
&ReadManagerTable();
my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
my $ismanager=($managers{$outsideip} ne undef);
- $clientname = "[unknonwn]";
+ $clientname = "[unknown]";
if($clientrec) { # Establish client type.
$ConnectionType = "client";
$clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
@@ -6033,7 +6616,7 @@ sub make_new_child {
#
# If the remote is attempting a local init... give that a try:
#
- my ($i, $inittype) = split(/:/, $remotereq);
+ (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
# If the connection type is ssl, but I didn't get my
# certificate files yet, then I'll drop back to
@@ -6053,6 +6636,7 @@ sub make_new_child {
}
if($inittype eq "local") {
+ $clientversion = $perlvar{'lonVersion'};
my $key = LocalConnection($client, $remotereq);
if($key) {
Debug("Got local key $key");
@@ -6060,7 +6644,7 @@ sub make_new_child {
my $cipherkey = pack("H32", $key);
$cipher = new IDEA($cipherkey);
print $client "ok:local\n";
- &logthis('<font color="green"'
+ &logthis('<font color="green">'
. "Successful local authentication </font>");
$keymode = "local"
} else {
@@ -6124,6 +6708,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");
@@ -6173,22 +6760,29 @@ sub is_author {
# Author role should show up as a key /domain/_au
- my $key = "/$domain/_au";
my $value;
- if (defined($hashref)) {
- $value = $hashref->{$key};
- }
+ if ($hashref) {
- if(defined($value)) {
- &Debug("$user @ $domain is an author");
+ my $key = "/$domain/_au";
+ if (defined($hashref)) {
+ $value = $hashref->{$key};
+ if(!untie_user_hash($hashref)) {
+ return 'error: ' . ($!+0)." untie (GDBM) Failed";
+ }
+ }
+
+ if(defined($value)) {
+ &Debug("$user @ $domain is an author");
+ }
+ } else {
+ return 'error: '.($!+0)." tie (GDBM) Failed";
}
return defined($value);
}
#
# Checks to see if the input roleput request was to set
-# an author role. If so, invokes the lchtmldir script to set
-# up a correct public_html
+# an author role. If so, creates construction space
# Parameters:
# request - The request sent to the rolesput subchunk.
# We're looking for /domain/_au
@@ -6198,16 +6792,15 @@ sub is_author {
#
sub manage_permissions {
my ($request, $domain, $user, $authtype) = @_;
-
- &Debug("manage_permissions: $request $domain $user $authtype");
-
# See if the request is of the form /$domain/_au
if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
- my $execdir = $perlvar{'lonDaemons'};
- my $userhome= "/home/$user" ;
- &logthis("system $execdir/lchtmldir $userhome $user $authtype");
- &Debug("Setting homedir permissions for $userhome");
- system("$execdir/lchtmldir $userhome $user $authtype");
+ my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
+ unless (-e $path) {
+ mkdir($path);
+ }
+ unless (-e $path.'/'.$user) {
+ mkdir($path.'/'.$user);
+ }
}
}
@@ -6282,9 +6875,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");
@@ -6379,54 +6970,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,
@@ -6457,6 +7018,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)=@_;
@@ -6669,7 +7289,9 @@ sub subscribe {
# the metadata
unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
$fname=~s/\/home\/httpd\/html\/res/raw/;
- $fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
+ my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
+ $protocol = 'http' if ($protocol ne 'https');
+ $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
$result="$fname\n";
}
} else {
@@ -6711,7 +7333,7 @@ sub change_unix_password {
sub make_passwd_file {
- my ($uname, $umode,$npass,$passfilename)=@_;
+ my ($uname,$udom,$umode,$npass,$passfilename)=@_;
my $result="ok";
if ($umode eq 'krb4' or $umode eq 'krb5') {
{
@@ -6752,7 +7374,7 @@ sub make_passwd_file {
#
my $uid = getpwnam($uname);
if((defined $uid) && ($uid == 0)) {
- &logthis(">>>Attempted to create privilged account blocked");
+ &logthis(">>>Attempt to create privileged account blocked");
return "no_priv_account_error\n";
}
@@ -6764,6 +7386,7 @@ sub make_passwd_file {
&Debug("user = ".$uname.", Password =". $npass);
my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
print $se "$uname\n";
+ print $se "$udom\n";
print $se "$npass\n";
print $se "$npass\n";
print $se "$lc_error_file\n"; # Status -> unique file.
@@ -6827,7 +7450,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");
@@ -6842,6 +7465,253 @@ 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;
+}
+
+#
+# releasereqd_check() will determine if a LON-CAPA version (defined in the
+# $major,$minor args passed) is not too old to allow use of a role in a
+# course ($cnum,$cdom args passed), if at least one of the following applies:
+# (a) the course is a Community, (b) the course's home server is *not* the
+# current server, or (c) cached course information is not stale.
+#
+# For the case where none of these apply, the course is added to the
+# $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
+# The $homecourse hash ref is for courses for which the current server is the
+# home server. LON-CAPA version requirements are checked elsewhere for the
+# items in $homecourse.
+#
+
+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->{$cdom}) eq 'HASH') {
+ if (ref($homecourses->{$cdom}{$cnum}) eq 'HASH') {
+ if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
+ push(@{$homecourses->{$cdom}{$cnum}},{$key=>$value});
+ } else {
+ $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
+ }
+ } else {
+ $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
+ }
+ } else {
+ $homecourses->{$cdom}{$cnum} = [{$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;
+}
+
+#
+# get_courseinfo_hash() is used to retrieve course information from the db
+# file: nohist_courseids.db for a course for which the current server is *not*
+# the home server.
+#
+# A hash of a hash will be retrieved. The outer hash contains a single key --
+# courseID -- for the course for which the data are being requested.
+# The contents of the inner hash, for that single item in the outer hash
+# are returned (and cached in memcache for 10 minutes).
+#
+
+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("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
+ } else {
+ &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
+ }
+ } 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;
+}
+
+#
+# check_homecourses() will retrieve course information for those courses which
+# are keys of the $homecourses hash ref (first arg). The nohist_courseids.db
+# GDBM file is tied and course information for each course retrieved. Last
+# visit (lasttime key) is also retrieved for each, and cached values updated
+# for any courses last visited less than 24 hours ago. Cached values are also
+# updated for any courses included in the $homecourses hash ref.
+#
+# The reason for the 24 hours constraint is that the cron entry in
+# /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes
+# cached course information to be updated nightly for courses with activity
+# within the past 24 hours.
+#
+# Role information for the user (included in a ref to an array of hashes as the
+# value for each key in $homecourses) is appended to the result returned by the
+# routine, which will in turn be appended to the string returned to the client
+# hosting the user's session.
+#
+
+sub check_homecourses {
+ my ($homecourses,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
+ my ($result,%addtocache);
+ my $yesterday = time - 24*3600;
+ if (ref($homecourses) eq 'HASH') {
+ my (%okcourses,%courseinfo,%recent);
+ foreach my $domain (keys(%{$homecourses})) {
+ my $hashref =
+ &tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT());
+ if (ref($hashref) eq 'HASH') {
+ 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 ($cdom,$cnum) = split(/_/,$unesc_key);
+ my $hashid = $cdom.':'.$cnum;
+ $courseinfo{$hashid} = $items;
+ if (ref($homecourses->{$cdom}{$cnum}) 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 for $domain");
+ }
+ } else {
+ &logthis("Failed to tie hash for nohist_courseids.db for $domain");
+ }
+ }
+ 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 $cdom (keys(%{$homecourses})) {
+ if (ref($homecourses->{$cdom}) eq 'HASH') {
+ foreach my $cnum (keys(%{$homecourses->{$cdom}})) {
+ my $hashid = $cdom.':'.$cnum;
+ next if ($recent{$hashid});
+ &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
+ }
+ }
+ }
+ foreach my $hashid (keys(%okcourses)) {
+ my ($cdom,$cnum) = split(/:/,$hashid);
+ if ((ref($homecourses->{$cdom}) eq 'HASH') &&
+ (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) {
+ foreach my $role (@{$homecourses->{$cdom}{$cnum}}) {
+ 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;
+}
+
+#
+# useable_role() will compare the LON-CAPA version required by a course with
+# the version available on the client server. If the client server's version
+# is compatible, 1 will be returned.
+#
+
+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)
@@ -7167,6 +8037,8 @@ Authen::Krb5
=head1 COREQUISITES
+none
+
=head1 OSNAMES
linux
@@ -7254,9 +8126,9 @@ or the CA's certificate in the call to l
<error> is the textual reason this failed. Usual reasons:
=over 2
-
+
=item Apache config file for loncapa incorrect:
-
+
one of the variables
lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate
undefined or incorrect
@@ -7375,7 +8247,7 @@ Could not rewrite the
internal password file for a user
=item Result of password change for <user> : <result>
-
+
A unix password change for <user> was attempted
and the pipe returned <result>
@@ -7404,7 +8276,7 @@ lond has been asked to exit by its clien
client systemand <input> is the full exit command sent to the server.
=item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].
-
+
A lond child terminated. NOte that this termination can also occur when the
child receives the QUIT or DIE signals. <pid> is the process id of the child,
<hostname> the host lond is working for, and <message> the reason the child died
@@ -7488,7 +8360,7 @@ file when sent it's USR1 signal. That p
assumed to be hung in some un-fixable way.
=item Finished checking children
-
+
Master processs's USR1 processing is cojmplete.
=item (Red) CRITICAL: ------- Starting ------
@@ -7502,7 +8374,7 @@ Started a new child process for <client>
connected to the child. This was as a result of a TCP/IP connection from a client.
=item Unable to determine who caller was, getpeername returned nothing
-
+
In child process initialization. either getpeername returned undef or
a zero sized object was returned. Processing continues, but in my opinion,
this should be cause for the child to exit.
@@ -7513,7 +8385,7 @@ In child process initialization. The pe
The client address is stored as "Unavailable" and processing continues.
=item (Yellow) INFO: Connection <ip> <name> connection type = <type>
-
+
In child initialization. A good connectionw as received from <ip>.
=over 2
@@ -7563,7 +8435,7 @@ The client (<client> is the peer's name
negotiated an SSL connection with this child process.
=item (Green) Successful insecure authentication with <client>
-
+
The client has successfully negotiated an insecure connection withthe child process.
@@ -7577,5 +8449,7 @@ string.
=back
+=back
+
=cut