File Coverage

blib/lib/Net/WebSocket/Handshake.pm

Criterion	Covered	Total	%
statement	88	113	77.8
branch	32	48	66.6
condition	2	3	66.6
subroutine	17	19	89.4
pod	5	5	100.0
total	144	188	76.6

package Net::WebSocket::Handshake;

use strict;
use warnings;

=encoding utf-8

=head1 NAME

Net::WebSocket::Handshake - base class for handshake objects

=head1 DESCRIPTION

This base class’s L and
L subclasses implement
WebSocket’s handshake logic. They handle the basics of a WebSocket
handshake and, optionally, subprotocol and extension negotiation.

This base class is NOT directly instantiable.

=cut

use Digest::SHA1 ();
use HTTP::Headers::Util ();

use Net::WebSocket::HTTP ();
use Net::WebSocket::X ();

use constant {
    _WS_MAGIC_CONSTANT => '258EAFA5-E914-47DA-95CA-C5AB0DC85B11',
    CRLF => "\x0d\x0a",
};

#----------------------------------------------------------------------

=head1 METHODS

=head2 I->new( %OPTS )

Returns an instance of the relevant subclass
(L or
L).
The following are common options for both:

=over

=item * C - A list of HTTP tokens (e.g., C)
that stand for subprotocols that this endpoint can use via the WebSocket
connection.

=item * C - A list of extension objects that the Handshake
object will interact with to determine extension support.

=back

=head1 COMMON EXTENSION INTERFACE

Each object in the C array must implement the following methods:

=over

=item * C The extension’s token. (e.g., C)

=item * C Returns an instance of
L to represent the extension and
its parameters in the HTTP headers.

=item * C Receives the extension parameters
(in the format that C
returns). This operation should configure the object to return the proper
value from its C method.

=item * C A boolean that indicates whether the peer indicates
proper support for the extension. This should not be called until after
C.

=back

=cut

sub new {
    my ($class, %opts) = @_;

    if ($opts{'extensions'}) {
        $opts{'_extension_tokens'} = { map { $_->token() => $_ } @{ $opts{'extensions'} } };
    }

    return bless \%opts, $class;
}

=head2 $sp_token = I->get_subprotocol()

Returns the negotiated subprotocol’s token (e.g., C).

=cut

sub get_subprotocol {
    my $self = shift;

    if (!$self->{'_no_use_legacy'}) {
        die 'Must call consume_headers() first!';
    }

    return $self->{'_subprotocol'};
}

=head2 I->consume_headers( HDR1 => VAL1, HDR2 => VAL2, .. )

The “workhorse” method of this base class. Takes in the HTTP headers
and verifies that the look as they should, setting this object’s own
internals as appropriate.

This will throw an appropriate exception if any header is missing
or otherwise invalid.

=cut

sub consume_headers {
    my ($self, @kv_pairs) = @_;

    $self->{'_no_use_legacy'} = 1;

    while ( my ($k => $v) = splice( @kv_pairs, 0, 2 ) ) {
        next if !defined $v;
        $self->_consume_peer_header($k => $v);
    }

    $self->_die_if_missing_headers();

    return;
}

=head2 my $hdrs_txt = I->to_string( %OPTS )

The text of the HTTP headers to send, with the 2nd trailing CR/LF
that ends the headers portion of an HTTP message.

If you use this object
to negotiate a subprotocol and/or extensions, those will be included
in the output from this method.

%OPTS can be:

=over

=item * C - an array reference of key/value pairs. For example:

    [
        Authorization => 'Basic Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==',
        'X-Custom'    => 'some value',
    ]

=back

=cut

sub to_string {
    my ($self, %opts) = @_;

    my @extra_lines;

    if (my $hdrs_ar = $opts{'headers'}) {
        $hdrs_ar = [ @$hdrs_ar ];

        while ( my ($key, $val) = splice( @$hdrs_ar, 0, 2 ) ) {
            push @extra_lines, "$key: $val";
        }
    }

    return join(
        CRLF(),
        $self->_create_header_lines(),
        @extra_lines,
        q<>, q<>,
    );
}

=head1 LEGACY INTERFACE

Prior to version 0.5 this module was a great deal less “helpful”:
it required callers to parse out and write WebSocket headers,
doing most of the validation manually. Version 0.5 added a generic
interface for entering in HTTP headers, which allows Net::WebSocket to
handle the parsing and creation of HTTP headers as well as subprotocol
and extension negotiation.

For now the legacy functionality is being left in; however,
it is considered DEPRECATED and will be removed eventually.

=head2 my $hdrs_txt = I->create_header_text()

The same output as C but minus the 2nd trailing
CR/LF. (This was intended to facilitate adding other headers; however,
that’s done easily enough with the newer C.)

