##----------------------------------------------------------------------------
## WebSocket Client & Server - ~/lib/WebSocket/Frame.pm
## Version v0.1.0
## Copyright(c) 2021 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2021/09/16
## Modified 2021/09/16
## All rights reserved
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package WebSocket::Frame;
BEGIN
{
    use strict;
    use warnings;
    use WebSocket qw( :all );
    use parent qw( WebSocket );
    use Config;
    use Encode ();
    use Scalar::Util qw( readonly );
    use Nice::Try;
    use constant MAX_RAND_INT       => 2**32;
    use constant MATH_RANDOM_SECURE => eval( "require Math::Random::Secure;" );
    use constant SUPPORT_64BITS     => ( ( $Config{use64bitint} // '' ) eq 'define' || !( $Config{ivsize} <= 4 || $Config{longsize} < 8 || $] < 5.010 ) );
    use constant RSV1               => chr(4 << 4);
    use constant RSV2               => chr(2 << 4);
    use constant RSV3               => chr(1 << 4);

    our $MAX_PAYLOAD_SIZE     = 65536;
    our $MAX_FRAGMENTS_AMOUNT = 128;

    our $TYPES = 
    {
        continuation => 0x00,
        text         => 0x01,
        binary       => 0x02,
        ping         => 0x09,
        pong         => 0x0a,
        close        => 0x08
    };
    our $VERSION = 'v0.1.0';
};

sub init
{
    my $self = shift( @_ );
    my $buffer;
    if( @_ && 
        ref( $_[0] ) ne 'HASH' && 
        (
            ( @_ == 2 && ref( $_[1] ) eq 'HASH' ) ||
            ( @_ % 2 )
        ) )
    {
        $buffer = shift( @_ );
    }
    $self->{buffer}                 = $buffer;
    # fin value must be undef
    $self->{fin}                    = undef;
    $self->{fragments}              = [];
    $self->{max_fragments_amount}   = $MAX_FRAGMENTS_AMOUNT unless( length( $self->{max_fragments_amount} ) );
    $self->{max_payload_size}       = $MAX_PAYLOAD_SIZE unless( length( $self->{max_payload_size} ) );
    $self->{opcode}                 = undef;
    $self->{rsv}                    = [];
    $self->{type}                   = '';
    $self->{version}                = '';
    $self->{_init_strict_use_sub} = 1;
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    $self->version( WEBSOCKET_DRAFT_VERSION_DEFAULT ) unless( $self->version );
    $self->{buffer} //= '';
    # $self->message( 3, "Buffer is '$self->{buffer}' -> ", sub{ $self->dump( $self->{buffer} ) });
    if( Encode::is_utf8( $self->{buffer} ) )
    {
        $self->{buffer} = Encode::encode( 'UTF-8', $self->{buffer} );
    }
    if( defined( $self->{type} ) && defined( $TYPES->{ $self->{type} } ) )
    {
        $self->opcode( $TYPES->{ $self->{type} } );
    }
    return( $self );
}

sub append
{
    my $self = shift( @_ );
    return unless( defined( $_[0] ) );

    $self->message( 3, "Appending '$_[0]' to buffer." );
    $self->buffer->append( $_[0] );
    $self->message( 3, "Buffer is now: '", $self->buffer->scalar, "'" );
    $_[0] = '' unless( readonly( $_[0] ) );
    return( $self );
}

sub buffer { return( shift->_set_get_scalar_as_object( 'buffer', @_ ) ); }

sub fin
{
    my $self = shift( @_ );
    $self->{fin} = shift( @_ ) if( @_ );
    return( defined( $self->{fin} ) ? $self->{fin} : 1 );
}

sub fragments { return( shift->_set_get_array_as_object( 'fragments', @_ ) ); }

sub is_binary       { return( shift->opcode == 2 ); }

sub is_close        { return( shift->opcode == 8 ); }

sub is_continuation { return( shift->opcode == 0 ); }

sub is_ping         { return( shift->opcode == 9 ); }

sub is_pong         { return( shift->opcode == 10 ); }

sub is_text         { return( shift->opcode == 1 ); }

sub masked { return( shift->_set_get_scalar( 'masked', @_ ) ); }

sub max_fragments_amount { return( shift->_set_get_number( 'max_fragments_amount', @_ ) ); }

sub max_payload_size { return( shift->_set_get_number( 'max_payload_size', @_ ) ); }

sub next
{
    my $self = shift( @_ );
    my $bytes = $self->next_bytes;
    return( $self->pass_error ) if( !defined( $bytes ) && $self->error );
    return( Encode::decode( 'UTF-8', $bytes ) ) if( $self->is_text );
    return( $bytes );
}

sub next_bytes
{
    my $self = shift( @_ );

    my $v = $self->version;
    $self->message( 3, "Version object is '$v' (", overload::StrVal( $v ), ") and buffer is ", $self->buffer->length, " bytes -> '", $self->buffer->scalar, "'" );
    if( ( $v->type eq 'hixie' && $v->revision == 75 ) ||
        ( $v->type eq 'hybi'  && $v->revision <= 3 ) )
    {
        if( $self->buffer->replace( qr/^\xff\x00/ => '' ) )
        {
            $self->message( 3, "Closing frame, returning empty string" );
            $self->opcode(8);
            return( '' );
        }
        # return unless( ${$self->{buffer}} =~ s/^[^\x00]*\x00(.*?)\xff//s );
        my $rv = $self->buffer->replace( qr/^[^\x00]*\x00(.*?)\xff/s, '' );
        return unless( $rv );
        # return( $1 );
        $self->message( 3, "Returning regexp capture '", $rv->capture->first, "'." );
        return( $rv->capture->first );
    }
    $self->message( 3, "Returning, because buffer is smaller than 2 bytes (", $self->buffer->length, ") -> (", $self->buffer->scalar, ")." ) unless( $self->buffer->length >= 2 );
    return unless( $self->buffer->length >= 2 );

    while( $self->buffer->length )
    {
        my( $first, $second ) = $self->buffer->unpack( 'C2' );
        $self->message( 3, "First segment is '$first' and second is '$second'" );

        my $fin  = ( $first & 0b10000000 ) == 0b10000000 ? 1 : 0;

        my $rsv1 = ( $first & 0b01000000 ) == 0b01000000 ? 1 : 0;
        my $rsv2 = ( $first & 0b00100000 ) == 0b00100000 ? 1 : 0;
        my $rsv3 = ( $first & 0b00010000 ) == 0b00010000 ? 1 : 0;
        $self->fin( $fin );
        $self->rsv( [$rsv1, $rsv2, $rsv3] );

        # Opcode
        my $opcode = $first & 0b00001111;
        my $masked = ( $second & 0b10000000 ) >> 7;
        $self->message( 3, "Is frame masked ? '$masked'" );
        $self->masked( $masked );
        my( $offset, $payload_len ) = ( 2, $second & 0b01111111 );
        # $self->message( 3, "offset now '$offset', payload length '$payload_len' -> '", $self->buffer->scalar, "'" );
        $self->message( 3, "offset now '$offset', payload length '$payload_len' and opcode is '$opcode'" );
        if( $payload_len == 126 )
        {
            $self->message( 3, "Returning, because buffer is smaller than ", ( $offset + 2 ), " bytes." ) unless( $self->buffer->length >= $offset + 2 );
            return unless( $self->buffer->length >= $offset + 2 );
            $payload_len = $self->buffer->substr( $offset, 2 )->unpack( 'n' );
            $offset += 2;
        }
        elsif( $payload_len > 126 )
        {
            $self->message( 3, "Returning, because buffer is smaller than ", ( $offset + 4 ), " bytes." ) unless( $self->buffer->length >= $offset + 4 );
            return unless( $self->buffer->length >= $offset + 4 );

            my $bits = $self->buffer->substr( $offset, 8 )->split( '' )->map(sub{ CORE::unpack( 'B*', $_ ) })->join( '' );

            # Most significant bit must be 0.
            # And here is a crazy way of doing it %)
            $bits->replace( qr{^.}, 0 );

            # Can we handle 64bit numbers?
            if( SUPPORT_64BITS )
            {
                $payload_len = $bits->pack( 'B*' )->unpack( 'Q>' );
            }
            else
            {
                $bits = $bits->substr(32);
                $payload_len = $bits->pack( 'B*' )->unpack( 'N' );
            }
            $offset += 8;
        }
        
        $self->message( 3, "Max payload size is '",  $self->max_payload_size, "' and this payload size is '$payload_len'" );
        if( $self->max_payload_size && $payload_len > $self->max_payload_size )
        {
            $self->buffer->empty;
            $self->message( 3, "Payload is too big. Deny big message ($payload_len) or increase max_payload_size ($self->{max_payload_size})" );
            return( $self->error({ code => WS_MESSAGE_TOO_LARGE, message => "Payload is too big. Deny big message ($payload_len) or increase max_payload_size ($self->{max_payload_size})" }) );
        }

        my $mask;
        if( $self->masked )
        {
            $self->message( 3, "Frame is masked." );
            $self->message( 3, "Returning, because buffer is smaller than ", ( $offset + 4 ), " bytes." ) unless( $self->buffer->length >= $offset + 4 );
            return unless( $self->buffer->length >= $offset + 4 );

            $mask = $self->buffer->substr( $offset, 4 );
            $offset += 4;
        }
        else
        {
            $self->message( 3, "Frame is not masked." );
        }

        $self->message( 3, "Returning, because buffer is smaller than ", ( $offset + $payload_len ), " bytes." ) if( $self->buffer->length < $offset + $payload_len );
        return if( $self->buffer->length < $offset + $payload_len );

        my $payload = $self->buffer->substr( $offset, $payload_len );

        if( $self->masked )
        {
            $payload = $self->_mask( $payload, $mask );
        }
        $self->message( 3, "Opcode is '$opcode' and payload is '$payload'" );

        # $self->message( 3, "Removing data from offset 0 to ", ( $offset + $payload_len ), " which is: '", $self->buffer->substr( 0, $offset + $payload_len )->scalar, "'" );
        $self->buffer->substr( 0, $offset + $payload_len, '' );

        # Injected control frame
        if( $self->fragments->length && $opcode & 0b1000 )
        {
            $self->opcode( $opcode );
            $self->message( 3, "Opcode set to '$opcode', returning payload of '$payload'" );
            return( $payload );
        }

        if( $self->fin )
        {
            if( $self->fragments->length )
            {
                $self->opcode( $self->fragments->shift );
            }
            else
            {
                $self->opcode( $opcode );
            }
            # $payload = join( '', @{$self->{fragments}}, $payload );
            $payload = $self->fragments->join( '', $payload );
            # $self->{fragments} = [];
            $self->fragments->empty;
            $self->message( 3, "Returning payload '$payload'" );
            return( $payload );
        }
        else
        {
            # Remember first fragment opcode
            if( !$self->fragments->length )
            {
                $self->fragments->push( $opcode );
            }

            $self->fragments->push( $payload );

            if( $self->fragments->length > $self->max_fragments_amount )
            {
                $self->message( 3, "Too many fragments (", $self->fragments->length, ")" );
                return( $self->error({ code => WS_INTERNAL_SERVER_ERROR, message => "Too many fragments" }) );
            }
        }
    }
    $self->message( "Returning undef because no data in buffer." );
    return;
}

# sub opcode { return( shift->_set_get_scalar_as_object( 'opcode', @_ ) ); }
sub opcode
{
    my $self = shift( @_ );
    $self->{opcode} = shift( @_ ) if( @_ );
    return( defined( $self->{opcode} ) ? $self->{opcode} : 1 );
}

sub rsv { return( shift->_set_get_array_as_object( 'rsv', @_ ) ); }

sub supported_types
{
    my $self = shift( @_ );
    if( @_ )
    {
        return( CORE::exists( $TYPES->{ lc( shift( @_ ) ) } ) );
    }
    return( $self->new_array( [sort( keys( %$TYPES ) )] ) );
}

sub to_bytes
{
    my $self = shift( @_ );
    my $v = $self->version;
    if( ( $v->type eq 'hixie' && $v->revision == 75 ) ||
        ( $v->type eq 'hybi'  && $v->revision <= 3 ) )
    {
        if( $self->type && $self->type eq 'close' )
        {
            return( "\xff\x00" );
        }
        return( "\x00" . $self->buffer . "\xff" );
    }

    if( $self->max_payload_size && 
        $self->buffer->length > $self->max_payload_size )
    {
        return( $self->error({ code => WS_MESSAGE_TOO_LARGE, message => "Payload is too big. Send shorter messages or increase max_payload_size" }) );
    }

    my $opcode = $self->opcode;
    $self->message( 3, "opcode='$opcode', fin='", $self->fin, "' and type is '", $self->type, "'" );
    my $head = $opcode + ( $self->fin ? 128 : 0 );
    $head |= 0b01000000 if( $self->rsv->first );
    $head |= 0b00100000 if( $self->rsv->second );
    $head |= 0b00010000 if( $self->rsv->third );
    my $string = pack( 'C', $head );
    # $self->message( 3, "string so far is -> '", sub{ $self->dump_hex( $string ) }, "'");

    my $payload_len = $self->buffer->length;
    if( $payload_len <= 125 )
    {
        # 128
        $payload_len |= 0b10000000 if( $self->masked );
        $string .= pack( 'C', $payload_len );
        # $string .= pack( 'C', $self->masked ? ( $payload_len | 128 ) : $payload_len );
    }
    # 65535
    elsif( $payload_len <= 0xffff )
    {
        $string .= pack( 'C', 126 + ( $self->masked ? 128 : 0 ) );
        $string .= pack( 'n', $payload_len );
        # $string .= pack( 'Cn', $self->masked ? (126 | 128) : 126, $payload_len );
    }
    else
    {
        $string .= pack( 'C', 127 + ( $self->masked ? 128 : 0 ) );

        # Shifting by an amount >= to the system wordsize is undefined
        $string .= pack( 'N', $Config{ivsize} <= 4 ? 0 : $payload_len >> 32 );
        $string .= pack( 'N', ( $payload_len & 0xffffffff ) );
        
        # $string .= pack( 'C', $self->masked ? (127 | 128) : 127 );
        # $string .= SUPPORT_64BITS
        #    ? pack( 'Q>', $payload_len )
        #    : pack( 'NN', ( $Config{ivsize} <= 4 ? 0 : $payload_len >> 32 ), $payload_len & 0xffffffff );
    }
    $self->message( 3, "Resulting string is now '$string'" );

    if( $self->masked )
    {
        $self->message( 3, "Masking frame." );
        my $mask = $self->{mask} || (
            MATH_RANDOM_SECURE
                ? Math::Random::Secure::irand( MAX_RAND_INT )
                : int( rand( MAX_RAND_INT ) )
        );
        $mask = pack( 'N', $mask );
        $string .= $mask;
        $string .= $self->_mask( $self->buffer->scalar, $mask );
    }
    else
    {
        $self->message( 3, "Not masking frame." );
        $string .= $self->buffer->scalar;
        # $self->message( 3, "string so far is -> '", sub{ $self->dump_hex( $string ) }, "'");
    }
    $self->message( 3, "Returning encoded payload -> '$string'" );
    return( $string );
}

sub type { return( shift->_set_get_scalar_as_object( 'type', @_ ) ); }

sub version { return( shift->_set_get_object_without_init( 'version', 'WebSocket::Version', @_ ) ); }

sub _mask
{
    my $self = shift( @_ );
    my( $payload, $mask ) = @_;
    $mask = "$mask" x ( int( length( "$payload" ) / 4 ) + 1 );
    $mask = substr( $mask, 0, length( "$payload" ) );
    $payload = "$payload" ^ $mask;
    return( $payload );
}

1;

__END__

=encoding utf-8

=head1 NAME

WebSocket::Frame - WebSocket Frame

=head1 SYNOPSIS

    use WebSocket::Frame;
    # Create frame
    my $frame = WebSocket::Frame->new( '123' );
    $frame->to_bytes;

    # Parse frames
    my $frame = WebSocket::Frame->new;
    $frame->append( $some_data );
    $f->next; # get next message
    $f->next; # get another next message

=head1 VERSION

    v0.1.0

=head1 DESCRIPTION

Construct or parse a WebSocket frame.

=head1 CONSTRUCTOR

=head2 C<new>

    # same as (buffer => 'data')
    WebSocket::Frame->new( 'data' );
    WebSocket::Frame->new( buffer => 'data', type => 'close' );

Create a new L<WebSocket::Frame> instance. Automatically detect if the passed data is a Perl string (UTF-8 flag) or bytes.

When called with more than one arguments, it takes the following named arguments (all of them are optional).

=over 4

=item I<buffer>

The payload of the frame. It can also be provided as the first argument of the L</new> method.

=item I<fin>

Boolean default to 1. Indicate whether this frame is the last frame of the entire message body

C<fin> flag of the frame. C<fin> flag must be 1 in the ending frame of fragments.

=item I<masked>

Boolean default to 0.

If set to true, the frame will be masked.

=item I<opcode>

Default to 1. Operation bit, which defines the type of this frame

The opcode of the frame. If I<type> field is set to a valid string, this field is ignored.

=item I<rsv>

Reserved bit, must be 0, if it is not 0, it is marked as connection failure

=item I<type>

Default to C<text>

The type of the frame. Accepted values are: C<continuation>, C<text>, C<binary>, C<ping>, C<pong>, C<close>

=item I<version>

String. Default to C<draft-ietf-hybi-17>

WebSocket protocol version string. See L<WebSocket> for valid version strings.

=back

=head1 METHODS

=head2 append

    $frame->append( $chunk );

Append a frame chunk.

Beware that this method is B<destructive>. It makes C<$chunk> empty unless C<$chunk> is read-only.

=head2 fin

Indicate whether this frame is the last frame of the entire message body

=head2 fragments

=head2 is_binary

Returns true if frame is of binary type, false otherwise.

=head2 is_close

Returns true if frame is of close type, false otherwise.

=head2 is_continuation

Returns true if frame is of continuation type, false otherwise.

=head2 is_ping

Returns true if frame is a ping request, false otherwise.

=head2 is_pong

Returns true if frame is a pong response, false otherwise.

=head2 is_text

Returns true if frame is of text type, false otherwise.

=head2 mask

Indicate whether the carried content needs to be XORed with a mask

=head2 masked

    $masked = $frame->masked;
    $frame->masked(1);

Get or set masking of the frame.

=head2 max_fragments_amount

The maximum fragments allowed.

=head2 max_payload_size

The maximum size of the payload. You may set this to C<0> (but not undef) to disable checking the payload size.

=head2 next

    $frame->append( $some_data );

    $frame->next; # next message

Return the next message as a Perl string (UTF-8 decoded).

=head2 next_bytes

Return the next message as is.

=head2 opcode

    $opcode = $frame->opcode;
    $frame->opcode(8);

Get or set opcode of the frame. Operation bit, which defines the type of this frame.

=head2 rsv

Reserved bit, must be 0, if it is not 0, it is marked as connection failure

=head2 supported_types

Provided a type and this returns true if it is supported, false otherwise. This is case insensitive.

Without any argument, this returns an L<array object|Module::Generic::Array> of supported frame types.

=head2 to_bytes

Construct a WebSocket message.

=head1 CREDITS

Viacheslav Tykhanovskyi for code borrowed.

=head1 AUTHOR

Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>

=head1 SEE ALSO

L<perl>

=head1 COPYRIGHT & LICENSE

Copyright(c) 2021 DEGUEST Pte. Ltd. DEGUEST Pte. Ltd.

You can use, copy, modify and redistribute this package and associated files under the same terms as Perl itself.

=cut

