Return to lonssl.pm CVS log

Up to [LON-CAPA] / loncom

Turn down the logging volume now that the ssl stuff looks like it's functional.

#
# $Id: lonssl.pm,v 1.9 2004/06/17 10:15:46 foxr Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# 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 
#    SSL tunnel.
#     See the POD sections and function documentation for more information.
#

use strict;

# CPAN/Standard  modules:

use IO::Socket::INET;
use IO::Socket::SSL;

use Fcntl;
use POSIX;

#  Loncapa modules:

use LONCAPA::Configuration;

#  Global storage:

my $perlvar;			#  this refers to the apache perlsetvar 
                                # variable hash.

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;
}

#--------------------------------------------------------------------------
#
# Name	PromoteClientSocket
# Description	Given an ordinary IO::Socket::INET Creates an SSL socket 
#               for a client that is connected to the same server.
# Parameters	Name	Type	           Description
#               Socket	IO::Socket::INET   Original ordinary socket.
#               CACert	string	           Full path name to the certificate 
#                                          authority certificate file.
#                MyCert	string	           Full path name to the certificate 
#                                          issued to this host.
#                KeyFile string    	   Full pathname to the host's private 
#                                          key file for the certificate.
# Returns
#	-	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,
	$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.  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($dupfno,
					      SSL_user_cert => 1,
					      SSL_key_file  => $KeyFile,
					      SSL_cert_file => $MyCert,
					      SSL_ca_fie    => $CACert);
    
    if(!$client) {
	$lasterror = IO::Socket::SSL::errstr();
	return undef;
    }
    return $client;		# Undef if the client negotiation fails.
}

#----------------------------------------------------------------------
# Name	PromoteServerSocket
# Description	Given an ordinary IO::Socket::INET Creates an SSL socket 
#               for a server that is connected to the same client.l
# Parameters	Name	Type	           Description
#               Socket	IO::Socket::INET   Original ordinary socket.
#               CACert	string	           Full path name to the certificate 
#                                          authority certificate file.
#                MyCert	string	           Full path name to the certificate 
#                                          issued to this host.
#                KeyFile string    	   Full pathname to the host's private 
#                                          key file for the certificate.
# Returns
#	-	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,
	$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:

    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);
    if(!$client) {
	$lasterror = IO::Socket::SSL::errstr();
	return undef;
    }
    return $client;
}

#-------------------------------------------------------------------------
#
# Name: Close
# Description: Properly closes an ssl client or ssl server socket in
#              a way that keeps the parent socket open.
# Parameters:  Name      Type            Description
#              Socket   IO::Socket::SSL  SSL Socket gotten from either
#                                        PromoteClientSocket or 
#                                        PromoteServerSocket
# Returns:
#   NONE
#
sub Close {
    my $Socket = shift;
    
    $Socket->close(SSL_no_shutdown =>1); # Otherwise the parent socket 
                                         # gets torn down.
}
#---------------------------------------------------------------------------
#
# Name   	GetPeerCertificate
# Description	Inquires about the certificate of the peer of a connection.
# Parameters	Name	        Type	          Description
#               SSLSocket	IO::Socket::SSL	  SSL tunnel socket open on 
#                                                 the peer.
# Returns
#	A two element list.  The first element of the list is the name of 
#       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);
}
#----------------------------------------------------------------------------
#
# Name  	CertificateFile
# Description	Locate the certificate files for this host.
# Returns
#	Returns a two element array.  The first element contains the name of
#  the certificate file for this host.  The second element contains the name
#  of the  certificate file for the CA that granted the certificate.  If 
#  either file cannot be located, returns undef.
#
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)) {
	$lasterror = "Missing info: dir: $CertificateDir CA: $CaFilename "
	            ."Cert: $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)) {
	$lasterror = "CA file $CaFilename or Cert File: $CertFilename "
	            ."not readable";
	return undef;
    }
    
    # Everything works fine!!
    
    return ($CaFilename, $CertFilename);

}
#------------------------------------------------------------------------
#
# Name	        KeyFile
# Description
#      Returns the name of the private key file of the current host.
# Returns
#      Returns the name of the key file or undef if the file cannot 
#      be found.
#
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)) {
	$lasterror = "Missing parameter dir: $CertificateDir "
	            ."key: $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)) {
	$lasterror = "Unreadable key file $KeyFilename";
	return undef;
    }
    
    return $KeyFilename;
}

1;