# Copyright (C) 2013 - Mytram <rmytram@gmail.com>
# Copyright (C) 2013 - Xavier Guimard <x.guimard@free.fr>
# This program is free software; you can redistribute it and/or modify it
# under the terms of either: the GNU General Public License as published
# by the Free Software Foundation; or the Artistic License.
#
# See http://dev.perl.org/licenses/ for more information.

use IO::Socket::INET;
use Net::Server::Mail::ESMTP;
use Net::Server::Mail::ESMTP::STARTTLS;
use IO::Socket::SSL qw(1.831 SSL_VERIFY_NONE);

use Net::SMTP;
use Net::Cmd;

use Test::Most;

use constant {
    OK      => 250,
    DEFER   => 450,
    NORETRY => 250,    # Drop the message silently so that it doesn't bounce
};

use strict;
use warnings;

my ( @tests, @socks );

my $host   = '127.0.0.1';
my $port   = 20000 + int( rand(1000) );
my $sender = 'sender@example.com';
my $recip1 = 'recip1@example.com';
my $recip2 = 'recip2@example.com';

my $data = << "EOS";
Subject: test message
From: <$sender>
To: <$recip1>
To: <$recip2>

hello world.

EOS

push @tests, [
    'STARTTLS support',
    sub {
        my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' );

        $s->peerhost eq $host
          or die "peerport is not $host";
        $s->peerport eq $port
          or die "peerport is not $port";

        defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] )
          or die "starttls is not supported";

        $s->command("STARTTLS")->response == Net::Cmd::CMD_OK
          or die "Cannot start command";

        # cause the server to close the connetion
        $s->command("hello");
        $s->command("bye");

        $s->quit;

        return 1;
    },
    {}
];

push @tests, [
    'STARTTLS invalid parameters',
    sub {
        my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' );

        $s->peerhost eq $host
          or die "peerport is not $host";
        $s->peerport eq $port
          or die "peerport is not $port";

        defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] )
          or die "starttls is not supported";

        $s->command("STARTTLS HELLO WORLD")->response == Net::Cmd::CMD_ERROR
          or die "Invalid paramter accepted";

        $s->quit;

        return 1;
    },
    {}
];

push @tests, [
    'STARTTLS handshake',
    sub {
        my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' );

        $s->peerhost eq $host
          or die "peerport is not $host";
        $s->peerport eq $port
          or die "peerport is not $port";

        defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] )
          or die "starttls is not supported";

        $s->command("STARTTLS")->response == Net::Cmd::CMD_OK
          or die "Cannot start command";

        my $rv =
          IO::Socket::SSL->start_SSL( $s,
            SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE, );

        ( defined $rv && ref $rv eq 'IO::Socket::SSL' )
          or die "TLS handshake failed " . IO::Socket::SSL::errstr();

        $s->close;

        return 1;
    },
    {}
];

push @tests, [
    'STARTTLS handshake failed in SSL_VERIFY_PEER',
    sub {
        my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' );

        $s->peerhost eq $host
          or die "peerport is not $host";
        $s->peerport eq $port
          or die "peerport is not $port";

        defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] )
          or die "starttls is not supported";

        $s->command("STARTTLS")->response == Net::Cmd::CMD_OK
          or die "Cannot start command";

        my $rv =
          IO::Socket::SSL->start_SSL( $s,
            SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER, );

        !( defined $rv && ref $rv eq 'IO::Socket::SSL' )
          or die "TLS handeshake failed";

        $s->close;

        return 1;
    },
    {}
];

push @tests, [
    'SMTP Plain',
    sub {
        my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' );

        $s->peerhost eq $host
          or die "peerport is not $host";
        $s->peerport eq $port
          or die "peerport is not $port";

        $s->mail($sender);
        $s->to( $recip1, $recip2 );
        $s->data();
        $s->datasend($data);
        $s->dataend();
        $s->quit;

        return 1;
    },
    {
        DATA => sub {

            # processing
            my ( $session, $message ) = @_;

            my $s = $session->get_sender();

            ok( $s eq $sender, "Sender" );
            my @recipients = $session->get_recipients();
            my %recips = map { $_ => 1 } @recipients;

            ok( $recips{$recip1}, "found $recip1" );
            ok( $recips{$recip2}, "found $recip2" );

            ok( $$message, "found message" );

            return ( 1, OK, 'Success!' );
          }
    }
];

