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

Diff for /loncom/lond between versions 1.178.2.8 and 1.178.2.18

version 1.178.2.8, 2004/03/16 10:52:30 version 1.178.2.18, 2004/04/19 11:32:35
Line 162  sub isClient { Line 162  sub isClient {
     return (($ConnectionType eq "client") || ($ConnectionType eq "both"));      return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
 }  }
 #  #
 #   Ties a resource file to a hash.  If necessary, an appropriate history  #  Ties a domain level resource file to a hash.
   #  If requested a history entry is created in the associated hist file.
   #
   #  Parameters:
   #     domain    - Name of the domain in which the resource file lives.
   #     namespace - Name of the hash within that domain.
   #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
   #     loghead   - Optional parameter, if present a log entry is created
   #                 in the associated history file and this is the first part
   #                  of that entry.
   #     logtail   - Goes along with loghead,  The actual logentry is of the
   #                 form $loghead:<timestamp>:logtail.
   # Returns:
   #    Reference to a hash bound to the db file or alternatively undef
   #    if the tie failed.
   #
   sub TieDomainHash {
       my $domain    = shift;
       my $namespace = shift;
       my $how       = shift;
       
       # Filter out any whitespace in the domain name:
       
       $domain =~ s/\W//g;
       
       # We have enough to go on to tie the hash:
       
       my $UserTopDir   = $perlvar{'lonUsersDir'};
       my $DomainDir    = $UserTopDir."/$domain";
       my $ResourceFile = $DomainDir."/$namespace.db";
       my %hash;
       if(tie(%hash, 'GDBM_File', $ResourceFile, $how, 0640)) {
    if (scalar @_) { # Need to log the operation.
       my $logFh = IO::File->new(">>$DomainDir/$namespace.hist");
       if($logFh) {
    my $TimeStamp = time;
    my ($loghead, $logtail) = @_;
    print $logFh "$loghead:$TimeStamp:$logtail\n";
       }
    }
    return \%hash; # Return the tied hash.
       }
       else {
    return undef; # Tie failed.
       }
   }
   
   #
   #   Ties a user's resource file to a hash.  
   #   If necessary, an appropriate history
 #   log file entry is made as well.  #   log file entry is made as well.
 #   This sub factors out common code from the subs that manipulate  #   This sub factors out common code from the subs that manipulate
 #   the various gdbm files that keep keyword value pairs.  #   the various gdbm files that keep keyword value pairs.
Line 179  sub isClient { Line 228  sub isClient {
 #   hash to which the database is tied.  It's up to the caller to untie.  #   hash to which the database is tied.  It's up to the caller to untie.
 #   undef if the has could not be tied.  #   undef if the has could not be tied.
 #  #
 sub TieResourceHash {  sub TieUserHash {
   my $domain      = shift;      my $domain      = shift;
   my $user        = shift;      my $user        = shift;
   my $namespace   = shift;      my $namespace   = shift;
   my $how         = shift;      my $how         = shift;
       
   $namespace=~s/\//\_/g; # / -> _      $namespace=~s/\//\_/g; # / -> _
   $namespace=~s/\W//g; # whitespace eliminated.      $namespace=~s/\W//g; # whitespace eliminated.
   my $proname     = propath($domain, $user);      my $proname     = propath($domain, $user);
      
   # If this is a namespace for which a history is kept,      # If this is a namespace for which a history is kept,
   # make the history log entry:      # make the history log entry:
       
       
   unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) {      unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) {
     my $hfh = IO::File->new(">>$proname/$namespace.hist");    my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
     if($hfh) {   if($hfh) {
       my $now = time;      my $now = time;
       my $loghead  = shift;      my $loghead  = shift;
       my $what    = shift;      my $what    = shift;
       print $hfh "$loghead:$now:$what\n";      print $hfh "$loghead:$now:$what\n";
     }   }
   }      }
   #  Tie the database.      #  Tie the database.
       
   my %hash;      my %hash;
   if(tie(%hash, 'GDBM_FILE', "$proname/$namespace.db",      if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
  $how, 0640)) {     $how, 0640)) {
     return \%hash;   return \%hash;
   }      }
   else {      else {
     return undef;   return undef;
   }      }
         
 }  }
   
 #  #
