--- loncom/lond 2009/08/22 19:52:08 1.424
+++ loncom/lond 2009/10/08 19:54:26 1.428
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.424 2009/08/22 19:52:08 raeburn Exp $
+# $Id: lond,v 1.428 2009/10/08 19:54:26 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -59,7 +59,7 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.424 $'; #' stupid emacs
+my $VERSION='$Revision: 1.428 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -1815,8 +1815,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 +1826,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 +1846,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 +1871,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;
@@ -3693,12 +3704,15 @@ 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
#
# $client - The socket open on the client.
# Returns:
@@ -3711,7 +3725,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) =split(/:/,$tail);
my $now = time;
my ($cloneruname,$clonerudom,%cc_clone);
if (defined($description)) {
@@ -3769,6 +3784,21 @@ sub dump_course_id_handler {
$cc_clone{$clonedom.'_'.$clonenum} = 1;
}
}
+ if (defined($createdbefore)) {
+ $createdbefore = &unescape($createdbefore);
+ } else {
+ $createdbefore = 0;
+ }
+ if (defined($createdafter)) {
+ $createdafter = &unescape($createdafter);
+ } else {
+ $createdafter = 0;
+ }
+ if (defined($creationcontext)) {
+ $creationcontext = &unescape($creationcontext);
+ } else {
+ $creationcontext = '.';
+ }
my $unpack = 1;
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
@@ -3781,7 +3811,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;
@@ -3832,15 +3863,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 +3907,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;
@@ -4052,60 +4098,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.
@@ -4156,50 +4148,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 +4244,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
#
@@ -4897,8 +4791,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;
}