[BACK]Return to LondConnection.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/LondConnection.pm between versions 1.11 and 1.42

version 1.11, 2003/09/30 10:46:57 version 1.42, 2006/08/25 21:20:11
Line 25 Line 25
 #  #
 # http://www.lon-capa.org/  # http://www.lon-capa.org/
 #  #
   
 package LondConnection;  package LondConnection;
   
 use strict;  use strict;
Line 35  use IO::File; Line 36  use IO::File;
 use Fcntl;  use Fcntl;
 use POSIX;  use POSIX;
 use Crypt::IDEA;  use Crypt::IDEA;
 use LONCAPA::Configuration;  use LONCAPA::lonlocal;
 use LONCAPA::HashIterator;  use LONCAPA::lonssl;
   
   
   
   
 my $DebugLevel=0;  my $DebugLevel=0;
   my %hostshash;
   my %perlvar;
   my $LocalDns = ""; # Need not be defined for managers.
   my $InsecureOk;
   
   #
   #  Set debugging level
   #
   sub SetDebug {
       $DebugLevel = shift;
   }
   
   #
   #   The config read is done in this way to support the read of
   #   the non-default configuration file in the
   #   event we are being used outside of loncapa.
   #
   
   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 {
       Debug(8, "ReadConfig called");
   
       my $perlvarref = read_conf('loncapa.conf');
       %perlvar    = %{$perlvarref};
       my $hoststab   = read_hosts(
    "$perlvar{lonTabDir}/hosts.tab") || 
    die "Can't read host table!!";
       %hostshash  = %{$hoststab};
       $ConfigRead = 1;
       
       my $myLonCapaName = $perlvar{lonHostID};
       Debug(8, "My loncapa name is $myLonCapaName");
       
       if(defined $hostshash{$myLonCapaName}) {
    Debug(8, "My loncapa name is in hosthash");
    my @ConfigLine = @{$hostshash{$myLonCapaName}};
    $LocalDns = $ConfigLine[3];
    Debug(8, "Got local name $LocalDns");
       }
       $InsecureOk = $perlvar{loncAllowInsecure};
       
       Debug(3, "ReadConfig - LocalDNS = $LocalDns");
   }
   
   #
   #  Read a foreign configuration.
   #  This sub is intended for the cases where the package
   #  will be read from outside the LonCAPA environment, in that case
   #  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 $perlvarref = LONCAPA::Configuration::read_conf('loncapa.conf');      my ($MyHost, $Filename) = @_;
 my %perlvar    = %{$perlvarref};  
 my $hoststab   =   
     LONCAPA::Configuration::read_hosts(  
             "$perlvar{'lonTabDir'}/hosts.tab") ||   
     die "Can't read host table!!";  
 my %hostshash  = %{$hoststab};  
   
 close(CONFIG);      &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 STDERR "host $host => $hostshash{$host}\n";
    }
       }
       $ConfigRead = 1;
   
       my $myLonCapaName = $perlvar{lonHostID};
       
       if(defined $hostshash{$myLonCapaName}) {
    my @ConfigLine = @{$hostshash{$myLonCapaName}};
    $LocalDns = $ConfigLine[3];
       }
       $InsecureOk = $perlvar{loncAllowInsecure};
       
       Debug(3, "ReadForeignConfig  - LocalDNS = $LocalDns");
   
   }
   
 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 65  sub Debug { Line 147  sub Debug {
   
 =head2 Dump  =head2 Dump
   
 Dump the internal state of the object: For debugging purposes.  Dump the internal state of the object: For debugging purposes, to stderr.
   
 =cut  =cut
   
 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 "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 "$key -> $value\n";   print STDERR "$key -> $value\n";
     }      }
     print "-------------------------------\n";      print STDERR "-------------------------------\n";
 }  }
   
 =pod  =pod
Line 89  old state. Line 181  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 100  sub Transition { Line 193  sub Transition {
 }  }
   
   
   
 =pod  =pod
   
 =head2 new  =head2 new