Line 676  sub AuthenticateHandler { Line 725  sub AuthenticateHandler {
     my $cmd        = shift;      my $cmd        = shift;
     my $tail       = shift;      my $tail       = shift;
     my $client     = shift;      my $client     = shift;
          
     #  Regenerate the full input line       #  Regenerate the full input line 
          
     my $userinput  = $cmd.":".$tail;      my $userinput  = $cmd.":".$tail;
       
     #  udom    - User's domain.      #  udom    - User's domain.
     #  uname   - Username.      #  uname   - Username.
     #  upass   - User's password.      #  upass   - User's password.
          
     my ($udom,$uname,$upass)=split(/:/,$tail);      my ($udom,$uname,$upass)=split(/:/,$tail);
     Debug(" Authenticate domain = $udom, user = $uname, password = $upass");      Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
     chomp($upass);      chomp($upass);
     $upass=unescape($upass);      $upass=unescape($upass);
   
     # Fetch the user authentication information:      my $pwdcorrect = ValidateUser($udom, $uname, $upass);
          if($pwdcorrect) {
     my $realpasswd = GetAuthType($udom, $uname);   Reply( $client, "authorized\n", $userinput);
     if($realpasswd ne "nouser") { # nouser means no passwd file.  
  my ($howpwd,$contentpwd)=split(/:/,$realpasswd);  
  my $pwdcorrect=0;  
  #   #
  #   Authenticate against password stored in the internal file.   #  Bad credentials: Failed to authorize
  #   #
  Debug("Authenticating via $howpwd");  
  if ($howpwd eq 'internal') {  
     &Debug("Internal auth");  
     $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);  
     #  
     #   Authenticate against the unix password file.  
     #  
  } elsif ($howpwd eq 'unix') {  
     &Debug("Unix auth");  
     if((getpwnam($uname))[1] eq "") { #no such user!  
  $pwdcorrect = 0;  
     } else {  
  $contentpwd=(getpwnam($uname))[1];  
  my $pwauth_path="/usr/local/sbin/pwauth";  
  unless ($contentpwd eq 'x') { # Not in shadow file.  
     $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);  
  } elsif (-e $pwauth_path) { # In shadow file so  
     open PWAUTH, "|$pwauth_path" or # use external program  
  die "Cannot invoke authentication";  
     print PWAUTH "$uname\n$upass\n";  
     close PWAUTH;  
     $pwdcorrect=!$?;  
  }  
     }  
     #  
     #   Authenticate against a Kerberos 4 server:  
     #  
  } elsif ($howpwd eq 'krb4') {  
     my $null=pack("C",0);  
     unless ($upass=~/$null/) {  
  my $krb4_error = &Authen::Krb4::get_pw_in_tkt($uname,  
       "",  
       $contentpwd,  
       'krbtgt',  
       $contentpwd,  
       1,  
       $upass);  
  if (!$krb4_error) {  
     $pwdcorrect = 1;  
  } else {   
     $pwdcorrect=0;   
     # log error if it is not a bad password  
     if ($krb4_error != 62) {  
  &logthis('krb4:'.$uname.','.$contentpwd.','.  
  &Authen::Krb4::get_err_txt($Authen::Krb4::error));  
     }  
  }  
     }  
     #  
     #   Authenticate against a Kerberos 5 server:  
     #  
  } elsif ($howpwd eq 'krb5') {  
     my $null=pack("C",0);  
     unless ($upass=~/$null/) {  
  my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);  
  my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;  
  my $krbserver=&Authen::Krb5::parse_name($krbservice);  
  my $credentials=&Authen::Krb5::cc_default();  
  $credentials->initialize($krbclient);  
  my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,  
  $krbserver,  
  $upass,  
  $credentials);  
  $pwdcorrect = ($krbreturn == 1);  
     } else {   
  $pwdcorrect=0;   
     }  
     #  
     #  Finally, the user may have written in an authentication module.  
     #  in that case, if requested, authenticate against it.  
     #  
  } elsif ($howpwd eq 'localauth') {  
     $pwdcorrect=&localauth::localauth($uname,$upass,$contentpwd);  
  }  
  #  
  #   Successfully authorized.  
  #  
  if ($pwdcorrect) {  
     Reply( $client, "authorized\n", $userinput);  
     #  
     #  Bad credentials: Failed to authorize  
     #  
  } else {  
     Failure( $client, "non_authorized\n", $userinput);  
  }  
  #  Used to be unknown_user but that allows crackers to   
  #  distinguish between bad username and bad password so...  
  #    
     } else {      } else {
  Failure( $client, "non_authorized\n", $userinput);   Failure( $client, "non_authorized\n", $userinput);
     }      }
   
     return 1;      return 1;
 }  }
 RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);  RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);
