--- loncom/lonssl.pm	2004/05/27 10:26:19	1.5
+++ loncom/lonssl.pm	2004/06/17 10:15:46	1.9
@@ -1,5 +1,5 @@
 #
-# $Id: lonssl.pm,v 1.5 2004/05/27 10:26:19 foxr Exp $
+# $Id: lonssl.pm,v 1.9 2004/06/17 10:15:46 foxr 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.
+    
+    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);
 
 }
 #------------------------------------------------------------------------
@@ -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:
+    
+    my $KeyFilename    = $CertificateDir.$pathsep.$KeyFilename;
+    if(! (-r $KeyFilename)) {
+	$lasterror = "Unreadable key file $KeyFilename";
+	return undef;
+    }
+    
+    return $KeyFilename;
 }
 
 1;
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<html><head>
<title>500 Internal Server Error</title>
</head><body>
<h1>Internal Server Error</h1>
<p>The server encountered an internal error or
misconfiguration and was unable to complete
your request.</p>
<p>Please contact the server administrator at 
 root@localhost to inform them of the time this error occurred,
 and the actions you performed just before this error.</p>
<p>More information about this error may be available
in the server error log.</p>
</body></html>