[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.432 and 1.446

version 1.432, 2009/10/29 03:23:52 version 1.446, 2010/07/17 19:14:35
Line 42  use Crypt::IDEA; Line 42  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
 use Digest::MD5 qw(md5_hex);  use Digest::MD5 qw(md5_hex);
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  
 use Authen::Krb5;  use Authen::Krb5;
 use localauth;  use localauth;
 use localenroll;  use localenroll;
Line 976  sub read_profile { Line 975  sub read_profile {
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my @queries=split(/\&/,$what);          my @queries=split(/\&/,$what);
           if ($namespace eq 'roles') {
               @queries = map { &unescape($_); } @queries; 
           }
         my $qresult='';          my $qresult='';
   
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
Line 2062  sub is_home_handler { Line 2064  sub is_home_handler {
 &register_handler("home", \&is_home_handler, 0,1,0);  &register_handler("home", \&is_home_handler, 0,1,0);
   
 #  #
 #   Process an update request for a resource?? I think what's going on here is  #   Process an update request for a resource.
 #   that a resource has been modified that we hold a subscription to.  #   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  #   If the resource is not local, then we must update, or at least invalidate our
 #   cached copy of the resource.   #   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:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
 #    $tail     - Tail of the command (remaining parameters).  #    $tail     - Tail of the command (remaining parameters).
Line 2095  sub update_resource_handler { Line 2091  sub update_resource_handler {
     my $ownership=ishome($fname);      my $ownership=ishome($fname);
     if ($ownership eq 'not_owner') {      if ($ownership eq 'not_owner') {
  if (-e $fname) {   if (-e $fname) {
               # Delete preview file, if exists
               unlink("$fname.tmp");
               # Get usage stats
     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
     my $now=time;      my $now=time;
     my $since=$now-$atime;      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'}) {      if ($since>$perlvar{'lonExpire'}) {
  my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");   my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
  &devalidate_meta_cache($fname);   &devalidate_meta_cache($fname);
  unlink("$fname");   unlink("$fname");
  unlink("$fname.meta");   unlink("$fname.meta");
     } else {      } 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 $transname="$fname.in.transfer";
  my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
Line 2132  sub update_resource_handler { Line 2135  sub update_resource_handler {
  }   }
  alarm(0);   alarm(0);
     }      }
                       # we successfully transfered, copy file over to real name
     rename($transname,$fname);      rename($transname,$fname);
     &devalidate_meta_cache($fname);      &devalidate_meta_cache($fname);
  }   }
Line 3123  sub dump_with_regexp { Line 3127  sub dump_with_regexp {
  my $count=0;   my $count=0;
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
             if ($namespace eq 'roles') {              if ($namespace eq 'roles') {
                 if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_cc$/) {                  if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_community)_(cc|co|in|ta|ep|ad|st|cr)}) {
                     if ($clientversion =~ /^(\d+\.\d+)$/) {                      my $cdom = $1;
                         next if ($1 <= 2.9);                      my $cnum = $2;
                       if ($clientversion =~ /^['"]?(\d+)\.(\d+)[.\d\-]+['"]?$/) {
                           my $major = $1;
                           my $minor = $2;
                           next if (($major < 2) || (($major == 2) && ($minor < 9)));
                       } else {
                           my $homeserver = &Apache::lonnet::homeserver($cnum,$cdom);
                           next unless ($currenthostid eq $homeserver);
                     }                      }
                 }                  }
             }              }
Line 3722  sub put_course_id_hash_handler { Line 3733  sub put_course_id_hash_handler {
 #                 createdafter - include courses for which creation date followed this date.  #                 createdafter - include courses for which creation date followed this date.
 #                 creationcontext - include courses created in specified context   #                 creationcontext - include courses created in specified context 
 #  #
   #                 domcloner - flag to indicate if user can create CCs in course's domain.
   #                             If so, ability to clone course is automatic. 
   #
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3734  sub dump_course_id_handler { Line 3748  sub dump_course_id_handler {
     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
         $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,          $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
         $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,          $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
         $creationcontext) =split(/:/,$tail);          $creationcontext,$domcloner) =split(/:/,$tail);
     my $now = time;      my $now = time;
     my ($cloneruname,$clonerudom,%cc_clone);      my ($cloneruname,$clonerudom,%cc_clone);
     if (defined($description)) {      if (defined($description)) {
Line 3807  sub dump_course_id_handler { Line 3821  sub dump_course_id_handler {
     } else {      } else {
         $creationcontext = '.';          $creationcontext = '.';
     }      }
       
     my $unpack = 1;      my $unpack = 1;
     if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&       if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && 
         $typefilter eq '.') {          $typefilter eq '.') {
Line 3838  sub dump_course_id_handler { Line 3851  sub dump_course_id_handler {
                     next if ($since > 1);                      next if ($since > 1);
                 }                  }
                 $is_hash =  1;                  $is_hash =  1;
                 if (defined($clonerudom)) {                  if ($domcloner) {
                       $canclone = 1;
                   } elsif (defined($clonerudom)) {
                     if ($items->{'cloners'}) {                      if ($items->{'cloners'}) {
                         my @cloneable = split(',',$items->{'cloners'});                          my @cloneable = split(',',$items->{'cloners'});
                         if (@cloneable) {                          if (@cloneable) {
Line 3866  sub dump_course_id_handler { Line 3881  sub dump_course_id_handler {
                             $items->{'cloners'} = $cloneruname.':'.$clonerudom;                              $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                             $valchange = 1;                              $valchange = 1;
                         }                          }
                           unless ($canclone) {
                               if ($items->{'owner'} =~ /:/) {
                                   if ($items->{'owner'} eq $cloner) {
                                       $canclone = 1;
                                   }
                               } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
                                   $canclone = 1;
                               }
                               if ($canclone) {
                                   $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                                   $valchange = 1;
                               }
                           }
                     }                      }
                 }                  }
                 if ($unpack || !$rtn_as_hash) {                  if ($unpack || !$rtn_as_hash) {
Line 4066  sub dump_course_id_handler { Line 4094  sub dump_course_id_handler {
 }  }
 &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);  &register_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;
   }
   &register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
   
 #  #
 # Puts an unencrypted entry in a namespace db file at the domain level   # Puts an unencrypted entry in a namespace db file at the domain level 
 #  #
Line 6327  sub make_new_child { Line 6402  sub make_new_child {
  my $cipherkey = pack("H32", $key);   my $cipherkey = pack("H32", $key);
  $cipher       = new IDEA($cipherkey);   $cipher       = new IDEA($cipherkey);
  print $client "ok:local\n";   print $client "ok:local\n";
  &logthis('<font color="green"'   &logthis('<font color="green">'
  . "Successful local authentication </font>");   . "Successful local authentication </font>");
  $keymode = "local"   $keymode = "local"
     } else {      } else {
Line 6549  sub rewrite_password_file { Line 6624  sub rewrite_password_file {
   
 #     Returns the authorization type or nouser if there is no such user.  #     Returns the authorization type or nouser if there is no such user.
 #  #
 sub get_auth_type   sub get_auth_type {
 {  
   
     my ($domain, $user)  = @_;      my ($domain, $user)  = @_;
   
     Debug("get_auth_type( $domain, $user ) \n");      Debug("get_auth_type( $domain, $user ) \n");
Line 6646  sub validate_user { Line 6719  sub validate_user {
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
  }   } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
  elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.              my $checkwithkrb5 = 0;
     if(! ($password =~ /$null/) ) {              if ($dist =~/^fedora(\d+)$/) {
  my $k4error = &Authen::Krb4::get_pw_in_tkt($user,                  if ($1 > 11) {
    "",                      $checkwithkrb5 = 1;
    $contentpwd,,                  }
    'krbtgt',              } elsif ($dist =~ /^suse([\d.]+)$/) {
    $contentpwd,                  if ($1 > 11.1) {
    1,                      $checkwithkrb5 = 1; 
    $password);                  }
  if(!$k4error) {              }
     $validated = 1;              if ($checkwithkrb5) {
  } else {                  $validated = &krb5_authen($password,$null,$user,$contentpwd);
     $validated = 0;              } else {
     &logthis('krb4: '.$user.', '.$contentpwd.', '.                  $validated = &krb4_authen($password,$null,$user,$contentpwd);
      &Authen::Krb4::get_err_txt($Authen::Krb4::error));              }
  }  
     } else {  
  $validated = 0; # Password has a match with null.  
     }  
  } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.   } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
     if(!($password =~ /$null/)) { # Null password not allowed.              $validated = &krb5_authen($password,$null,$user,$contentpwd);
  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;  
     }  
  } elsif ($howpwd eq "localauth") {    } elsif ($howpwd eq "localauth") { 
     #  Authenticate via installation specific authentcation method:      #  Authenticate via installation specific authentcation method:
     $validated = &localauth::localauth($user,       $validated = &localauth::localauth($user, 
Line 6724  sub validate_user { Line 6767  sub validate_user {
     return $validated;      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 {  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
Line 7094  sub sethost { Line 7196  sub sethost {
  eq &Apache::lonnet::get_host_ip($hostid)) {   eq &Apache::lonnet::get_host_ip($hostid)) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
  $currentdomainid=&Apache::lonnet::host_domain($hostid);   $currentdomainid=&Apache::lonnet::host_domain($hostid);
  &logthis("Setting hostid to $hostid, and domain to $currentdomainid");  # &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
     } else {      } else {
  &logthis("Requested host id $hostid not an alias of ".   &logthis("Requested host id $hostid not an alias of ".
  $perlvar{'lonHostID'}." refusing connection");   $perlvar{'lonHostID'}." refusing connection");
Line 7844  string. Line 7946  string.
   
 =back  =back
   
   =back
   
   
 =cut  =cut
Removed from v.1.432  
changed lines
  Added in v.1.446

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>