File Coverage

blib/lib/Net/WebSocket/Handshake/Client.pm

Criterion	Covered	Total	%
statement	74	84	88.1
branch	19	30	63.3
condition	4	12	33.3
subroutine	16	17	94.1
pod	2	4	50.0
total	115	147	78.2

package Net::WebSocket::Handshake::Client;

=encoding utf-8

=head1 NAME

Net::WebSocket::Handshake::Client

=head1 SYNOPSIS

    my $hsk = Net::WebSocket::Handshake::Client->new(

        #required
        uri => 'ws://haha.test',

        #optional, to imitate a web client
        origin => ..,

        #optional, base 64 .. auto-created if not given
        key => '..',

        #optional
        subprotocols => [ 'echo', 'haha' ],

        #optional
        extensions => \@extension_objects,
    );

    print $hsk->to_string();

    $hsk->consume_headers( NAME1 => VALUE1, .. );

=head1 DESCRIPTION

This class implements WebSocket handshake logic for a client.
It handles the basics of handshaking and, optionally, subprotocol
and extension negotiation.

It is a subclass of L.

=cut

use strict;
use warnings;

use parent qw( Net::WebSocket::Handshake );

use URI::Split ();

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

use constant SCHEMAS => (
    'ws', 'wss',
    'http', 'https',
);

=head1 METHODS

=head2 I->new( %OPTS )

Returns an instance of the class; %OPTS includes the options from
L as well as:

=over

=item * C - (required) The full URI you’re connecting to.

=item * C - (optional) The HTTP Origin header’s value. Useful
for imitating a web browser.

=back

=cut

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

    if (length $opts{'uri'}) {
        @opts{ 'uri_schema', 'uri_auth', 'uri_path', 'uri_query' } = URI::Split::uri_split($opts{'uri'});
    }

    if (!$opts{'uri_schema'} || !grep { $_ eq $opts{'uri_schema'} } SCHEMAS()) {
        die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
    }

    if (!length $opts{'uri_auth'}) {
        die Net::WebSocket::X->create('BadArg', uri => $opts{'uri'});
    }

    @opts{ 'uri_host', 'uri_port' } = split m<:>, $opts{'uri_auth'};

    $opts{'key'} ||= _create_key();

    return $class->SUPER::new(%opts);
}

=head2 I->valid_status_or_die( CODE, REASON )

Throws an exception if the given CODE isn’t the HTTP status code (101)
that WebSocket requires in response to all requests. (REASON is included
with the exception on error; otherwise it’s unused.)

You only need this if if you’re not using a request-parsing interface
that’s compatible with L; otherwise,
L’s C function
will do this (and other niceties) for you.

=cut

sub valid_status_or_die {
    my ($self, $code, $reason) = @_;

    if ($code ne Net::WebSocket::Constants::REQUIRED_HTTP_STATUS()) {
        die Net::WebSocket::X->create('BadHTTPStatus', $code, $reason);
    }

    return;
}

#Shouldn’t be needed?
sub get_key {
    my ($self) = @_;

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

#----------------------------------------------------------------------
#Legacy:

=head1 LEGACY INTERFACE: SYNOPSIS

    my $hsk = Net::WebSocket::Handshake::Client->new(

        #..same as the newer interface, except:

        #optional
        extensions => \@extension_objects,
    );

    print $hsk->create_header_text() . "\x0d\x0a";

    #...Parse the response’s headers yourself...

    #Validates the value of the “Sec-WebSocket-Accept” header;
    #throws Net::WebSocket::X::BadAccept if not.
    $hsk->validate_accept_or_die($accept_value);

=cut

sub validate_accept_or_die {
    my ($self, $received) = @_;

    my $should_be = $self->_get_accept();

    return if $received eq $should_be;

    die Net::WebSocket::X->create('BadAccept', $should_be, $received );
}

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

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

    my $path = $self->{'uri_path'};

    if (!defined $path || !length $path) {
        $path = '/';
    }

    if (defined $self->{'uri_query'} && length $self->{'uri_query'}) {
        $path .= "?$self->{'uri_query'}";
    }

    return (
        "GET $path HTTP/1.1",
        "Host: $self->{'uri_host'}",

        #For now let’s assume no one wants any other Upgrade:
        #or Connection: values than the ones WebSocket requires.
        'Upgrade: websocket',
        'Connection: Upgrade',

        "Sec-WebSocket-Key: $self->{'key'}",
        'Sec-WebSocket-Version: ' . Net::WebSocket::Constants::PROTOCOL_VERSION(),

        $self->_encode_extensions(),

        $self->_encode_subprotocols(),

        ( $self->{'origin'} ? "Origin: $self->{'origin'}" : () ),
    );
}

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

    my @needed = $self->_missing_generic_headers();
    push @needed, 'Sec-WebSocket-Accept' if !$self->{'_accept_header_ok'};

    if (@needed) {
        die Net::WebSocket::X->create('MissingHeaders', @needed);
    }

    return;
}

sub _consume_peer_header {
    my ($self, $name => $value) = @_;

    my $orig_name = $name;

    $name =~ tr;  #case insensitivity

    for my $hdr_part ( qw( accept protocol extensions ) ) {
        if ($name eq "sec-websocket-$hdr_part") {
            if ( exists $self->{"_got_$name"} ) {
                die Net::WebSocket::X->create('DuplicateHeader', $orig_name, $self->{"_got_$name"}, $value);
            }

            $self->{"_got_$name"} = $value;
        }
    }

    if ($name eq 'sec-websocket-accept') {
        $self->validate_accept_or_die($value);
        $self->{'_accept_header_ok'} = 1;
    }
    elsif ($name eq 'sec-websocket-protocol') {
        if (!grep { $_ eq $value } @{ $self->{'subprotocols'} }) {
            die Net::WebSocket::X->create('UnknownSubprotocol', $value);
        }

        $self->{'_subprotocol'} = $value;
    }
    else {
        $self->_consume_generic_header($name => $value);
    }

    return;
}

sub _handle_unrecognized_extension {
    my ($self, $xtn_obj) = @_;

    die Net::WebSocket::X->create('UnknownExtension', $xtn_obj->to_string());
}


sub _create_key {
    require MIME::Base64;

    #NB: Not cryptographically secure, but it should be good enough
    #for the purpose of a nonce. Most implementations use TLS anyway,
    #so this is kind of pointless except that the RFC mandates it. :-/
    my $sixteen_bytes = pack 'S8', map { rand 65536 } 1 .. 8;

    my $b64 = MIME::Base64::encode_base64($sixteen_bytes);
    chomp $b64;

    return $b64;
}

#Send all extensions to the server in the request.
use constant _should_include_extension_in_headers => 1;

1;