--- loncom/lonssl.pm 2004/05/27 10:26:19 1.5 +++ loncom/lonssl.pm 2006/08/25 17:49:15 1.10 @@ -1,5 +1,5 @@ # -# $Id: lonssl.pm,v 1.5 2004/05/27 10:26:19 foxr Exp $ +# $Id: lonssl.pm,v 1.10 2006/08/25 17:49:15 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -23,7 +23,7 @@ # # http://www.lon-capa.org/ # - +package lonssl; # lonssl.pm # This file contains common functions used by lond and lonc when # negotiating the exchange of the session encryption key via an @@ -33,11 +33,14 @@ use strict; -# CPAN modules: +# CPAN/Standard modules: use IO::Socket::INET; use IO::Socket::SSL; +use Fcntl; +use POSIX; + # Loncapa modules: use LONCAPA::Configuration; @@ -49,12 +52,55 @@ my $perlvar; # this refers to the apa my $pathsep = "/"; # We're on unix after all. +my $DEBUG = 0; # Set to non zero to enable debug output. + # Initialization code: $perlvar = LONCAPA::Configuration::read_conf('loncapa.conf'); +my $lasterror=""; + + + +sub LastError { + return $lasterror; +} + +sub Debug { + my $msg = shift; + if ($DEBUG) { + print STDERR $msg; + } +} + +#------------------------------------------------------------------------- +# 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 { + Debug("SetFdBlocking called \n"); + my $Handle = shift; + + + + my $flags = fcntl($Handle, F_GETFL, 0); + if(!$flags) { + Debug("SetBLocking fcntl get faild $!\n"); + } + my $newflags = $flags & (~ O_NONBLOCK); # Turn off O_NONBLOCK... + if(!fcntl($Handle, F_SETFL, $newflags)) { + Debug("Can't set non block mode $!\n"); + } + return $flags; +} #-------------------------------------------------------------------------- # @@ -73,25 +119,39 @@ $perlvar = LONCAPA::Configuration::read_ # - Reference to an SSL socket on success # - undef on failure. Reason for failure can be interrogated from # IO::Socket::SSL +# Side effects: socket is left in blocking mode!! +# sub PromoteClientSocket { - my $PlaintextSocket = shift; - my $CACert = shift; - my $MyCert = shift; - my $KeyFile = shift; + my ($PlaintextSocket, + $CACert, + $MyCert, + $KeyFile) = @_; + + + Debug("Client promotion using key: $KeyFile, Cert: $MyCert, CA: $CACert\n"); # To create the ssl socket we need to duplicate the existing # socket. Otherwise closing the ssl socket will close the plaintext socket - # too: - - open (DUPLICATE, "+>$PlaintextSocket"); + # 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 + # that's what they want + + my $oldflags = SetFdBlocking($PlaintextSocket); + my $dupfno = fcntl($PlaintextSocket, F_DUPFD, 0); + Debug("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_key_file => $KeyFile, 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. } @@ -111,25 +171,39 @@ sub PromoteClientSocket { # - Reference to an SSL socket on success # - undef on failure. Reason for failure can be interrogated from # IO::Socket::SSL +# Side Effects: +# Socket is left in blocking mode!!! +# sub PromoteServerSocket { - my $PlaintextSocket = shift; - my $CACert = shift; - my $MyCert = shift; - my $KeyFile = shift; + my ($PlaintextSocket, + $CACert, + $MyCert, + $KeyFile) = @_; + # To create the ssl socket we need to duplicate the existing # socket. Otherwise closing the ssl socket will close the plaintext socket # too: - open (DUPLICATE, "+>$PlaintextSocket"); - - my $client = IO::Socket::SSL->new_from_fd(fileno(DUPLICATE), + Debug("Server promotion: Key = $KeyFile, Cert $MyCert CA $CACert\n"); + + my $oldflags = SetFdBlocking($PlaintextSocket); + my $dupfno = fcntl($PlaintextSocket, F_DUPFD, 0); + if (!$dupfno) { + Debug("dup failed: $!\n"); + } + Debug(" Fileno = $dupfno\n"); + my $client = IO::Socket::SSL->new_from_fd($dupfno, SSL_server => 1, # Server role. SSL_user_cert => 1, SSL_key_file => $KeyFile, SSL_cert_file => $MyCert, - SSL_ca_fie => $$CACert); + SSL_ca_fie => $CACert); + if(!$client) { + $lasterror = IO::Socket::SSL::errstr(); + return undef; + } return $client; } @@ -163,12 +237,12 @@ sub Close { # the certificate authority. The second element of the list is the name # of the owner of the certificate. sub GetPeerCertificate { - my $SSLSocket = shift; - - my $CertOwner = $SSLSocket->peer_certificate("owner"); - my $CertCA = $SSLSocket->peer_certificate("authority"); - - return \($CertCA, $CertOwner); + my $SSLSocket = shift; + + my $CertOwner = $SSLSocket->peer_certificate("owner"); + my $CertCA = $SSLSocket->peer_certificate("authority"); + + return ($CertCA, $CertOwner); } #---------------------------------------------------------------------------- # @@ -182,31 +256,35 @@ sub GetPeerCertificate { # sub CertificateFile { - # I need some perl variables from the configuration file for this: - - my $CertificateDir = $perlvar->{lonCertificateDirectory}; - my $CaFilename = $perlvar->{lonnetCertificateAuthority}; - my $CertFilename = $perlvar->{lonnetCertificate}; - - # Ensure the existence of these variables: - - if((!$CertificateDir) || (!$CaFilename) || (!$CertFilename)) { - return undef; - } - - # Build the actual filenames and check for their existence and - # readability. - - my $CaFilename = $CertificateDir.$pathsep.$CaFilename; - my $CertFilename = $CertificateDir.$pathsep.$CertFilename; - - if((! -r $CaFilename) || (! -r $CertFilename)) { - return undef; - } - - # Everything works fine!! - - return \($CaFilename, $CertFilename); + # I need some perl variables from the configuration file for this: + + my $CertificateDir = $perlvar->{lonCertificateDirectory}; + my $CaFilename = $perlvar->{lonnetCertificateAuthority}; + my $CertFilename = $perlvar->{lonnetCertificate}; + + # Ensure the existence of these variables: + + if((!$CertificateDir) || (!$CaFilename) || (!$CertFilename)) { + $lasterror = "Missing info: dir: $CertificateDir CA: $CaFilename " + ."Cert: $CertFilename"; + return undef; + } + + # Build the actual filenames and check for their existence and + # readability. + + $CaFilename = $CertificateDir.$pathsep.$CaFilename; + $CertFilename = $CertificateDir.$pathsep.$CertFilename; + + if((! -r $CaFilename) || (! -r $CertFilename)) { + $lasterror = "CA file $CaFilename or Cert File: $CertFilename " + ."not readable"; + return undef; + } + + # Everything works fine!! + + return ($CaFilename, $CertFilename); } #------------------------------------------------------------------------ @@ -220,26 +298,29 @@ sub CertificateFile { # sub KeyFile { - # I need some perl variables from the configuration file for this: - - my $CertificateDir = $perlvar->{lonCertificateDirectory}; - my $KeyFilename = $perlvar->{lonnetPrivateKey}; - - # Ensure the variables exist: - - if((!$CertificateDir) || (!$KeyFilename)) { - return undef; - } - - # Build the actual filename and ensure that it not only exists but - # is also readable: - - my $KeyFilename = $CertificateDir.$pathsep.$KeyFilename; - if(! (-r $KeyFilename)) { - return undef; - } - - return $KeyFilename; + # I need some perl variables from the configuration file for this: + + my $CertificateDir = $perlvar->{lonCertificateDirectory}; + my $KeyFilename = $perlvar->{lonnetPrivateKey}; + + # Ensure the variables exist: + + if((!$CertificateDir) || (!$KeyFilename)) { + $lasterror = "Missing parameter dir: $CertificateDir " + ."key: $KeyFilename"; + return undef; + } + + # Build the actual filename and ensure that it not only exists but + # is also readable: + + $KeyFilename = $CertificateDir.$pathsep.$KeyFilename; + if(! (-r $KeyFilename)) { + $lasterror = "Unreadable key file $KeyFilename"; + return undef; + } + + return $KeyFilename; } 1;