view release on metacpan or  search on metacpan

TLSProfile.pm  view on Meta::CPAN

a successful TLS negotiation.  It will be passed a reference to the
session as its first and only argument.  For example, this might be
used to change the local profiles offered.

=item SSL_*

These are parameters that are understood by C<IO::Socket::SSL::new>.
You will probably want to use a few of them: SSL_cert_file,
SSL_key_file, and SSL_verify_mode are typical.

=back

=cut

sub initialize {
  my $self = shift;
  my %args = @_;

  $self->{uri} 	     = $URI;
  $self->{_callback} = 0;
  $self->{_ssl_args} = { SSL_version => 'TLSv1' };

  for (keys %args) {
    my $val = $args{$_};

    /^server$/io and do {
      $self->{_is_server} = $val;
      next;
    };
    /^callback$/io and do {
      $self->{_callback} = $val;
      next;
    };
    /^SSL_/ and do {
      $self->{_ssl_args}->{$_} = $val;
      next;
    };
  }
}


# This handles the piggybacked <ready /> request.  IMO, this is really
# the only way to do TLS.  I'm not sure why anyone would bother with
# the non-piggybacked form of this profile.
#
# NOTE: this handles the back end of the exchange itself, so we can
# drop right into the TLS negotation after sending the <proceed />
# response.
sub start_channel_request {
  my $self    = shift;
  my $session = shift;
  my $message = shift;
  my $data    = shift;

  my $el = $self->_parse_content($data);
  if ($el->nodeName eq 'ready') {

    # FIXME: deal with version attribute.

    # send <profile> response ourselves.
    my $proceed_cdata = new XML::LibXML::CDATASection("<proceed />");
    $session->{mgmt_profile}->send_profile_message
      ($session, $message->msgno(), $self->uri(), $proceed_cdata, 0);

    # start TLS
    $self->_start_TLS($session);

    # inform the management profile to do nothing else.
    return 'NUL';
  }
  else {
    # we create the channel, but return an embedded error.
    return ('RPY', "<error code='501'>unknown request.</error>", 0);
  }
}

# This handles server side of the non-piggybacked form of the TLS
# negotiation.
sub MSG {
  my $self    = shift;
  my $session = shift;
  my $message = shift;

  if ($message->content_type() ne 'application/beep+xml') {
    my $resp = new Net::BEEP::Lite::Message
      (Type 	   => 'ERR',
       Msgno 	   => $message->msgno(),
       Channel 	   => $message->channel_number(),
       ContentType => 'application/beep+xml',
       Content 	   => "<error code='501'>Unknown request.</error>");

    $session->send_message($resp);
    return;
  }

  my $el = $self->_parse_content($message->content());
  if ($el->nodeName eq 'ready') {

    # send <proceed /> response
    my $resp = new Net::BEEP::Lite::Message
      (Type 	   => 'RPY',
       Channel 	   => $message->channel_number(),
       Msgno 	   => $message->msgno(),
       ContentType => 'application/beep+xml',
       Content 	   => '<proceed />');

    $session->send_message($resp);

    # start TLS
    $self->_start_TLS($session);
  }
  else {

    my $resp = new Net::BEEP::Lite::Message
      (Type 	   => 'ERR',
       Channel 	   => $message->channel_number(),
       Msgno 	   => $message->msgno(),
       ContentType => 'application/beep+xml',
       Content 	   => "<error code='501'>Unknown request.</error>");

    $session->send_message($resp);
  }