--- loncom/lond 2009/08/16 21:49:21 1.421 +++ loncom/lond 2010/05/23 10:45:46 1.442 @@ -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.442 2010/05/23 10:45:46 www 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.421 $'; #' stupid emacs +my $VERSION='$Revision: 1.442 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -67,6 +66,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; @@ -975,6 +975,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++) { @@ -1815,8 +1818,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 +1829,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 +1849,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 +1874,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 +2064,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,16 +2091,23 @@ 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; @@ -2120,6 +2135,7 @@ sub update_resource_handler { } alarm(0); } + # we successfully transfered, copy file over to real name rename($transname,$fname); &devalidate_meta_cache($fname); } @@ -3110,6 +3126,15 @@ 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|co|in|ta|ep|ad|st|cr)/) { + if ($clientversion =~ /^(\d+)\.(\d+)$/) { + my $major = $1; + my $minor = $2; + next if (($major < 2) || (($major == 2) && ($minor < 9))); + } + } + } if ($regexp eq '.') { $count++; if (defined($range) && $count >= $end) { last; } @@ -3693,12 +3718,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 +3739,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 +3798,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 +3825,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 +3840,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'}) { @@ -3824,6 +3872,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 $udom.':'.$items->{'owner'}) { + $canclone = 1; + } + if ($canclone) { + $items->{'cloners'} = $cloneruname.':'.$clonerudom; + $valchange = 1; + } + } } } if ($unpack || !$rtn_as_hash) { @@ -3832,15 +3893,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 +3937,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 +4085,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 +4175,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 +4225,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 +4321,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 +4841,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 +4866,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 +5080,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: @@ -6301,7 +6337,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]; @@ -6329,7 +6365,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 @@ -6349,6 +6385,7 @@ sub make_new_child { } if($inittype eq "local") { + $clientversion = $perlvar{'lonVersion'}; my $key = LocalConnection($client, $remotereq); if($key) { Debug("Got local key $key"); @@ -6356,7 +6393,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 { @@ -6578,9 +6615,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"); @@ -6675,54 +6710,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, @@ -6753,6 +6758,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)=@_; @@ -7873,5 +7937,7 @@ string. =back +=back + =cut