File Coverage

blib/lib/Protocol/TLS/Server.pm

Criterion	Covered	Total	%
statement	68	89	76.4
branch	8	18	44.4
condition	1	3	33.3
subroutine	14	16	87.5
pod	0	2	0.0
total	91	128	71.0

package Protocol::TLS::Server;
use strict;
use warnings;
use Carp;
use MIME::Base64;
use Protocol::TLS::Trace qw(tracer bin2hex);
use Protocol::TLS::Context;
use Protocol::TLS::Connection;
use Protocol::TLS::Constants
  qw(cipher_type const_name :versions :ciphers :c_types :end_types :hs_types :state_types :alert_desc);

sub new {
    my ( $class, %opts ) = @_;
    my $self = bless { %opts, sid => {}, }, $class;
    $self->_load_cert( delete $opts{cert_file} );
    $self->_load_priv_key( delete $opts{key_file} );
    $self;
}

sub _load_cert {
    my ( $self, $file ) = @_;
    croak "specify cert_file path" unless defined $file;

    local $/;
    open my $fh, '<', $file or croak "opening cert_file error: $!";

    # TODO: multiple certs
    my ($cert) = (
        <$fh> =~ /^-----BEGIN\x20CERTIFICATE-----\r?\n
          (.+?\r?\n)
          -----END\x20CERTIFICATE-----\r?\n/sx
    );
    close $fh;
    croak "Certificate must be in PEM format" unless $cert;
    $self->{cert} = decode_base64($cert);
    ();
}

sub _load_priv_key {
    my ( $self, $file ) = @_;
    croak "specify key_file path" unless defined $file;

    local $/;
    open my $fh, '<', $file or croak "opening key_file error: $!";
    my ($key) = (
        <$fh> =~ /^-----BEGIN\x20RSA\x20PRIVATE\x20KEY-----\r?\n
          (.+?\r?\n)
          -----END\x20RSA\x20PRIVATE\x20KEY-----\r?\n/sx
    );
    close $fh;
    croak "Private key must be in PEM format" unless $key;
    $self->{key} = decode_base64($key);
    ();
}

sub new_connection {
    my ( $self, %opts ) = @_;
    my $ctx = Protocol::TLS::Context->new( type => SERVER );
    $ctx->{key}      = $self->{key};
    $ctx->{cert}     = $self->{cert};
    $ctx->{proposed} = {
        ciphers => [
            TLS_RSA_WITH_AES_128_CBC_SHA, TLS_RSA_WITH_NULL_SHA256,
            TLS_RSA_WITH_NULL_SHA,
        ],
        tls_version => TLS_v12,
        compression => [0],
    };
    my $con = Protocol::TLS::Connection->new($ctx);

    $ctx->{on_change_state} = sub {
        my ( $ctx, $prev_state, $new_state ) = @_;
        tracer->debug( "State changed from "
              . const_name( 'state_types', $prev_state ) . " to "
              . const_name( 'state_types', $new_state )
              . "\n" );
    };

    if ( exists $opts{on_data} ) {
        $ctx->{on_data} = $opts{on_data};
    }

    $ctx->state_cb(
        STATE_HS_START,
        sub {
            my $ctx = shift;
            my $p   = $ctx->{pending};
            my $sp  = $p->{securityParameters};
            my $sid = $p->{session_id};

            # Resume session
            if ( $sid ne '' && exists $self->{sid}->{$sid} ) {
                my $s = $self->{sid}->{$sid};
                $p->{tls_version} = $s->{tls_version};
                $p->{cipher}      = $s->{cipher};
                $sp->{$_}         = $s->{securityParameters}->{$_}
                  for keys %{ $s->{securityParameters} };

                # save sid as proposed
                $ctx->{proposed}->{session_id} = $sid;
                tracer->debug( "Resume session: " . bin2hex($sid) );

                $ctx->enqueue(
                    [
                        CTYPE_HANDSHAKE,
                        HSTYPE_SERVER_HELLO,
                        {
                            tls_version   => $p->{tls_version},
                            server_random => $sp->{server_random},
                            session_id    => $sid,
                            cipher        => $p->{cipher},
                            compression   => $sp->{CompressionMethod}
                        }
                    ]
                );
                $ctx->enqueue( [CTYPE_CHANGE_CIPHER_SPEC],
                    [ CTYPE_HANDSHAKE, HSTYPE_FINISHED, $ctx->finished ] );
            }

            # New session
            else {
                $sid = $p->{session_id} = $ctx->crypto->random(32);
                $ctx->enqueue(
                    [
                        CTYPE_HANDSHAKE,
                        HSTYPE_SERVER_HELLO,
                        {
                            tls_version   => $p->{tls_version},
                            server_random => $sp->{server_random},
                            session_id    => $sid,
                            cipher        => $p->{cipher},
                            compression   => $sp->{CompressionMethod}
                        }
                    ],
                    [ CTYPE_HANDSHAKE, HSTYPE_CERTIFICATE, $ctx->{cert} ],
                    [ CTYPE_HANDSHAKE, HSTYPE_SERVER_HELLO_DONE ]
                );
            }
        }
    );

    $ctx->state_cb( STATE_HS_FULL,
        sub {
            my $ctx = shift;
            $ctx->enqueue( [CTYPE_CHANGE_CIPHER_SPEC],
                [ CTYPE_HANDSHAKE, HSTYPE_FINISHED, $ctx->finished ] );
        }
    );

    $ctx->state_cb( STATE_OPEN,
        sub {
            my $ctx = shift;
            my $p   = $ctx->{pending};

            # add sid to server's cache
            $self->{sid}->{ $p->{session_id} } = $ctx->copy_pending;
            tracer->debug( "Saved sid: " . bin2hex( $p->{session_id} ) );
            $ctx->{session_id}  = $p->{session_id};
            $ctx->{tls_version} = $p->{tls_version};
            $ctx->clear_pending;

            # Handle callbacks
            if ( exists $opts{on_handshake_finish} ) {
                $opts{on_handshake_finish}->($ctx);
            }
        }
    );

    $con;
}

1
__END__