Diff for /loncom/lond between versions 1.175 and 1.201

version 1.175, 2004/02/17 20:07:25 version 1.201, 2004/06/21 14:08:20
Line 45  use Authen::Krb4; Line 45  use Authen::Krb4;
 use Authen::Krb5;  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
   use localenroll;
 use File::Copy;  use File::Copy;
 use LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
   use LONCAPA::lonlocal;
   use LONCAPA::lonssl;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 11;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
Line 59  my $currenthostid; Line 62  my $currenthostid;
 my $currentdomainid;  my $currentdomainid;
   
 my $client;  my $client;
 my $clientip;  my $clientip; # IP address of client.
 my $clientname;  my $clientdns; # DNS name of client.
   my $clientname; # LonCAPA name of client.
   
 my $server;  my $server;
 my $thisserver;  my $thisserver; # DNS of us.
   
   my $keymode;
   
 #   # 
 #   Connection type is:  #   Connection type is:
Line 74  my $thisserver; Line 80  my $thisserver;
   
 my $ConnectionType;  my $ConnectionType;
   
 my %hostid;  my %hostid; # ID's for hosts in cluster by ip.
 my %hostdom;  my %hostdom; # LonCAPA domain for hosts in cluster.
 my %hostip;  my %hostip; # IPs for hosts in cluster.
   my %hostdns; # ID's of hosts looked up by DNS name.
   
 my %managers; # Ip -> manager names  my %managers; # Ip -> manager names
   
Line 120  my @adderrors    = ("ok", Line 127  my @adderrors    = ("ok",
     "lcuseradd Password mismatch");      "lcuseradd Password mismatch");
   
   
   #------------------------------------------------------------------------
   #
   #   LocalConnection
   #     Completes the formation of a locally authenticated connection.
   #     This function will ensure that the 'remote' client is really the
   #     local host.  If not, the connection is closed, and the function fails.
   #     If so, initcmd is parsed for the name of a file containing the
   #     IDEA session key.  The fie is opened, read, deleted and the session
   #     key returned to the caller.
   #
   # Parameters:
   #   $Socket      - Socket open on client.
   #   $initcmd     - The full text of the init command.
   #
   # Implicit inputs:
   #    $clientdns  - The DNS name of the remote client.
   #    $thisserver - Our DNS name.
   #
   # Returns:
   #     IDEA session key on success.
   #     undef on failure.
   #
   sub LocalConnection {
       my ($Socket, $initcmd) = @_;
       Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");
       if($clientdns ne $thisserver) {
    &logthis('<font color="red"> LocalConnection rejecting non local: '
    ."$clientdns ne $thisserver </font>");
    close $Socket;
    return undef;
       } 
       else {
    chomp($initcmd); # Get rid of \n in filename.
    my ($init, $type, $name) = split(/:/, $initcmd);
    Debug(" Init command: $init $type $name ");
   
    # Require that $init = init, and $type = local:  Otherwise
    # the caller is insane:
   
    if(($init ne "init") && ($type ne "local")) {
       &logthis('<font color = "red"> LocalConnection: caller is insane! '
        ."init = $init, and type = $type </font>");
       close($Socket);;
       return undef;
   
    }
    #  Now get the key filename:
   
    my $IDEAKey = lonlocal::ReadKeyFile($name);
    return $IDEAKey;
       }
   }
   #------------------------------------------------------------------------------
   #
   #  SSLConnection
   #   Completes the formation of an ssh authenticated connection. The
   #   socket is promoted to an ssl socket.  If this promotion and the associated
   #   certificate exchange are successful, the IDEA key is generated and sent
   #   to the remote peer via the SSL tunnel. The IDEA key is also returned to
   #   the caller after the SSL tunnel is torn down.
   #
   # Parameters:
   #   Name              Type             Purpose
   #   $Socket          IO::Socket::INET  Plaintext socket.
   #
   # Returns:
   #    IDEA key on success.
   #    undef on failure.
   #
   sub SSLConnection {
       my $Socket   = shift;
   
       Debug("SSLConnection: ");
       my $KeyFile         = lonssl::KeyFile();
       if(!$KeyFile) {
    my $err = lonssl::LastError();
    &logthis("<font color=\"red\"> CRITICAL"
    ."Can't get key file $err </font>");
    return undef;
       }
       my ($CACertificate,
    $Certificate) = lonssl::CertificateFile();
   
   
       # If any of the key, certificate or certificate authority 
       # certificate filenames are not defined, this can't work.
   
       if((!$Certificate) || (!$CACertificate)) {
    my $err = lonssl::LastError();
    &logthis("<font color=\"red\"> CRITICAL"
    ."Can't get certificates: $err </font>");
   
    return undef;
       }
       Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate");
   
       # Indicate to our peer that we can procede with
       # a transition to ssl authentication:
   
       print $Socket "ok:ssl\n";
   
       Debug("Approving promotion -> ssl");
       #  And do so:
   
       my $SSLSocket = lonssl::PromoteServerSocket($Socket,
    $CACertificate,
    $Certificate,
    $KeyFile);
       if(! ($SSLSocket) ) { # SSL socket promotion failed.
    my $err = lonssl::LastError();
    &logthis("<font color=\"red\"> CRITICAL "
    ."SSL Socket promotion failed: $err </font>");
    return undef;
       }
       Debug("SSL Promotion successful");
   
       # 
       #  The only thing we'll use the socket for is to send the IDEA key
       #  to the peer:
   
       my $Key = lonlocal::CreateCipherKey();
       print $SSLSocket "$Key\n";
   
       lonssl::Close($SSLSocket); 
   
       Debug("Key exchange complete: $Key");
   
       return $Key;
   }
   #
   #     InsecureConnection: 
   #        If insecure connections are allowd,
   #        exchange a challenge with the client to 'validate' the
   #        client (not really, but that's the protocol):
   #        We produce a challenge string that's sent to the client.
   #        The client must then echo the challenge verbatim to us.
   #
   #  Parameter:
   #      Socket      - Socket open on the client.
   #  Returns:
   #      1           - success.
   #      0           - failure (e.g.mismatch or insecure not allowed).
   #
   sub InsecureConnection {
       my $Socket  =  shift;
   
       #   Don't even start if insecure connections are not allowed.
   
       if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed.
    return 0;
       }
   
       #   Fabricate a challenge string and send it..
   
       my $challenge = "$$".time; # pid + time.
       print $Socket "$challenge\n";
       &status("Waiting for challenge reply");
   
       my $answer = <$Socket>;
       $answer    =~s/\W//g;
       if($challenge eq $answer) {
    return 1;
       } 
       else {
    logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
    &status("No challenge reqply");
    return 0;
       }
       
   
   }
   
 #  #
 #   GetCertificate: Given a transaction that requires a certificate,  #   GetCertificate: Given a transaction that requires a certificate,
 #   this function will extract the certificate from the transaction  #   this function will extract the certificate from the transaction
