--- loncom/lond 2009/08/16 21:49:21 1.421 +++ loncom/lond 2009/10/21 16:14:24 1.431 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.421 2009/08/16 21:49:21 raeburn Exp $ +# $Id: lond,v 1.431 2009/10/21 16:14:24 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.421 $'; #' stupid emacs +my $VERSION='$Revision: 1.431 $'; #' 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 ($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 +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; @@ -3795,6 +3826,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 +3866,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 +3910,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 +4101,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 +4151,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 +4247,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 # @@ -4870,17 +4767,23 @@ sub enrollment_enabled_handler { ®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0); # -# Validate an institutional code use for a LON-CAPA course. +# Validate an institutional code used for a LON-CAPA course. # # 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: -# $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. @@ -4889,8 +4792,12 @@ sub validate_instcode_handler { my ($cmd, $tail, $client) = @_; my $userinput = "$cmd:$tail"; my ($dom,$instcode,$owner) = split(/:/, $tail); - my $outcome=&localenroll::validate_instcode($dom,$instcode,$owner); - &Reply($client, \$outcome, $userinput); + $instcode = &unescape($instcode); + $owner = &unescape($owner); + my ($outcome,$description) = + &localenroll::validate_instcode($dom,$instcode,$owner); + my $result = &escape($outcome).'&'.&escape($description); + &Reply($client, \$result, $userinput); return 1; } @@ -5099,6 +5006,61 @@ sub retrieve_auto_file_handler { } ®ister_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0); +sub crsreq_checks_handler { + my ($cmd, $tail, $client) = @_; + 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,\@reqtypes, + \%validations); + if ($response eq 'ok') { + foreach my $key (keys(%validations)) { + $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&'; + } + $result =~ s/\&$//; + } else { + $result = 'error'; + } + }; + if (!$@) { + &Reply($client, \$result, $userinput); + } else { + &Failure($client,"unknown_cmd\n",$userinput); + } + return 1; +} +®ister_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0); + +sub validate_crsreq_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = split(/:/, $tail); + $instcode = &unescape($instcode); + $owner = &unescape($owner); + $crstype = &unescape($crstype); + $inststatuslist = &unescape($inststatuslist); + $instcode = &unescape($instcode); + $instseclist = &unescape($instseclist); + my $outcome; + eval { + local($SIG{__DIE__})='DEFAULT'; + $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype, + $inststatuslist,$instcode, + $instseclist); + }; + if (!$@) { + &Reply($client, \$outcome, $userinput); + } else { + &Failure($client,"unknown_cmd\n",$userinput); + } + return 1; +} +®ister_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0); + # # Read and retrieve institutional code format (for support form). # Formal Parameters: