File Coverage

blib/lib/Protocol/WebSocket/Response.pm

Criterion	Covered	Total	%
statement	133	136	97.7
branch	54	66	81.8
condition	10	11	90.9
subroutine	26	26	100.0
pod	13	13	100.0
total	236	252	93.6

package Protocol::WebSocket::Response;

use strict;
use warnings;

use base 'Protocol::WebSocket::Message';

require Carp;
use MIME::Base64 ();
use Digest::SHA ();

use Protocol::WebSocket::URL;
use Protocol::WebSocket::Cookie::Response;

sub location { @_ > 1 ? $_[0]->{location} = $_[1] : $_[0]->{location} }

sub resource_name {
    @_ > 1 ? $_[0]->{resource_name} = $_[1] : $_[0]->{resource_name};
}

sub cookies { @_ > 1 ? $_[0]->{cookies} = $_[1] : $_[0]->{cookies} }

sub cookie {
    my $self = shift;

    push @{$self->{cookies}}, $self->_build_cookie(@_);
}

sub key { @_ > 1 ? $_[0]->{key} = $_[1] : $_[0]->{key} }

sub number1 { shift->_number('number1', 'key1', @_) }
sub number2 { shift->_number('number2', 'key2', @_) }

sub _number {
    my $self = shift;
    my ($name, $key, $value) = @_;

    my $method = "SUPER::$name";
    return $self->$method($value) if defined $value;

    $value = $self->$method();
    $value = $self->_extract_number($self->$key) if not defined $value;

    return $value;
}

sub key1 { @_ > 1 ? $_[0]->{key1} = $_[1] : $_[0]->{key1} }
sub key2 { @_ > 1 ? $_[0]->{key2} = $_[1] : $_[0]->{key2} }

sub status {
    return '101';
}

sub headers {
    my $self = shift;

    my $version = $self->version || 'draft-ietf-hybi-10';

    my $headers = [];

    push @$headers, Upgrade => 'WebSocket';
    push @$headers, Connection => 'Upgrade';

    if ($version eq 'draft-hixie-75' || $version eq 'draft-ietf-hybi-00') {
        Carp::croak(qq/host is required/) unless defined $self->host;

        my $location = $self->_build_url(
            host          => $self->host,
            secure        => $self->secure,
            resource_name => $self->resource_name,
        );
        my $origin =
          $self->origin ? $self->origin : 'http://' . $location->host;
        $origin =~ s{^http:}{https:} if !$self->origin && $self->secure;

        if ($version eq 'draft-hixie-75') {
            push @$headers, 'WebSocket-Protocol' => $self->subprotocol
              if defined $self->subprotocol;
            push @$headers, 'WebSocket-Origin'   => $origin;
            push @$headers, 'WebSocket-Location' => $location->to_string;
        }
        elsif ($version eq 'draft-ietf-hybi-00') {
            push @$headers, 'Sec-WebSocket-Protocol' => $self->subprotocol
              if defined $self->subprotocol;
            push @$headers, 'Sec-WebSocket-Origin'   => $origin;
            push @$headers, 'Sec-WebSocket-Location' => $location->to_string;
        }
    }
    elsif ($version eq 'draft-ietf-hybi-10' || $version eq 'draft-ietf-hybi-17') {
        Carp::croak(qq/key is required/) unless defined $self->key;

        my $key = $self->key;
        $key .= '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; # WTF
        $key = Digest::SHA::sha1($key);
        $key = MIME::Base64::encode_base64($key);
        $key =~ s{\s+}{}g;

        push @$headers, 'Sec-WebSocket-Accept' => $key;

        push @$headers, 'Sec-WebSocket-Protocol' => $self->subprotocol
          if defined $self->subprotocol;
    }
    else {
        Carp::croak('Version ' . $version . ' is not supported');
    }

    if (@{$self->cookies}) {
        my $cookie = join ',' => map { $_->to_string } @{$self->cookies};
        push @$headers, 'Set-Cookie' => $cookie;
    }

    return $headers;
}

sub body {
    my $self = shift;

    return $self->checksum if $self->version eq 'draft-ietf-hybi-00';

    return '';
}

sub to_string {
    my $self = shift;

    my $status = $self->status;

    my $string = '';
    $string .= "HTTP/1.1 $status WebSocket Protocol Handshake\x0d\x0a";

    for (my $i = 0; $i < @{$self->headers}; $i += 2) {
        my $key   = $self->headers->[$i];
        my $value = $self->headers->[$i + 1];

        $string .= "$key: $value\x0d\x0a";
    }

    $string .= "\x0d\x0a";

    $string .= $self->body;

    return $string;
}

sub _parse_first_line {
    my ($self, $line) = @_;

    my $status = $self->status;
    unless ($line =~ m{^HTTP/1\.1 $status }) {
        my $vis = $line;
        if( length( $vis ) > 80 ) {
            substr( $vis, 77 )= '...';
        }
        $self->error('Wrong response line. Got [[' . $vis . "]], expected [[HTTP/1.1 $status ]]");
        return;
    }

    return $self;
}

sub _parse_body {
    my $self = shift;

    if ($self->field('Sec-WebSocket-Accept')) {
        $self->version('draft-ietf-hybi-10');
    }
    elsif ($self->field('Sec-WebSocket-Origin')) {
        $self->version('draft-ietf-hybi-00');

        return 1 if length $self->{buffer} < 16;

        my $checksum = substr $self->{buffer}, 0, 16, '';
        $self->checksum($checksum);
    }
    else {
        $self->version('draft-hixie-75');
    }

    return $self if $self->_finalize;

    $self->error('Not a valid response');
    return;
}

sub _finalize {
    my $self = shift;

    if ($self->version eq 'draft-hixie-75') {
        my $location = $self->field('WebSocket-Location');
        return unless defined $location;
        $self->location($location);

        my $url = $self->_build_url;
        return unless $url->parse($self->location);

        $self->secure($url->secure);
        $self->host($url->host);
        $self->resource_name($url->resource_name);

        $self->origin($self->field('WebSocket-Origin'));

        $self->subprotocol($self->field('WebSocket-Protocol'));
    }
    elsif ($self->version eq 'draft-ietf-hybi-00') {
        my $location = $self->field('Sec-WebSocket-Location');
        return unless defined $location;
        $self->location($location);

        my $url = $self->_build_url;
        return unless $url->parse($self->location);

        $self->secure($url->secure);
        $self->host($url->host);
        $self->resource_name($url->resource_name);

        $self->origin($self->field('Sec-WebSocket-Origin'));
        $self->subprotocol($self->field('Sec-WebSocket-Protocol'));
    }
    else {
        $self->subprotocol($self->field('Sec-WebSocket-Protocol'));
    }

    return 1;
}

sub _build_url    { shift; Protocol::WebSocket::URL->new(@_) }
sub _build_cookie { shift; Protocol::WebSocket::Cookie::Response->new(@_) }

1;
__END__