Line 833  sub ChangePasswordHandler { Line 792  sub ChangePasswordHandler {
     $upass=&unescape($upass);      $upass=&unescape($upass);
     $npass=&unescape($npass);      $npass=&unescape($npass);
     &Debug("Trying to change password for $uname");      &Debug("Trying to change password for $uname");
     my $realpasswd  = GetAuthType($udom, $uname);  
     if ($realpasswd ne "nouser") {      # First require that the user can be authenticated with their
       # old password:
   
       my $validated = ValidateUser($udom, $uname, $upass);
       if($validated) {
    my $realpasswd  = GetAuthType($udom, $uname); # Defined since authd.
   
  my ($howpwd,$contentpwd)=split(/:/,$realpasswd);   my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
  if ($howpwd eq 'internal') {   if ($howpwd eq 'internal') {
     &Debug("internal auth");      &Debug("internal auth");
     if (crypt($upass,$contentpwd) eq $contentpwd) {      my $salt=time;
  my $salt=time;      $salt=substr($salt,6,2);
  $salt=substr($salt,6,2);      my $ncpass=crypt($npass,$salt);
  my $ncpass=crypt($npass,$salt);      if(RewritePwFile($udom, $uname, "internal:$ncpass")) {
  if(RewritePwFile($udom, $uname, "internal:$ncpass")) {   &logthis("Result of password change for "
     &logthis("Result of password change for "   ."$uname: pwchange_success");
      ."$uname: pwchange_success");   Reply($client, "ok\n", $userinput);
     Reply($client, "ok\n", $userinput);  
  } else {  
     &logthis("Unable to open $uname passwd "                 
      ."to change password");  
     Failure( $client, "non_authorized\n",$userinput);  
  }  
     } else {      } else {
  Failure($client, "non_authorized\n", $userinput);   &logthis("Unable to open $uname passwd "               
    ."to change password");
    Failure( $client, "non_authorized\n",$userinput);
     }      }
  } elsif ($howpwd eq 'unix') {   } elsif ($howpwd eq 'unix') {
     # Unix means we have to access /etc/password      # Unix means we have to access /etc/password
     # one way or another.  
     # First: Make sure the current password is  
     #        correct  
     &Debug("auth is unix");      &Debug("auth is unix");
     $contentpwd=(getpwnam($uname))[1];      my $execdir=$perlvar{'lonDaemons'};
     my $pwdcorrect = "0";      &Debug("Opening lcpasswd pipeline");
     my $pwauth_path="/usr/local/sbin/pwauth";      my $pf = IO::File->new("|$execdir/lcpasswd > "
     unless ($contentpwd eq 'x') {     ."$perlvar{'lonDaemons'}"
  $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);     ."/logs/lcpasswd.log");
     } elsif (-e $pwauth_path) {      print $pf "$uname\n$npass\n$npass\n";
  open PWAUTH, "|$pwauth_path" or      close $pf;
     die "Cannot invoke authentication";      my $err = $?;
  print PWAUTH "$uname\n$upass\n";      my $result = ($err>0 ? 'pwchange_failure' : 'ok');
  close PWAUTH;      &logthis("Result of password change for $uname: ".
  &Debug("exited pwauth with $? ($uname,$upass) ");       &lcpasswdstrerror($?));
  $pwdcorrect=($? == 0);      Reply($client, "$result\n", $userinput);
     }  
     if ($pwdcorrect) {  
  my $execdir=$perlvar{'lonDaemons'};  
  &Debug("Opening lcpasswd pipeline");  
  my $pf = IO::File->new("|$execdir/lcpasswd > "  
        ."$perlvar{'lonDaemons'}"  
        ."/logs/lcpasswd.log");  
  print $pf "$uname\n$npass\n$npass\n";  
  close $pf;  
  my $err = $?;  
  my $result = ($err>0 ? 'pwchange_failure' : 'ok');  
  &logthis("Result of password change for $uname: ".  
  &lcpasswdstrerror($?));  
  Reply($client, "$result\n", $userinput);  
     } else {  
  Reply($client, "non_authorized\n", $userinput);  
     }  
  } else {   } else {
     # this just means that the current password mode is not      # this just means that the current password mode is not
     # one we know how to change (e.g the kerberos auth modes or      # one we know how to change (e.g the kerberos auth modes or
Line 896  sub ChangePasswordHandler { Line 837  sub ChangePasswordHandler {
     #      #
     Reply( $client, "auth_mode_error\n", $userinput);      Reply( $client, "auth_mode_error\n", $userinput);
  }     }  
     } else {  
  #  used to be unknonw user but that gives out too much info..      }
  #  so make it the same as if the initial passwd was bad.      else {
  #  
  Reply( $client, "non_authorized\n", $userinput);   Reply( $client, "non_authorized\n", $userinput);
     }      }
   
     return 1;      return 1;
 }  }
 RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);  RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);
