#
#
# a class for implementing a IO::Socket::INET type interface
# to SSL-sockets (aspa@hip.fi).
#
# this implementation draws from Crypt::SSLeay (Net::SSL)
# by Gisle Aas.
# 
#
# $Id: Net_SSL.pm,v 1.5 1999/05/27 17:22:09 aspa Exp aspa $.
#

#
# prerequisites: Net_SSLeay-1.03.
#

# Notes:
# ======
# * IO::Socket::INET interface used by LWP::Protocol::http (see
#   LWP::Protocol::http::request (LWP v5.43)):
#   - syswrite, sysread (only non-negative offsets work), close.
# * Net::SSL interface used by LWP::Protocol (see
#   LWP::Protocol::https (LWP v5.43)):
#   - $sock->get_peer_certificate, $sock->get_cipher,
#     $cert->subject_name, $cert->issuer_name.
# * LWP::Protocol::https disables warnings.
#
# Status:
# =======
# * basic client side functionality (connection establishment,
#   certificate verification, IO) works.
# * server sockets also seem to be working.
#
# TODO:
# =====
# * SSL session support.
#

package Net::SSL;

use strict;
use Carp;
use IO::Socket;
use Net::SSLeay;

#$^W = 1;

# this class inherits from IO::Handle and IO::Socket::INET.
#
# IO::Handle-interface:
# =====================
# - inherited methods: close, fileno, opened, flush.
# - overridden methods: sysread, syswrite, read, write, DESTROY.
# - unsupported: getc, eof, truncate, stat, ungetc, setbuf, setvbuf,
#   <$fh>.
# - unimplemented: print, printf, getline, getlines, fdopen,
#   untaint, error, clearerr.
# - ?: -.
#
# IO::Socket::INET-interface:
# ===========================
# - inherited methods: socket, socketpair, bind, listen, peername,
#   sockname, timeout, sockopt, sockdomain, socktype, protocol,
#   sockaddr, sockport, sockhost, peeraddr, peerport, peerhost.
# - overridden methods: accept, connect.
# - unsupported: -.
# - unimplemented: send, recv.
# - ?: -.
#
# private methods:
# ================
# - _init_SSL, _init_CTX, _unsupported, _unimplemented,
#   _get_SSL_err_str.
#
@Net::SSL::ISA = qw(IO::Socket::INET);


Net::SSLeay::load_error_strings();
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::randomize();

$Net::SSL::init_done = 0;
$Net::SSL::SSL_ctx = 0;


# ***** configure
#
# return values: Net::SSL or undef.
#
sub configure {
  my ($self, $args) = @_;

  my ($r, $ctx);

  ${*$self}{'SSL_ssl'} = undef;

  # _init_CTX sets up SSL context. it's run only once.
  if( ! defined ($ctx = $self->_init_CTX($args)) ) {
    # context initialization failed. fatal.
    return undef;
  } else {
    # a valid context was returned. save it.
    $Net::SSL::SSL_ctx = $ctx;
    $Net::SSL::init_done = 1;
  }

  # call superclass's (IO::Socket::INET) configure to setup
  # connection. superclass's configure calls connect and
  # accept methods among others.
  if( !($r = $self->SUPER::configure($args)) ) {
    my $err_str = "\$fh->SUPER::configure() failed: $!.";
    return $self->_error("configure: '$err_str'.");
  }
  
  return $self;
}

# ***** connect
#
# return values: Net::SSL or undef.
#
sub connect {
  my $self = shift;

  my ($r, $ssl);

  if( !($r = $self->SUPER::connect(@_)) ) {
    return $r;
  }

  if( ! ($ssl = $self->_init_SSL()) ) {
    return $ssl;
  }

  if ( ($r = Net::SSLeay::connect($ssl)) < 0 ) {
    my $err_str = $self->_get_SSL_err_str();    
    return $self->_error("SSL_connect: '$err_str'.");
  }

  return $self;
}

# ***** accept
#
# return values: Net::SSL or undef.
#
sub accept {
  my $self = shift;

  my ($ns, $r, $ssl);

  if( ! ($ns = $self->SUPER::accept()) ) {
    return $self->_error("accept failed: '$!'.\n");
  }

  if( ! ($ssl = $ns->_init_SSL()) ) {
    return $ssl;
  }

  if( ($r = Net::SSLeay::accept($ssl)) < 0 ) {
    my $err_str = $self->_get_SSL_err_str();
    return $self->_error("SSL_accept: '$err_str'.");
  }

  return $ns;
}


# ***** alias sysread and syswrite.
*read = \&sysread;
*write = \&syswrite;


# ***** syswrite

