Diff for /loncom/LondConnection.pm between versions 1.25 and 1.62

version 1.25, 2004/02/09 13:33:16 version 1.62, 2018/12/14 02:05:38
Line 36  use IO::File; Line 36  use IO::File;
 use Fcntl;  use Fcntl;
 use POSIX;  use POSIX;
 use Crypt::IDEA;  use Crypt::IDEA;
   use LONCAPA::lonlocal;
   use LONCAPA::lonssl;
   
   
   
 my $DebugLevel=0;  my $DebugLevel=0;
 my %hostshash;  
 my %perlvar;  my %perlvar;
   my %secureconf;
   my %badcerts;
   my %hosttypes;
   my %crlchecked;
   my $InsecureOk;
   
 #  #
 #  Set debugging level  #  Set debugging level
Line 61  sub SetDebug { Line 64  sub SetDebug {
 my $ConfigRead = 0;  my $ConfigRead = 0;
   
 #   Read the configuration file for apache to get the perl  #   Read the configuration file for apache to get the perl
 #   variable set.  #   variables set.
   
 sub ReadConfig {  sub ReadConfig {
       Debug(8, "ReadConfig called");
   
     my $perlvarref = read_conf('loncapa.conf');      my $perlvarref = read_conf('loncapa.conf');
     %perlvar    = %{$perlvarref};      %perlvar    = %{$perlvarref};
     my $hoststab   = read_hosts(  
  "$perlvar{lonTabDir}/hosts.tab") ||   
  die "Can't read host table!!";  
     %hostshash  = %{$hoststab};  
     $ConfigRead = 1;      $ConfigRead = 1;
       
 }  
   
 #      $InsecureOk = $perlvar{loncAllowInsecure};
 #  Read a foreign configuration.  
 #  This sub is intended for the cases where the package      unless (lonssl::Read_Connect_Config(\%secureconf,\%perlvar) eq 'ok') {
 #  will be read from outside the LonCAPA environment, in that case          Debug(1,"Failed to retrieve secureconf hash.\n");
 #  the client will need to explicitly provide:  
 #   - A file in hosts.tab format.  
 #   - Some idea of the 'lonCAPA' name of the local host (for building  
 #     the encryption key).  
 #  
 #  Parameters:  
 #      MyHost   - Name of this host as far as LonCAPA is concerned.  
 #      Filename - Name of a hosts.tab formatted file that will be used  
 #                 to build up the hosts table.  
 #  
 sub ReadForeignConfig {  
     my $MyHost   = shift;  
     my $Filename = shift;  
   
     &Debug(4, "ReadForeignConfig $MyHost $Filename\n");  
   
     $perlvar{lonHostID} = $MyHost; # Rmember my host.  
     my $hosttab = read_hosts($Filename) ||  
  die "Can't read hosts table!!";  
     %hostshash = %{$hosttab};  
     if($DebugLevel > 3) {  
  foreach my $host (keys %hostshash) {  
     print "host $host => $hostshash{$host}\n";  
  }  
     }      }
     $ConfigRead = 1;      unless (lonssl::Read_Host_Types(\%hosttypes,\%perlvar) eq 'ok') {
           Debug(1,"Failed to retrieve hosttypes hash.\n");
       }
       %badcerts = ();
       %crlchecked = ();
   }
   
   sub ResetReadConfig {
       $ConfigRead = 0;
 }  }
   
 sub Debug {  sub Debug {
     my $level   = shift;  
     my $message = shift;      my ($level, $message) = @_;
   
     if ($level < $DebugLevel) {      if ($level < $DebugLevel) {
  print($message."\n");   print STDERR ($message."\n");
     }      }
 }  }
   
Line 125  Dump the internal state of the object: F Line 108  Dump the internal state of the object: F
   
 sub Dump {  sub Dump {
     my $self   = shift;      my $self   = shift;
       my $level  = shift;
       my $now    = time;
       my $local  = localtime($now);
       
       if ($level >= $DebugLevel) {
    return;
       }
   
       
     my $key;      my $key;
     my $value;      my $value;
     print STDERR "Dumping LondConnectionObject:\n";      print STDERR "[ $local ] Dumping LondConnectionObject:\n";
       print STDERR join(':',caller(1))."\n";
     while(($key, $value) = each %$self) {      while(($key, $value) = each %$self) {
  print STDERR "$key -> $value\n";   print STDERR "$key -> $value\n";
     }      }
Line 143  old state. Line 136  old state.
 =cut  =cut
   
 sub Transition {  sub Transition {
     my $self     = shift;  
     my $newstate = shift;      my ($self, $newstate) = @_;
   
     my $oldstate = $self->{State};      my $oldstate = $self->{State};
     $self->{State} = $newstate;      $self->{State} = $newstate;
     $self->{TimeoutRemaining} = $self->{TimeoutValue};      $self->{TimeoutRemaining} = $self->{TimeoutValue};
Line 171  host the remote lond is on. This host is Line 165  host the remote lond is on. This host is
   
  port number the remote lond is listening on.   port number the remote lond is listening on.
   
   =item lonid
   
    lonid of the remote lond is listening on.
   
   =item deflonid
   
    default lonhostID of the remote lond is listening on.
   
 =cut  =cut
   
 sub new {  sub new {
     my $class    = shift; # class name.      my ($class, $DnsName, $Port, $lonid, $deflonid, $loncaparev) = @_;
     my $Hostname = shift; # Name of host to connect to.  
     my $Port     = shift; # Port to connect   
   
     if (!$ConfigRead) {      if (!$ConfigRead) {
  ReadConfig();   ReadConfig();
  $ConfigRead = 1;   $ConfigRead = 1;
     }      }
     &Debug(4,$class."::new( ".$Hostname.",".$Port.")\n");      &Debug(4,$class."::new( ".$DnsName.",".$Port.",".$lonid.",".$deflonid.",".$loncaparev.")\n");
   
       my ($conntype,$gotconninfo,$allowinsecure);
       if ((ref($secureconf{'connto'}) eq 'HASH') &&
           (exists($hosttypes{$lonid}))) {
           $conntype = $secureconf{'connto'}{$hosttypes{$lonid}};
           if ($conntype ne '') {
               if ($conntype ne 'req') {
                   $allowinsecure = 1;
               }
               $gotconninfo = 1;
           }
       }
       unless ($gotconninfo) {
           $allowinsecure = $InsecureOk;
       }
   
     # The host must map to an entry in the hosts table:      # The host must map to an entry in the hosts table:
     #  We connect to the dns host that corresponds to that      #  We connect to the dns host that corresponds to that
Line 190  sub new { Line 205  sub new {
     #  negotion.  In the objec these become the Host and      #  negotion.  In the objec these become the Host and
     #  LoncapaHim fields of the object respectively.      #  LoncapaHim fields of the object respectively.
     #      #
     if (!exists $hostshash{$Hostname}) {      # if it is me use loopback for connection
  &Debug(8, "No Such host $Hostname");      if ($DnsName eq &main::my_hostname()) { $DnsName="127.0.0.1"; }
  return undef; # No such host!!!      Debug(9, "Connecting to $DnsName");
     }  
     my @ConfigLine = @{$hostshash{$Hostname}};  
     my $DnsName    = $ConfigLine[3]; # 4'th item is dns of host.  
     Debug(5, "Connecting to ".$DnsName);  
     # Now create the object...      # Now create the object...
     my $self     = { Host               => $DnsName,      my $self     = { Host               => $DnsName,
                      LoncapaHim         => $Hostname,                       LoncapaHim         => $lonid,
                        LoncapaDefid       => $deflonid,
                        LoncapaRev         => $loncaparev, 
                      Port               => $Port,                       Port               => $Port,
                      State              => "Initialized",                       State              => "Initialized",
        AuthenticationMode => "",
        InsecureOK         => $allowinsecure,
                      TransactionRequest => "",                       TransactionRequest => "",
                      TransactionReply   => "",                       TransactionReply   => "",
                        NextRequest        => "",
                      InformReadable     => 0,                       InformReadable     => 0,
                      InformWritable     => 0,                       InformWritable     => 0,
                      TimeoutCallback    => undef,                       TimeoutCallback    => undef,
Line 211  sub new { Line 227  sub new {
                      Timeoutable        => 0,                       Timeoutable        => 0,
                      TimeoutValue       => 30,                       TimeoutValue       => 30,
                      TimeoutRemaining   => 0,                       TimeoutRemaining   => 0,
        LocalKeyFile       => "",
                      CipherKey          => "",                       CipherKey          => "",
                      LondVersion        => "Unknown",                       LondVersion        => "Unknown",
                      Cipher             => undef};                       Cipher             => undef,
        ClientData         => undef};
     bless($self, $class);      bless($self, $class);
     unless ($self->{Socket} = IO::Socket::INET->new(PeerHost => $self->{Host},      unless ($self->{Socket} = IO::Socket::INET->new(PeerHost => $self->{Host},
     PeerPort => $self->{Port},         PeerPort => $self->{Port},
     Type     => SOCK_STREAM,         Type     => SOCK_STREAM,
     Proto    => "tcp",         Proto    => "tcp",
     Timeout  => 3)) {         Timeout  => 3)) {
    Debug(8, "Error? \n$@ \n$!");
  return undef; # Inidicates the socket could not be made.   return undef; # Inidicates the socket could not be made.
     }      }
       my $socket = $self->{Socket}; # For local use only.
       $socket->sockopt(SO_KEEPALIVE, 1); # Turn on keepalive probes when idle.
       #  If we are local, we'll first try local auth mode, otherwise, we'll try
       #  the ssl auth mode:
   
       my $key;
       my $keyfile;
       if ($DnsName eq '127.0.0.1') {
    $self->{AuthenticationMode} = "local";
    ($key, $keyfile)         = lonlocal::CreateKeyFile();
    Debug(8, "Local key: $key, stored in $keyfile");
      
    #  If I can't make the key file fall back to insecure if 
    #  allowed...else give up right away.
   
    if(!(defined $key) || !(defined $keyfile)) {
               my $canconnect = 0;
               if (ref($secureconf{'connto'}) eq 'HASH') {
                   unless ($secureconf{'connto'}->{'dom'} eq 'req') {
                       $canconnect = 1;
                   }
               } else {
                   $canconnect = $InsecureOk;
               }
       if ($canconnect) {
    $self->{AuthenticationMode} = "insecure";
    $self->{TransactionRequest} = "init\n";
       } 
       else {
    $socket->close;
    return undef;
       }
    }
    $self->{TransactionRequest} = "init:local:$keyfile\n";
    Debug(9, "Init string is init:local:$keyfile");
    if(!$self->CreateCipher($key)) { # Nothing's going our way...
       $socket->close;
       return undef;
    }
   
       } else {
    #  Remote peer:  I'd like to do ssl, but if my host key or certificates
    #  are not all installed, my only choice is insecure, if that's 
    #  allowed:
   
    my ($ca, $cert) = lonssl::CertificateFile;
    my $sslkeyfile  = lonssl::KeyFile;
           my $badcertfile = lonssl::has_badcert_file($self->{LoncapaHim});
           my ($loncaparev) = ($perlvar{'lonVersion'} =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/);
   
    if (($conntype ne 'no') && (defined($ca)) && (defined($cert)) && (defined($sslkeyfile)) &&
               (!exists($badcerts{$self->{LoncapaHim}})) && !$badcertfile) {
       $self->{AuthenticationMode} = "ssl";
       $self->{TransactionRequest} = "init:ssl:$loncaparev\n";
    } elsif ($self->{InsecureOK}) {
       # Allowed to do insecure:
       $self->{AuthenticationMode} = "insecure";
       $self->{TransactionRequest} = "init::$loncaparev\n";
    } else {
       # Not allowed to do insecure...
       $socket->close;
       return undef;
    }
       }
   
     #      #
     # We're connected.  Set the state, and the events we'll accept:      # We're connected.  Set the state, and the events we'll accept:
     #      #
     $self->Transition("Connected");      $self->Transition("Connected");
     $self->{InformWritable}     = 1;    # When  socket is writable we send init      $self->{InformWritable}     = 1;    # When  socket is writable we send init
     $self->{Timeoutable}        = 1;    # Timeout allowed during startup negotiation.       $self->{Timeoutable}        = 1;    # Timeout allowed during startup negotiation. 
     $self->{TransactionRequest} = "init\n";  
           
     #      #
     # Set socket to nonblocking I/O.      # Set socket to nonblocking I/O.
     #      #
     my $socket = $self->{Socket};      my $flags    = fcntl($socket, F_GETFL,0);
     my $flags    = fcntl($socket->fileno, F_GETFL,0);      if(!$flags) {
     if($flags == -1) {  
  $socket->close;   $socket->close;
  return undef;   return undef;
     }      }
     if(fcntl($socket, F_SETFL, $flags | O_NONBLOCK) == -1) {      if(!fcntl($socket, F_SETFL, $flags | O_NONBLOCK)) {
  $socket->close;   $socket->close;
  return undef;   return undef;
     }      }
   
     # return the object :      # return the object :
   
       Debug(9, "Initial object state: ");
       $self->Dump(9);
   
     return $self;      return $self;
 }  }
   
Line 279  sub Readable { Line 365  sub Readable {
     my $self    = shift;      my $self    = shift;
     my $socket  = $self->{Socket};      my $socket  = $self->{Socket};
     my $data    = '';      my $data    = '';
     my $rv      = $socket->recv($data, POSIX::BUFSIZ,  0);      my $rv;
       my $ConnectionMode = $self->{AuthenticationMode};
   
       if ($socket) {
    eval {
       $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
    }
       } else {
    $self->Transition("Disconnected");
    return -1;
       }
     my $errno   = $! + 0;             # Force numeric context.      my $errno   = $! + 0;             # Force numeric context.
   
     unless (defined($rv) && length $data) {# Read failed,      unless (defined($rv) && length $data) {# Read failed,
Line 296  sub Readable { Line 392  sub Readable {
  $self->Transition("Disconnected");   $self->Transition("Disconnected");
  return -1;   return -1;
     }      }
       # If we actually got data, reset the timeout.
   
       if (length $data) {
    $self->{TimeoutRemaining}   = $self->{TimeoutValue}; # getting data resets the timeout period.
       }
     #  Append the data to the buffer.  And figure out if the read is done:      #  Append the data to the buffer.  And figure out if the read is done:
   
     &Debug(9,"Received from host: ".$data);      &Debug(9,"Received from host: ".$data);
     $self->{TransactionReply} .= $data;      $self->{TransactionReply} .= $data;
     if($self->{TransactionReply} =~ /(.*\n)/) {      if($self->{TransactionReply} =~ m/\n$/) {
  &Debug(8,"Readable End of line detected");   &Debug(8,"Readable End of line detected");
   
   
  if ($self->{State}  eq "Initialized") { # We received the challenge:   if ($self->{State}  eq "Initialized") { # We received the challenge:
     if($self->{TransactionReply} eq "refused\n") { # Remote doesn't have      #   Our init was replied to. What happens next depends both on
       #  the actual init we sent (AuthenticationMode member data)
  $self->Transition("Disconnected"); # in host tables.      #  and the response:
  $socket->close();      #     AuthenticationMode == local:
  return -1;      #       Response ok:   The key has been exchanged and
     }      #                      the key file destroyed. We can jump
       #                      into setting the host and requesting the
       #                      Later we'll also bypass key exchange.
       #       Response digits: 
       #                      Old style lond. Delete the keyfile.
       #                      If allowed fall back to insecure mode.
       #                      else close connection and fail.
       #       Response other:
       #                      Failed local auth 
       #                      Close connection and fail.
       #
       #    AuthenticationMode == ssl:
       #        Response ok:ssl
       #        Response digits:
       #        Response other:
       #    Authentication mode == insecure
       #        Response digits
       #        Response other:
           
     &Debug(8," Transition out of Initialized");      my $Response = $self->{TransactionReply};
     $self->{TransactionRequest} = $self->{TransactionReply};      if($ConnectionMode eq "local") {
     $self->{InformWritable}     = 1;   if($Response =~ /^ok:local/) { #  Good local auth.
     $self->{InformReadable}     = 0;      $self->ToVersionRequest();
     $self->Transition("ChallengeReceived");      return 0;
     $self->{TimeoutRemaining}   = $self->{TimeoutValue};   }
     return 0;   elsif ($Response =~/^[0-9]+/) { # Old style lond.
       return $self->CompleteInsecure();
   
    }
    else {                # Complete flop
       &Debug(3, "init:local : unrecognized reply");
       $self->Transition("Disconnected");
       $socket->close;
       return -1;
    }
       }
       elsif ($ConnectionMode eq "ssl") {
    if($Response =~ /^ok:ssl/) {     # Good ssl...
       my $sslresult = $self->ExchangeKeysViaSSL();
                       if ($sslresult == 1) { # Success skip to vsn stuff
    # Need to reset to non blocking:
   
    my $flags = fcntl($socket, F_GETFL, 0);
    fcntl($socket, F_SETFL, $flags | O_NONBLOCK);
    $self->ToVersionRequest();
    return 0;
       } 
       else { # Failed in ssl exchange.
           if (($sslresult == -1) && (lonssl::LastError == -1) && ($self->{InsecureOK})) {
                               my $badcertdir = &lonssl::BadCertDir();
                               if (($badcertdir) && $self->{LoncapaHim}) {
                                   if (open(my $fh,'>',"$badcertdir/".$self->{LoncapaHim})) {
                                       close($fh);
                                   }
                               }
       $badcerts{$self->{LoncapaHim}} = 1;
                               &Debug(3,"SSL verification failed: close socket and initiate insecure connection");
                               $self->Transition("ReInitNoSSL");
                               $socket->close;
                               return -1;
    }
    &Debug(3,"init:ssl failed key negotiation!");
    $self->Transition("Disconnected");
    $socket->close;
    return -1;
                       }
    } 
    elsif ($Response =~ /^[0-9]+/) { # Old style lond.
       return $self->CompleteInsecure();
    }
    else {                 # Complete flop
    }
       }
       elsif ($ConnectionMode eq "insecure") {
    if($self->{TransactionReply} eq "refused\n") { # Remote doesn't have
       
       $self->Transition("Disconnected"); # in host tables.
       $socket->close();
       return -1;
   
    }
    return $self->CompleteInsecure();
       }
       else {
    &Debug(1,"Authentication mode incorrect");
    die "BUG!!! LondConnection::Readable invalid authmode";
       }
   
   
  }  elsif ($self->{State} eq "ChallengeReplied") {   }  elsif ($self->{State} eq "ChallengeReplied") {
     if($self->{TransactionReply} ne "ok\n") {      if($self->{TransactionReply} ne "ok\n") {
  $self->Transition("Disconnected");   $self->Transition("Disconnected");
  $socket->close();   $socket->close();
  return -1;   return -1;
     }      }
     $self->Transition("RequestingVersion");      $self->ToVersionRequest();
     $self->{InformReadable}   = 0;  
     $self->{InformWritable}   = 1;  
     $self->{TransactionRequest} = "version\n";  
     return 0;      return 0;
   
  } elsif ($self->{State} eq "ReadingVersionString") {   } elsif ($self->{State} eq "ReadingVersionString") {
     $self->{LondVersion}       = chomp($self->{TransactionReply});      chomp($self->{TransactionReply});
       $self->{LondVersion}       = $self->{TransactionReply};
     $self->Transition("SetHost");      $self->Transition("SetHost");
     $self->{InformReadable}    = 0;      $self->{InformReadable}    = 0;
     $self->{InformWritable}    = 1;      $self->{InformWritable}    = 1;
Line 342  sub Readable { Line 524  sub Readable {
  $socket->close();   $socket->close();
  return -1;   return -1;
     }      }
     $self->Transition("RequestingKey");      #  If the auth mode is insecure we must still
     $self->{InformReadable}  = 0;      #  exchange session keys. Otherwise,
     $self->{InformWritable}  = 1;      #  we can just transition to idle.
     $self->{TransactionRequest} = "ekey\n";  
     return 0;      if($ConnectionMode eq "insecure") {
    $self->Transition("RequestingKey");
    $self->{InformReadable}  = 0;
    $self->{InformWritable}  = 1;
    $self->{TransactionRequest} = "ekey\n";
    return 0;
       }
       else {
    $self->ToIdle();
    return 0;
       }
  } elsif ($self->{State}  eq "ReceivingKey") {   } elsif ($self->{State}  eq "ReceivingKey") {
     my $buildkey = $self->{TransactionReply};      my $buildkey = $self->{TransactionReply};
               chomp($buildkey);
     my $key = $self->{LoncapaHim}.$perlvar{'lonHostID'};      my $key = $self->{LoncapaHim}.$perlvar{'lonHostID'};
     $key=~tr/a-z/A-Z/;      $key=~tr/a-z/A-Z/;
     $key=~tr/G-P/0-9/;      $key=~tr/G-P/0-9/;
     $key=~tr/Q-Z/0-9/;      $key=~tr/Q-Z/0-9/;
     $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;      $key =$key.$buildkey.$key.$buildkey.$key.$buildkey;
     $key=substr($key,0,32);      $key               = substr($key,0,32);
     my $cipherkey=pack("H32",$key);      if(!$self->CreateCipher($key)) {
     $self->{Cipher} = new IDEA $cipherkey;  
     if($self->{Cipher} eq undef) {  
  $self->Transition("Disconnected");   $self->Transition("Disconnected");
  $socket->close();   $socket->close();
  return -1;   return -1;
     } else {      } else {
  $self->Transition("Idle");   $self->ToIdle();
  $self->{InformWritable}  =  0;  
  $self->{InformReadable}  =  0;  
  $self->{Timeoutable}     = 0;  
  return 0;   return 0;
     }      }
  } elsif ($self->{State}  eq "ReceivingReply") {   } elsif ($self->{State}  eq "ReceivingReply") {
Line 375  sub Readable { Line 563  sub Readable {
     my $answer = $self->{TransactionReply};      my $answer = $self->{TransactionReply};
     if($answer =~ /^enc\:/) {      if($answer =~ /^enc\:/) {
  $answer = $self->Decrypt($answer);   $answer = $self->Decrypt($answer);
  $self->{TransactionReply} = $answer;   $self->{TransactionReply} = "$answer\n";
     }      }
       # if we have a NextRequest do it immeadiately
       if ($self->{NextRequest}) {
    $self->{TransactionRequest} = $self->{NextRequest};
    undef( $self->{NextRequest} );
    $self->{TransactionReply}   = "";
    $self->{InformWritable}     = 1;
    $self->{InformReadable}     = 0;
    $self->{Timeoutable}        = 1;
    $self->Transition("SendingRequest");
    return 0;
       } else {
     # finish the transaction      # finish the transaction
   
     $self->{InformWritable}     = 0;   $self->ToIdle();
     $self->{InformReadable}     = 0;   return 0;
     $self->{Timeoutable}        = 0;      }
     $self->Transition("Idle");  
     return 0;  
  } elsif ($self->{State} eq "Disconnected") { # No connection.   } elsif ($self->{State} eq "Disconnected") { # No connection.
     return -1;      return -1;
  } else { # Internal error: Invalid state.   } else { # Internal error: Invalid state.
Line 395  sub Readable { Line 591  sub Readable {
     }      }
   
     return 0;      return 0;
       
 }  }
   
   
Line 410  mark the object as waiting for readabili Line 606  mark the object as waiting for readabili
 Returns  0 if successful, or -1 if not.  Returns  0 if successful, or -1 if not.
   
 =cut  =cut
   
 sub Writable {  sub Writable {
     my $self     = shift; # Get reference to the object.      my $self     = shift; # Get reference to the object.
     my $socket   = $self->{Socket};      my $socket   = $self->{Socket};
     my $nwritten = $socket->send($self->{TransactionRequest}, 0);      my $nwritten;
       if ($socket) {
    eval {
       $nwritten = $socket->send($self->{TransactionRequest}, 0);
    }
       } else {
    # For whatever reason, there's no longer a socket left.
   
   
    $self->Transition("Disconnected");
    return -1;
       }
     my $errno    = $! + 0;      my $errno    = $! + 0;
     unless (defined $nwritten) {      unless (defined $nwritten) {
  if($errno != POSIX::EINTR) {   if($errno != POSIX::EINTR) {
Line 428  sub Writable { Line 634  sub Writable {
  ($errno == POSIX::EAGAIN)         ||   ($errno == POSIX::EAGAIN)         ||
  ($errno == POSIX::EINTR)          ||   ($errno == POSIX::EINTR)          ||
  ($errno ==  0)) {   ($errno ==  0)) {
    $self->{TimeoutRemaining} = $self->{TimeoutValue};
  substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part   substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part
  if(length $self->{TransactionRequest} == 0) {   if(length $self->{TransactionRequest} == 0) {
     $self->{InformWritable} = 0;      $self->{InformWritable} = 0;
Line 462  sub Writable { Line 669  sub Writable {
  $socket->close();   $socket->close();
  return -1;   return -1;
     }      }
       
 }  }
   
 =pod  =pod
   
 =head2 Tick  =head2 Tick
Line 517  timout, and to request writability notif Line 724  timout, and to request writability notif
 =cut  =cut
   
 sub InitiateTransaction {  sub InitiateTransaction {
     my $self   = shift;  
     my $data   = shift;      my ($self, $data) = @_;
   
     Debug(1, "initiating transaction: ".$data);      Debug(1, "initiating transaction: ".$data);
     if($self->{State} ne "Idle") {      if($self->{State} ne "Idle") {
Line 526  sub InitiateTransaction { Line 733  sub InitiateTransaction {
  return -1; # Error indicator.   return -1; # Error indicator.
     }      }
     # if the transaction is to be encrypted encrypt the data:      # if the transaction is to be encrypted encrypt the data:
       (my $sethost, my $server,$data)=split(/:/,$data,3);
   
     if($data =~ /^encrypt\:/) {      if($data =~ /^encrypt\:/) {
  $data = $self->Encrypt($data);   $data = $self->Encrypt($data);
     }      }
   
     # Setup the trasaction      # Setup the trasaction
       # currently no version of lond supports inlining the sethost
     $self->{TransactionRequest} = $data;      if ($self->PeerVersion() <= 321) {
    if ($server ne $self->{LoncapaHim}) {
       $self->{NextRequest}        = $data;
       $self->{TransactionRequest} = "$sethost:$server\n";
       $self->{LoncapaHim}         = $server;
    } else {
       $self->{TransactionRequest}        = $data;
    }
       } else {
    $self->{LoncapaHim}         = $server;
    $self->{TransactionRequest} = "$sethost:$server:$data";
       }
     $self->{TransactionReply}   = "";      $self->{TransactionReply}   = "";
     $self->{InformWritable}     = 1;      $self->{InformWritable}     = 1;
     $self->{InformReadable}     = 0;      $self->{InformReadable}     = 0;
Line 569  established callback or undef if there w Line 788  established callback or undef if there w
 =cut  =cut
   
 sub SetTimeoutCallback {  sub SetTimeoutCallback {
     my $self                 = shift;  
     my $callback             = shift;      my ($self, $callback) = @_;
   
     my $oldCallback          = $self->{TimeoutCallback};      my $oldCallback          = $self->{TimeoutCallback};
     $self->{TimeoutCallback} = $callback;      $self->{TimeoutCallback} = $callback;
     return $oldCallback;      return $oldCallback;
Line 596  sub Shutdown { Line 816  sub Shutdown {
     $socket->shutdown(2);      $socket->shutdown(2);
  }   }
     }      }
       $self->{Timeoutable}   = 0; # Shutdown sockets can't timeout.
 }  }
   
 =pod  =pod
Line 698  The output string can be directly sent t Line 919  The output string can be directly sent t
 =cut  =cut
   
 sub Encrypt {  sub Encrypt {
     my $self    = shift; # Reference to the object.      
     my $request = shift;        # Text to send.      my ($self, $request) = @_;
   
         
     # Split the encrypt: off the request and figure out it's length.      # Split the encrypt: off the request and figure out it's length.
Line 741  Decrypt a response from the server.  The Line 962  Decrypt a response from the server.  The
 =cut  =cut
   
 sub Decrypt {  sub Decrypt {
     my $self      = shift; # Recover reference to object  
     my $encrypted = shift; # This is the encrypted data.      my ($self, $encrypted) = @_;
   
     #  Bust up the response into length, and encryptedstring:      #  Bust up the response into length, and encryptedstring:
   
Line 765  sub Decrypt { Line 986  sub Decrypt {
     #  $length tells us the actual length of the decrypted string:      #  $length tells us the actual length of the decrypted string:
   
     $decrypted = substr($decrypted, 0, $length);      $decrypted = substr($decrypted, 0, $length);
       Debug(9, "Decrypted $EncryptedString to $decrypted");
   
     return $decrypted;      return $decrypted;
   
 }  }
   # ToIdle
   #     Called to transition to idle... done enough it's worth subbing
   #     off to ensure it's always done right!!
   #
   sub ToIdle {
       my $self   = shift;
   
 =pod      $self->Transition("Idle");
       $self->{InformWritiable} = 0;
       $self->{InformReadable}  = 0;
       $self->{Timeoutable}     = 0;
   }
   
   #  ToVersionRequest
   #    Called to transition to "RequestVersion"  also done a few times
   #    so worth subbing out.
   #
   sub ToVersionRequest {
       my $self   = shift;
       
       $self->Transition("RequestingVersion");
       $self->{InformReadable}   = 0;
       $self->{InformWritable}   = 1;
       $self->{TransactionRequest} = "version\n";
       
   }
   #
   #  CreateCipher
   #    Given a cipher key stores the key in the object context,
   #    creates the cipher object, (stores that in object context),
   #    This is done a couple of places, so it's worth factoring it out.
   #
   # Parameters:
   #    (self)
   #    key - The Cipher key.
   #
   # Returns:
   #    0   - Failure to create IDEA cipher.
   #    1   - Success.
   #
   sub CreateCipher {
       my ($self, $key)   = @_; # According to coding std.
   
 =head2 GetHostIterator      $self->{CipherKey} = $key; # Save the text key...
       my $packedkey = pack ("H32", $key);
       my $cipher            = new IDEA $packedkey;
       if($cipher) {
    $self->{Cipher} = $cipher;
    Debug("Cipher created  dumping socket: ");
    $self->Dump(9);
    return 1;
       }
       else {
    return 0;
       }
   }
   # ExchangeKeysViaSSL
   #     Called to do cipher key exchange via SSL.
   #     The socket is promoted to an SSL socket. If that's successful,
   #     we read out cipher key through the socket and create an IDEA
   #     cipher object.
   # Parameters:
   #    (self)
   # Returns:
   #      true    - Success.
   #      false   - Failure.
   #
   # Assumptions:
   #  1.   The ssl session setup has timeout logic built in so we don't
   #     have to worry about DOS attacks at that stage.
   #  2.   If the ssl session gets set up we are talking to a legitimate
   #     lond so again we don't have to worry about DOS attacks.
   #  All this allows us just to call 
   sub ExchangeKeysViaSSL {
       my $self   = shift;
       my $socket = $self->{Socket};
       my $peer = $self->{LoncapaHim};
       my $peerdef = $self->{LoncapaDefid};
       my $loncaparev = $self->{LoncapaRev};
   
       #  Get our signed certificate, the certificate authority's 
       #  certificate and our private key file.  All of these
       #  are needed to create the ssl connection.
   
       my ($SSLCACertificate,
    $SSLCertificate) = lonssl::CertificateFile();
       my $SSLKey             = lonssl::KeyFile();
       my $CRLFile;
       unless ($crlchecked{$peerdef}) {
           $CRLFile = lonssl::CRLFile();
           $crlchecked{$peerdef} = 1;
       }
       #  Promote our connection to ssl and read the key from lond.
   
       my $SSLSocket = lonssl::PromoteClientSocket($socket,
    $SSLCACertificate,
    $SSLCertificate,
    $SSLKey,
                                                   $peer,
                                                   $peerdef,
                                                   $CRLFile,
                                                   $loncaparev);
       if(defined $SSLSocket) {
    my $key  = <$SSLSocket>;
    lonssl::Close($SSLSocket);
    if($key) {
       chomp($key); # \n is not part of the key.
       return $self->CreateCipher($key);
    } 
    else {
       Debug(3, "Failed to read ssl key");
       return 0;
    }
       }
       else {
    # Failed!!
    Debug(3, "Failed to negotiate SSL connection!");
    return -1;
       }
       # should not get here
       return 0;
   
 Returns a hash iterator to the host information.  Each get from   }
 this iterator returns a reference to an array that contains   
 information read from the hosts configuration file.  Array elements  
 are used as follows:  
   
  [0]   - LonCapa host name.  
  [1]   - LonCapa domain name.  
  [2]   - Loncapa role (e.g. library or access).  
  [3]   - DNS name server hostname.  
  [4]   - IP address (result of e.g. nslookup [3]).  
  [5]   - Maximum connection count.  
  [6]   - Idle timeout for reducing connection count.  
  [7]   - Minimum connection count.  
   
 =cut  
   
 sub GetHostIterator {  
   
     return HashIterator->new(\%hostshash);      #
   #  CompleteInsecure:
   #      This function is called to initiate the completion of
   #      insecure challenge response negotiation.
   #      To do this, we copy the challenge string to the transaction
   #      request, flip to writability and state transition to 
   #      ChallengeReceived..
   #      All this is only possible if InsecureOk is true.
   # Parameters:
   #      (self)    - This object's context hash.
   #  Return:
   #      0   - Ok to transition.
   #     -1   - Not ok to transition (InsecureOk not ok).
   #
   sub CompleteInsecure {
       my $self = shift;
       if ($self->{InsecureOK}) {
    $self->{AuthenticationMode} = "insecure";
    &Debug(8," Transition out of Initialized:insecure");
    $self->{TransactionRequest} = $self->{TransactionReply};
    $self->{InformWritable}     = 1;
    $self->{InformReadable}     = 0;
    $self->Transition("ChallengeReceived");
    $self->{TimeoutRemaining}   = $self->{TimeoutValue};
    return 0;
   
   
       }
       else {
    &Debug(3, "Insecure key negotiation disabled!");
    my $socket = $self->{Socket};
    $socket->close;
    return -1;
       }
 }  }
   
 ###########################################################  ###########################################################
Line 806  sub GetHostIterator { Line 1164  sub GetHostIterator {
 #  #
   
   
 my $confdir='/etc/httpd/conf/';  my @confdirs=('/etc/httpd/conf/','/etc/apache2/');
   
 # ------------------- Subroutine read_conf: read LON-CAPA server configuration.  # ------------------- Subroutine read_conf: read LON-CAPA server configuration.
 # This subroutine reads PerlSetVar values out of specified web server  # This subroutine reads PerlSetVar values out of specified web server
Line 814  my $confdir='/etc/httpd/conf/'; Line 1172  my $confdir='/etc/httpd/conf/';
 sub read_conf  sub read_conf
   {    {
     my (@conf_files)=@_;      my (@conf_files)=@_;
     my %perlvar;      my (%perlvar,%configdirs);
     foreach my $filename (@conf_files,'loncapa_apache.conf')      foreach my $filename (@conf_files,'loncapa_apache.conf') {
       {          my $configdir = '';
   if($DebugLevel > 3) {          $configdirs{$filename} = [@confdirs];
       print("Going to read $confdir.$filename\n");          while ($configdir eq '' && @{$configdirs{$filename}} > 0) {
   }              my $testdir = shift(@{$configdirs{$filename}});
  open(CONFIG,'<'.$confdir.$filename) or              if (-e $testdir.$filename) {
     die("Can't read $confdir$filename");                  $configdir = $testdir;
  while (my $configline=<CONFIG>)              }
   {          }
     if ($configline =~ /^[^\#]*PerlSetVar/)          if ($configdir eq '') {
       {              die("Couldn't find a directory containing $filename");
  my ($unused,$varname,$varvalue)=split(/\s+/,$configline);          }
    if($DebugLevel > 3) {
       print STDERR ("Going to read $configdir.$filename\n");
    }
    open(CONFIG,'<'.$configdir.$filename) or
       die("Can't read $configdir$filename");
    while (my $configline=<CONFIG>) {
       if ($configline =~ /^[^\#]*PerlSetVar/) {
           my ($unused,$varname,$varvalue)=split(/\s+/,$configline);
  chomp($varvalue);   chomp($varvalue);
  $perlvar{$varname}=$varvalue;   $perlvar{$varname}=$varvalue;
       }      }
   }   }
  close(CONFIG);   close(CONFIG);
       }      }
     if($DebugLevel > 3) {      if($DebugLevel > 3) {
  print "Dumping perlvar:\n";   print STDERR "Dumping perlvar:\n";
  foreach my $var (keys %perlvar) {   foreach my $var (keys %perlvar) {
     print "$var = $perlvar{$var}\n";      print STDERR "$var = $perlvar{$var}\n";
  }   }
     }      }
     my $perlvarref=\%perlvar;      my $perlvarref=\%perlvar;
     return $perlvarref;      return $perlvarref;
 }  }
   
 #---------------------- Subroutine read_hosts: Read a LON-CAPA hosts.tab  
 # formatted configuration file.  
 #  
 my $RequiredCount = 5; # Required item count in hosts.tab.  
 my $DefaultMaxCon = 5; # Default value for maximum connections.  
 my $DefaultIdle   = 1000;       # Default connection idle time in seconds.  
 my $DefaultMinCon = 0;          # Default value for minimum connections.  
   
 sub read_hosts {  
     my $Filename = shift;  
     my %HostsTab;  
       
    open(CONFIG,'<'.$Filename) or die("Can't read $Filename");  
     while (my $line = <CONFIG>) {  
  if (!($line =~ /^\s*\#/)) {  
     my @items = split(/:/, $line);  
     if(scalar @items >= $RequiredCount) {  
  if (scalar @items == $RequiredCount) { # Only required items:  
     $items[$RequiredCount] = $DefaultMaxCon;  
  }  
  if(scalar @items == $RequiredCount + 1) { # up through maxcon.  
     $items[$RequiredCount+1] = $DefaultIdle;  
  }  
  if(scalar @items == $RequiredCount + 2) { # up through idle.  
     $items[$RequiredCount+2] = $DefaultMinCon;  
  }  
  {  
     my @list = @items; # probably not needed but I'm unsure of   
     # about the scope of item so...  
     $HostsTab{$list[0]} = \@list;   
  }  
     }  
  }  
     }  
     close(CONFIG);  
     my $hostref = \%HostsTab;  
     return ($hostref);  
 }  
 #  #
 #   Get the version of our peer.  Note that this is only well  #   Get the version of our peer.  Note that this is only well
 #   defined if the state machine has hit the idle state at least  #   defined if the state machine has hit the idle state at least
Line 889  sub read_hosts { Line 1217  sub read_hosts {
 #  #
 sub PeerVersion {  sub PeerVersion {
    my $self = shift;     my $self = shift;
         my ($version) = ($self->{LondVersion} =~ /Revision: 1\.(\d+)/);
    return $self->{LondVersion};     return $version;
   }
   
   #
   #  Manipulate the client data field
   #
   sub SetClientData {
       my ($self, $newData) = @_;
       $self->{ClientData} = $newData;
   }
   #
   #  Get the current client data field.
   #
   sub GetClientData {
       my $self = shift;
       return $self->{ClientData};
   }
   
   #
   # Get the HostID of our peer 
   #
   
   sub PeerLoncapaHim {
       my $self = shift;
       return $self->{LoncapaHim};
   }
   
   #
   # Get the Authentication mode
   #
   
   sub GetKeyMode {
       my $self = shift;
       return $self->{AuthenticationMode};
 }  }
   
 1;  1;
Line 966  Socket open on the connection. Line 1327  Socket open on the connection.
   
 The current state.  The current state.
   
   =item AuthenticationMode
   
   How authentication is being done. This can be any of:
   
       o local - Authenticate via a key exchanged in a file.
       o ssl   - Authenticate via a key exchaned through a temporary ssl tunnel.
       o insecure - Exchange keys in an insecure manner.
   
   insecure is only allowed if the configuration parameter loncAllowInsecure 
   is nonzero.
   
 =item TransactionRequest  =item TransactionRequest
   
 The request being transmitted.  The request being transmitted.
Line 1075  true if the current state requires a wri Line 1447  true if the current state requires a wri
   
 true if the current state requires timeout support.  true if the current state requires timeout support.
   
 =item GetHostIterator:  
   
 Returns an iterator into the host file hash.  
   
 =cut  =cut

Removed from v.1.25  
changed lines
  Added in v.1.62


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