--- loncom/lond 2009/08/22 19:10:01 1.423
+++ loncom/lond 2010/11/12 21:52:51 1.466
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.423 2009/08/22 19:10:01 raeburn Exp $
+# $Id: lond,v 1.466 2010/11/12 21:52:51 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -42,7 +42,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;
@@ -59,7 +58,7 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.423 $'; #' stupid emacs
+my $VERSION='$Revision: 1.466 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -67,6 +66,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;
@@ -975,6 +977,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 +1073,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 +1112,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 +1121,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 +1151,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
@@ -1653,6 +1660,14 @@ 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);
+
# 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.
@@ -1762,15 +1777,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
#
@@ -1815,8 +1864,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);
@@ -1825,9 +1875,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);
}
@@ -1841,8 +1895,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 "
@@ -1863,7 +1920,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;
@@ -2050,16 +2110,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).
@@ -2083,20 +2137,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");
@@ -2104,11 +2168,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;
@@ -2120,6 +2186,7 @@ sub update_resource_handler {
}
alarm(0);
}
+ # we successfully transfered, copy file over to real name
rename($transname,$fname);
&devalidate_meta_cache($fname);
}
@@ -3088,7 +3155,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 {
@@ -3106,10 +3173,41 @@ 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 =~ 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; }
@@ -3126,6 +3224,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 {
@@ -3693,12 +3797,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#
+# 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.
+# 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:
@@ -3711,7 +3821,8 @@ 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) =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)) {
@@ -3769,7 +3880,21 @@ sub dump_course_id_handler {
$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 '.' &&
$typefilter eq '.') {
@@ -3781,7 +3906,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;
@@ -3795,8 +3921,13 @@ sub dump_course_id_handler {
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 (defined($clonerudom)) {
+ if ($domcloner) {
+ $canclone = 1;
+ } elsif (defined($clonerudom)) {
if ($items->{'cloners'}) {
my @cloneable = split(',',$items->{'cloners'});
if (@cloneable) {
@@ -3824,6 +3955,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) {
@@ -3832,15 +3976,28 @@ sub dump_course_id_handler {
$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'});
@@ -3863,6 +4020,8 @@ sub dump_course_id_handler {
} else {
next if ($catfilter ne '');
next if ($selfenrollonly);
+ next if ($createdbefore || $createdafter);
+ next if ($creationcontext ne '.');
if ((defined($clonerudom)) && (defined($cloneruname))) {
if ($cc_clone{$unesc_key}) {
$canclone = 1;
@@ -4009,6 +4168,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
#
@@ -4052,60 +4258,6 @@ sub put_domain_handler {
}
®ister_handler("putdom", \&put_domain_handler, 0, 1, 0);
-#
-# Puts a piece of new data in a namespace db file at the domain level
-# returns error if key already exists
-#
-# Parameters:
-# $cmd - The command that got us here.
-# $tail - Tail of the command (remaining parameters).
-# $client - File descriptor connected to client.
-# Returns
-# 0 - Requested to exit, caller should shut down.
-# 1 - Continue processing.
-# Side effects:
-# reply is written to $client.
-#
-sub newput_domain_handler {
- my ($cmd, $tail, $client) = @_;
-
- my $userinput = "$cmd:$tail";
-
- my ($udom,$namespace,$what) =split(/:/,$tail,3);
- chomp($what);
- my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
- "N", $what);
- if(!$hashref) {
- &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting newputdom\n", $userinput);
- return 1;
- }
-
- my @pairs=split(/\&/,$what);
- foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- if (exists($hashref->{$key})) {
- &Failure($client, "key_exists: ".$key."\n",$userinput);
- return 1;
- }
- }
-
- foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- $hashref->{$key}=$value;
- }
-
- if (&untie_domain_hash($hashref)) {
- &Reply( $client, "ok\n", $userinput);
- } else {
- &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
- "while attempting newputdom\n",
- $userinput);
- }
- return 1;
-}
-®ister_handler("newputdom", \&newput_domain_handler, 0, 1, 0);
-
# Unencrypted get from the namespace database file at the domain level.
# This function retrieves a keyed item from a specific named database in the
# domain directory.
@@ -4128,6 +4280,7 @@ sub newput_domain_handler {
sub get_domain_handler {
my ($cmd, $tail, $client) = @_;
+
my $userinput = "$client:$tail";
my ($udom,$namespace,$what)=split(/:/,$tail,3);
@@ -4156,50 +4309,6 @@ sub get_domain_handler {
®ister_handler("getdom", \&get_domain_handler, 0, 1, 0);
#
-# Deletes a key in a user profile database.
-#
-# Parameters:
-# $cmd - Command keyword (deldom).
-# $tail - Command tail. IN this case a colon
-# separated list containing:
-# the domain to which the database file belongs;
-# the namespace (name of the database file);
-# & separated list of keys to delete.
-# $client - File open on client socket.
-# Returns:
-# 1 - Continue processing
-# 0 - Exit server.
-#
-#
-sub delete_domain_entry {
- my ($cmd, $tail, $client) = @_;
-
- my $userinput = "cmd:$tail";
-
- my ($udom,$namespace,$what) = split(/:/,$tail);
- chomp($what);
- my $hashref = &tie_domain_hash($udom, $namespace, &GDBM_WRCREAT(),
- "D",$what);
- if ($hashref) {
- my @keys=split(/\&/,$what);
- foreach my $key (@keys) {
- delete($hashref->{$key});
- }
- if (&untie_user_hash($hashref)) {
- &Reply($client, "ok\n", $userinput);
- } else {
- &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
- "while attempting deldom\n", $userinput);
- }
- } else {
- &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting deldom\n", $userinput);
- }
- return 1;
-}
-®ister_handler("deldom", \&delete_domain_entry, 0, 1, 0);
-
-#
# Puts an id to a domains id database.
#
# Parameters:
@@ -4296,60 +4405,6 @@ sub get_id_handler {
}
®ister_handler("idget", \&get_id_handler, 0, 1, 0);
-sub dump_dom_with_regexp {
- my ($cmd, $tail, $client) = @_;
- my $userinput = "$cmd:$tail";
- my ($udom,$namespace,$regexp,$range)=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_domain_hash($udom, $namespace, &GDBM_READER());
- if ($hashref) {
- my $qresult='';
- my $count=0;
- while (my ($key,$value) = each(%$hashref)) {
- 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)) {
- chop($qresult);
- &Reply($client, \$qresult, $userinput);
- } else {
- &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
- }
- } else {
- &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
- }
- return 1;
-}
-®ister_handler("dumpdom", \&dump_dom_with_regexp, 0, 1, 0);
-
#
# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database
#
@@ -4370,7 +4425,8 @@ sub dump_dom_with_regexp {
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());
@@ -4634,7 +4690,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;
@@ -4877,10 +4933,16 @@ sub enrollment_enabled_handler {
# $tail - The tail of the command. In this case,
# this is a colon separated set of words that will be split
# into:
-# $inst_course_id - The institutional cod3 from the
-# institutions point of view.
-# $cdom - The domain from the institutions
-# point of view.
+# $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.
@@ -4891,8 +4953,10 @@ sub validate_instcode_handler {
my ($dom,$instcode,$owner) = split(/:/, $tail);
$instcode = &unescape($instcode);
$owner = &unescape($owner);
- my $outcome=&localenroll::validate_instcode($dom,$instcode,$owner);
- &Reply($client, \$outcome, $userinput);
+ my ($outcome,$description) =
+ &localenroll::validate_instcode($dom,$instcode,$owner);
+ my $result = &escape($outcome).'&'.&escape($description);
+ &Reply($client, \$result, $userinput);
return 1;
}
@@ -5106,10 +5170,12 @@ sub crsreq_checks_handler {
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,\%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}).'&';
@@ -6171,7 +6237,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");
@@ -6260,6 +6326,7 @@ $SIG{USR2} = \&UpdateHosts;
# Read the host hashes:
&Apache::lonnet::load_hosts_tab();
+my %iphost = &Apache::lonnet::get_iphost(1);
my $dist=`$perlvar{'lonDaemons'}/distprobe`;
@@ -6320,6 +6387,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.
@@ -6356,7 +6424,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];
@@ -6384,7 +6452,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
@@ -6404,6 +6472,7 @@ sub make_new_child {
}
if($inittype eq "local") {
+ $clientversion = $perlvar{'lonVersion'};
my $key = LocalConnection($client, $remotereq);
if($key) {
Debug("Got local key $key");
@@ -6411,7 +6480,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 {
@@ -6475,6 +6544,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");
@@ -6633,9 +6705,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");
@@ -6730,54 +6800,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,
@@ -6808,6 +6848,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)=@_;
@@ -7178,7 +7277,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");
@@ -7193,6 +7292,182 @@ 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;
+}
# ----------------------------------- POD (plain old documentation, CPAN style)
@@ -7928,5 +8203,7 @@ string.
=back
+=back
+
=cut
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.