File:  [LON-CAPA] / loncom / lonssl.pm
Revision 1.9: download - view: text, annotated - select for diffs
Thu Jun 17 10:15:46 2004 UTC (19 years, 9 months ago) by foxr
Branches: MAIN
CVS tags: version_2_2_0, version_2_1_X, version_2_1_99_3, version_2_1_99_2, version_2_1_99_1, version_2_1_99_0, version_2_1_3, version_2_1_2, version_2_1_1, version_2_1_0, version_2_0_X, version_2_0_99_1, version_2_0_2, version_2_0_1, version_2_0_0, version_1_99_3, version_1_99_2, version_1_99_1_tmcc, version_1_99_1, version_1_99_0_tmcc, version_1_99_0, version_1_3_X, version_1_3_3, version_1_3_2, version_1_3_1, version_1_3_0, version_1_2_X, version_1_2_99_1, version_1_2_99_0, version_1_2_1, version_1_2_0, version_1_1_99_5, version_1_1_99_4, version_1_1_99_3, version_1_1_99_2, version_1_1_99_1, HEAD
Turn down the logging volume now that the ssl stuff looks like it's functional.

    1: #
    2: # $Id: lonssl.pm,v 1.9 2004/06/17 10:15:46 foxr Exp $
    3: #
    4: # Copyright Michigan State University Board of Trustees
    5: #
    6: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    7: #
    8: # LON-CAPA is free software; you can redistribute it and/or modify
    9: # it under the terms of the GNU General Public License as published by
   10: # the Free Software Foundation; either version 2 of the License, or
   11: # (at your option) any later version.
   12: #
   13: # LON-CAPA is distributed in the hope that it will be useful,
   14: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   15: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16: # GNU General Public License for more details.
   17: #
   18: # You should have received a copy of the GNU General Public License
   19: # along with LON-CAPA; if not, write to the Free Software
   20: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   21: #
   22: # /home/httpd/html/adm/gpl.txt
   23: #
   24: # http://www.lon-capa.org/
   25: #
   26: package lonssl;
   27: #  lonssl.pm
   28: #    This file contains common functions used by lond and lonc when 
   29: #    negotiating the exchange of the session encryption key via an 
   30: #    SSL tunnel.
   31: #     See the POD sections and function documentation for more information.
   32: #
   33: 
   34: use strict;
   35: 
   36: # CPAN/Standard  modules:
   37: 
   38: use IO::Socket::INET;
   39: use IO::Socket::SSL;
   40: 
   41: use Fcntl;
   42: use POSIX;
   43: 
   44: #  Loncapa modules:
   45: 
   46: use LONCAPA::Configuration;
   47: 
   48: #  Global storage:
   49: 
   50: my $perlvar;			#  this refers to the apache perlsetvar 
   51:                                 # variable hash.
   52: 
   53: my $pathsep = "/";		# We're on unix after all.
   54: 
   55: my $DEBUG = 0;			# Set to non zero to enable debug output.
   56: 
   57: 
   58: # Initialization code:
   59: 
   60: $perlvar = LONCAPA::Configuration::read_conf('loncapa.conf');
   61: 
   62: 
   63: my $lasterror="";
   64: 
   65: 
   66: 
   67: sub LastError {
   68:     return $lasterror;
   69: }
   70: 
   71: sub Debug {
   72:     my $msg  = shift;
   73:     if ($DEBUG) {
   74: 	print STDERR $msg;
   75:     }
   76: }
   77: 
   78: #-------------------------------------------------------------------------
   79: # Name SetFdBlocking - 
   80: #      Turn blocking mode on on the file handle.  This is required for
   81: #      SSL key negotiation.
   82: #
   83: # Parameters:
   84: #      Handle   - Reference to the handle to modify.
   85: # Returns:
   86: #      prior flag settings.
   87: #
   88: sub SetFdBlocking {
   89:     Debug("SetFdBlocking called \n");
   90:     my $Handle = shift;
   91: 
   92: 
   93: 
   94:     my $flags  = fcntl($Handle, F_GETFL, 0);
   95:     if(!$flags) {
   96: 	Debug("SetBLocking fcntl get faild $!\n");
   97:     }
   98:     my $newflags  = $flags & (~ O_NONBLOCK); # Turn off O_NONBLOCK...
   99:     if(!fcntl($Handle, F_SETFL, $newflags)) {
  100: 	Debug("Can't set non block mode  $!\n");
  101:     }
  102:     return $flags;
  103: }
  104: 
  105: #--------------------------------------------------------------------------
  106: #
  107: # Name	PromoteClientSocket
  108: # Description	Given an ordinary IO::Socket::INET Creates an SSL socket 
  109: #               for a client that is connected to the same server.
  110: # Parameters	Name	Type	           Description
  111: #               Socket	IO::Socket::INET   Original ordinary socket.
  112: #               CACert	string	           Full path name to the certificate 
  113: #                                          authority certificate file.
  114: #                MyCert	string	           Full path name to the certificate 
  115: #                                          issued to this host.
  116: #                KeyFile string    	   Full pathname to the host's private 
  117: #                                          key file for the certificate.
  118: # Returns
  119: #	-	Reference to an SSL socket on success
  120: #       -	undef on failure.  Reason for failure can be interrogated from 
  121: #               IO::Socket::SSL
  122: # Side effects:  socket is left in blocking mode!!
  123: #
  124: 
  125: sub PromoteClientSocket {
  126:     my ($PlaintextSocket,
  127: 	$CACert,
  128: 	$MyCert,
  129: 	$KeyFile)          = @_;
  130:     
  131:     
  132:     Debug("Client promotion using key: $KeyFile, Cert: $MyCert, CA: $CACert\n");
  133: 
  134:     # To create the ssl socket we need to duplicate the existing
  135:     # socket.  Otherwise closing the ssl socket will close the plaintext socket
  136:     # too.  We also must flip into blocking mode for the duration of the
  137:     # ssl negotiation phase.. the caller will have to flip to non block if
  138:     # that's what they want
  139: 
  140:     my $oldflags = SetFdBlocking($PlaintextSocket);
  141:     my $dupfno   = fcntl($PlaintextSocket, F_DUPFD, 0);
  142:     Debug("Client promotion got dup = $dupfno\n");
  143: 
  144:     
  145:     my $client = IO::Socket::SSL->new_from_fd($dupfno,
  146: 					      SSL_user_cert => 1,
  147: 					      SSL_key_file  => $KeyFile,
  148: 					      SSL_cert_file => $MyCert,
  149: 					      SSL_ca_fie    => $CACert);
  150:     
  151:     if(!$client) {
  152: 	$lasterror = IO::Socket::SSL::errstr();
  153: 	return undef;
  154:     }
  155:     return $client;		# Undef if the client negotiation fails.
  156: }
  157: 
  158: #----------------------------------------------------------------------
  159: # Name	PromoteServerSocket
  160: # Description	Given an ordinary IO::Socket::INET Creates an SSL socket 
  161: #               for a server that is connected to the same client.l
  162: # Parameters	Name	Type	           Description
  163: #               Socket	IO::Socket::INET   Original ordinary socket.
  164: #               CACert	string	           Full path name to the certificate 
  165: #                                          authority certificate file.
  166: #                MyCert	string	           Full path name to the certificate 
  167: #                                          issued to this host.
  168: #                KeyFile string    	   Full pathname to the host's private 
  169: #                                          key file for the certificate.
  170: # Returns
  171: #	-	Reference to an SSL socket on success
  172: #       -	undef on failure.  Reason for failure can be interrogated from 
  173: #               IO::Socket::SSL
  174: # Side Effects:
  175: #       Socket is left in blocking mode!!!
  176: #
  177: sub PromoteServerSocket {
  178:     my ($PlaintextSocket,
  179: 	$CACert,
  180: 	$MyCert,
  181: 	$KeyFile)          = @_;
  182: 
  183: 
  184: 
  185:     # To create the ssl socket we need to duplicate the existing
  186:     # socket.  Otherwise closing the ssl socket will close the plaintext socket
  187:     # too:
  188: 
  189:     Debug("Server promotion: Key = $KeyFile, Cert $MyCert CA $CACert\n");
  190:  
  191:     my $oldflags = SetFdBlocking($PlaintextSocket);
  192:     my $dupfno   = fcntl($PlaintextSocket, F_DUPFD, 0);
  193:     if (!$dupfno) {
  194: 	Debug("dup failed: $!\n");
  195:     }
  196:     Debug(" Fileno = $dupfno\n");
  197:     my $client = IO::Socket::SSL->new_from_fd($dupfno,
  198: 					      SSL_server    => 1, # Server role.
  199: 					      SSL_user_cert => 1,
  200: 					      SSL_key_file  => $KeyFile,
  201: 					      SSL_cert_file => $MyCert,
  202: 					      SSL_ca_fie    => $CACert);
  203:     if(!$client) {
  204: 	$lasterror = IO::Socket::SSL::errstr();
  205: 	return undef;
  206:     }
  207:     return $client;
  208: }
  209: 
  210: #-------------------------------------------------------------------------
  211: #
  212: # Name: Close
  213: # Description: Properly closes an ssl client or ssl server socket in
  214: #              a way that keeps the parent socket open.
  215: # Parameters:  Name      Type            Description
  216: #              Socket   IO::Socket::SSL  SSL Socket gotten from either
  217: #                                        PromoteClientSocket or 
  218: #                                        PromoteServerSocket
  219: # Returns:
  220: #   NONE
  221: #
  222: sub Close {
  223:     my $Socket = shift;
  224:     
  225:     $Socket->close(SSL_no_shutdown =>1); # Otherwise the parent socket 
  226:                                          # gets torn down.
  227: }
  228: #---------------------------------------------------------------------------
  229: #
  230: # Name   	GetPeerCertificate
  231: # Description	Inquires about the certificate of the peer of a connection.
  232: # Parameters	Name	        Type	          Description
  233: #               SSLSocket	IO::Socket::SSL	  SSL tunnel socket open on 
  234: #                                                 the peer.
  235: # Returns
  236: #	A two element list.  The first element of the list is the name of 
  237: #       the certificate authority.  The second element of the list is the name 
  238: #       of the owner of the certificate.
  239: sub GetPeerCertificate {
  240:     my $SSLSocket = shift;
  241:     
  242:     my $CertOwner = $SSLSocket->peer_certificate("owner");
  243:     my $CertCA    = $SSLSocket->peer_certificate("authority");
  244:     
  245:     return ($CertCA, $CertOwner);
  246: }
  247: #----------------------------------------------------------------------------
  248: #
  249: # Name  	CertificateFile
  250: # Description	Locate the certificate files for this host.
  251: # Returns
  252: #	Returns a two element array.  The first element contains the name of
  253: #  the certificate file for this host.  The second element contains the name
  254: #  of the  certificate file for the CA that granted the certificate.  If 
  255: #  either file cannot be located, returns undef.
  256: #
  257: sub CertificateFile {
  258: 
  259:     # I need some perl variables from the configuration file for this:
  260:     
  261:     my $CertificateDir  = $perlvar->{lonCertificateDirectory};
  262:     my $CaFilename      = $perlvar->{lonnetCertificateAuthority};
  263:     my $CertFilename    = $perlvar->{lonnetCertificate};
  264:     
  265:     #  Ensure the existence of these variables:
  266:     
  267:     if((!$CertificateDir)  || (!$CaFilename) || (!$CertFilename)) {
  268: 	$lasterror = "Missing info: dir: $CertificateDir CA: $CaFilename "
  269: 	            ."Cert: $CertFilename";
  270: 	return undef;
  271:     }
  272:     
  273:     #   Build the actual filenames and check for their existence and
  274:     #   readability.
  275:     
  276:     my $CaFilename   = $CertificateDir.$pathsep.$CaFilename;
  277:     my $CertFilename = $CertificateDir.$pathsep.$CertFilename;
  278:     
  279:     if((! -r $CaFilename) || (! -r $CertFilename)) {
  280: 	$lasterror = "CA file $CaFilename or Cert File: $CertFilename "
  281: 	            ."not readable";
  282: 	return undef;
  283:     }
  284:     
  285:     # Everything works fine!!
  286:     
  287:     return ($CaFilename, $CertFilename);
  288: 
  289: }
  290: #------------------------------------------------------------------------
  291: #
  292: # Name	        KeyFile
  293: # Description
  294: #      Returns the name of the private key file of the current host.
  295: # Returns
  296: #      Returns the name of the key file or undef if the file cannot 
  297: #      be found.
  298: #
  299: sub KeyFile {
  300: 
  301:     # I need some perl variables from the configuration file for this:
  302:     
  303:     my $CertificateDir   = $perlvar->{lonCertificateDirectory};
  304:     my $KeyFilename      = $perlvar->{lonnetPrivateKey};
  305:     
  306:     # Ensure the variables exist:
  307:     
  308:     if((!$CertificateDir) || (!$KeyFilename)) {
  309: 	$lasterror = "Missing parameter dir: $CertificateDir "
  310: 	            ."key: $KeyFilename";
  311: 	return undef;
  312:     }
  313:     
  314:     # Build the actual filename and ensure that it not only exists but
  315:     # is also readable:
  316:     
  317:     my $KeyFilename    = $CertificateDir.$pathsep.$KeyFilename;
  318:     if(! (-r $KeyFilename)) {
  319: 	$lasterror = "Unreadable key file $KeyFilename";
  320: 	return undef;
  321:     }
  322:     
  323:     return $KeyFilename;
  324: }
  325: 
  326: 1;

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