Line 949  sub AddUserHandler { Line 890  sub AddUserHandler {
     for (my $i=3;$i<= ($#fpparts-1);$i++) {      for (my $i=3;$i<= ($#fpparts-1);$i++) {
  $fpnow.='/'.$fpparts[$i];    $fpnow.='/'.$fpparts[$i]; 
  unless (-e $fpnow) {   unless (-e $fpnow) {
       &logthis("mkdir $fpnow");
     unless (mkdir($fpnow,0777)) {      unless (mkdir($fpnow,0777)) {
  $fperror="error: ".($!+0)." mkdir failed while attempting "   $fperror="error: ".($!+0)." mkdir failed while attempting "
     ."makeuser";      ."makeuser";
Line 1048  sub IsHomeHandler { Line 990  sub IsHomeHandler {
         
     my ($udom,$uname)=split(/:/,$tail);      my ($udom,$uname)=split(/:/,$tail);
     chomp($uname);      chomp($uname);
     my $passfile = PasswordPath($udom, $uname);      my $passfile = PasswordFilename($udom, $uname);
     if($passfile) {      if($passfile) {
  Reply( $client, "found\n", $userinput);   Reply( $client, "found\n", $userinput);
     } else {      } else {
Line 1196  sub FetchUserFileHandler { Line 1138  sub FetchUserFileHandler {
 }  }
 RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);  RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);
 #  #
 #   Authenticate access to a user file.  Question?   The token for athentication  #   Authenticate access to a user file. 
 #   is allowed to be sent as cleartext is this really what we want?  This token  
 #   represents the user's session id.  Once it is forged does this allow too much   
 #   access??  
 #  #
 # Parameters:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
Line 1259  sub UnsubscribeHandler { Line 1198  sub UnsubscribeHandler {
 }  }
 RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);  RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);
   
 #   Subscribe to a resource.  #   Subscribe to a resource
 #  #
 # Parameters:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
Line 1360  sub PutUserProfileEntry { Line 1299  sub PutUserProfileEntry {
     my $tail      = shift;      my $tail      = shift;
     my $client    = shift;      my $client    = shift;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
       
     my ($udom,$uname,$namespace,$what) =split(/:/,$tail);      my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
     if ($namespace ne 'roles') {      if ($namespace ne 'roles') {
        chomp($what);   chomp($what);
        my $hashref = TieResourceHash($udom, $uname, $namespace,   my $hashref = TieUserHash($udom, $uname, $namespace,
      &GDBM_WRCREAT(),"P",$what);    &GDBM_WRCREAT(),"P",$what);
        if($hashref) {   if($hashref) {
  my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
  foreach my $pair (@pairs) {      foreach my $pair (@pairs) {
     my ($key,$value)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
     $hashref->{$key}=$value;   $hashref->{$key}=$value;
   }      }
   if (untie(%$hashref)) {      if (untie(%$hashref)) {
      Reply( $client, "ok\n", $userinput);   Reply( $client, "ok\n", $userinput);
   } else {      } else {
      Failure($client, "error: ".($!+0)." untie(GDBM) failed ".   Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
      "while attempting put\n",    "while attempting put\n", 
      $userinput);   $userinput);
   }      }
        } else {   } else {
   Failure( $client, "error: ".($!)." tie(GDBM) Failed ".      Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
    "while attempting put\n", $userinput);       "while attempting put\n", $userinput);
        }   }
      } else {      } else {
         Failure( $client, "refused\n", $userinput);          Failure( $client, "refused\n", $userinput);
      }      }
           
      return 1;      return 1;
 }  }
 RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0);  RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0);
   
Line 1415  sub IncrementUserValueHandler { Line 1354  sub IncrementUserValueHandler {
     my ($udom,$uname,$namespace,$what) =split(/:/,$tail);      my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
     if ($namespace ne 'roles') {      if ($namespace ne 'roles') {
         chomp($what);          chomp($what);
  my $hashref = TieResourceHash($udom, $uname,   my $hashref = TieUserHash($udom, $uname,
       $namespace, &GDBM_WRCREAT(),    $namespace, &GDBM_WRCREAT(),
       "P",$what);    "P",$what);
  if ($hashref) {   if ($hashref) {
    my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
    foreach my $pair (@pairs) {      foreach my $pair (@pairs) {
      my ($key,$value)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
      # We could check that we have a number...   # We could check that we have a number...
      if (! defined($value) || $value eq '') {   if (! defined($value) || $value eq '') {
         $value = 1;      $value = 1;
      }   }
      $hashref->{$key}+=$value;   $hashref->{$key}+=$value;
    }      }
    if (untie(%$hashref)) {      if (untie(%$hashref)) {
       Reply( $client, "ok\n", $userinput);   Reply( $client, "ok\n", $userinput);
    } else {      } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) failed ".   Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
       "while attempting inc\n", $userinput);   "while attempting inc\n", $userinput);
    }      }
  } else {   } else {
    Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".      Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting inc\n", $userinput);      "while attempting inc\n", $userinput);
  }   }
       } else {      } else {
  Failure($client, "refused\n", $userinput);   Failure($client, "refused\n", $userinput);
       }      }
           
     return 1;      return 1;
 }  }
Line 1476  sub RolesPutHandler { Line 1415  sub RolesPutHandler {
    "what = ".$what);     "what = ".$what);
     my $namespace='roles';      my $namespace='roles';
     chomp($what);      chomp($what);
     my $hashref = TieResourceHash($udom, $uname, $namespace,      my $hashref = TieUserHash($udom, $uname, $namespace,
   &GDBM_WRCREAT(), "P",        &GDBM_WRCREAT(), "P",
   "$exedom:$exeuser:$what");        "$exedom:$exeuser:$what");
     #      #
     #  Log the attempt to set a role.  The {}'s here ensure that the file       #  Log the attempt to set a role.  The {}'s here ensure that the file 
     #  handle is open for the minimal amount of time.  Since the flush      #  handle is open for the minimal amount of time.  Since the flush
