version 1.1, 2004/05/26 10:19:54
|
version 1.19, 2018/08/20 18:53:20
|
Line 0
|
Line 1
|
|
# |
|
# $Id$ |
|
# |
|
# 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 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 |
|
# 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. |
|
# peer string lonHostID of remote LON-CAPA server |
|
# CRLFile Full path name to the certificate |
|
# revocation list file for the cluster |
|
# to which server belongs (optional) |
|
|
|
# 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, |
|
$peer, |
|
$CRLFile) = @_; |
|
|
|
Debug("Client promotion using key: $KeyFile, Cert: $MyCert, CA: $CACert, CRL: $CRLFile, 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 %sslargs = (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 (($CRLFile ne '') && (-e $CRLFile)) { |
|
$sslargs{SSL_check_crl} = 1; |
|
$sslargs{SSL_crl_file} = $CRLFile; |
|
} |
|
my $client = IO::Socket::SSL->new_from_fd($dupfno,%sslargs); |
|
if(!$client) { |
|
if ($IO::Socket::SSL::SSL_ERROR == -1) { |
|
$lasterror = -1; |
|
} |
|
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. |
|
# 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. |
|
# peer string lonHostID of remote LON-CAPA client |
|
# CRLFile Full path name to the certificate |
|
# revocation list file for the cluster |
|
# to which server belongs (optional) |
|
# clientversion LON-CAPA version running on remote |
|
# client |
|
# 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, |
|
$peer, |
|
$CRLFile, |
|
$clientversion) = @_; |
|
|
|
# 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 %sslargs = (SSL_server => 1, # Server role. |
|
SSL_use_cert => 1, |
|
SSL_key_file => $KeyFile, |
|
SSL_cert_file => $MyCert, |
|
SSL_ca_file => $CACert); |
|
my ($major,$minor) = split(/\./,$clientversion); |
|
if (($major < 2) || ($major == 2 && $minor < 12)) { |
|
$sslargs{SSL_verify_mode} = Net::SSLeay::VERIFY_NONE(); |
|
} else { |
|
$sslargs{SSL_verifycn_name} = $peer; |
|
$sslargs{SSL_verify_mode} = Net::SSLeay::VERIFY_PEER(); |
|
if (($CRLFile ne '') && (-e $CRLFile)) { |
|
$sslargs{SSL_check_crl} = 1; |
|
$sslargs{SSL_crl_file} = $CRLFile; |
|
} |
|
} |
|
my $client = IO::Socket::SSL->new_from_fd($dupfno,%sslargs); |
|
if(!$client) { |
|
if ($IO::Socket::SSL::SSL_ERROR == -1) { |
|
$lasterror = -1; |
|
} |
|
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. |
|
|
|
$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 CRLFile { |
|
|
|
# I need some perl variables from the configuration file for this: |
|
|
|
my $CertificateDir = $perlvar->{lonCertificateDirectory}; |
|
my $CRLFilename = $perlvar->{lonnetCertRevocationList}; |
|
|
|
# Ensure the variables exist: |
|
|
|
if((!$CertificateDir) || (!$CRLFilename)) { |
|
$lasterror = "Missing parameter dir: $CertificateDir " |
|
."CRL file: $CRLFilename"; |
|
return undef; |
|
} |
|
|
|
# Build the actual filename and ensure that it not only exists but |
|
# is also readable: |
|
|
|
$CRLFilename = $CertificateDir.$pathsep.$CRLFilename; |
|
if(! (-r $CRLFilename)) { |
|
$lasterror = "Unreadable key file $CRLFilename"; |
|
return undef; |
|
} |
|
|
|
return $CRLFilename; |
|
} |
|
|
|
sub BadCertDir { |
|
my $SocketDir = $perlvar->{lonSockDir}; |
|
if (-d "$SocketDir/nosslverify/") { |
|
return "$SocketDir/nosslverify" |
|
} |
|
} |
|
|
|
sub has_badcert_file { |
|
my ($client) = @_; |
|
my $SocketDir = $perlvar->{lonSockDir}; |
|
if (-e "$SocketDir/nosslverify/$client") { |
|
return 1; |
|
} |
|
return; |
|
} |
|
|
|
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; |
|
} |
|
|
|
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; |