File Coverage

blib/lib/Protocol/TLS/Client.pm

Criterion	Covered	Total	%
statement	88	114	77.1
branch	10	32	31.2
condition	2	9	22.2
subroutine	16	16	100.0
pod	2	2	100.0
total	118	173	68.2

package Protocol::TLS::Client;
use strict;
use warnings;
use Carp;
use Protocol::TLS::Trace qw(tracer bin2hex);
use Protocol::TLS::Utils qw(load_cert load_priv_key);
use Protocol::TLS::Context;
use Protocol::TLS::Connection;
use Protocol::TLS::Constants qw(const_name :state_types :end_types :c_types
  :versions :hs_types :ciphers cipher_type :alert_desc :hash_alg :sign_alg);

sub new {
    my ( $class, %opts ) = @_;
    my $self = bless { %opts, sid => {} }, $class;
    if ( exists $opts{cert_file} && exists $opts{key_file} ) {
        $self->{cert} = load_cert( $opts{cert_file} );
        $self->{key}  = load_priv_key( $opts{key_file} );
    }
    $self;
}

sub new_connection {
    my ( $self, $server_name, %opts ) = @_;
    croak "Specify server name of host" unless defined $server_name;

    my $ctx = Protocol::TLS::Context->new( type => CLIENT );
    $ctx->{key}  = $self->{key}  if exists $self->{key};
    $ctx->{cert} = $self->{cert} if exists $self->{cert};

    my $con = Protocol::TLS::Connection->new($ctx);

    # Grab random session_id from cache (if exists)
    if ( exists $self->{sid}->{$server_name} ) {
        my $s   = $self->{sid}->{$server_name};
        my $sid = ( keys %$s )[0];

        $ctx->{proposed} = {
            session_id  => $sid,
            tls_version => $s->{$sid}->{tls_version},
            ciphers     => [ $s->{$sid}->{cipher} ],
            compression => [ $s->{$sid}->{compression} ],
        };
    }
    else {
        $ctx->{proposed} = {
            session_id => '',
            ciphers    => [
                TLS_RSA_WITH_AES_128_CBC_SHA, TLS_RSA_WITH_NULL_SHA256,
                TLS_RSA_WITH_NULL_SHA,
            ],
            tls_version => TLS_v12,
            compression => [0],
        };
    }

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

    $ctx->enqueue( [ CTYPE_HANDSHAKE, HSTYPE_CLIENT_HELLO, $ctx->{proposed} ] );

    $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 ) );
    };

    # New session
    $ctx->state_cb(
        STATE_HS_HALF,
        sub {
            my $ctx    = shift;
            my $p      = $ctx->{pending};
            my $pro    = $ctx->{proposed};
            my $sp     = $p->{securityParameters};
            my $crypto = $ctx->crypto;

            # Server invalidate our session
            if ( $pro->{session_id} ne '' ) {
                delete $self->{sid}->{$server_name}->{ $pro->{session_id} };
            }

            my $pub_key = $crypto->cert_pubkey( $p->{cert}->[0] );

            if ( exists $p->{client_cert} ) {
                $ctx->enqueue(
                    [
                        CTYPE_HANDSHAKE,
                        HSTYPE_CERTIFICATE,
                        exists $ctx->{cert} ? $ctx->{cert} : ()
                    ]
                );
            }

            my ( $da, $ca, $mac ) = cipher_type( $p->{cipher} );

            if ( $da eq 'RSA' ) {
                my $preMasterSecret =
                  pack( "n", $p->{tls_version} ) . $crypto->random(46);

                $sp->{master_secret} = $crypto->PRF(
                    $preMasterSecret,
                    "master secret",
                    $sp->{client_random} . $sp->{server_random}, 48
                );

                my $encoded =
                  $crypto->rsa_encrypt( $pub_key, $preMasterSecret );
                $ctx->enqueue(
                    [ CTYPE_HANDSHAKE, HSTYPE_CLIENT_KEY_EXCHANGE, $encoded ] );
            }
            else {
                die "not implemented";
            }

            if ( exists $p->{client_cert} && exists $ctx->{cert} ) {
                my ( $sign, $hash_n, $alg_n, $hash, $alg );

                $alg = $crypto->cert_pubkeyalg( $ctx->{cert} );

                if ( $alg && exists &{"SIGN_$alg"} ) {
                    no strict 'refs';
                    $alg_n = &{"SIGN_$alg"};
                }
                elsif ($alg) {
                    die "algotithm $alg not implemented";
                }
                else {
                    die "cert error";
                }

                my $sah = $p->{client_cert}->{sah};

                for my $i ( 0 .. @$sah / 2 - 1 ) {
                    if ( $sah->[ $i * 2 + 1 ] == $alg_n ) {
                        $hash_n = $sah->[ $i * 2 ];
                        $hash = const_name( 'hash_alg', $sah->[ $i * 2 ] );
                        $hash =~ s/HASH_//;
                        tracer->debug("Selected $alg, $hash");
                        last;
                    }
                }

                if ( $alg eq 'RSA' ) {
                    $sign = $crypto->rsa_sign( $ctx->{key}, $hash,
                        join '', @{ $p->{hs_messages} } );
                }
                else {
                    die "algotithm $alg not implemented";
                }

                $ctx->enqueue(
                    [
                        CTYPE_HANDSHAKE, HSTYPE_CERTIFICATE_VERIFY,
                        $hash_n,         $alg_n,
                        $sign
                    ]
                );
            }

            $ctx->enqueue( [CTYPE_CHANGE_CIPHER_SPEC],
                [ CTYPE_HANDSHAKE, HSTYPE_FINISHED, $ctx->finished ] );
        }
    );

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

            #my $pro    = $ctx->{proposed};
            my $sp = $p->{securityParameters};

            my $s = $self->{sid}->{$server_name}->{ $p->{session_id} };
            $p->{tls_version} = $s->{tls_version};
            $p->{cipher}      = $s->{cipher};
            $sp->{$_}         = $s->{securityParameters}->{$_}
              for keys %{ $s->{securityParameters} },

              tracer->debug( "Resume session: " . bin2hex( $p->{session_id} ) );
        }
    );

    $ctx->state_cb( STATE_HS_RESUME,
        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 client's cache
            $self->{sid}->{$server_name}->{ $p->{session_id} } =
              $ctx->copy_pending;
            tracer->debug( "Saved sid:\n" . 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__