sub syswrite {
  if( (@_ != 3) && (@_ != 4) ) {
    croak '$fh->syswrite(BUF, LEN [, OFFSET])';
  }

  my $self = shift;
  my $buf = shift;
  my $arg_len = shift;
  my $offset = shift || 0;

  my ($res, $len, $real_len, $wbuf);
  my $ssl = ${*$self}{'SSL_ssl'};


  # do we have a write offset?
  if(!$offset) {
    $wbuf = \$buf;
  } else {
    $wbuf = \substr("$buf", $offset, $arg_len);
  }

  # argument length is not allowed to be greater than buffer length.
  if( $arg_len > ($real_len = length($$wbuf)) ) {
    $len = $real_len;
  } else {
    $len = $arg_len; 
  }
  
  # see Net_SSLeay-1.03/SSLeay.xs,
  # openssl-0.9.1c/ssl/ssl_lib.c and bio_ssl.c.
  if( ($res = Net::SSLeay::write($ssl, $$wbuf)) < 0 ) {
    my $err_str = $self->_get_SSL_err_str();
    return $self->_error("SSL_write: '$err_str'.");
  }

  return $res;
}


# ***** sysread

sub sysread {
  if( (@_ != 3) && (@_ != 4) ) {
    croak '$fh->sysread(BUF, LEN [, OFFSET])';
  }
  
  my $self = $_[0];
  my $len = $_[2];
  my $offset = $_[3] || 0;

  my $int_buf;

  my $ssl = ${*$self}{'SSL_ssl'};

  # see Net_SSLeay-1.03/SSLeay.xs,
  # openssl-0.9.1c/ssl/ssl_lib.c and bio_ssl.c.
  if( ! defined ($int_buf = Net::SSLeay::read($ssl, $len)) ) {
    my $err_str = $self->_get_SSL_err_str();
    return $self->_error("SSL_read: '$err_str'.");
  }

  if($offset) {
    # append the read data to buffer.
    $_[1] = "$_[1]" . "$int_buf";
  } else {
    # copy read data to buffer
    $_[1] = "$int_buf";
  }

  return length($int_buf);
}


# ***** DESTROY

sub DESTROY {
  my $self = shift;

  my $ssl = ${*$self}{'SSL_ssl'};
  
  # do these release all SSLeay resources?
  if($ssl) {
    Net::SSLeay::free($ssl);
    ${*$self}{'SSL_ssl'} = undef;
  }

#  if($ctx) {
#    Net::SSLeay::CTX_free($ctx);
#    ${*$self}{'SSL_ctx'} = undef;
#  }

  return $self->SUPER::DESTROY();
}


# ***** get_verify_mode

sub get_verify_mode {
    my $self = shift;

    my $ctx = $Net::SSL::SSL_ctx;

    # Net::SSLeay does not implement this function, yet.
    #my $mode = &Net::SSLeay::CTX_get_verify_mode($ctx);
    #return $mode;
}

# ***** get_cipher

sub get_cipher {
  my $self = shift;
  my $ssl = ${*$self}{'SSL_ssl'};

  my $cipher = Net::SSLeay::get_cipher($ssl);

  return $cipher;
}


# ***** get_peer_certificate

sub get_peer_certificate {
  my $self = shift;
  my $ssl = ${*$self}{'SSL_ssl'};

  my $cert = Net::SSLeay::get_peer_certificate($ssl);

  my $cert_obj = Certificate->new();
  $cert_obj->{'Certificate'} = $cert;

  return $cert_obj;
}

# ***** _init_SSL
#
# return values: SSL-ref or undef.
#
sub _init_SSL {
  my $self = shift;

  my ($r, $ssl);

  my $ctx = $Net::SSL::SSL_ctx;

  # create a new SSL structure and attach it to the context.
  if (!($ssl = Net::SSLeay::new($ctx)) ) {
    my $err_str = $self->_get_SSL_err_str();
    return $self->_error("SSL_new: '$err_str'.");
  }	
   
  if( ! ($r = Net::SSLeay::set_fd($ssl, $self->fileno)) ) {
    my $err_str = $self->_get_SSL_err_str();
    return $self->_error("set_fd: '$err_str'.");
  }

  ${*$self}{'SSL_ssl'} = $ssl;

  return $ssl;
}


