--- loncom/lond 2006/05/18 02:32:06 1.328
+++ loncom/lond 2006/10/11 19:15:47 1.343
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.328 2006/05/18 02:32:06 albertel Exp $
+# $Id: lond,v 1.343 2006/10/11 19:15:47 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -58,9 +58,8 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $lond_max_wait_time = 13;
-my $VERSION='$Revision: 1.328 $'; #' stupid emacs
+my $VERSION='$Revision: 1.343 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -836,16 +835,14 @@ sub AdjustOurHost {
# Use the config line to get my hostname.
# Use gethostbyname to translate that into an IP address.
#
- my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
- my $BinaryIp = gethostbyname($name);
- my $ip = inet_ntoa($ip);
+ my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
#
# Reassemble the config line from the elements in the list.
# Note that if the loncnew items were not present before, they will
# be now even if they would be empty
#
my $newConfigLine = $id;
- foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
+ foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) {
$newConfigLine .= ":".$item;
}
# Replace the line:
@@ -891,11 +888,11 @@ sub EditFile {
# Split the command into it's pieces: edit:filetype:script
- my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
+ my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script
# Check the pre-coditions for success:
- if($request != "edit") { # Something is amiss afoot alack.
+ if($cmd != "edit") { # Something is amiss afoot alack.
return "error:edit request detected, but request != 'edit'\n";
}
if( ($filetype ne "hosts") &&
@@ -940,181 +937,6 @@ sub EditFile {
return "ok\n";
}
-#---------------------------------------------------------------
-#
-# Manipulation of hash based databases (factoring out common code
-# for later use as we refactor.
-#
-# Ties a domain level resource file to a hash.
-# If requested a history entry is created in the associated hist file.
-#
-# Parameters:
-# domain - Name of the domain in which the resource file lives.
-# namespace - Name of the hash within that domain.
-# how - How to tie the hash (e.g. GDBM_WRCREAT()).
-# loghead - Optional parameter, if present a log entry is created
-# in the associated history file and this is the first part
-# of that entry.
-# logtail - Goes along with loghead, The actual logentry is of the
-# form $loghead:<timestamp>:logtail.
-# Returns:
-# Reference to a hash bound to the db file or alternatively undef
-# if the tie failed.
-#
-sub tie_domain_hash {
- my ($domain,$namespace,$how,$loghead,$logtail) = @_;
-
- # Filter out any whitespace in the domain name:
-
- $domain =~ s/\W//g;
-
- # We have enough to go on to tie the hash:
-
- my $user_top_dir = $perlvar{'lonUsersDir'};
- my $domain_dir = $user_top_dir."/$domain";
- my $resource_file = $domain_dir."/$namespace";
- return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
-}
-
-sub untie_domain_hash {
- return &_locking_hash_untie(@_);
-}
-#
-# Ties a user's resource file to a hash.
-# If necessary, an appropriate history
-# log file entry is made as well.
-# This sub factors out common code from the subs that manipulate
-# the various gdbm files that keep keyword value pairs.
-# Parameters:
-# domain - Name of the domain the user is in.
-# user - Name of the 'current user'.
-# namespace - Namespace representing the file to tie.
-# how - What the tie is done to (e.g. GDBM_WRCREAT().
-# loghead - Optional first part of log entry if there may be a
-# history file.
-# what - Optional tail of log entry if there may be a history
-# file.
-# Returns:
-# hash to which the database is tied. It's up to the caller to untie.
-# undef if the has could not be tied.
-#
-sub tie_user_hash {
- my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
-
- $namespace=~s/\//\_/g; # / -> _
- $namespace=~s/\W//g; # whitespace eliminated.
- my $proname = propath($domain, $user);
-
- my $file_prefix="$proname/$namespace";
- return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
-}
-
-sub untie_user_hash {
- return &_locking_hash_untie(@_);
-}
-
-# internal routines that handle the actual tieing and untieing process
-
-sub _do_hash_tie {
- my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
- my %hash;
- if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
- # If this is a namespace for which a history is kept,
- # make the history log entry:
- if (($namespace !~/^nohist\_/) && (defined($loghead))) {
- my $args = scalar @_;
- Debug(" Opening history: $file_prefix $args");
- my $hfh = IO::File->new(">>$file_prefix.hist");
- if($hfh) {
- my $now = time;
- print $hfh "$loghead:$now:$what\n";
- }
- $hfh->close;
- }
- return \%hash;
- } else {
- return undef;
- }
-}
-
-sub _do_hash_untie {
- my ($hashref) = @_;
- my $result = untie(%$hashref);
- return $result;
-}
-
-{
- my $sym;
-
- sub _locking_hash_tie {
- my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
- my $lock_type=LOCK_SH;
-# Are we reading or writing?
- if ($how eq &GDBM_READER()) {
-# We are reading
- if (!open($sym,"$file_prefix.db.lock")) {
-# We don't have a lock file. This could mean
-# - that there is no such db-file
-# - that it does not have a lock file yet
- if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
-# No such file. Forget it.
- $! = 2;
- return undef;
- }
-# Apparently just no lock file yet. Make one
- open($sym,">>$file_prefix.db.lock");
- }
- } elsif ($how eq &GDBM_WRCREAT()) {
-# We are writing
- open($sym,">>$file_prefix.db.lock");
-# Writing needs exclusive lock
- $lock_type=LOCK_EX;
- } else {
- &logthis("Unknown method $how for $file_prefix");
- die();
- }
-# If this is compressed, we will also need an exclusive lock
- if (-e "$file_prefix.db.gz") { $lock_type=LOCK_EX; }
-# Okay, try to obtain the lock we want
- my $failed=0;
- eval {
- local $SIG{__DIE__}='DEFAULT';
- local $SIG{ALRM}=sub {
- $failed=1;
- die("failed lock");
- };
- alarm($lond_max_wait_time);
- flock($sym,$lock_type);
- alarm(0);
- };
- if ($failed) {
- $! = 100; # throwing error # 100
- return undef;
- }
-# The file is ours!
-# If it is archived, un-archive it now
- if (-e "$file_prefix.db.gz") {
- system("gunzip $file_prefix.db.gz");
- if (-e "$file_prefix.hist.gz") {
- system("gunzip $file_prefix.hist.gz");
- }
- }
-# Change access mode to non-blocking
- $how=$how|&GDBM_NOLOCK();
-# Go ahead and tie the hash
- return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
- }
-
- sub _locking_hash_untie {
- my ($hashref) = @_;
- my $result = untie(%$hashref);
- flock($sym,LOCK_UN);
- close($sym);
- undef($sym);
- return $result;
- }
-}
-
# read_profile
#
# Returns a set of specific entries from a user's profile file.
@@ -1428,7 +1250,7 @@ sub push_file_handler {
#
sub du_handler {
my ($cmd, $ududir, $client) = @_;
- my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
+ ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
my $userinput = "$cmd:$ududir";
if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
@@ -2023,6 +1845,7 @@ sub update_resource_handler {
my $reply=&reply("unsub:$fname","$clientname");
&devalidate_meta_cache($fname);
unlink("$fname");
+ unlink("$fname.meta");
} else {
my $transname="$fname.in.transfer";
my $remoteurl=&reply("sub:$fname","$clientname");
@@ -2300,11 +2123,21 @@ sub token_auth_user_file_handler {
chomp($session);
my $reply="non_auth\n";
- if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
- $session.'.id')) {
- while (my $line=<ENVIN>) {
- if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }
+ my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
+ if (open(ENVIN,"$file")) {
+ flock(ENVIN,LOCK_SH);
+ tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
+ if (exists($disk_env{"userfile.$fname"})) {
+ $reply="ok\n";
+ } else {
+ foreach my $envname (keys(%disk_env)) {
+ if ($envname=~ m|^userfile\.\Q$fname\E|) {
+ $reply="ok\n";
+ last;
+ }
+ }
}
+ untie(%disk_env);
close(ENVIN);
&Reply($client, $reply, "$cmd:$tail");
} else {
@@ -2767,7 +2600,7 @@ sub get_profile_entry_encrypted {
my $userinput = "$cmd:$tail";
- my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
+ my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
chomp($what);
my $qresult = read_profile($udom, $uname, $namespace, $what);
my ($first) = split(/:/, $qresult);
@@ -3213,7 +3046,7 @@ sub restore_handler {
my $userinput = "$cmd:$tail"; # Only used for logging purposes.
- my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);
+ my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);
$namespace=~s/\//\_/g;
$namespace=~s/\W//g;
chomp($rid);
@@ -3388,7 +3221,7 @@ sub reply_query_handler {
my $userinput = "$cmd:$tail";
- my ($cmd,$id,$reply)=split(/:/,$userinput);
+ my ($id,$reply)=split(/:/,$tail);
my $store;
my $execdir=$perlvar{'lonDaemons'};
if ($store=IO::File->new(">$execdir/tmp/$id")) {
@@ -3461,10 +3294,10 @@ sub put_course_id_handler {
my @new_items = split(/:/,$courseinfo);
my $numnew = scalar(@new_items);
if ($numcurrent > 0) {
- if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier
- $courseinfo .= ':'.join(':',@current_items);
- } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X
- $courseinfo .= ':'.$current_items[$numcurrent-1];
+ if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2
+ for (my $j=$numcurrent-$numnew; $j>=0; $j--) {
+ $courseinfo .= ':'.$current_items[$numcurrent-$j-1];
+ }
}
}
$hashref->{$key}=$courseinfo.':'.$now;
@@ -3508,12 +3341,11 @@ sub put_course_id_handler {
# institutional code - optional supplied code to filter
# the dump. Only courses with an institutional code
# that match the supplied code will be returned.
-# owner - optional supplied username of owner to filter
-# the dump. Only courses for which the course
-# owner matches the supplied username will be
-# returned. Implicit assumption that owner
-# is a user in the domain in which the
-# course database is defined.
+# owner - optional supplied username and domain of owner to
+# filter the dump. Only courses for which the course
+# owner matches the supplied username and/or domain
+# will be returned. Pre-2.2.0 legacy entries from
+# nohist_courseiddump will only contain usernames.
# $client - The socket open on the client.
# Returns:
# 1 - Continue processing.
@@ -3524,7 +3356,8 @@ sub dump_course_id_handler {
my $userinput = "$cmd:$tail";
- my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);
+ my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
+ $typefilter) =split(/:/,$tail);
if (defined($description)) {
$description=&unescape($description);
} else {
@@ -3535,26 +3368,42 @@ sub dump_course_id_handler {
} else {
$instcodefilter='.';
}
+ my ($ownerunamefilter,$ownerdomfilter);
if (defined($ownerfilter)) {
$ownerfilter=&unescape($ownerfilter);
+ if ($ownerfilter ne '.' && defined($ownerfilter)) {
+ if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
+ $ownerunamefilter = $1;
+ $ownerdomfilter = $2;
+ } else {
+ $ownerunamefilter = $ownerfilter;
+ $ownerdomfilter = '';
+ }
+ }
} else {
$ownerfilter='.';
}
+
if (defined($coursefilter)) {
$coursefilter=&unescape($coursefilter);
} else {
$coursefilter='.';
}
+ if (defined($typefilter)) {
+ $typefilter=&unescape($typefilter);
+ } else {
+ $typefilter='.';
+ }
unless (defined($since)) { $since=0; }
my $qresult='';
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {
- my ($descr,$lasttime,$inst_code,$owner);
+ my ($descr,$lasttime,$inst_code,$owner,$type);
my @courseitems = split(/:/,$value);
$lasttime = pop(@courseitems);
- ($descr,$inst_code,$owner)=@courseitems;
+ ($descr,$inst_code,$owner,$type)=@courseitems;
if ($lasttime<$since) { next; }
my $match = 1;
unless ($description eq '.') {
@@ -3571,8 +3420,37 @@ sub dump_course_id_handler {
}
unless ($ownerfilter eq '.' || !defined($ownerfilter)) {
my $unescapeOwner = &unescape($owner);
- unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {
- $match = 0;
+ if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
+ if ($unescapeOwner =~ /:/) {
+ if (eval('$unescapeOwner !~
+ /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {
+ $match = 0;
+ }
+ } else {
+ if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {
+ $match = 0;
+ }
+ }
+ } elsif ($ownerunamefilter ne '') {
+ if ($unescapeOwner =~ /:/) {
+ if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {
+ $match = 0;
+ }
+ } else {
+ if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {
+ $match = 0;
+ }
+ }
+ } elsif ($ownerdomfilter ne '') {
+ if ($unescapeOwner =~ /:/) {
+ if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {
+ $match = 0;
+ }
+ } else {
+ if ($ownerdomfilter ne $udom) {
+ $match = 0;
+ }
+ }
}
}
unless ($coursefilter eq '.' || !defined($coursefilter)) {
@@ -3581,6 +3459,18 @@ sub dump_course_id_handler {
$match = 0;
}
}
+ unless ($typefilter eq '.' || !defined($typefilter)) {
+ my $unescapeType = &unescape($type);
+ if ($type eq '') {
+ if ($typefilter ne 'Course') {
+ $match = 0;
+ }
+ } else {
+ unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {
+ $match = 0;
+ }
+ }
+ }
if ($match == 1) {
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
}
@@ -4198,7 +4088,8 @@ sub enrollment_enabled_handler {
my $userinput = $cmd.":".$tail; # For logging purposes.
- my $cdom = split(/:/, $tail); # Domain we're asking about.
+ my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about.
+
my $outcome = &localenroll::run($cdom);
&Reply($client, "$outcome\n", $userinput);
@@ -4254,6 +4145,7 @@ sub validate_course_owner_handler {
my $userinput = "$cmd:$tail";
my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
+ $owner = &unescape($owner);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
&Reply($client, "$outcome\n", $userinput);
@@ -4294,16 +4186,47 @@ sub validate_course_section_handler {
®ister_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
#
-# Create a password for a new auto-enrollment user.
-# I think/guess, this password allows access to the institutions
-# AIS class list server/services. Stuart can correct this comment
-# when he finds out how wrong I am.
+# Validate course owner's access to enrollment data for specific class section.
+#
#
# 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:
-# $authparam - An authentication parameter (username??).
+# $inst_class - Institutional code for the specific class section
+# $courseowner - The escaped username:domain of the course owner
+# $cdom - The domain of the course from the institution's
+# point of view.
+# $client - The socket open on the client.
+# Returns:
+# 1 - continue processing.
+#
+
+sub validate_class_access_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($inst_class,$courseowner,$cdom) = split(/:/, $tail);
+ $courseowner = &unescape($courseowner);
+ my $outcome;
+ eval {
+ local($SIG{__DIE__})='DEFAULT';
+ $outcome=&localenroll::check_section($inst_class,$courseowner,$cdom);
+ };
+ &Reply($client,"$outcome\n", $userinput);
+
+ return 1;
+}
+®ister_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);
+
+#
+# Create a password for a new LON-CAPA user added by auto-enrollment.
+# Only used for case where authentication method for new user is localauth
+#
+# 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:
+# $authparam - An authentication parameter (localauth parameter).
# $cdom - The domain of the course from the institution's
# point of view.
# $client - The socket open on the client.
@@ -5269,18 +5192,6 @@ sub sub_sql_reply {
return $answer;
}
-# -------------------------------------------- Return path to profile directory
-
-sub propath {
- my ($udom,$uname)=@_;
- $udom=~s/\W//g;
- $uname=~s/\W//g;
- my $subdir=$uname.'__';
- $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
- my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
- return $proname;
-}
-
# --------------------------------------- Is this the home server of an author?
sub ishome {
@@ -5446,7 +5357,7 @@ sub make_new_child {
my $remotereq=<$client>;
chomp($remotereq);
Debug("Got init: $remotereq");
- my $inikeyword = split(/:/, $remotereq);
+
if ($remotereq =~ /^init/) {
&sethost("sethost:$perlvar{'lonHostID'}");
#
@@ -5879,7 +5790,7 @@ sub get_chat {
my @entries=();
my $namespace = 'nohist_chatroom';
my $namespace_inroom = 'nohist_inchatroom';
- if (defined($group)) {
+ if ($group ne '') {
$namespace .= '_'.$group;
$namespace_inroom .= '_'.$group;
}
@@ -5911,7 +5822,7 @@ sub chat_add {
my $time=time;
my $namespace = 'nohist_chatroom';
my $logfile = 'chatroom.log';
- if (defined($group)) {
+ if ($group ne '') {
$namespace .= '_'.$group;
$logfile = 'chatroom_'.$group.'.log';
}