Line 119  host the remote lond is on. This host is Line 213  host the remote lond is on. This host is
 =cut  =cut
   
 sub new {  sub new {
     my $class    = shift; # class name.      my ($class, $DnsName, $Port) = @_;
     my $Hostname = shift; # Name of host to connect to.  
     my $Port     = shift; # Port to connect       if (!$ConfigRead) {
     &Debug(4,$class."::new( ".$Hostname.",".$Port.")\n");   ReadConfig();
    $ConfigRead = 1;
       }
       &Debug(4,$class."::new( ".$DnsName.",".$Port.")\n");
   
     # 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 130  sub new { Line 227  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 (!exists $hostshash{$DnsName}) {
    &Debug(8, "No Such host $DnsName");
  return undef; # No such host!!!   return undef; # No such host!!!
     }      }
     my @ConfigLine = @{$hostshash{$Hostname}};      my @ConfigLine = @{$hostshash{$DnsName}};
     my $DnsName    = $ConfigLine[3]; # 4'th item is dns of host.      my $Hostname    = $ConfigLine[0]; # 0'th item is the msu id of host.
     Debug(5, "Connecting to ".$DnsName);      Debug(5, "Connecting to ".$DnsName);
       # if it is me use loopback for connection
       if ($DnsName eq $LocalDns) { $DnsName="127.0.0.1"; }
       Debug(8, "Connecting to $DnsName I am $LocalDns");
     # Now create the object...      # Now create the object...
     my $self     = { Host               => $DnsName,      my $self     = { Host               => $DnsName,
      LoncapaHim         => $Hostname,                       LoncapaHim         => $Hostname,
              Port               => $Port,                       Port               => $Port,
              State              => "Initialized",                       State              => "Initialized",
              TransactionRequest => "",       AuthenticationMode => "",
              TransactionReply   => "",                       TransactionRequest => "",
              InformReadable     => 0,                       TransactionReply   => "",
              InformWritable     => 0,                       NextRequest        => "",
      TimeoutCallback    => undef,                       InformReadable     => 0,
      TransitionCallback => undef,                       InformWritable     => 0,
              Timeoutable        => 0,                       TimeoutCallback    => undef,
              TimeoutValue       => 30,                       TransitionCallback => undef,
      TimeoutRemaining   => 0,                       Timeoutable        => 0,
      CipherKey          => "",                       TimeoutValue       => 30,
      Cipher             => undef};                       TimeoutRemaining   => 0,
        LocalKeyFile       => "",
                        CipherKey          => "",
                        LondVersion        => "Unknown",
                        Cipher             => 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  => 5)) {         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.
       #  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)) {
       if($InsecureOk) {
    $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;
   
    if((defined $ca)  && (defined $cert) && (defined $sslkeyfile)) {
   
       $self->{AuthenticationMode} = "ssl";
       $self->{TransactionRequest} = "init:ssl\n";
    } else {
       if($InsecureOk) { # Allowed to do insecure:
    $self->{AuthenticationMode} = "insecure";
    $self->{TransactionRequest} = "init\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 217  sub Readable { Line 380  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 238  sub Readable { Line 411  sub Readable {
   
     &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:
       #     AuthenticationMode == local:
       #       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:
       
       my $Response = $self->{TransactionReply};
       if($ConnectionMode eq "local") {
    if($Response =~ /^ok:local/) { #  Good local auth.
       $self->ToVersionRequest();
       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...
       if($self->ExchangeKeysViaSSL()) { # 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.
    &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") {
       if($self->{TransactionReply} ne "ok\n") {
    $self->Transition("Disconnected");
  $socket->close();   $socket->close();
  return -1;   return -1;
     }      }
       $self->ToVersionRequest();
       return 0;
   
     &Debug(8," Transition out of Initialized");   } elsif ($self->{State} eq "ReadingVersionString") {
     $self->{TransactionRequest} = $self->{TransactionReply};      chomp($self->{TransactionReply});
     $self->{InformWritable}     = 1;      $self->{LondVersion}       = $self->{TransactionReply};
     $self->{InformReadable}     = 0;      $self->Transition("SetHost");
     $self->Transition("ChallengeReceived");      $self->{InformReadable}    = 0;
     $self->{TimeoutRemaining}   = $self->{TimeoutValue};      $self->{InformWritable}    = 1;
       my $peer = $self->{LoncapaHim};
       $self->{TransactionRequest}= "sethost:$peer\n";
     return 0;      return 0;
  } elsif ($self->{State} eq "ChallengeReplied") { # should be ok.   } elsif ($self->{State} eq "HostSet") { # should be ok.
     if($self->{TransactionReply} != "ok\n") {      if($self->{TransactionReply} ne "ok\n") {
  $self->Transition("Disconnected");   $self->Transition("Disconnected");
  $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};
     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} == 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 294  sub Readable { Line 558  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->{TimeoutRemaining}   = $self->{TimeoutValue};
    $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 332  Returns  0 if successful, or -1 if not. Line 605  Returns  0 if successful, or -1 if not.
 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 347  sub Writable { Line 631  sub Writable {
  ($errno == POSIX::EINTR)          ||   ($errno == POSIX::EINTR)          ||
  ($errno ==  0)) {   ($errno ==  0)) {
  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;
     $self->{InformReadable} = 1;           $self->{InformReadable} = 1;
     $self->{TransactionReply} = '';           $self->{TransactionReply} = '';
     #           #
     # Figure out the next state:           # Figure out the next state:
     #           #
     if($self->{State} eq "Connected") {           if($self->{State} eq "Connected") {
  $self->Transition("Initialized");              $self->Transition("Initialized");
     } elsif($self->{State} eq "ChallengeReceived") {           } elsif($self->{State} eq "ChallengeReceived") {
  $self->Transition("ChallengeReplied");              $self->Transition("ChallengeReplied");
     } elsif($self->{State} eq "RequestingKey") {           } elsif($self->{State} eq "RequestingVersion") {
  $self->Transition("ReceivingKey");              $self->Transition("ReadingVersionString");
  $self->{InformWritable} = 0;           } elsif ($self->{State} eq "SetHost") {
  $self->{InformReadable} = 1;              $self->Transition("HostSet");
  $self->{TransactionReply} = '';           } elsif($self->{State} eq "RequestingKey") {
     } elsif ($self->{State} eq "SendingRequest") {              $self->Transition("ReceivingKey");
  $self->Transition("ReceivingReply");  #            $self->{InformWritable} = 0;
  $self->{TimeoutRemaining} = $self->{TimeoutValue};  #            $self->{InformReadable} = 1;
     } elsif ($self->{State} eq "Disconnected") {  #            $self->{TransactionReply} = '';
  return -1;           } elsif ($self->{State} eq "SendingRequest") {
     }              $self->Transition("ReceivingReply");
     return 0;              $self->{TimeoutRemaining} = $self->{TimeoutValue};
  }           } elsif ($self->{State} eq "Disconnected") {
     } else { # The write failed (e.g. partner disconnected).              return -1;
  $self->Transition("Disconnected");           }
  $socket->close();           return 0;
  return -1;        }
     }     } else { # The write failed (e.g. partner disconnected).
         $self->Transition("Disconnected");
         $socket->close();
         return -1;
      }
   
 }  }
 =pod  =pod
Line 431  timout, and to request writability notif Line 719  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 440  sub InitiateTransaction { Line 728  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 483  established callback or undef if there w Line 783  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 501  Shuts down the socket. Line 802  Shuts down the socket.
 sub Shutdown {  sub Shutdown {
     my $self = shift;      my $self = shift;
     my $socket = $self->GetSocket();      my $socket = $self->GetSocket();
     $socket->shutdown(2);      Debug(5,"socket is -$socket-");
       if ($socket) {
    # Ask lond to exit too.  Non blocking so
    # there is no cost for failure.
    eval {
       $socket->send("exit\n", 0);
       $socket->shutdown(2);
    }
       }
 }  }
   
 =pod  =pod
Line 604  The output string can be directly sent t Line 913  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 647  Decrypt a response from the server.  The Line 956  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 671  sub Decrypt { Line 980  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;
   
       $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.
   
       $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};
   
       #  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();
   
       #  Promote our connection to ssl and read the key from lond.
   
       my $SSLSocket = lonssl::PromoteClientSocket($socket,
    $SSLCACertificate,
    $SSLCertificate,
    $SSLKey);
       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 0;
       }
       # should not get here
       return 0;
   
   }
   
   
   
   #
   #  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($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;
       }
   }
   
 =pod  =pod
   
