version 1.6, 2004/05/28 09:37:03
|
version 1.8, 2004/06/17 09:27:38
|
Line 35 use strict;
|
Line 35 use strict;
|
|
|
# CPAN/Standard modules: |
# CPAN/Standard modules: |
|
|
use English; |
|
use IO::Socket::INET; |
use IO::Socket::INET; |
use IO::Socket::SSL; |
use IO::Socket::SSL; |
|
|
|
use Fcntl; |
|
use POSIX; |
|
|
# Loncapa modules: |
# Loncapa modules: |
|
|
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
Line 56 my $pathsep = "/"; # We're on unix afte
|
Line 58 my $pathsep = "/"; # We're on unix afte
|
$perlvar = LONCAPA::Configuration::read_conf('loncapa.conf'); |
$perlvar = LONCAPA::Configuration::read_conf('loncapa.conf'); |
|
|
|
|
|
my $lasterror=""; |
|
|
|
|
|
sub LastError { |
|
return $lasterror; |
|
} |
|
|
|
#------------------------------------------------------------------------- |
|
# Name SetFdBlocking - |
|
# Turn blocking mode on on the file handle. This is required for |
|
# SSL key negotiation. |
|
# |
|
# Parameters: |
|
# Handle - Reference to the handle to modify. |
|
# Returns: |
|
# prior flag settings. |
|
# |
|
sub SetFdBlocking { |
|
print STDERR "SetFdBlocking called \n"; |
|
my $Handle = shift; |
|
|
|
|
|
|
|
my $flags = fcntl($Handle, F_GETFL, 0); |
|
if(!$flags) { |
|
print STDERR "SetBLocking fcntl get faild $!\n"; |
|
} |
|
my $newflags = $flags & (~ O_NONBLOCK); # Turn off O_NONBLOCK... |
|
if(!fcntl($Handle, F_SETFL, $newflags)) { |
|
print STDERR "Can't set non block mode $!\n"; |
|
} |
|
return $flags; |
|
} |
|
|
#-------------------------------------------------------------------------- |
#-------------------------------------------------------------------------- |
# |
# |
Line 74 $perlvar = LONCAPA::Configuration::read_
|
Line 109 $perlvar = LONCAPA::Configuration::read_
|
# - Reference to an SSL socket on success |
# - Reference to an SSL socket on success |
# - undef on failure. Reason for failure can be interrogated from |
# - undef on failure. Reason for failure can be interrogated from |
# IO::Socket::SSL |
# IO::Socket::SSL |
|
# Side effects: socket is left in blocking mode!! |
|
# |
|
|
sub PromoteClientSocket { |
sub PromoteClientSocket { |
my ($PlaintextSocket, |
my ($PlaintextSocket, |
$CACert, |
$CACert, |
$MyCert, |
$MyCert, |
$KeyFile) = @ARG; |
$KeyFile) = @_; |
|
|
|
|
|
print STDERR "Client promotion using key: $KeyFile, Cert: $MyCert, CA: $CACert\n"; |
|
|
# To create the ssl socket we need to duplicate the existing |
# To create the ssl socket we need to duplicate the existing |
# socket. Otherwise closing the ssl socket will close the plaintext socket |
# socket. Otherwise closing the ssl socket will close the plaintext socket |
# too: |
# too. We also must flip into blocking mode for the duration of the |
|
# ssl negotiation phase.. the caller will have to flip to non block if |
open (DUPLICATE, "+>$PlaintextSocket"); |
# that's what they want |
|
|
|
my $oldflags = SetFdBlocking($PlaintextSocket); |
|
my $dupfno = fcntl($PlaintextSocket, F_DUPFD, 0); |
|
print STDERR "Client promotion got dup = $dupfno\n"; |
|
|
|
|
my $client = IO::Socket::SSL->new_from_fd(fileno(DUPLICATE), |
my $client = IO::Socket::SSL->new_from_fd($dupfno, |
SSL_user_cert => 1, |
SSL_user_cert => 1, |
SSL_key_file => $KeyFile, |
SSL_key_file => $KeyFile, |
SSL_cert_file => $MyCert, |
SSL_cert_file => $MyCert, |
SSL_ca_fie => $$CACert); |
SSL_ca_fie => $CACert); |
|
|
|
if(!$client) { |
|
$lasterror = IO::Socket::SSL::errstr(); |
|
return undef; |
|
} |
return $client; # Undef if the client negotiation fails. |
return $client; # Undef if the client negotiation fails. |
} |
} |
|
|
Line 113 sub PromoteClientSocket {
|
Line 161 sub PromoteClientSocket {
|
# - Reference to an SSL socket on success |
# - Reference to an SSL socket on success |
# - undef on failure. Reason for failure can be interrogated from |
# - undef on failure. Reason for failure can be interrogated from |
# IO::Socket::SSL |
# IO::Socket::SSL |
|
# Side Effects: |
|
# Socket is left in blocking mode!!! |
|
# |
sub PromoteServerSocket { |
sub PromoteServerSocket { |
my ($PlaintextSocket, |
my ($PlaintextSocket, |
$CACert, |
$CACert, |
$MyCert, |
$MyCert, |
$KeyFile) = @ARG; |
$KeyFile) = @_; |
|
|
|
|
|
|
Line 125 sub PromoteServerSocket {
|
Line 176 sub PromoteServerSocket {
|
# socket. Otherwise closing the ssl socket will close the plaintext socket |
# socket. Otherwise closing the ssl socket will close the plaintext socket |
# too: |
# too: |
|
|
open (DUPLICATE, "+>$PlaintextSocket"); |
print STDERR "Server promotion: Key = $KeyFile, Cert $MyCert CA $CACert\n"; |
|
|
my $client = IO::Socket::SSL->new_from_fd(fileno(DUPLICATE), |
my $oldflags = SetFdBlocking($PlaintextSocket); |
|
my $dupfno = fcntl($PlaintextSocket, F_DUPFD, 0); |
|
if (!$dupfno) { |
|
print STDERR "dup failed: $!\n"; |
|
} |
|
print STDERR " Fileno = $dupfno\n"; |
|
my $client = IO::Socket::SSL->new_from_fd($dupfno, |
SSL_server => 1, # Server role. |
SSL_server => 1, # Server role. |
SSL_user_cert => 1, |
SSL_user_cert => 1, |
SSL_key_file => $KeyFile, |
SSL_key_file => $KeyFile, |
SSL_cert_file => $MyCert, |
SSL_cert_file => $MyCert, |
SSL_ca_fie => $$CACert); |
SSL_ca_fie => $CACert); |
|
if(!$client) { |
|
$lasterror = IO::Socket::SSL::errstr(); |
|
return undef; |
|
} |
return $client; |
return $client; |
} |
} |
|
|
Line 171 sub GetPeerCertificate {
|
Line 232 sub GetPeerCertificate {
|
my $CertOwner = $SSLSocket->peer_certificate("owner"); |
my $CertOwner = $SSLSocket->peer_certificate("owner"); |
my $CertCA = $SSLSocket->peer_certificate("authority"); |
my $CertCA = $SSLSocket->peer_certificate("authority"); |
|
|
return \($CertCA, $CertOwner); |
return ($CertCA, $CertOwner); |
} |
} |
#---------------------------------------------------------------------------- |
#---------------------------------------------------------------------------- |
# |
# |
Line 194 sub CertificateFile {
|
Line 255 sub CertificateFile {
|
# Ensure the existence of these variables: |
# Ensure the existence of these variables: |
|
|
if((!$CertificateDir) || (!$CaFilename) || (!$CertFilename)) { |
if((!$CertificateDir) || (!$CaFilename) || (!$CertFilename)) { |
|
$lasterror = "Missing info: dir: $CertificateDir CA: $CaFilename " |
|
."Cert: $CertFilename"; |
return undef; |
return undef; |
} |
} |
|
|
Line 204 sub CertificateFile {
|
Line 267 sub CertificateFile {
|
my $CertFilename = $CertificateDir.$pathsep.$CertFilename; |
my $CertFilename = $CertificateDir.$pathsep.$CertFilename; |
|
|
if((! -r $CaFilename) || (! -r $CertFilename)) { |
if((! -r $CaFilename) || (! -r $CertFilename)) { |
|
$lasterror = "CA file $CaFilename or Cert File: $CertFilename " |
|
."not readable"; |
return undef; |
return undef; |
} |
} |
|
|
# Everything works fine!! |
# Everything works fine!! |
|
|
return \($CaFilename, $CertFilename); |
return ($CaFilename, $CertFilename); |
|
|
} |
} |
#------------------------------------------------------------------------ |
#------------------------------------------------------------------------ |
Line 231 sub KeyFile {
|
Line 296 sub KeyFile {
|
# Ensure the variables exist: |
# Ensure the variables exist: |
|
|
if((!$CertificateDir) || (!$KeyFilename)) { |
if((!$CertificateDir) || (!$KeyFilename)) { |
|
$lasterror = "Missing parameter dir: $CertificateDir " |
|
."key: $KeyFilename"; |
return undef; |
return undef; |
} |
} |
|
|
Line 239 sub KeyFile {
|
Line 306 sub KeyFile {
|
|
|
my $KeyFilename = $CertificateDir.$pathsep.$KeyFilename; |
my $KeyFilename = $CertificateDir.$pathsep.$KeyFilename; |
if(! (-r $KeyFilename)) { |
if(! (-r $KeyFilename)) { |
|
$lasterror = "Unreadable key file $KeyFilename"; |
return undef; |
return undef; |
} |
} |
|
|