Line 1533  sub RolesDeleteHandler { Line 1472  sub RolesDeleteHandler {
    "what = ".$what);     "what = ".$what);
     my $namespace='roles';      my $namespace='roles';
     chomp($what);      chomp($what);
     my $hashref = TieResourceHash($udom, $uname, $namespace,      my $hashref = TieUserHash($udom, $uname, $namespace,
   &GDBM_WRCREAT(), "D",        &GDBM_WRCREAT(), "D",
   "$exedom:$exeuser:$what");        "$exedom:$exeuser:$what");
       
     if ($hashref) {      if ($hashref) {
        my @rolekeys=split(/\&/,$what);   my @rolekeys=split(/\&/,$what);
          
        foreach my $key (@rolekeys) {   foreach my $key (@rolekeys) {
   delete $hashref->{$key};      delete $hashref->{$key};
        }   }
        if (untie(%$hashref)) {   if (untie(%$hashref)) {
   Reply($client, "ok\n", $userinput);      Reply($client, "ok\n", $userinput);
  } else {   } else {
    Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
     "while attempting rolesdel\n", $userinput);       "while attempting rolesdel\n", $userinput);
  }   }
      } else {      } else {
         Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".          Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  "while attempting rolesdel\n", $userinput);   "while attempting rolesdel\n", $userinput);
      }      }
           
     return 1;      return 1;
 }  }