Line 685  this iterator returns a reference to an Line 1145  this iterator returns a reference to an
 information read from the hosts configuration file.  Array elements  information read from the hosts configuration file.  Array elements
 are used as follows:  are used as follows:
   
  [0]   - LonCapa host name.   [0]   - LonCapa host id.
  [1]   - LonCapa domain name.   [1]   - LonCapa domain name.
  [2]   - Loncapa role (e.g. library or access).   [2]   - Loncapa role (e.g. library or access).
  [3]   - DNS name server hostname.   [3]   - DNS name server hostname.
Line 701  sub GetHostIterator { Line 1161  sub GetHostIterator {
     return HashIterator->new(\%hostshash);          return HashIterator->new(\%hostshash);    
 }  }
   
   ###########################################################
   #
   #  The following is an unashamed kludge that is here to
   # allow LondConnection to be used outside of the
   # loncapa environment (e.g. by lonManage).
   # 
   #   This is a textual inclusion of pieces of the
   #   Configuration.pm module.
   #
   
   
   my $confdir='/etc/httpd/conf/';
   
   # ------------------- Subroutine read_conf: read LON-CAPA server configuration.
   # This subroutine reads PerlSetVar values out of specified web server
   # configuration files.
   sub read_conf
     {
       my (@conf_files)=@_;
       my %perlvar;
       foreach my $filename (@conf_files,'loncapa_apache.conf')
         {
     if($DebugLevel > 3) {
         print STDERR ("Going to read $confdir.$filename\n");
     }
    open(CONFIG,'<'.$confdir.$filename) or
       die("Can't read $confdir$filename");
    while (my $configline=<CONFIG>)
     {
       if ($configline =~ /^[^\#]*PerlSetVar/)
         {
    my ($unused,$varname,$varvalue)=split(/\s+/,$configline);
    chomp($varvalue);
    $perlvar{$varname}=$varvalue;
         }
     }
    close(CONFIG);
         }
       if($DebugLevel > 3) {
    print STDERR "Dumping perlvar:\n";
    foreach my $var (keys %perlvar) {
       print STDERR "$var = $perlvar{$var}\n";
    }
       }
       my $perlvarref=\%perlvar;
       return $perlvarref;
   }
   
   #---------------------- Subroutine read_hosts: Read a LON-CAPA hosts.tab
   # formatted configuration file.
   #
   my $RequiredCount = 4; # 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*\#/) {
       $line=~s/\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[3]} = \@list; 
    }
       }
    }
       }
       close(CONFIG);
       my $hostref = \%HostsTab;
       return ($hostref);
   }
   #
   #   Get the version of our peer.  Note that this is only well
   #   defined if the state machine has hit the idle state at least
   #   once (well actually if it has transitioned out of 
   #   ReadingVersionString   The member data LondVersion is returned.
   #
   sub PeerVersion {
      my $self = shift;
      my ($version) = ($self->{LondVersion} =~ /Revision: 1\.(\d+)/);
      return $version;
   }
   
 1;  1;
   
 =pod  =pod
Line 774  Socket open on the connection. Line 1333  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.
Removed from v.1.11  
changed lines
  Added in v.1.42

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