=cut

sub create_header_text {
    my $self = shift;

    return join( CRLF(), $self->_create_header_lines(), q<> );
}

=head1 SEE ALSO

=over

=item * L

=item * L

=back

=cut

#----------------------------------------------------------------------

sub _get_accept {
    my ($self) = @_;

    my $key_b64 = $self->{'key'} or do {
        die Net::WebSocket::X->create('BadArg', key => $self->{'key'});
    };

    $key_b64 =~ s<\A\s+|\s+\z><>g;

    my $accept = Digest::SHA1::sha1_base64( $key_b64 . _WS_MAGIC_CONSTANT() );

    #pad base64
    $accept .= '=' x (4 - (length($accept) % 4));

    return $accept;
}

#Post-legacy, move this to Client and have the Server use logic
#that allows only one.
sub _encode_subprotocols {
    my ($self) = @_;

    return ( $self->{'subprotocols'} && @{ $self->{'subprotocols'} }
        ? ( 'Sec-WebSocket-Protocol: ' . join(', ', @{ $self->{'subprotocols'} } ) )
        : ()
    );
}

sub _encode_extensions {
    my ($self) = @_;

    return if !$self->{'extensions'};

    my @handshake_xtns;
    for my $xtn ( @{ $self->{'extensions'} } ) {
        if ( $xtn->isa('Net::WebSocket::Handshake::Extension') ) {
            $self->_warn_legacy();
            push @handshake_xtns, $xtn;
        }
        elsif ( $self->_should_include_extension_in_headers($xtn) ) {
            push @handshake_xtns, $xtn->get_handshake_object();
        }
    }

    return if !@handshake_xtns;

    my ($first, @others) = @handshake_xtns;

    return 'Sec-WebSocket-Extensions: ' . $first->to_string(@others);
}

sub _warn_legacy {
    my ($self) = @_;

    if (!$self->{'_warned_legacy'}) {
        my $ref = ref $self;
        warn "You are using $ref’s legacy interface. This interface will eventually be removed from $ref entirely, so please update your application to the newer interface. (The update should simplify your code.)";

        $self->{'_warned_legacy'}++;
    }

    return;
}

sub _missing_generic_headers {
    my ($self) = @_;

    my @missing;
    push @missing, 'Connection' if !$self->{'_connection_header_ok'};
    push @missing, 'Upgrade' if !$self->{'_upgrade_header_ok'};

    return @missing;
}

sub _consume_sec_websocket_extensions_header {
    my ($self, $value) = @_;

    require Net::WebSocket::Handshake::Extension;

    for my $xtn ( Net::WebSocket::Handshake::Extension->parse_string($value) ) {
        my $xtn_token = $xtn->token();
        my $xtn_handler = $self->{'_extension_tokens'}{ $xtn_token };
        if ($xtn_handler) {
            $xtn_handler->consume_parameters($xtn->parameters());

            if ($xtn_handler->ok_to_use()) {
                $self->{'_match_extensions'}{ $xtn_token } = $xtn_handler;
            }
        }
        else {
            $self->_handle_unrecognized_extension($xtn);
        }
    }

    return;
}

sub _consume_generic_header {
    my ($self, $hname, $value) = @_;

    tr for ($hname);

    if ($hname eq 'connection') {
        $value =~ tr;
        for my $t ( Net::WebSocket::HTTP::split_tokens($value) ) {
            if ($t eq 'upgrade') {
                $self->{'_connection_header_ok'} = 1;
            }
        }

        if (!$self->{'_connection_header_ok'}) {
            die Net::WebSocket::X->create('BadHeader', 'Connection' => $value, 'Must contain “upgrade”');
        }
    }
    elsif ($hname eq 'upgrade') {
        $value =~ tr;
        for my $t ( Net::WebSocket::HTTP::split_tokens($value) ) {
            if ($t eq 'websocket') {
                $self->{'_upgrade_header_ok'} = 1;
            }
        }

        if (!$self->{'_upgrade_header_ok'}) {
            die Net::WebSocket::X->create('BadHeader', 'Upgrade' => $value, 'Must contain “websocket”');
        }
    }
    elsif ($hname eq 'sec-websocket-protocol') {
        for my $token ( Net::WebSocket::HTTP::split_tokens($value) ) {
            if (!defined $self->{'_match_protocol'}) {
                ($self->{'_match_protocol'}) = grep { $_ eq $token } @{ $self->{'subprotocols'} };
            }
        }
    }
    elsif ($hname eq 'sec-websocket-extensions') {
        $self->_consume_sec_websocket_extensions_header($value);
    }

    return;
}

1;