The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use IO::Async::Test;

use Test::More;
use Test::Identity;

use IO::Socket::INET;

use Socket qw( inet_ntoa unpack_sockaddr_in );

use IO::Async::Loop;

# Some odd locations like BSD jails might not like INADDR_LOOPBACK. We'll
# establish a baseline first to test against
my $INADDR_LOOPBACK = do {
   my $localsock = IO::Socket::INET->new( LocalAddr => "localhost", Listen => 1 );
   $localsock->sockaddr;
};
my $INADDR_LOOPBACK_HOST = inet_ntoa( $INADDR_LOOPBACK );
if( $INADDR_LOOPBACK ne INADDR_LOOPBACK ) {
   diag( "Testing with INADDR_LOOPBACK=$INADDR_LOOPBACK_HOST; this may be because of odd networking" );
}

my $loop = IO::Async::Loop->new_builtin;

testing_loop( $loop );

{
   my $listensock = IO::Socket::INET->new(
      LocalAddr => "localhost",
      Type      => SOCK_STREAM,
      Listen    => 1,
   ) or die "Cannot socket() - $!";

   my $newclient;

   my $f = $loop->listen(
      handle => $listensock,
      on_accept => sub { $newclient = $_[0]; },
   );

   ok( $f->is_ready, '$loop->listen on handle ready synchronously' );

   my $notifier = $f->get;
   isa_ok( $notifier, "IO::Async::Notifier", 'synchronous on_notifier given a Notifier' );

   identical( $notifier->loop, $loop, 'synchronous $notifier->loop is $loop' );

   my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM )
      or die "Cannot socket() - $!";

   $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!";

   ok( defined $clientsock->peername, '$clientsock is connected' );

   wait_for { defined $newclient };

   is_deeply( [ unpack_sockaddr_in $newclient->peername ],
              [ unpack_sockaddr_in $clientsock->sockname ], '$newclient peer is correct' );
}

{
   my $listensock;
   my $newclient;

   my $f = $loop->listen(
      family   => "inet",
      socktype => "stream",
      service  => "", # Ask the kernel to allocate a port for us
      host     => "localhost",

      on_listen => sub { $listensock = $_[0]; },

      on_accept => sub { $newclient = $_[0]; },
   );

   my $notifier = $f->get;

   ok( defined $listensock->fileno, '$listensock has a fileno' );
   # Not sure if it'll be an IO::Socket::INET or ::IP, but either way it should support these
   can_ok( $listensock, qw( peerhost peerport ) );

   isa_ok( $notifier, "IO::Async::Notifier", 'asynchronous on_notifier given a Notifier' );

   identical( $notifier->loop, $loop, 'asynchronous $notifier->loop is $loop' );

   my $listenaddr = $listensock->sockname;

   ok( defined $listenaddr, '$listensock has address' );

   my ( $listenport, $listen_inaddr ) = unpack_sockaddr_in( $listenaddr );

   is( inet_ntoa( $listen_inaddr ), $INADDR_LOOPBACK_HOST, '$listenaddr is INADDR_LOOPBACK' );

   my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM )
      or die "Cannot socket() - $!";

   $clientsock->connect( $listenaddr ) or die "Cannot connect() - $!";

   is( (unpack_sockaddr_in( $clientsock->peername ))[0], $listenport, '$clientsock on the correct port' );

   wait_for { defined $newclient };

   can_ok( $newclient, qw( peerhost peerport ) );

   is_deeply( [ unpack_sockaddr_in $newclient->peername ],
              [ unpack_sockaddr_in $clientsock->sockname ], '$newclient peer is correct' );
}

# Now we want to test failure. It's hard to know in a test script what will
# definitely fail, but it's likely we're either running as non-root, or the
# machine has at least one of an SSH or a webserver running. In this case,
# it's likely we'll fail to bind TCP port 22 or 80.

my $badport;
my $failure;
foreach my $port ( 22, 80 ) {
   IO::Socket::INET->new(
      Type      => SOCK_STREAM,
      LocalHost => "localhost",
      LocalPort => $port,
      Listen    => 1,
   ) and next;
      
   $badport = $port;
   $failure = $!;
   last;
}

SKIP: {
   skip "No bind()-failing ports found", 6 unless defined $badport;

   my $failop;
   my $failerr;

   my @error;

   # We need to capture the Listener object before failure, so we can assert
   # it gets removed from the Loop again afterwards
   my $listener;
   no warnings 'redefine';
   my $add = IO::Async::Loop->can( "add" );
   local *IO::Async::Loop::add = sub {
      $listener = $_[1];
      $add->( @_ );
   };

   $loop->listen(
      family   => "inet",
      socktype => "stream",
      host     => "localhost",
      service  => $badport,

      on_resolve_error => sub { die "Test died early - resolve error $_[0]\n"; },

      on_listen => sub { die "Test died early - listen on port $badport actually succeeded\n"; },

      on_accept => sub { "DUMMY" }, # really hope this doesn't happen ;)

      on_fail => sub { $failop = shift; $failerr = pop; },
      on_listen_error => sub { @error = @_; },
   );

   ok( defined $listener, 'Managed to capture listener being added to Loop' );

   wait_for { @error };

   is( $failop, "bind", '$failop is bind' );
   is( "$failerr", $failure, "\$failerr is '$failure'" );

   is( $error[0], "bind", '$error[0] is bind' );
   is( "$error[1]", $failure, "\$error[1] is '$failure'" );

   ok( defined $listener, '$listener defined after bind failure' );
   ok( !$listener->loop, '$listener not in loop after bind failure' );
}

done_testing;