Line 225  sub ValidManager { Line 404  sub ValidManager {
 #     1   - Success.  #     1   - Success.
 #  #
 sub CopyFile {  sub CopyFile {
     my $oldfile = shift;  
     my $newfile = shift;      my ($oldfile, $newfile) = @_;
   
     #  The file must exist:      #  The file must exist:
   
Line 326  sub AdjustHostContents { Line 505  sub AdjustHostContents {
 #      0       - failure and $! has an errno.  #      0       - failure and $! has an errno.
 #  #
 sub InstallFile {  sub InstallFile {
     my $Filename = shift;  
     my $Contents = shift;      my ($Filename, $Contents) = @_;
     my $TempFile = $Filename.".tmp";      my $TempFile = $Filename.".tmp";
   
     #  Open the file for write:      #  Open the file for write:
Line 350  sub InstallFile { Line 529  sub InstallFile {
   
     return 1;      return 1;
 }  }
   
   
 #  #
 #   ConfigFileFromSelector: converts a configuration file selector  #   ConfigFileFromSelector: converts a configuration file selector
 #                 (one of host or domain at this point) into a   #                 (one of host or domain at this point) into a 
Line 564  sub isValidEditCommand { Line 745  sub isValidEditCommand {
 #                  file being edited.  #                  file being edited.
 #  #
 sub ApplyEdit {  sub ApplyEdit {
     my $directive   = shift;  
     my $editor      = shift;      my ($directive, $editor) = @_;
   
     # Break the directive down into its command and its parameters      # Break the directive down into its command and its parameters
     # (at most two at this point.  The meaning of the parameters, if in fact      # (at most two at this point.  The meaning of the parameters, if in fact
Line 649  sub AdjustOurHost { Line 830  sub AdjustOurHost {
 #        editor     - Editor containing the file.  #        editor     - Editor containing the file.
 #  #
 sub ReplaceConfigFile {  sub ReplaceConfigFile {
     my $filename  = shift;      
     my $editor    = shift;      my ($filename, $editor) = @_;
   
     CopyFile ($filename, $filename.".old");      CopyFile ($filename, $filename.".old");
   
Line 749  sub catchexception { Line 930  sub catchexception {
     $SIG{'QUIT'}='DEFAULT';      $SIG{'QUIT'}='DEFAULT';
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     &status("Catching exception");      &status("Catching exception");
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $thisserver died through "       ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
     &logthis('Famous last words: '.$status.' - '.$lastlog);      &logthis('Famous last words: '.$status.' - '.$lastlog);
Line 760  sub catchexception { Line 941  sub catchexception {
   
 sub timeout {  sub timeout {
     &status("Handling Timeout");      &status("Handling Timeout");
     &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");      &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
     &catchexception('Timeout');      &catchexception('Timeout');
 }  }
 # -------------------------------- Set signal handlers to record abnormal exits  # -------------------------------- Set signal handlers to record abnormal exits
Line 812  $server = IO::Socket::INET->new(LocalPor Line 993  $server = IO::Socket::INET->new(LocalPor
 # global variables  # global variables
   
 my %children               = ();       # keys are current child process IDs  my %children               = ();       # keys are current child process IDs
 my $children               = 0;        # current number of children  
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
Line 822  sub REAPER {                        # ta Line 1002  sub REAPER {                        # ta
  $pid = waitpid(-1,&WNOHANG());   $pid = waitpid(-1,&WNOHANG());
  if (defined($children{$pid})) {   if (defined($children{$pid})) {
     &logthis("Child $pid died");      &logthis("Child $pid died");
     $children --;      delete($children{$pid});
     delete $children{$pid};   } elsif ($pid > 0) {
  } else {  
     &logthis("Unknown Child $pid died");      &logthis("Unknown Child $pid died");
  }   }
     } while ( $pid > 0 );      } while ( $pid > 0 );
       foreach my $child (keys(%children)) {
    $pid = waitpid($child,&WNOHANG());
    if ($pid > 0) {
       &logthis("Child $child - $pid looks like we missed it's death");
       delete($children{$pid});
    }
       }
     &status("Finished Handling child death");      &status("Finished Handling child death");
 }  }
   
Line 838  sub HUNTSMAN {                      # si Line 1024  sub HUNTSMAN {                      # si
     &logthis("Free socket: ".shutdown($server,2)); # free up socket      &logthis("Free socket: ".shutdown($server,2)); # free up socket
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lond.pid");      unlink("$execdir/logs/lond.pid");
     &logthis("<font color=red>CRITICAL: Shutting down</font>");      &logthis("<font color='red'>CRITICAL: Shutting down</font>");
     &status("Done killing children");      &status("Done killing children");
     exit;                           # clean up with dignity      exit;                           # clean up with dignity
 }  }
Line 848  sub HUPSMAN {                      # sig Line 1034  sub HUPSMAN {                      # sig
     &status("Killing children for restart (HUP)");      &status("Killing children for restart (HUP)");
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     &logthis("Free socket: ".shutdown($server,2)); # free up socket      &logthis("Free socket: ".shutdown($server,2)); # free up socket
     &logthis("<font color=red>CRITICAL: Restarting</font>");      &logthis("<font color='red'>CRITICAL: Restarting</font>");
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lond.pid");      unlink("$execdir/logs/lond.pid");
     &status("Restarting self (HUP)");      &status("Restarting self (HUP)");
Line 858  sub HUPSMAN {                      # sig Line 1044  sub HUPSMAN {                      # sig
 #  #
 #    Kill off hashes that describe the host table prior to re-reading it.  #    Kill off hashes that describe the host table prior to re-reading it.
 #    Hashes affected are:  #    Hashes affected are:
 #       %hostid, %hostdom %hostip  #       %hostid, %hostdom %hostip %hostdns.
 #  #
 sub KillHostHashes {  sub KillHostHashes {
     foreach my $key (keys %hostid) {      foreach my $key (keys %hostid) {
Line 870  sub KillHostHashes { Line 1056  sub KillHostHashes {
     foreach my $key (keys %hostip) {      foreach my $key (keys %hostip) {
  delete $hostip{$key};   delete $hostip{$key};
     }      }
       foreach my $key (keys %hostdns) {
    delete $hostdns{$key};
       }
 }  }
 #  #
 #   Read in the host table from file and distribute it into the various hashes:  #   Read in the host table from file and distribute it into the various hashes:
Line 880  sub KillHostHashes { Line 1069  sub KillHostHashes {
 sub ReadHostTable {  sub ReadHostTable {
   
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";      open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
           my $myloncapaname = $perlvar{'lonHostID'};
       Debug("My loncapa name is : $myloncapaname");
     while (my $configline=<CONFIG>) {      while (my $configline=<CONFIG>) {
  my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);   if (!($configline =~ /^\s*\#/)) {
  chomp($ip); $ip=~s/\D+$//;      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
  $hostid{$ip}=$id;      chomp($ip); $ip=~s/\D+$//;
  $hostdom{$id}=$domain;      $hostid{$ip}=$id;         # LonCAPA name of host by IP.
  $hostip{$id}=$ip;      $hostdom{$id}=$domain;    # LonCAPA domain name of host. 
  if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      $hostip{$id}=$ip;      # IP address of host.
       $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
   
       if ($id eq $perlvar{'lonHostID'}) { 
    Debug("Found me in the host table: $name");
    $thisserver=$name; 
       }
    }
     }      }
     close(CONFIG);      close(CONFIG);
 }  }
Line 1008  sub Debug { Line 1205  sub Debug {
 #     request - Original request from client.  #     request - Original request from client.
 #  #
 sub Reply {  sub Reply {
     my $fd      = shift;  
     my $reply   = shift;      my ($fd, $reply, $request) = @_;
     my $request = shift;  
   
     print $fd $reply;      print $fd $reply;
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
Line 1023  sub logstatus { Line 1219  sub logstatus {
     my $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     {      {
     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");      my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
     print $fh $$."\t".$clientname."\t".$currenthostid."\t".$status."\t".$lastlog."\n";      print $fh $$."\t".$clientname."\t".$currenthostid."\t"
    .$status."\t".$lastlog."\t $keymode\n";
     $fh->close();      $fh->close();
     }      }
     &status("Finished londstatus.txt");      &status("Finished londstatus.txt");
     {      {
  my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");   my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
         print $fh $status."\n".$lastlog."\n".time;          print $fh $status."\n".$lastlog."\n".time."\n$keymode";
         $fh->close();          $fh->close();
     }      }
     &status("Finished logging");      &status("Finished logging");
Line 1088  sub reconlonc { Line 1285  sub reconlonc {
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
         } else {          } else {
     &logthis(      &logthis(
               "<font color=red>CRITICAL: "                "<font color='red'>CRITICAL: "
              ."lonc at pid $loncpid not responding, giving up</font>");               ."lonc at pid $loncpid not responding, giving up</font>");
         }          }
     } else {      } else {
       &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');        &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
     }      }
 }  }
   
Line 1196  my $execdir=$perlvar{'lonDaemons'}; Line 1393  my $execdir=$perlvar{'lonDaemons'};
 open (PIDSAVE,">$execdir/logs/lond.pid");  open (PIDSAVE,">$execdir/logs/lond.pid");
 print PIDSAVE "$$\n";  print PIDSAVE "$$\n";
 close(PIDSAVE);  close(PIDSAVE);
 &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");  &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
 &status('Starting');  &status('Starting');
   
   
Line 1251  sub make_new_child { Line 1448  sub make_new_child {
     #  the pid hash.      #  the pid hash.
     #      #
     my $caller = getpeername($client);      my $caller = getpeername($client);
     my ($port,$iaddr)=unpack_sockaddr_in($caller);      my ($port,$iaddr);
     $clientip=inet_ntoa($iaddr);      if (defined($caller) && length($caller) > 0) {
    ($port,$iaddr)=unpack_sockaddr_in($caller);
       } else {
    &logthis("Unable to determine who caller was, getpeername returned nothing");
       }
       if (defined($iaddr)) {
    $clientip  = inet_ntoa($iaddr);
    Debug("Connected with $clientip");
    $clientdns = gethostbyaddr($iaddr, AF_INET);
    Debug("Connected with $clientdns by name");
       } else {
    &logthis("Unable to determine clientip");
    $clientip='Unavailable';
       }
           
     if ($pid) {      if ($pid) {
         # Parent records the child's birth and returns.          # Parent records the child's birth and returns.
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = $clientip;          $children{$pid} = $clientip;
         $children++;  
         &status('Started child '.$pid);          &status('Started child '.$pid);
         return;          return;
     } else {      } else {
Line 1285  sub make_new_child { Line 1494  sub make_new_child {
 # =============================================================================  # =============================================================================
             # do something with the connection              # do something with the connection
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
  # see if we know client and check for spoof IP by challenge   # see if we know client and 'check' for spoof IP by ineffective challenge
   
  ReadManagerTable; # May also be a manager!!   ReadManagerTable; # May also be a manager!!
   
Line 1303  sub make_new_child { Line 1512  sub make_new_child {
     $clientname = $managers{$clientip};      $clientname = $managers{$clientip};
  }   }
  my $clientok;   my $clientok;
   
  if ($clientrec || $ismanager) {   if ($clientrec || $ismanager) {
     &status("Waiting for init from $clientip $clientname");      &status("Waiting for init from $clientip $clientname");
     &logthis('<font color="yellow">INFO: Connection, '.      &logthis('<font color="yellow">INFO: Connection, '.
Line 1310  sub make_new_child { Line 1520  sub make_new_child {
   " ($clientname) connection type = $ConnectionType </font>" );    " ($clientname) connection type = $ConnectionType </font>" );
     &status("Connecting $clientip  ($clientname))");       &status("Connecting $clientip  ($clientname))"); 
     my $remotereq=<$client>;      my $remotereq=<$client>;
     $remotereq=~s/[^\w:]//g;      chomp($remotereq);
       Debug("Got init: $remotereq");
       my $inikeyword = split(/:/, $remotereq);
     if ($remotereq =~ /^init/) {      if ($remotereq =~ /^init/) {
  &sethost("sethost:$perlvar{'lonHostID'}");   &sethost("sethost:$perlvar{'lonHostID'}");
  my $challenge="$$".time;   #
  print $client "$challenge\n";   #  If the remote is attempting a local init... give that a try:
  &status(   #
  "Waiting for challenge reply from $clientip ($clientname)");    my ($i, $inittype) = split(/:/, $remotereq);
  $remotereq=<$client>;  
  $remotereq=~s/\W//g;   # If the connection type is ssl, but I didn't get my
  if ($challenge eq $remotereq) {   # certificate files yet, then I'll drop  back to 
     $clientok=1;   # insecure (if allowed).
     print $client "ok\n";  
    if($inittype eq "ssl") {
       my ($ca, $cert) = lonssl::CertificateFile;
       my $kfile       = lonssl::KeyFile;
       if((!$ca)   || 
          (!$cert) || 
          (!$kfile)) {
    $inittype = ""; # This forces insecure attempt.
    &logthis("<font color=\"blue\"> Certificates not "
    ."installed -- trying insecure auth</font>");
       }
       else { # SSL certificates are in place so
       } # Leave the inittype alone.
    }
   
    if($inittype eq "local") {
       my $key = LocalConnection($client, $remotereq);
       if($key) {
    Debug("Got local key $key");
    $clientok     = 1;
    my $cipherkey = pack("H32", $key);
    $cipher       = new IDEA($cipherkey);
    print $client "ok:local\n";
    &logthis('<font color="green"'
    . "Successful local authentication </font>");
    $keymode = "local"
       } else {
    Debug("Failed to get local key");
    $clientok = 0;
    shutdown($client, 3);
    close $client;
       }
    } elsif ($inittype eq "ssl") {
       my $key = SSLConnection($client);
       if ($key) {
    $clientok = 1;
    my $cipherkey = pack("H32", $key);
    $cipher       = new IDEA($cipherkey);
    &logthis('<font color="green">'
    ."Successfull ssl authentication with $clientname </font>");
    $keymode = "ssl";
        
       } else {
    $clientok = 0;
    close $client;
       }
      
  } else {   } else {
     &logthis(      my $ok = InsecureConnection($client);
      "<font color=blue>WARNING: $clientip did not reply challenge</font>");      if($ok) {
     &status('No challenge reply '.$clientip);   $clientok = 1;
    &logthis('<font color="green">'
    ."Successful insecure authentication with $clientname </font>");
    print $client "ok\n";
    $keymode = "insecure";
       } else {
    &logthis('<font color="yellow">'
     ."Attempted insecure connection disallowed </font>");
    close $client;
    $clientok = 0;
   
       }
  }   }
     } else {      } else {
  &logthis(   &logthis(
  "<font color=blue>WARNING: "   "<font color='blue'>WARNING: "
  ."$clientip failed to initialize: >$remotereq< </font>");   ."$clientip failed to initialize: >$remotereq< </font>");
  &status('No init '.$clientip);   &status('No init '.$clientip);
     }      }
       
  } else {   } else {
     &logthis(      &logthis(
      "<font color=blue>WARNING: Unknown client $clientip</font>");       "<font color='blue'>WARNING: Unknown client $clientip</font>");
     &status('Hung up on '.$clientip);      &status('Hung up on '.$clientip);
  }   }
    
  if ($clientok) {   if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
           
Line 1349  sub make_new_child { Line 1620  sub make_new_child {
  }   }
  &reconlonc("$perlvar{'lonSockDir'}/$id");   &reconlonc("$perlvar{'lonSockDir'}/$id");
     }      }
     &logthis("<font color=green>Established connection: $clientname</font>");      &logthis("<font color='green'>Established connection: $clientname</font>");
     &status('Will listen to '.$clientname);      &status('Will listen to '.$clientname);
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
     while (my $userinput=<$client>) {      while (my $userinput=<$client>) {
Line 1546  sub make_new_child { Line 1817  sub make_new_child {
  $pwdcorrect=0;    $pwdcorrect=0; 
  # log error if it is not a bad password   # log error if it is not a bad password
  if ($krb4_error != 62) {   if ($krb4_error != 62) {
     &logthis('krb4:'.$uname.','.$contentpwd.','.      &logthis('krb4:'.$uname.','.
      &Authen::Krb4::get_err_txt($Authen::Krb4::error));       &Authen::Krb4::get_err_txt($Authen::Krb4::error));
  }   }
     }      }
Line 1812  sub make_new_child { Line 2083  sub make_new_child {
  } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.   } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
     if(isClient) {      if(isClient) {
  my ($cmd,$fname)=split(/:/,$userinput);   my ($cmd,$fname)=split(/:/,$userinput);
  my ($udom,$uname,$ufile)=split(/\//,$fname);   my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
  my $udir=propath($udom,$uname).'/userfiles';   my $udir=propath($udom,$uname).'/userfiles';
  unless (-e $udir) { mkdir($udir,0770); }   unless (-e $udir) { mkdir($udir,0770); }
  if (-e $udir) {   if (-e $udir) {
     $ufile=~s/^[\.\~]+//;                              $ufile=~s/^[\.\~]+//;
     $ufile=~s/\///g;                              my $path = $udir;
                               if ($ufile =~m|(.+)/([^/]+)$|) {
                                   my @parts=split('/',$1);
                                   foreach my $part (@parts) {
                                       $path .= '/'.$part;
                                       if ((-e $path)!=1) {
                                           mkdir($path,0770);
                                       }
                                   }
                               }
     my $destname=$udir.'/'.$ufile;      my $destname=$udir.'/'.$ufile;
     my $transname=$udir.'/'.$ufile.'.in.transit';      my $transname=$udir.'/'.$ufile.'.in.transit';
     my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;      my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
Line 1846  sub make_new_child { Line 2126  sub make_new_child {
  }   }
     } else {      } else {
  Reply($client, "refused\n", $userinput);   Reply($client, "refused\n", $userinput);
       }
   # --------------------------------------------------------- remove a user file 
    } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
       if(isClient) {
    my ($cmd,$fname)=split(/:/,$userinput);
    my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
    &logthis("$udom - $uname - $ufile");
    if ($ufile =~m|/\.\./|) {
       # any files paths with /../ in them refuse 
                               # to deal with
       print $client "refused\n";
    } else {
       my $udir=propath($udom,$uname);
       if (-e $udir) {
    my $file=$udir.'/userfiles/'.$ufile;
    if (-e $file) {
       unlink($file);
       if (-e $file) {
    print $client "failed\n";
       } else {
    print $client "ok\n";
       }
    } else {
       print $client "not_found\n";
    }
       } else {
    print $client "not_home\n";
       }
    }
       } else {
    Reply($client, "refused\n", $userinput);
     }      }
 # ------------------------------------------ authenticate access to a user file  # ------------------------------------------ authenticate access to a user file
  } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only   } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
Line 1857  sub make_new_child { Line 2167  sub make_new_child {
  if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.   if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
  $session.'.id')) {   $session.'.id')) {
     while (my $line=<ENVIN>) {      while (my $line=<ENVIN>) {
  if ($line=~/userfile\.$fname\=/) { $reply='ok'; }   if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
     }      }
     close(ENVIN);      close(ENVIN);
     print $client $reply."\n";      print $client $reply."\n";
Line 1873  sub make_new_child { Line 2183  sub make_new_child {
     if(isClient) {      if(isClient) {
  my ($cmd,$fname)=split(/:/,$userinput);   my ($cmd,$fname)=split(/:/,$userinput);
  if (-e $fname) {   if (-e $fname) {
     print $client &unsub($client,$fname,$clientip);      print $client &unsub($fname,$clientip);
  } else {   } else {
     print $client "not_found\n";      print $client "not_found\n";
  }   }
Line 2000  sub make_new_child { Line 2310  sub make_new_child {
  } else {   } else {
     print $client "error: ".($!+0)      print $client "error: ".($!+0)
  ." untie(GDBM) failed ".   ." untie(GDBM) failed ".
  "while attempting put\n";   "while attempting inc\n";
  }   }
     } else {      } else {
  print $client "error: ".($!)   print $client "error: ".($!)
     ." tie(GDBM) Failed ".      ." tie(GDBM) Failed ".
     "while attempting put\n";      "while attempting inc\n";
     }      }
  } else {   } else {
     print $client "refused\n";      print $client "refused\n";
Line 2331  sub make_new_child { Line 2641  sub make_new_child {
  my $proname=propath($udom,$uname);   my $proname=propath($udom,$uname);
  my %hash;   my %hash;
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {   if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
        study($regexp);  
        while (my ($key,$value) = each(%hash)) {         while (my ($key,$value) = each(%hash)) {
    if ($regexp eq '.') {     if ($regexp eq '.') {
        $qresult.=$key.'='.$value.'&';         $qresult.=$key.'='.$value.'&';
Line 2479  sub make_new_child { Line 2788  sub make_new_child {
     }      }
 # ------------------------------------------------------------------- querysend  # ------------------------------------------------------------------- querysend
  } elsif ($userinput =~ /^querysend/) {   } elsif ($userinput =~ /^querysend/) {
     if(isClient) {      if (isClient) {
  my ($cmd,$query,   my ($cmd,$query,
     $arg1,$arg2,$arg3)=split(/\:/,$userinput);      $arg1,$arg2,$arg3)=split(/\:/,$userinput);
  $query=~s/\n*$//g;   $query=~s/\n*$//g;
Line 2569  sub make_new_child { Line 2878  sub make_new_child {
     $qresult.=$key.'='.$descr.'&';      $qresult.=$key.'='.$descr.'&';
  } else {   } else {
     my $unescapeVal = &unescape($descr);      my $unescapeVal = &unescape($descr);
     if (eval('$unescapeVal=~/$description/i')) {      if (eval('$unescapeVal=~/\Q$description\E/i')) {
  $qresult.="$key=$descr&";   $qresult.="$key=$descr&";
     }      }
  }   }
Line 2724  sub make_new_child { Line 3033  sub make_new_child {
  Reply($client, "refused\n", $userinput);   Reply($client, "refused\n", $userinput);
             
     }      }
   # ----------------------------------------- portfolio directory list (portls)
                   } elsif ($userinput =~ /^portls/) {
                       if(isClient) {
                           my ($cmd,$uname,$udom)=split(/:/,$userinput);
                           my $udir=propath($udom,$uname).'/userfiles/portfolio';
                           my $dirLine='';
                           my $dirContents='';
                           if (opendir(LSDIR,$udir.'/')){
                               while ($dirLine = readdir(LSDIR)){
                                   $dirContents = $dirContents.$dirLine.'<br />';
                               }
                           } else {
                               $dirContents = "No directory found\n";
                           }
                           print $client $dirContents."\n";
                       } else {
                           Reply($client, "refused\n", $userinput);
                       }
 # -------------------------------------------------------------------------- ls  # -------------------------------------------------------------------------- ls
  } elsif ($userinput =~ /^ls/) {   } elsif ($userinput =~ /^ls/) {
     if(isClient) {      if(isClient) {
Line 2810  sub make_new_child { Line 3137  sub make_new_child {
     } else {      } else {
  print $client "refused\n";   print $client "refused\n";
     }      }
   #------------------------------- is auto-enrollment enabled?
                   } elsif ($userinput =~/^autorun:/) {
                       if (isClient) {
                           my ($cmd,$cdom) = split(/:/,$userinput);
                           my $outcome = &localenroll::run($cdom);
                           print $client "$outcome\n";
                       } else {
                           print $client "0\n";
                       }
   #------------------------------- get official sections (for auto-enrollment).
                   } elsif ($userinput =~/^autogetsections:/) {
                       if (isClient) {
                           my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
                           my @secs = &localenroll::get_sections($coursecode,$cdom);
                           my $seclist = &escape(join(':',@secs));
                           print $client "$seclist\n";
                       } else {
                           print $client "refused\n";
                       }
   #----------------------- validate owner of new course section (for auto-enrollment).
                   } elsif ($userinput =~/^autonewcourse:/) {
                       if (isClient) {
                           my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
                           my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
                           print $client "$outcome\n";
                       } else {
                           print $client "refused\n";
                       }
   #-------------- validate course section in schedule of classes (for auto-enrollment).
                   } elsif ($userinput =~/^autovalidatecourse:/) {
                       if (isClient) {
                           my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
                           my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
                           print $client "$outcome\n";
                       } else {
                           print $client "refused\n";
                       }
   #--------------------------- create password for new user (for auto-enrollment).
                   } elsif ($userinput =~/^autocreatepassword:/) {
                       if (isClient) {
                           my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
                           my ($create_passwd,$authchk);
                           ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);
                           print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
                       } else {
                           print $client "refused\n";
                       }
   #---------------------------  read and remove temporary files (for auto-enrollment).
                   } elsif ($userinput =~/^autoretrieve:/) {
                       if (isClient) {
                           my ($cmd,$filename) = split(/:/,$userinput);
                           my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
                           if ( (-e $source) && ($filename ne '') ) {
                               my $reply = '';
                               if (open(my $fh,$source)) {
                                   while (<$fh>) {
                                       chomp($_);
                                       $_ =~ s/^\s+//g;
                                       $_ =~ s/\s+$//g;
                                       $reply .= $_;
                                   }
                                   close($fh);
                                   print $client &escape($reply)."\n";
   #                                unlink($source);
                               } else {
                                   print $client "error\n";
                               }
                           } else {
                               print $client "error\n";
                           }
                       } else {
                           print $client "refused\n";
                       }
 # ------------------------------------------------------------- unknown command  # ------------------------------------------------------------- unknown command
   
  } else {   } else {
Line 2818  sub make_new_child { Line 3218  sub make_new_child {
  }   }
 # -------------------------------------------------------------------- complete  # -------------------------------------------------------------------- complete
  alarm(0);   alarm(0);
  &status('Listening to '.$clientname);   &status('Listening to '.$clientname." ($keymode)");
     }      }
 # --------------------------------------------- client unknown or fishy, refuse  # --------------------------------------------- client unknown or fishy, refuse
  } else {   } else {
     print $client "refused\n";      print $client "refused\n";
     $client->close();      $client->close();
     &logthis("<font color=blue>WARNING: "      &logthis("<font color='blue'>WARNING: "
      ."Rejected client $clientip, closing connection</font>");       ."Rejected client $clientip, closing connection</font>");
  }   }
     }                   }             
           
 # =============================================================================  # =============================================================================
           
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."Disconnect from $clientip ($clientname)</font>");           ."Disconnect from $clientip ($clientname)</font>");    
           
           
Line 2856  sub make_new_child { Line 3256  sub make_new_child {
 #  #
 sub ManagePermissions  sub ManagePermissions
 {  {
     my $request = shift;  
     my $domain  = shift;      my ($request, $domain, $user, $authtype) = @_;
     my $user    = shift;  
     my $authtype= shift;  
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
Line 2876  sub ManagePermissions Line 3274  sub ManagePermissions
 #  #
 sub GetAuthType   sub GetAuthType 
 {  {
     my $domain = shift;  
     my $user   = shift;      my ($domain, $user)  = @_;
   
     Debug("GetAuthType( $domain, $user ) \n");      Debug("GetAuthType( $domain, $user ) \n");
     my $proname    = &propath($domain, $user);       my $proname    = &propath($domain, $user); 
Line 2986  sub chatadd { Line 3384  sub chatadd {
 sub unsub {  sub unsub {
     my ($fname,$clientip)=@_;      my ($fname,$clientip)=@_;
     my $result;      my $result;
       my $unsubs = 0; # Number of successful unsubscribes:
   
   
       # An old way subscriptions were handled was to have a 
       # subscription marker file:
   
       Debug("Attempting unlink of $fname.$clientname");
     if (unlink("$fname.$clientname")) {      if (unlink("$fname.$clientname")) {
  $result="ok\n";   $unsubs++; # Successful unsub via marker file.
     } else {      } 
  $result="not_subscribed\n";  
     }      # The more modern way to do it is to have a subscription list
       # file:
   
     if (-e "$fname.subscription") {      if (-e "$fname.subscription") {
  my $found=&addline($fname,$clientname,$clientip,'');   my $found=&addline($fname,$clientname,$clientip,'');
  if ($found) { $result="ok\n"; }   if ($found) { 
       $unsubs++;
    }
       } 
   
       #  If either or both of these mechanisms succeeded in unsubscribing a 
       #  resource we can return ok:
   
       if($unsubs) {
    $result = "ok\n";
     } else {      } else {
  if ($result != "ok\n") { $result="not_subscribed\n"; }   $result = "not_subscribed\n";
     }      }
   
     return $result;      return $result;
 }  }
   
Line 3118  sub make_passwd_file { Line 3535  sub make_passwd_file {
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  {   {
       #
       #  Don't allow the creation of privileged accounts!!! that would
       #  be real bad!!!
       #
       my $uid = getpwnam($uname);
       if((defined $uid) && ($uid == 0)) {
    &logthis(">>>Attempted to create privilged account blocked");
    return "no_priv_account_error\n";
       }
   
     my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";      my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
     {      {
  &Debug("Executing external: ".$execpath);   &Debug("Executing external: ".$execpath);
Line 3150  sub sethost { Line 3577  sub sethost {
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {      if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
  $currenthostid=$hostid;   $currenthostid  =$hostid;
  $currentdomainid=$hostdom{$hostid};   $currentdomainid=$hostdom{$hostid};
  &logthis("Setting hostid to $hostid, and domain to $currentdomainid");   &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
     } else {      } else {
Line 3190  sub userload { Line 3617  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
 =head1 NAME  =head1 NAME

Removed from v.1.175  
changed lines
  Added in v.1.201


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