#
# ***** _init_CTX
#
# return values: SSL context ref or undef.
#
sub _init_CTX {
  my ($self, $args) = @_;

  # set default values for key and cert files etc.
  # NB: currently these values can't be configured when the
  # package is used with LWP.
  my $DEFAULT_KEY_FILE = "certs/key.pem";
  my $DEFAULT_CERT_FILE = "certs/cert.pem";
  my $DEFAULT_CA_FILE = "certs/my-ca.pem";
  my $DEFAULT_CA_PATH = $ENV{'PWD'} . "/certs";
  # &Net::SSLeay::VERIFY_NONE, &Net::SSLeay::VERIFY_PEER;
  my $DEFAULT_VERIFY_MODE = &Net::SSLeay::VERIFY_PEER;
  #my $DEFAULT_VERIFY_MODE = &Net::SSLeay::VERIFY_NONE;
  my $DEFAULT_USE_CERT = 0;

  my ($key_file, $cert_file, $ca_file, $ca_path,
      $use_cert, $verify_mode);
  my ($r, $s, $ctx);


  if( $Net::SSL::init_done ) {
    # context is already set.
    return $Net::SSL::SSL_ctx;
  }

  # get SSL arguments.
  $key_file = $args->{'SSL_key_file'} || $DEFAULT_KEY_FILE;
  $cert_file = $args->{'SSL_cert_file'} || $DEFAULT_CERT_FILE;
  $ca_file = $args->{'SSL_ca_file'} || $DEFAULT_CA_FILE;
  $ca_path = $args->{'SSL_ca_path'} || $DEFAULT_CA_PATH;
  $verify_mode = (defined $args->{'SSL_verify_mode'}) ? 
      $args->{'SSL_verify_mode'} : $DEFAULT_VERIFY_MODE;
  $use_cert = $args->{'SSL_use_cert'} || $DEFAULT_USE_CERT;

  
  # create SSL context;
  if(! ($ctx = Net::SSLeay::CTX_new()) ) {
    my $err_str = $self->_get_SSL_err_str();
    return $self->_error("CTX_new(): '$err_str'.");
  }
  
  # set options for the context.
  $r = Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL);

  # set SSL certificate load paths.
  if(!($r = Net::SSLeay::CTX_load_verify_locations($ctx,
						   $ca_file,
						   $ca_path))) {
    my $err_str = $self->_get_SSL_err_str();
    return $self->_error("CTX_load_verify_locations: '$err_str'.");
  }

  # NOTE: private key, certificate and certificate verification
  #       mode are associated only to the SSL context. this is
  #       because they are client/server specific attributes and
  #       it doesn't seem to make much sense to change them between
  #       requests (aspa@hip.fi).

  # load certificate and private key.
  if( defined $args->{'Listen'} || $use_cert ) {
    if(!($r=Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx,
		 $key_file, &Net::SSLeay::FILETYPE_PEM))) {
      my $err_str = $self->_get_SSL_err_str();    
      return $self->_error("CTX_use_RSAPrivateKey_file: '$err_str'.");
    }
    if(!($r=Net::SSLeay::CTX_use_certificate_file($ctx,
		 $cert_file, &Net::SSLeay::FILETYPE_PEM))) {
      my $err_str = $self->_get_SSL_err_str();    
      return $self->_error("CTX_use_certificate_file: '$err_str'.");
    }
  }

  $r = Net::SSLeay::CTX_set_verify($ctx, $verify_mode, 0);

  return $ctx;
}



# ***** unsupported methods.

sub getc { shift->_unsupported("getc"); }
sub eof { shift->_unsupported("eof"); }
sub truncate { shift->_unsupported("truncate"); }
sub stat { shift->_unsupported("stat"); }
sub ungetc { shift->_unsupported("ungetc"); }
sub setbuf { shift->_unsupported("setbuf"); }
sub setvbuf { shift->_unsupported("setvbuf"); }


# ***** unimplemented methods.

sub print { shift->_unimplemented("print"); }
sub printf { shift->_unimplemented("printf"); }
sub getline { shift->_unimplemented("getline"); }
sub getlines { shift->_unimplemented("getlines"); }
sub fdopen { shift->_unimplemented("fdopen"); }
sub untaint { shift->_unimplemented("untaint"); }


sub _unsupported {
  my($self, $meth) = @_;
  die "'$meth' not supported by Net::SSL sockets";
}


sub _unimplemented {
  my($self, $meth) = @_;
  die "'$meth' not implemented for Net::SSL sockets";
}

sub _get_SSL_err_str {
  my $err = Net::SSLeay::ERR_get_error();    
  my $err_str = Net::SSLeay::ERR_error_string($err);
  return $err_str;
}

1;

#
# ******************** Certificate class ********************
#

#
# a minimal class for providing certificate handling functionality
# needed by libwww-perl (LWP::Protocol::https).
#

package Certificate;

sub new { bless {} };

sub subject_name {
  my $self = shift;
  my $cert = $self->{'Certificate'};

  my $name = Net::SSLeay::X509_get_subject_name($cert);
  my $str_name = Net::SSLeay::X509_NAME_oneline($name);

  return "$str_name";
}

sub issuer_name {
  my $self = shift;
  my $cert = $self->{'Certificate'};

  my $name = Net::SSLeay::X509_get_issuer_name($cert);
  my $str_name = Net::SSLeay::X509_NAME_oneline($name);

  return "$str_name";
}


1;

__END__


# net resources:
# ==============
# http://www.linpro.no/lwp
# http://search.ietf.org/internet-drafts/draft-ietf-tls-https-02.txt
# http://www.ietf.org/rfc/rfc2246.txt
# http://www.rsa.com/rsalabs/pubs/PKCS
# ftp://ftp.bull.com/pub/OSIdirectory/ITUnov96/X.509
# http://www.ietf.org/rfc/rfc1945.txt
# http://www.ietf.org/rfc/rfc2068.txt
# http://www.fortify.net
