--- loncom/lonssl.pm 2004/05/26 11:12:58 1.2
+++ loncom/lonssl.pm 2018/07/29 03:03:36 1.16
@@ -1,5 +1,5 @@
#
-# $Id: lonssl.pm,v 1.2 2004/05/26 11:12:58 foxr Exp $
+# $Id: lonssl.pm,v 1.16 2018/07/29 03:03:36 raeburn 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
@@ -32,10 +32,77 @@
#
use strict;
+
+# CPAN/Standard modules:
+
use IO::Socket::INET;
use IO::Socket::SSL;
+use Net::SSLeay;
+
+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
@@ -49,36 +116,64 @@ use IO::Socket::SSL;
# issued to this host.
# KeyFile string Full pathname to the host's private
# key file for the certificate.
+# peer string lonHostID of remote LON-CAPA server
# 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 = shift;
- my $CACert = shift;
- my $MyCert = shift;
- my $KeyFile = shift;
-
- # 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),
- SSL_user_cert => 1,
- SSL_key_file => $KeyFile,
- SSL_cert_file => $MyCert,
- SSL_ca_fie => $$CACert);
-
- return $client; # Undef if the client negotiation fails.
+ my ($PlaintextSocket,
+ $CACert,
+ $MyCert,
+ $KeyFile,
+ $peer) = @_;
+
+
+ Debug("Client promotion using key: $KeyFile, Cert: $MyCert, CA: $CACert, Remote Host: $peer\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");
+
+ # Starting with IO::Socket::SSL rev. 1.79, carp warns that a verify
+ # mode of SSL_VERIFY_NONE should be explicitly set for client, if
+ # verification is not to be used, and SSL_verify_mode is not set.
+ # Starting with rev. 1.95, the default became SSL_VERIFY_PEER which
+ # prevents an SSL connection to lond unless SSL_verifycn_name is set
+ # to the lonHostID of the remote host, (and the remote certificate has
+ # the remote lonHostID as CN, and has been signed by the LON-CAPA CA.
+ # Set SSL_verify_mode to Net::SSLeay::VERIFY_PEER() instead of to
+ # SSL_VERIFY_PEER for compatibility with IO::Socket::SSL rev. 1.01
+ # used by CentOS/RHEL/Scientific Linux 5).
+
+ my $client = IO::Socket::SSL->new_from_fd($dupfno,
+ SSL_use_cert => 1,
+ SSL_key_file => $KeyFile,
+ SSL_cert_file => $MyCert,
+ SSL_ca_file => $CACert,
+ SSL_verifycn_name => $peer,
+ SSL_verify_mode => Net::SSLeay::VERIFY_PEER());
+
+ 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
+# for a server that is connected to the same client.
# Parameters Name Type Description
# Socket IO::Socket::INET Original ordinary socket.
# CACert string Full path name to the certificate
@@ -87,31 +182,48 @@ sub PromoteClientSocket {
# issued to this host.
# KeyFile string Full pathname to the host's private
# key file for the certificate.
+# peer string lonHostID of remote LON-CAPA client
# Returns
# - Reference to an SSL socket on success
# - undef on failure. Reason for failure can be interrogated from
# IO::Socket::SSL
-sub PromoteServerSocket
-{
- my $PlaintextSocket = shift;
- my $CACert = shift;
- my $MyCert = shift;
- my $KeyFile = shift;
-
-
- # 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),
- SSL_server => 1, # Server role.
- SSL_user_cert => 1,
- SSL_key_file => $KeyFile,
- SSL_cert_file => $MyCert,
- SSL_ca_fie => $$CACert);
- return $client;
+# Side Effects:
+# Socket is left in blocking mode!!!
+#
+sub PromoteServerSocket {
+ my ($PlaintextSocket,
+ $CACert,
+ $MyCert,
+ $KeyFile,
+ $peer) = @_;
+
+
+
+ # 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_use_cert => 1,
+ SSL_key_file => $KeyFile,
+ SSL_cert_file => $MyCert,
+ SSL_ca_file => $CACert,
+ SSL_verifycn_name => $peer,
+ SSL_verify_mode => Net::SSLeay::VERIFY_PEER());
+ if(!$client) {
+ $lasterror = IO::Socket::SSL::errstr();
+ return undef;
+ }
+ return $client;
}
#-------------------------------------------------------------------------
@@ -127,9 +239,167 @@ sub PromoteServerSocket
# NONE
#
sub Close {
- my $Socket = shift;
+ 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.
+
+ $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);
+
+}
+#------------------------------------------------------------------------
+#
+# 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:
+
+ $KeyFilename = $CertificateDir.$pathsep.$KeyFilename;
+ if(! (-r $KeyFilename)) {
+ $lasterror = "Unreadable key file $KeyFilename";
+ return undef;
+ }
+
+ return $KeyFilename;
+}
+
+sub Read_Connect_Config {
+ my ($secureconf,$perlvarref) = @_;
+ return unless (ref($secureconf) eq 'HASH');
+
+ unless (ref($perlvarref) eq 'HASH') {
+ $perlvarref = $perlvar;
+ }
+
+ # Clean out the old table first.
+ foreach my $key (keys(%{$secureconf})) {
+ delete($secureconf->{$key});
+ }
+
+ my $result;
+ my $tablename = $perlvarref->{'lonTabDir'}."/connectionrules.tab";
+ if (open(my $fh,"<$tablename")) {
+ while (my $line = <$fh>) {
+ chomp($line);
+ my ($name,$value) = split(/=/,$line);
+ if ($value =~ /^(?:no|yes|req)$/) {
+ if ($name =~ /^conn(to|from)_(dom|intdom|other)$/) {
+ $secureconf->{'conn'.$1}{$2} = $value;
+ }
+ }
+ }
+ close($fh);
+ return 'ok';
+ }
+ return;
+}
- $Socket->close(SSL_no_shutdown =>1); # Otherwise the parent socket
- # gets torn down.
+sub Read_Host_Types {
+ my ($hosttypes,$perlvarref) = @_;
+ return unless (ref($hosttypes) eq 'HASH');
+
+ unless (ref($perlvarref) eq 'HASH') {
+ $perlvarref = $perlvar;
+ }
+
+ # Clean out the old table first.
+ foreach my $key (keys(%{$hosttypes})) {
+ delete($hosttypes->{$key});
+ }
+
+ my $result;
+ my $tablename = $perlvarref->{'lonTabDir'}."/hosttypes.tab";
+ if (open(my $fh,"<$tablename")) {
+ while (my $line = <$fh>) {
+ chomp($line);
+ my ($name,$value) = split(/:/,$line);
+ if (($name ne '') && ($value =~ /^(dom|intdom|other)$/)) {
+ $hosttypes->{$name} = $value;
+ }
+ }
+ close($fh);
+ return 'ok';
+ }
+ return;
}
+1;