sub upgrade_to_tls {
    my $s = shift;
    defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] )
      or die "starttls is not supported";

    $s->command("STARTTLS")->response == Net::Cmd::CMD_OK
      or die "Cannot start command";

    my $rv =
      IO::Socket::SSL->start_SSL( $s,
        { SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE } )
      or die "Cannot upgrade to tls";

    # $s is IO::Socket::SSL now
    Net::Cmd::command( $s, 'EHLO localhost' )
      or die "Cannot send EHLO localhost command";
    Net::Cmd::response($s) == Net::Cmd::CMD_OK
      or die "EHLO failed after upgrading to TLS";
}

push @tests, [
    'TLS and quit',
    sub {
        my $s = _Net::SMTPS->new( $host, Port => $port, Hello => 'localhost' );

        unless ( defined $s ) {
            return 1;
        }
        $s->quit;

        return 1;
    },
    {    # No server verification
    }
];

push @tests, [
    'TLS and send message',
    sub {
        my $s = _Net::SMTPS->new( $host, Port => $port );
        unless ( defined $s ) {
            return 1;
        }
        $s->mail($sender);
        $s->to( $recip1, $recip2 );
        $s->data();
        $s->datasend($data);
        $s->dataend();
        $s->quit;
        return 1;
    },
    {
        DATA => sub {

            # processing
            my ( $session, $message ) = @_;

            my $s = $session->get_sender();

            ok( $s eq $sender, "Sender" );
            my @recipients = $session->get_recipients();
            my %recips = map { $_ => 1 } @recipients;

            ok( $recips{$recip1}, "found $recip1" );
            ok( $recips{$recip2}, "found $recip2" );

            ok( $$message, "found message" );

            return ( 1, OK, 'Success!' );
          }
    }
];

sub process_test {
    my $sock  = shift;
    my $tc_id = shift;
    my $test  = shift;

    my $client = $sock->accept;
    push @socks, $client;
    my $smtp = Net::Server::Mail::ESMTP->new(
        socket       => $client,
        idle_timeout => 300,
        SSL_config   => {
            SSL_cert_file => 't/certs/server-cert.pem',
            SSL_key_file  => 't/certs/server-key.pem',
        },
    ) or die "Cannot create ESMTP";

    ok( $smtp, "Accepted client for $tc_id: " . $test->[0] );

    $smtp->register('Net::Server::Mail::ESMTP::STARTTLS');

    $smtp->set_callback( DATA => $test->[2]{DATA} || sub { } );

    $smtp->process();

    $client->close;
    shift @socks;
}

my $ppid = $$;
my $pid  = fork();
if ( !defined $pid ) {
    die $!;
}
elsif ($pid) {

    # child process - server
    my $sock = IO::Socket::INET->new(
        Listen    => 1,
        LocalAddr => $host,
        LocalPort => $port,
        Proto     => 'tcp',
        Timeout   => 5,
    );
    if ( !$sock ) {
        kill 9, $pid;
        diag("kill 9 $pid (child)");
        plan skip_all => "Cannot create sock: $!";
        exit;
    }

    push @socks, $sock;

    my $id = 0;
    for (@tests) {
        $id++;
        my $tc = sprintf( "Test%02d", $id );
        process_test( $sock, $tc, $_ );
    }

    wait;
    $sock->close;

    done_testing();
    exit;
}
else {
    # child
    sleep 1;    # to give server time to set up sock
    for my $test (@tests) {
        my $rv;
        eval {
            local $SIG{__DIE__};
            $rv = $test->[1]->();
        };
        if ( $@ || !$rv ) {

            # kill the server
            diag("Error: $@");
            diag("kill 9, $ppid (server)");
            kill 9, $ppid;
            exit;
        }
    }

    exit;

}

BEGIN {

    package _Net::SMTPS;

    use strict;
    use warnings;
    use IO::Socket::SSL;

    use Net::Cmd;

    use Sys::Hostname;

    our @ISA = qw(IO::Socket::SSL Net::SMTP);

    sub new {
        my $class = shift;
        my $host  = shift;

        my %args = @_;
        my $s = Net::SMTP->new( $host, %args );

        if (
            defined $s->supports( 'STARTTLS', 500,
                ["Command unknown: 'STARTTLS'"] ) )
        {
            # OK, TLS is advertised as supported. Let's try it.
            if ( $s->command('STARTTLS')->response == CMD_OK ) {

                # The STARTTLS command was accepted, now begin SSL negotiation.
                # Net::SMTP::TLS is hardcoded! This will break
                # future inheritance
                my $rv = _Net::SMTPS->start_SSL(
                    $s,
                    SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
                    %args,
                );

                # $self has been blessed to $class
                return undef unless ref $rv;

                $s->hello( $args{Hello} || Sys::Hostname::hostname );
                return $s;
            }
        }

        return undef;
    }

    1;

}

END {
    $_->close for @socks;
}
