--- loncom/lond 2009/08/22 19:52:08 1.424 +++ loncom/lond 2009/10/29 03:23:52 1.432 @@ -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.432 2009/10/29 03:23:52 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.432 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -67,6 +67,7 @@ my $currentdomainid; my $client; my $clientip; # IP address of client. my $clientname; # LonCAPA name of client. +my $clientversion; # LonCAPA version running on client my $server; @@ -1815,8 +1816,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 +1827,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 +1847,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 +1872,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; @@ -3110,6 +3122,13 @@ sub dump_with_regexp { my $qresult=''; my $count=0; while (my ($key,$value) = each(%$hashref)) { + if ($namespace eq 'roles') { + if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_cc$/) { + if ($clientversion =~ /^(\d+\.\d+)$/) { + next if ($1 <= 2.9); + } + } + } if ($regexp eq '.') { $count++; if (defined($range) && $count >= $end) { last; } @@ -3693,12 +3712,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 +3733,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 +3792,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 '.' && @@ -3781,7 +3819,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,6 +3834,9 @@ 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 ($items->{'cloners'}) { @@ -3832,15 +3874,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 +3918,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 +4109,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 +4159,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 +4255,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 +4802,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; } @@ -6364,7 +6271,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]; @@ -6392,7 +6299,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 @@ -6412,6 +6319,7 @@ sub make_new_child { } if($inittype eq "local") { + $clientversion = $perlvar{'lonVersion'}; my $key = LocalConnection($client, $remotereq); if($key) { Debug("Got local key $key");