Line 1585  sub GetProfileEntry { Line 1524  sub GetProfileEntry {
         
     my ($udom,$uname,$namespace,$what) = split(/:/,$tail);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
     my $hashref = TieResourceHash($udom, $uname, $namespace,      my $hashref = TieUserHash($udom, $uname, $namespace,
  &GDBM_READER());        &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my @queries=split(/\&/,$what);          my @queries=split(/\&/,$what);
         my $qresult='';          my $qresult='';
   
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
     $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.      $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
  }   }
Line 1640  sub GetProfileEntryEncrypted { Line 1579  sub GetProfileEntryEncrypted {
         
     my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);      my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
     chomp($what);      chomp($what);
     my $hashref = TieResourceHash($udom, $uname, $namespace,      my $hashref = TieUserHash($udom, $uname, $namespace,
   &GDBM_READER());    &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my @queries=split(/\&/,$what);          my @queries=split(/\&/,$what);
Line 1655  sub GetProfileEntryEncrypted { Line 1594  sub GetProfileEntryEncrypted {
  $qresult.="         ";   $qresult.="         ";
  my $encqresult='';   my $encqresult='';
  for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {   for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
     $encqresult.= unpack("H16", $cipher->encrypt(substr($qresult,      $encqresult.= unpack("H16", 
  $encidx,   $cipher->encrypt(substr($qresult,
  8)));   $encidx,
    8)));
  }   }
  Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);   Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
     } else {      } else {
Line 1674  sub GetProfileEntryEncrypted { Line 1614  sub GetProfileEntryEncrypted {
           
     return 1;      return 1;
 }  }
 RegisterHandler("eget", \&GetProfileEncrypted, 0, 1, 0);  RegisterHandler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);
   
 #  #
 #   Deletes a key in a user profile database.  #   Deletes a key in a user profile database.
Line 1703  sub DeleteProfileEntry { Line 1643  sub DeleteProfileEntry {
   
     my ($udom,$uname,$namespace,$what) = split(/:/,$tail);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
     my $hashref = TieResourceHash($udom, $uname, $namespace,      my $hashref = TieUserHash($udom, $uname, $namespace,
   &GDBM_WRCREAT(),    &GDBM_WRCREAT(),
   "D",$what);    "D",$what);
     if ($hashref) {      if ($hashref) {
Line 1747  sub GetProfileKeys { Line 1687  sub GetProfileKeys {
   
     my ($udom,$uname,$namespace)=split(/:/,$tail);      my ($udom,$uname,$namespace)=split(/:/,$tail);
     my $qresult='';      my $qresult='';
     my $hashref = TieResourceHash($udom, $uname, $namespace,      my $hashref = TieUserHash($udom, $uname, $namespace,
   &GDBM_READER());    &GDBM_READER());
     if ($hashref) {      if ($hashref) {
  foreach my $key (keys %$hashref) {   foreach my $key (keys %$hashref) {
Line 1794  sub DumpProfileDatabase { Line 1734  sub DumpProfileDatabase {
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
     my ($udom,$uname,$namespace) = split(/:/,$tail);      my ($udom,$uname,$namespace) = split(/:/,$tail);
     my $hashref = TieResourceHash($udom, $uname, $namespace,      my $hashref = TieUserHash($udom, $uname, $namespace,
   &GDBM_READER());    &GDBM_READER());
     if ($hashref) {      if ($hashref) {
  # Structure of %data:   # Structure of %data:
Line 1802  sub DumpProfileDatabase { Line 1742  sub DumpProfileDatabase {
  # $data{$symb}->{'v.'.$parameter}=$version;   # $data{$symb}->{'v.'.$parameter}=$version;
  # since $parameter will be unescaped, we do not   # since $parameter will be unescaped, we do not
   # have to worry about silly parameter names...    # have to worry about silly parameter names...
   
         my $qresult='';          my $qresult='';
  my %data = ();                     # A hash of anonymous hashes..   my %data = ();                     # A hash of anonymous hashes..
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
Line 1875  sub DumpWithRegexp { Line 1815  sub DumpWithRegexp {
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
     my $hashref =TieResourceHash($udom, $uname, $namespace,      my $hashref =TieUserHash($udom, $uname, $namespace,
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my $qresult='';          my $qresult='';
Line 1905  sub DumpWithRegexp { Line 1845  sub DumpWithRegexp {
 }  }
 RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);  RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);
   
 #  Store an aitem in any database but the roles database.  #  Store an aitem in any resource meta data(?) or database with
   #  versioning?
 #  #
 #  Parameters:  #  Parameters:
 #    $cmd                - Request command keyword.  #    $cmd                - Request command keyword.
Line 1935  sub StoreHandler { Line 1876  sub StoreHandler {
   
  chomp($what);   chomp($what);
  my @pairs=split(/\&/,$what);   my @pairs=split(/\&/,$what);
  my $hashref  = TieResourceHash($udom, $uname, $namespace,   my $hashref  = TieUserHash($udom, $uname, $namespace,
        &GDBM_WRCREAT(), "P",         &GDBM_WRCREAT(), "P",
        "$rid:$what");         "$rid:$what");
  if ($hashref) {   if ($hashref) {
Line 2214  sub PutCourseIdHandler { Line 2155  sub PutCourseIdHandler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$what)=split(/:/,$tail);      my ($udom, $what) = split(/:/, $tail);
     chomp($what);      chomp($what);
     $udom=~s/\W//g;  
     my $proname=  
  "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";  
     my $now=time;      my $now=time;
     my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {      my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
     my ($key,$value)=split(/=/,$pair);      my ($key,$value)=split(/=/,$pair);
     $hash{$key}=$value.':'.$now;      $hashref->{$key}=$value.':'.$now;
  }   }
  if (untie(%hash)) {   if (untie(%$hashref)) {
     Reply($client, "ok\n", $userinput);      Reply($client, "ok\n", $userinput);
  } else {   } else {
     Failure( $client, "error: ".($!+0)      Failure( $client, "error: ".($!+0)
Line 2282  sub DumpCourseIdHandler { Line 2221  sub DumpCourseIdHandler {
     }      }
     unless (defined($since)) { $since=0; }      unless (defined($since)) { $since=0; }
     my $qresult='';      my $qresult='';
     my $proname = "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";      logthis(" Looking for $description  since $since");
     my %hash;      my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {      if ($hashref) {
  while (my ($key,$value) = each(%hash)) {   while (my ($key,$value) = each(%$hashref)) {
     my ($descr,$lasttime)=split(/\:/,$value);      my ($descr,$lasttime)=split(/\:/,$value);
       logthis("Got:  key = $key descr = $descr time: $lasttime");
     if ($lasttime<$since) {       if ($lasttime<$since) { 
    logthis("Skipping .. too early");
  next;    next; 
     }      }
     if ($description eq '.') {      if ($description eq '.') {
    logthis("Adding wildcard match");
  $qresult.=$key.'='.$descr.'&';   $qresult.=$key.'='.$descr.'&';
     } else {      } else {
  my $unescapeVal = &unescape($descr);   my $unescapeVal = &unescape($descr);
    logthis("Matching with $unescapeVal");
  if (eval('$unescapeVal=~/$description/i')) {   if (eval('$unescapeVal=~/$description/i')) {
       logthis("Adding on match");
     $qresult.="$key=$descr&";      $qresult.="$key=$descr&";
  }   }
     }      }
  }   }
  if (untie(%hash)) {   if (untie(%$hashref)) {
     chop($qresult);      chop($qresult);
     Reply($client, "$qresult\n", $userinput);      Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 2340  sub PutIdHandler { Line 2284  sub PutIdHandler {
   
     my ($udom,$what)=split(/:/,$tail);      my ($udom,$what)=split(/:/,$tail);
     chomp($what);      chomp($what);
     $udom=~s/\W//g;  
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
     my $now=time;  
     {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname.hist")) {   
     print $hfh "P:$now:$what\n";   
  }  
     }  
     my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
     my %hash;      my $hashref = TieDomainHash($udom, "ids", &GDBM_WRCREAT(),
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {   "P", $what);
       if ($hashref) {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
     my ($key,$value)=split(/=/,$pair);      my ($key,$value)=split(/=/,$pair);
     $hash{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (untie(%hash)) {   if (untie(%$hashref)) {
     Reply($client, "ok\n", $userinput);      Reply($client, "ok\n", $userinput);
  } else {   } else {
     Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2394  sub GetIdHandler { Line 2330  sub GetIdHandler {
     my $cmd    = shift;      my $cmd    = shift;
     my $tail   = shift;      my $tail   = shift;
     my $client = shift;      my $client = shift;
       
     my $userinput = "$client:$tail";      my $userinput = "$client:$tail";
       
     my ($udom,$what)=split(/:/,$tail);      my ($udom,$what)=split(/:/,$tail);
     chomp($what);      chomp($what);
     $udom=~s/\W//g;  
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
     my @queries=split(/\&/,$what);      my @queries=split(/\&/,$what);
     my $qresult='';      my $qresult='';
     my %hash;      my $hashref = TieDomainHash($udom, "ids", &GDBM_READER());
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {      if ($hashref) {
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
     $qresult.="$hash{$queries[$i]}&";      $qresult.="$hashref->{$queries[$i]}&";
  }   }
  if (untie(%hash)) {   if (untie(%$hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     Reply($client, "$qresult\n", $userinput);      Reply($client, "$qresult\n", $userinput);
  } else {   } else {
Line 2419  sub GetIdHandler { Line 2353  sub GetIdHandler {
  Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  "while attempting idget\n",$userinput);   "while attempting idget\n",$userinput);
     }      }
       
     return 1;      return 1;
 }  }
   
Line 2487  sub TmpGetHandler { Line 2421  sub TmpGetHandler {
     my $id        = shift;      my $id        = shift;
     my $client    = shift;      my $client    = shift;
     my $userinput = "$cmd:$id";       my $userinput = "$cmd:$id"; 
       
     chomp($id);      chomp($id);
     $id=~s/\W/\_/g;      $id=~s/\W/\_/g;
     my $store;      my $store;
Line 2522  sub TmpDelHandler { Line 2456  sub TmpDelHandler {
     my $cmd      = shift;      my $cmd      = shift;
     my $id       = shift;      my $id       = shift;
     my $client   = shift;      my $client   = shift;
       
     my $userinput= "$cmd:$id";      my $userinput= "$cmd:$id";
       
     chomp($id);      chomp($id);
     $id=~s/\W/\_/g;      $id=~s/\W/\_/g;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
Line 2534  sub TmpDelHandler { Line 2468  sub TmpDelHandler {
  Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".   Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
  "while attempting tmpdel\n", $userinput);   "while attempting tmpdel\n", $userinput);
     }      }
       
     return 1;      return 1;
   
 }  }
Line 3862  sub subsqlreply { Line 3796  sub subsqlreply {
   
 sub propath {  sub propath {
     my ($udom,$uname)=@_;      my ($udom,$uname)=@_;
       Debug("Propath:$udom:$uname");
     $udom=~s/\W//g;      $udom=~s/\W//g;
     $uname=~s/\W//g;      $uname=~s/\W//g;
       Debug("Propath2:$udom:$uname");
     my $subdir=$uname.'__';      my $subdir=$uname.'__';
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";      my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
       Debug("Propath returning $proname");
     return $proname;      return $proname;
 }   } 
   
Line 4124  sub PasswordPath { Line 4061  sub PasswordPath {
     my $user   = shift;      my $user   = shift;
   
     my $path   = &propath($domain, $user);      my $path   = &propath($domain, $user);
     my $path  .= "/passwd";      $path  .= "/passwd";
   
     return $path;      return $path;
 }  }
Line 4143  sub PasswordFilename { Line 4080  sub PasswordFilename {
     my $domain    = shift;      my $domain    = shift;
     my $user      = shift;      my $user      = shift;
   
     my $path  = PasswordPath($domain, $user);      Debug ("PasswordFilename called: dom = $domain user = $user");
   
       my $path  = PasswordPath($domain, $user);
       Debug("PasswordFilename got path: $path");
     if(-e $path) {      if(-e $path) {
  return $path;   return $path;
     } else {      } else {
Line 4204  sub GetAuthType { Line 4143  sub GetAuthType {
     }      }
 }  }
   
   #
   #  Validate a user given their domain, name and password.  This utility
   #  function is used by both  AuthenticateHandler and ChangePasswordHandler
   #  to validate the login credentials of a user.
   # Parameters:
   #    $domain    - The domain being logged into (this is required due to
   #                 the capability for multihomed systems.
   #    $user      - The name of the user being validated.
   #    $password  - The user's propoposed password.
   #
   # Returns:
   #     1        - The domain,user,pasword triplet corresponds to a valid
   #                user.
   #     0        - The domain,user,password triplet is not a valid user.
   #
   sub ValidateUser {
       my $domain  = shift;
       my $user    = shift;
       my $password= shift;
   
       # Why negative ~pi you may well ask?  Well this function is about
       # authentication, and therefore very important to get right.
       # I've initialized the flag that determines whether or not I've 
       # validated correctly to a value it's not supposed to get.
       # At the end of this function. I'll ensure that it's not still that
       # value so we don't just wind up returning some accidental value
       # as a result of executing an unforseen code path that
       # did not set $validated.
   
       my $validated = -3.14159;
   
       #  How we authenticate is determined by the type of authentication
       #  the user has been assigned.  If the authentication type is
       #  "nouser", the user does not exist so we will return 0.
   
       my $contents = GetAuthType($domain, $user);
       my ($howpwd, $contentpwd) = split(/:/, $contents);
   
       my $null = pack("C",0); # Used by kerberos auth types.
   
       if ($howpwd ne 'nouser') {
   
    if($howpwd eq "internal") { # Encrypted is in local password file.
       $validated = (crypt($password, $contentpwd) eq $contentpwd);
    }
    elsif ($howpwd eq "unix") { # User is a normal unix user.
       $contentpwd = (getpwnam($user))[1];
       if($contentpwd) {
    if($contentpwd eq 'x') { # Shadow password file...
       my $pwauth_path = "/usr/local/sbin/pwauth";
       open PWAUTH,  "|$pwauth_path" or
    die "Cannot invoke authentication";
       print PWAUTH "$user\n$password\n";
       close PWAUTH;
       $validated = ! $?;
   
    } else {         # Passwords in /etc/passwd. 
       $validated = (crypt($password,
    $contentpwd) eq $contentpwd);
    }
       } 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 "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($krbclient);
    my $krbreturn  = &Authen::KRb5::get_in_tkt_with_password($krbclient,
    $krbserver,
    $password,
    $credentials);
    $validated = ($krbreturn == 1);
       }
       else {
    $validated = 0;
       }
    }
    elsif ($howpwd eq "localauth") { 
       #  Authenticate via installation specific authentcation method:
       $validated = &localauth::localauth($user, 
          $password, 
          $contentpwd);
    }
    else { # Unrecognized auth is also bad.
       $validated = 0;
    }
       } else {
    $validated = 0;
       }
       #
       #  $validated has the correct stat of the authentication:
       #
   
       unless ($validated != -3.14159) {
    die "ValidateUser - failed to set the value of validated";
       }
       return $validated;
   }
   
   #
   #    Add a line to the subscription list?
   #
 sub addline {  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
     my $contents;      my $contents;
Line 4223  sub addline { Line 4291  sub addline {
     $sh->close();      $sh->close();
     return $found;      return $found;
 }  }
   #
   #    Get chat messages.
   #
 sub getchat {  sub getchat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
     my %hash;      my %hash;
Line 4248  sub getchat { Line 4318  sub getchat {
     }      }
     return (@participants,@entries);      return (@participants,@entries);
 }  }
   #
   #   Add a chat message
   #
 sub chatadd {  sub chatadd {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat)=@_;
     my %hash;      my %hash;
Line 4419  sub make_passwd_file { Line 4491  sub make_passwd_file {
     print $pf "localauth:$npass\n";      print $pf "localauth:$npass\n";
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  {   #
     my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";   #  Don't allow the creation of privileged accounts!!! that would
     {   #  be real bad!!!
  &Debug("Executing external: ".$execpath);   #
  &Debug("user  = ".$uname.", Password =". $npass);   my $uid = getpwnam($uname);
  my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");   if((defined $uid) && ($uid == 0)) {
  print $se "$uname\n";      &logthis(">>>Attempted add of privileged account blocked<<<");
  print $se "$npass\n";      return "no_priv_account_error\n";
  print $se "$npass\n";  
     }  
     my $useraddok = $?;  
     if($useraddok > 0) {  
  &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));  
     }  
     my $pf = IO::File->new(">$passfilename");  
     print $pf "unix:\n";  
  }   }
   
    #
    my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
   
    &Debug("Executing external: ".$execpath);
    &Debug("user  = ".$uname.", Password =". $npass);
    my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
    print $se "$uname\n";
    print $se "$npass\n";
    print $se "$npass\n";
   
    my $useraddok = $?;
    if($useraddok > 0) {
       my $lcstring = lcuseraddstrerror($useraddok);
       &logthis("Failed lcuseradd: $lcstring");
       return "error: lcuseradd failed: $lcstring\n";
    }
    my $pf = IO::File->new(">$passfilename");
    print $pf "unix:\n";
    
     } elsif ($umode eq 'none') {      } elsif ($umode eq 'none') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
Removed from v.1.178.2.8  
changed lines
  Added in v.1.178.2.18

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