version 1.5, 2003/06/13 02:38:30
|
version 1.62, 2018/12/14 02:05:38
|
Line 25
|
Line 25
|
# |
# |
# http://www.lon-capa.org/ |
# http://www.lon-capa.org/ |
# |
# |
|
|
package LondConnection; |
package LondConnection; |
|
|
|
use strict; |
use IO::Socket; |
use IO::Socket; |
use IO::Socket::INET; |
use IO::Socket::INET; |
use IO::Handle; |
use IO::Handle; |
Line 34 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 %perlvar; |
|
my %secureconf; |
|
my %badcerts; |
|
my %hosttypes; |
|
my %crlchecked; |
|
my $InsecureOk; |
|
|
my $DebugLevel=4; |
# |
|
# 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 = LONCAPA::Configuration::read_conf('loncapa.conf'); |
my $perlvarref = read_conf('loncapa.conf'); |
my %perlvar = %{$perlvarref}; |
%perlvar = %{$perlvarref}; |
my $hoststab = |
$ConfigRead = 1; |
LONCAPA::Configuration::read_hosts( |
|
"$perlvar{'lonTabDir'}/hosts.tab") || |
|
die "Can't read host table!!"; |
|
my %hostshash = %{$hoststab}; |
|
|
|
close(CONFIG); |
$InsecureOk = $perlvar{loncAllowInsecure}; |
|
|
|
unless (lonssl::Read_Connect_Config(\%secureconf,\%perlvar) eq 'ok') { |
|
Debug(1,"Failed to retrieve secureconf hash.\n"); |
|
} |
|
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 64 sub Debug {
|
Line 102 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; |
print "Dumping LondConnectionObject:\n"; |
my $level = shift; |
|
my $now = time; |
|
my $local = localtime($now); |
|
|
|
if ($level >= $DebugLevel) { |
|
return; |
|
} |
|
|
|
|
|
my $key; |
|
my $value; |
|
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 86 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 97 sub Transition {
|
Line 148 sub Transition {
|
} |
} |
|
|
|
|
|
|
=pod |
=pod |
|
|
=head2 new |
=head2 new |
Line 113 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) { |
&Debug(4,$class."::new( ".$Hostname.",".$Port.")\n"); |
ReadConfig(); |
|
$ConfigRead = 1; |
|
} |
|
&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 127 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 |
return undef; # No such host!!! |
if ($DnsName eq &main::my_hostname()) { $DnsName="127.0.0.1"; } |
} |
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, |
Port => $Port, |
LoncapaDefid => $deflonid, |
State => "Initialized", |
LoncapaRev => $loncaparev, |
TransactionRequest => "", |
Port => $Port, |
TransactionReply => "", |
State => "Initialized", |
InformReadable => 0, |
AuthenticationMode => "", |
InformWritable => 0, |
InsecureOK => $allowinsecure, |
TimeoutCallback => undef, |
TransactionRequest => "", |
TransitionCallback => undef, |
TransactionReply => "", |
Timeoutable => 0, |
NextRequest => "", |
TimeoutValue => 60, |
InformReadable => 0, |
TimeoutRemaining => 0, |
InformWritable => 0, |
CipherKey => "", |
TimeoutCallback => undef, |
Cipher => undef}; |
TransitionCallback => undef, |
|
Timeoutable => 0, |
|
TimeoutValue => 30, |
|
TimeoutRemaining => 0, |
|
LocalKeyFile => "", |
|
CipherKey => "", |
|
LondVersion => "Unknown", |
|
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)) { |
|
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->{TransactionRequest} = "init\n"; |
$self->{Timeoutable} = 1; # Timeout allowed during startup negotiation. |
|
|
|
|
# |
# |
# Set socket to nonblocking I/O. |
# Set socket to nonblocking I/O. |
# |
# |
my $socket = $self->{Socket}; |
my $flags = fcntl($socket, F_GETFL,0); |
$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 212 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, |
if(($errno == POSIX::EWOULDBLOCK) || |
if(($errno == POSIX::EWOULDBLOCK) || |
($errno == POSIX::EAGAIN) || |
($errno == POSIX::EAGAIN) || |
($errno == POSIX::EINTR) || |
($errno == POSIX::EINTR)) { |
($errno == 0)) { |
|
return 0; |
return 0; |
} |
} |
|
|
Line 230 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") { # 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... |
|
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") { |
|
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}; |
|
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} == 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 290 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 328 Returns 0 if successful, or -1 if not.
|
Line 609 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 337 sub Writable {
|
Line 629 sub Writable {
|
} |
} |
|
|
} |
} |
if (($rv >= 0) || |
if (($nwritten >= 0) || |
($errno == POSIX::EWOULDBLOCK) || |
($errno == POSIX::EWOULDBLOCK) || |
($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 354 sub Writable {
|
Line 647 sub Writable {
|
$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 "RequestingVersion") { |
|
$self->Transition("ReadingVersionString"); |
|
} elsif ($self->{State} eq "SetHost") { |
|
$self->Transition("HostSet"); |
} elsif($self->{State} eq "RequestingKey") { |
} elsif($self->{State} eq "RequestingKey") { |
$self->Transition("ReceivingKey"); |
$self->Transition("ReceivingKey"); |
$self->{InformWritable} = 0; |
# $self->{InformWritable} = 0; |
$self->{InformReadable} = 1; |
# $self->{InformReadable} = 1; |
$self->{TransactionReply} = ''; |
# $self->{TransactionReply} = ''; |
} elsif ($self->{State} eq "SendingRequest") { |
} elsif ($self->{State} eq "SendingRequest") { |
$self->Transition("ReceivingReply"); |
$self->Transition("ReceivingReply"); |
$self->{TimeoutRemaining} = $self->{TimeoutValue}; |
$self->{TimeoutRemaining} = $self->{TimeoutValue}; |
Line 372 sub Writable {
|
Line 669 sub Writable {
|
$socket->close(); |
$socket->close(); |
return -1; |
return -1; |
} |
} |
|
|
} |
} |
=pod |
=pod |
|
|
Line 427 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 436 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 479 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 497 Shuts down the socket.
|
Line 807 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); |
|
} |
|
} |
|
$self->{Timeoutable} = 0; # Shutdown sockets can't timeout. |
} |
} |
|
|
=pod |
=pod |
Line 600 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 643 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 654 sub Decrypt {
|
Line 973 sub Decrypt {
|
# Decode the data in 8 byte blocks. The string is encoded |
# Decode the data in 8 byte blocks. The string is encoded |
# as hex digits so there are two characters per byte: |
# as hex digits so there are two characters per byte: |
|
|
$decrpyted = ""; |
my $decrypted = ""; |
for(my $index = 0; $index < length($EncryptedString); |
for(my $index = 0; $index < length($EncryptedString); |
$index += 16) { |
$index += 16) { |
$decrypted .= $self->{Cipher}->decrypt( |
$decrypted .= $self->{Cipher}->decrypt( |
Line 667 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. |
|
|
|
$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; |
|
|
=head2 GetHostIterator |
} |
|
|
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. nslooup [3]). |
|
[5] - Maximum connection count. |
|
[6] - Idle timeout for reducing connection count. |
|
[7] - Minimum connection count. |
|
|
|
=cut |
# |
|
# 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; |
|
} |
|
} |
|
|
|
########################################################### |
|
# |
|
# 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 @confdirs=('/etc/httpd/conf/','/etc/apache2/'); |
|
|
|
# ------------------- 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,%configdirs); |
|
foreach my $filename (@conf_files,'loncapa_apache.conf') { |
|
my $configdir = ''; |
|
$configdirs{$filename} = [@confdirs]; |
|
while ($configdir eq '' && @{$configdirs{$filename}} > 0) { |
|
my $testdir = shift(@{$configdirs{$filename}}); |
|
if (-e $testdir.$filename) { |
|
$configdir = $testdir; |
|
} |
|
} |
|
if ($configdir eq '') { |
|
die("Couldn't find a directory containing $filename"); |
|
} |
|
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); |
|
$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; |
|
} |
|
|
|
# |
|
# 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; |
|
} |
|
|
|
# |
|
# 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}; |
|
} |
|
|
sub GetHostIterator { |
# |
|
# Get the Authentication mode |
|
# |
|
|
return HashIterator->new(\%hostshash); |
sub GetKeyMode { |
|
my $self = shift; |
|
return $self->{AuthenticationMode}; |
} |
} |
|
|
1; |
1; |
Line 770 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 879 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 |