--- loncom/lond 2011/06/11 21:10:03 1.475
+++ loncom/lond 2013/05/11 22:42:22 1.489.2.5
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.475 2011/06/11 21:10:03 raeburn Exp $
+# $Id: lond,v 1.489.2.5 2013/05/11 22:42:22 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -34,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;
@@ -60,7 +61,7 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.475 $'; #' stupid emacs
+my $VERSION='$Revision: 1.489.2.5 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -92,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:
@@ -151,8 +154,8 @@ my @adderrors = ("ok",
my @installerrors = ("ok",
"Initial user id of client not that of www",
"Usage error, not enough command line arguments",
- "Source file name does not exist",
- "Destination file name does not exist",
+ "Source filename does not exist",
+ "Destination filename does not exist",
"Some file operation failed",
"Invalid table filename."
);
@@ -1641,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";
@@ -2003,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);
@@ -2078,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,
@@ -2278,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);
@@ -2300,6 +2374,24 @@ sub fetch_user_file_handler {
unlink($transname);
&Failure($client, "failed\n", $userinput);
} else {
+ if ($fname =~ /^default.+\.(page|sequence)$/) {
+ my ($major,$minor) = split(/\./,$clientversion);
+ if (($major < 2) || ($major == 2 && $minor < 11)) {
+ my $now = time;
+ &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600);
+ my $key = &escape('internal.contentchange');
+ my $what = "$key=$now";
+ my $hashref = &tie_user_hash($udom,$uname,'environment',
+ &GDBM_WRCREAT(),"P",$what);
+ if ($hashref) {
+ $hashref->{$key}=$now;
+ if (!&untie_user_hash($hashref)) {
+ &logthis("error: ".($!+0)." untie (GDBM) failed ".
+ "when updating internal.contentchange");
+ }
+ }
+ }
+ }
&Reply($client, "ok\n", $userinput);
}
}
@@ -3172,6 +3264,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.
@@ -3181,93 +3276,12 @@ sub dump_profile_database {
sub dump_with_regexp {
my ($cmd, $tail, $client) = @_;
+ my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);
- my $userinput = "$cmd:$tail";
-
- my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
- if (defined($regexp)) {
- $regexp=&unescape($regexp);
- } else {
- $regexp='.';
- }
- my ($start,$end);
- if (defined($range)) {
- if ($range =~/^(\d+)\-(\d+)$/) {
- ($start,$end) = ($1,$2);
- } elsif ($range =~/^(\d+)$/) {
- ($start,$end) = (0,$1);
- } else {
- undef($range);
- }
- }
- 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 =~ 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));
- }
- }
- }
- }
- if ($regexp eq '.') {
- $count++;
- if (defined($range) && $count >= $end) { last; }
- if (defined($range) && $count < $start) { next; }
- $qresult.=$key.'='.$value.'&';
- } else {
- my $unescapeKey = &unescape($key);
- if (eval('$unescapeKey=~/$regexp/')) {
- $count++;
- if (defined($range) && $count >= $end) { last; }
- if (defined($range) && $count < $start) { next; }
- $qresult.="$key=$value&";
- }
- }
- }
- 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 {
- &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
- }
+ if ($res =~ /^error:/) {
+ &Failure($client, \$res, "$cmd:$tail");
} else {
- &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
+ &Reply($client, \$res, "$cmd:$tail");
}
return 1;
@@ -3925,7 +3939,7 @@ sub dump_course_id_handler {
$creationcontext = '.';
}
my $unpack = 1;
- if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
+ if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
$typefilter eq '.') {
$unpack = 0;
}
@@ -4982,9 +4996,10 @@ sub validate_instcode_handler {
my ($dom,$instcode,$owner) = split(/:/, $tail);
$instcode = &unescape($instcode);
$owner = &unescape($owner);
- my ($outcome,$description) =
+ my ($outcome,$description,$credits) =
&localenroll::validate_instcode($dom,$instcode,$owner);
- my $result = &escape($outcome).'&'.&escape($description);
+ my $result = &escape($outcome).'&'.&escape($description).'&'.
+ &escape($credits);
&Reply($client, \$result, $userinput);
return 1;
@@ -6362,7 +6377,7 @@ $SIG{USR2} = \&UpdateHosts;
&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);
@@ -6455,7 +6470,8 @@ sub make_new_child {
#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();
unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||
- ($dist eq 'fedora6') || ($dist eq 'suse9.3')) {
+ ($dist eq 'fedora6') || ($dist eq 'suse9.3') ||
+ ($dist eq 'suse12.2') || ($dist eq 'suse12.3')) {
&Authen::Krb5::init_ets();
}
@@ -6501,6 +6517,12 @@ sub make_new_child {
# If the remote is attempting a local init... give that a try:
#
(my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
+ # 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.
+ # $clientversion contains path to keyfile if $inittype eq 'local'
+ # it's overridden below in this case
+ $clientversion ||= $Apache::lonnet::loncaparevs{$clientname};
# If the connection type is ssl, but I didn't get my
# certificate files yet, then I'll drop back to
@@ -6644,22 +6666,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
@@ -6669,16 +6698,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);
+ }
}
}
@@ -7167,7 +7195,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 {
@@ -7209,7 +7239,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') {
{
@@ -7250,7 +7280,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";
}
@@ -7262,6 +7292,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.
@@ -7355,167 +7386,6 @@ sub get_usersession_config {
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;
@@ -7728,7 +7598,7 @@ Place in B
stores hash in namespace
-=item rolesputy
+=item rolesput
put a role into a user's environment