HTTP-Promise
view release on metacpan or search on metacpan
lib/HTTP/Promise/IO.pm view on Meta::CPAN
pack_sockaddr_in
INADDR_ANY
);
use Time::HiRes qw( time );
use constant ERROR_EINTR => ( abs( Errno::EINTR ) * -1 );
our $CRLF = "\015\012";
our $IS_WIN32 = ( $^O eq 'MSWin32' );
# This is for connect() so it knows
our $INIT_PARAMS = [qw( buffer debug inactivity_timeout last_delimiter max_read_buffer ssl_opts stop_if timeout )];
our $VERSION = 'v0.1.1';
};
use strict;
use warnings;
sub init
{
my $self = shift( @_ );
return( $self->error( "No filehandle was provided." ) ) if( !scalar( @_ ) );
my $fh = shift( @_ );
return( $self->error( "Filehandle provided (", overload::StrVal( $fh ), ") is not a proper filehandle." ) ) if( !$self->_is_glob( $fh ) );
# This needs to be set to empty string and not undef to make chaining work with Module::Generic::Scalar
$self->{buffer} = '';
$self->{inactivity_timeout} = 600;
$self->{last_delimiter} = '';
$self->{max_read_buffer} = 0;
$self->{ssl_opts} = {};
$self->{stop_if} = sub{};
$self->{timeout} = 5;
$self->{_init_strict_use_sub} = 1;
$self->SUPER::init( @_ ) || return( $self->pass_error );
# Ensure O_NONBLOCK is set so that calls to select in can_read() would not report ok
# although no data is available. See select in perlfunc for more details.
my $dummy = '';
if( $self->_can( $fh => 'fcntl' ) )
{
my $flags = $fh->fcntl( F_GETFL, $dummy );
return( $self->error({ code => 500, message => "Unable to get flags from filehandle '$fh': $!" }) ) if( !defined( $flags ) );
my $rv = $fh->fcntl( F_SETFL, ( $flags | O_NONBLOCK ) );
return( $self->error({ code => 500, message => "Unable to set flags to filehandle '$fh': $!" }) ) if( !defined( $rv ) );
}
else
{
my $flags = fcntl( $fh, F_GETFL, $dummy );
return( $self->error({ code => 500, message => "Unable to get flags from filehandle '$fh': $!" }) ) if( !defined( $flags ) );
my $rv = fcntl( $fh, F_SETFL, ( $flags | O_NONBLOCK ) );
return( $self->error({ code => 500, message => "Unable to set flags to filehandle '$fh': $!" }) ) if( !defined( $rv ) );
}
$self->{_fh} = $fh;
return( $self );
}
sub buffer { return( shift->_set_get_scalar_as_object( 'buffer', @_ ) ); }
sub can_read
{
my $self = shift( @_ );
my $fh = $self->filehandle;
my $opts = $self->_get_args_as_hash( @_ );
return(1) unless( defined( fileno( $fh ) ) );
return(1) if( $fh->isa( 'IO::Socket::SSL' ) && $fh->pending );
return(1) if( $fh->isa( 'Net::SSL' ) && $fh->can('pending') && $fh->pending );
# If this is an in-memory scalar filehandle
# check that it is opened so we can read from it
if( fileno( $fh ) == -1 )
{
if( $self->_can( $fh => 'can_read' ) )
{
return( $fh->can_read );
}
else
{
my( $dummy, $flags );
if( $self->_can( $fh => 'fcntl' ) )
{
$flags = $fh->fcntl( F_GETFL, $dummy );
}
else
{
$flags = fcntl( $fh, F_GETFL, $dummy );
}
return( $self->error({ code => 500, message => "Unable to get flags from filehandle '$fh': $!" }) ) if( !defined( $flags ) );
return( ( $flags == O_RDONLY ) || ( $flags & ( O_RDONLY | O_RDWR ) ) );
}
}
# With no timeout, wait forever. An explicit timeout of 0 can be used to just check
# if the socket is readable without waiting.
my $timeout = $opts->{timeout} ? $opts->{timeout} : $self->timeout;
my $fbits = '';
vec( $fbits, fileno( $fh ), 1 ) = 1;
SELECT:
{
my $before;
$before = time() if( $timeout );
my $nfound = select( $fbits, undef, undef, $timeout );
if( $nfound < 0 )
{
if( $!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK} )
{
# don't really think EAGAIN/EWOULDBLOCK can happen here
if( $timeout )
{
$timeout -= time() - $before;
$timeout = 0 if( $timeout < 0 );
}
redo( SELECT );
}
return( $self->error({ code => 500, message => "select failed: $!" }) );
}
return( $nfound > 0 );
}
}
sub close
{
my $self = shift( @_ );
my $fh = $self->filehandle;
$fh->close if( $self->_can( $fh, 'close' ) );
lib/HTTP/Promise/IO.pm view on Meta::CPAN
{
if( $laddr ne INADDR_ANY )
{
return( $self->error( "Unable to bind to local host \"$opts->{local_host}\": $!" ) );
}
else
{
return( $self->error( "Unable to bind to local port \"$opts->{local_port}\": $!" ) );
}
};
}
RETRY:
CORE::socket( $sock, Socket::sockaddr_family( $sock_addr ), SOCK_STREAM, 0 ) ||
return( $self->error( "Unable to create socket: $!" ) );
$self->_set_sockopts( $sock ) || return( $self->pass_error );
my $params = {};
if( $self->_is_array( $INIT_PARAMS ) )
{
for( @$INIT_PARAMS )
{
$params->{ $_ } = $opts->{ $_ } if( exists( $opts->{ $_ } ) );
}
}
my $new = $self->new( $sock, $params ) || return( $self->pass_error );
if( CORE::connect( $sock, $sock_addr ) )
{
# connected
}
elsif( $! == EINPROGRESS || ( $IS_WIN32 && $! == EWOULDBLOCK ) )
{
my $rv = $new->make_select_timeout( write => 1, timeout => $opts->{timeout} );
return( $self->error( "Cannot connect to ${host}:${port}: ", $new->error->message ) ) if( !defined( $rv ) );
return( $self->error( "Select timeout on socket." ) ) if( !$rv );
}
# connected
else
{
if( $! == EINTR && !$stop_if->() )
{
CORE::close( $sock );
goto( RETRY );
}
return( $self->error( "Cannot connect to ${host}:${port}: $!" ) );
}
return( $new );
}
# connect SSL socket.
# You can override this method in your child class, if you want to use Crypt::SSLeay or some other library.
# Returns file handle like object
sub connect_ssl
{
my $self = shift( @_ );
my $opts = $self->_get_args_as_hash( @_ );
my $host = $opts->{host} || return( $self->error( "No host to connect to was provided." ) );
my $port = $opts->{port} || return( $self->error( "No port to connect to was provided." ) );
return( $self->error( "Port provided ($port) is not a number" ) ) if( $port !~ /^\d+$/ );
return( $self->error( "No timeout was provided to connect." ) ) if( !exists( $opts->{timeout} ) || !length( $opts->{timeout} ) );
$self->_load_class( 'IO::Socket::SSL' ) || return( $self->pass_error );
my $params = {};
if( $self->_is_array( $INIT_PARAMS ) )
{
for( @$INIT_PARAMS )
{
$params->{ $_ } = $opts->{ $_ } if( exists( $opts->{ $_ } ) );
}
}
$params->{host} = $host;
$params->{port} = $port;
my $new = $self->connect( %$params ) ||
return( $self->pass_error );
my $sock = $new->filehandle;
my $timeout = $opts->{timeout} // $self->timeout // 5;
# my $timeout = ( $opts->{timeout} - time() );
# return( $self->error( "Cannot create SSL connection: timeout" ) ) if( $timeout <= 0 );
my $ssl_opts = $new->_ssl_opts;
if( !IO::Socket::SSL->start_SSL(
$sock,
PeerHost => $host,
PeerPort => $port,
Timeout => $timeout,
( defined( $opts->{local_host} ) ? ( LocalHost => $opts->{local_host} ) : () ),
( defined( $opts->{local_port} ) ? ( LocalPort => $opts->{local_port} ) : () ),
%$ssl_opts,
) )
{
return( $self->error( "Cannot create SSL connection: ", IO::Socket::SSL::errstr() ) );
}
$new->_set_sockopts( $sock );
return( $new );
}
sub connect_ssl_over_proxy
{
my $self = shift( @_ );
my $opts = $self->_get_args_as_hash( @_ );
my $proxy_host = $opts->{proxy_host} || return( $self->error( "No proxy host to connect to was provided." ) );
my $proxy_port = $opts->{proxy_port} || return( $self->error( "No proxy port to connect to was provided." ) );
my $host = $opts->{host} || return( $self->error( "No host to connect to was provided." ) );
my $port = $opts->{port} || return( $self->error( "No port to connect to was provided." ) );
return( $self->error( "Proxy port provided ($proxy_port) is not a number" ) ) if( $proxy_port !~ /^\d+$/ );
return( $self->error( "Host port provided ($port) is not a number" ) ) if( $port !~ /^\d+$/ );
return( $self->error( "Port provided ($port) is not a number" ) ) if( $port !~ /^\d+$/ );
return( $self->error( "No timeout was provided to connect." ) ) if( !exists( $opts->{timeout} ) || !length( $opts->{timeout} ) );
my $proxy_authorization = $opts->{proxy_authorization};
$self->_load_class( 'IO::Socket::SSL' ) || return( $self->pass_error );
my $params = {};
if( $self->_is_array( $INIT_PARAMS ) )
{
for( @$INIT_PARAMS )
{
$params->{ $_ } = $opts->{ $_ } if( exists( $opts->{ $_ } ) );
}
}
$params->{host} = $proxy_host;
$params->{port} = $proxy_port;
my $new = $self->connect( %$params ) ||
return( $self->pass_error );
my $sock = $new->filehandle;
my $p = "CONNECT ${host}:${port} HTTP/1.0${CRLF}Server: ${host}${CRLF}";
if( defined( $proxy_authorization ) )
{
$p .= "Proxy-Authorization: ${proxy_authorization}${CRLF}";
}
$p .= $CRLF;
$new->_write_all( $sock, $p, $opts->{timeout} ) ||
return( $self->error({
code => 500,
message => "Failed to send HTTP request to proxy: " . ( $! != 0 ? "$!" : 'timeout' )
}) );
my $buf = '';
my $read = $new->read( \$buf, $new->buffer_size, length( $buf ), $opts->{timeout} );
if( !defined( $read ) )
{
return( $self->error( "Cannot read proxy response: " . ( $! != 0 ? "$!" : 'timeout' ) ) );
}
# eof
elsif( $read == 0 )
{
return( $self->error( "Unexpected EOF while reading proxy response" ) );
}
elsif( $buf !~ /^HTTP\/1\.[0-9] 200 .+\015\012/ )
{
return( $self->error( "Invalid HTTP Response via proxy" ) );
}
my $timeout = ( $opts->{timeout} - time() );
return( $self->error( "Cannot start SSL connection: timeout" ) ) if( $opts->{timeout} <= 0 );
my $ssl_opts = $new->_ssl_opts;
unless( exists( $ssl_opts->{SSL_verifycn_name} ) )
{
$ssl_opts->{SSL_verifycn_name} = $host;
}
IO::Socket::SSL->start_SSL(
$sock,
PeerHost => "$host",
PeerPort => "$port",
Timeout => "$timeout",
( defined( $opts->{local_host} ) ? ( LocalHost => $opts->{local_host} ) : () ),
( defined( $opts->{local_port} ) ? ( LocalPort => $opts->{local_port} ) : () ),
%$ssl_opts
) or return( $self->error( "Cannot start SSL connection: " . IO::Socket::SSL::errstr() ) );
$new->_set_sockopts( $sock );
return( $new );
}
sub filehandle { return( shift->_set_get_glob( '_fh', @_ ) ); }
# Credits: Olaf Alders in Net::HTTP
sub getline
{
my $self = shift( @_ );
my $opts = $self->_get_args_as_hash( @_ );
$opts->{chomp} = 0 if( !CORE::exists( $opts->{chomp} ) );
$opts->{max_read_buffer} = 0;
my $fh = $self->filehandle || return( $self->error( "No filehandle currently set." ) );
my $buff = $self->buffer;
my $max = $opts->{max_read_buffer} || $self->max_read_buffer;
my $pos;
my $is_object = $self->_can( $fh => 'sysread' ) ? 1 : 0;
while(1)
{
# Get the position of line ending. \015 might not be there, but \012 will
$pos = $buff->index( "\012" );
last if( $pos >= 0 );
# 413 Entity too large
return( $self->error({ code => 413, message => "Line too long (limit is $max)" }) ) if( $max && $buff->length > $max );
# need to read more data to find a line ending
my $new_bytes = 0;
READ:
{
my $rv = $self->can_read;
return( $self->pass_error ) if( !defined( $rv ) );
return( $self->error( "Cannot read from filehandle '$fh'" ) ) if( !$rv );
# consume all incoming bytes
my $bytes_read = $is_object
? $fh->sysread( $$buff, 1024, $buff->length )
: sysread( $fh, $$buff, 1024, $buff->length );
if( defined( $bytes_read ) )
{
$new_bytes += $bytes_read;
}
elsif( $!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK} )
{
redo READ;
}
else
{
$self->mesage( 4, "$bytes_read bytes read from filehandle '$fh' with total read so far of ", $buff->length );
# if we have already accumulated some data let's at
# least return that as a line
$buff->length or return( $self->error( "read() failed: $!" ) );
}
# no line-ending, no new bytes
return(
$buff->length
? $buff->substr( 0, $buff->length, '' )
# : undef
: ''
) if( $new_bytes == 0 );
};
}
lib/HTTP/Promise/IO.pm view on Meta::CPAN
my $is_object = $self->_can( $fh => 'syswrite' ) ? 1 : 0;
while(1)
{
my $bytes = $is_object
? $fh->syswrite( $_[1], $len, $off )
: syswrite( $fh, $_[1], $len, $off );
if( defined( $bytes ) )
{
return( $bytes );
}
if( $! == EAGAIN || $! == EWOULDBLOCK || ( $IS_WIN32 && $! == EISCONN ) )
{
# passthru
}
# Could not write because of an interruption
elsif( $! == EINTR )
{
return( $self->error({ code => ERROR_EINTR, message => "Interruption prevented writing to filehandle '$fh': $!" }) ) if( $self->stop_if->() );
# otherwise passthru
}
else
{
return( $self->error( "Error writing ${len} bytes at offset ${off} from buffer (size: ", length( $_[2] ), " bytes) to filehandle '$fh': $!" ) );
}
my $rv = $self->make_select_timeout( write => 1, timeout => $timeout );
return( $self->pass_error ) if( !defined( $rv ) );
return( $self->error( "Unable to select the filehandle." ) ) if( !$rv );
}
}
sub write_all
{
my $self = $_[0];
return( $self->error( "Invalid number of arguments. Usage: \$self->_write_all( \$buffer )" ) ) unless( @_ > 1 && @_ < 4 );
# Buffer is #1
my $timeout = @_ > 2 ? $_[2] : $self->timeout;
my $off = 0;
while( my $len = length( $_[1] ) - $off )
{
my $bytes = $self->write( $_[1], $len, $off, $timeout );
return( $self->pass_error ) if( !defined( $bytes ) );
return( $bytes ) if( !$bytes );
$off += $bytes;
# Should never happen
last if( $len < 0 );
}
# Return total bytes sent
return( $off );
}
sub _set_sockopts
{
my $self = shift( @_ );
my $sock = shift( @_ ) ||
return( $self->error( "No socket was provided." ) );
setsockopt( $sock, IPPROTO_TCP, TCP_NODELAY, 1 ) or
return( $self->error( "Failed to setsockopt(TCP_NODELAY): $!" ) );
if( $IS_WIN32 )
{
if( ref( $sock ) ne 'IO::Socket::SSL' )
{
my $tmp = 1;
ioctl( $sock, 0x8004667E, \$tmp ) or
return( $self->error( "Cannot set flags for the socket: $!" ) );
}
}
else
{
my $flags = fcntl( $sock, F_GETFL, 0 ) or
return( $self->error( "Cannot get flags for the socket: $!" ) );
$flags = fcntl( $sock, F_SETFL, $flags | O_NONBLOCK ) or
return( $self->error( "Cannot set flags for the socket: $!" ) );
}
{
# no buffering
my $orig = select();
select( $sock ); $| = 1;
select( $orig );
}
binmode( $sock );
return( $sock );
}
sub _ssl_opts
{
my $self = shift( @_ );
my $ssl_opts = $self->ssl_opts;
unless( exists( $ssl_opts->{SSL_verify_mode} ) )
{
if( exists( $ssl_opts->{verify_hostname} ) &&
!$ssl_opts->{verify_hostname} )
{
$ssl_opts->{SSL_verify_mode} = IO::Socket::SSL::SSL_VERIFY_NONE();
}
else
{
# set SSL_VERIFY_PEER as default.
$ssl_opts->{SSL_verify_mode} = IO::Socket::SSL::SSL_VERIFY_PEER();
}
unless( exists( $ssl_opts->{SSL_verifycn_scheme} ) )
{
$ssl_opts->{SSL_verifycn_scheme} = 'www'
}
}
if( $ssl_opts->{SSL_verify_mode} )
{
unless( exists( $ssl_opts->{SSL_ca_file} ) || exists( $ssl_opts->{SSL_ca_path} ) )
{
$self->_load_class( 'Mozilla::CA' ) || return( $self->pass_error );
$ssl_opts->{SSL_ca_file} = Mozilla::CA::SSL_ca_file();
}
}
return( $ssl_opts );
}
sub FREEZE
{
my $self = CORE::shift( @_ );
my $serialiser = CORE::shift( @_ ) // '';
my $class = CORE::ref( $self );
my %hash = %$self;
CORE::delete( @hash{ qw( _fh ) } );
if( CORE::exists( $hash{stop_if} ) &&
CORE::defined( $hash{stop_if} ) &&
CORE::ref( $hash{stop_if} ) )
{
require B::Deparse;
my $deparse = B::Deparse->new( '-p', '-sC' );
my $code = $deparse->coderef2text( CORE::delete( $hash{stop_if} ) );
$hash{stop_if_code} = $code;
}
# Return an array reference rather than a list so this works with Sereal and CBOR
CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
# But Storable want a list with the first element being the serialised element
CORE::return( $class, \%hash );
}
sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }
sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }
sub THAW
{
my( $self, undef, @args ) = @_;
my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
my $new;
# Storable pattern requires to modify the object it created rather than returning a new one
if( CORE::ref( $self ) )
{
foreach( CORE::keys( %$hash ) )
{
$self->{ $_ } = CORE::delete( $hash->{ $_ } );
}
$new = $self;
}
else
lib/HTTP/Promise/IO.pm view on Meta::CPAN
=over 4
=item C<capture>
Boolean. When set to true, this will capture the match specified with C<string>. The resulting would then be retrievable using L</last_delimiter>
=item C<chunk_size>
An integer. This is the maximum bytes this will read per each iteration.
=item C<exclude>
Boolean. If this is true, this will exclude the C<string> sought from the buffer allocation.
=item C<include>
Boolean. If this is true, this will set the buffer including the C<string> sought after.
=item C<string>
This is the C<string> to read data until it is found. The C<string> can be a simple string, or a regular expression.
=back
=head2 read_until_in_memory
my $data = $r->read_until_in_memory( $string );
my $data = $r->read_until_in_memory( $string, $options_hash_or_hashref );
die( "Error: ", $r->error ) if( !defined( $data ) );
Provided with a C<string> to be found, this will load data from the internal buffer, the filehandle, or a combination of both into memory until the specified C<string> is found.
Upon success, it returns the data read, which could be an empty string if nothing matched.
If an error occurred, this will set an L<error|Module::Generic/error> and return C<undef>.
It takes the following possible options, either as an hash or hash reference:
=over
=item C<capture>
Boolean. When set to true, this will capture the match specified with C<string>. The resulting would then be retrievable using L</last_delimiter>
=item C<chunk_size>
An integer. This is the maximum bytes this will read per each iteration.
=item C<exclude>
Boolean. If this is true, this will exclude the C<string> sought from the buffer allocation.
=item C<include>
Boolean. If this is true, this will set the buffer including the C<string> sought after.
=back
=head2 ssl_opts
Sets or gets an hash reference of ssl options to be used with L<IO::Socket::SSL/start_SSL>
=head2 stop_if
Sets or gets a code reference acting as a callback when an error C<EINTR> if encountered. If the callback returns true, the method using it, will stop and return an error, otherwise, it will keep trying.
=head2 timeout
Sets or gets the timeout threshold. This returns a L<number object|Module::Generic::Number>
=head2 unread
Provided with some data and this will put it back into the internal buffer, at its beginning.
This returns the current object for chaining.
=head2 write
This write to the filehandle set, and takes a buffer to write, an optional length, an optional offset, and an optional timeout value.
If no length is provided, this default to the length of the buffer.
If no offset is provided, this default to C<0>.
If no timeout is provided, this default to the value set with L</timeout>
It returns the number of bytes written or, upon error, sets an L<error|Module::Generic/error> and returns C<undef>
=head2 write_all
Provided with some data an an optional timeout, and this will write the data to the filehandle set.
It returns the number of bytes written or, upon error, sets an L<error|Module::Generic/error> and returns C<undef>
=head1 THREAD-SAFETY
This module is thread-safe for all operations, as it operates on per-object state and uses thread-safe external libraries.
=head1 AUTHOR
Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
=head1 SEE ALSO
L<HTTP::Promise>, L<HTTP::Promise::Request>, L<HTTP::Promise::Response>, L<HTTP::Promise::Message>, L<HTTP::Promise::Entity>, L<HTTP::Promise::Headers>, L<HTTP::Promise::Body>, L<HTTP::Promise::Body::Form>, L<HTTP::Promise::Body::Form::Data>, L<HTTP:...
=head1 COPYRIGHT & LICENSE
Copyright(c) 2022 DEGUEST Pte. Ltd.
All rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=cut
( run in 1.150 second using v1.01-cache-2.11-cpan-39bf76dae61 )