aboutsummaryrefslogtreecommitdiffstats
path: root/tests/starttls-injection/imapd
blob: 9000c8d1c984bd78cba930f41d19722834ea7e4d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
#!/usr/bin/perl -T

use warnings;
use strict;

use Errno qw/EINTR/;
use Net::SSLeay qw/die_now die_if_ssl_error/;
use Socket qw/INADDR_LOOPBACK AF_INET SOCK_STREAM pack_sockaddr_in
    SOL_SOCKET SO_REUSEADDR SHUT_RDWR/;

BEGIN {
    Net::SSLeay::load_error_strings();
    Net::SSLeay::SSLeay_add_ssl_algorithms();
    Net::SSLeay::randomize();
}

socket(my $S, AF_INET, SOCK_STREAM, 0) or die;
setsockopt($S, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die;
bind($S, pack_sockaddr_in(10143, INADDR_LOOPBACK)) or die "bind: $!\n";
listen($S, 1) or die "listen: $!";

my $CONFDIR = $ENV{HOME} =~ /\A(\p{Print}+)\z/ ? "$1/.dovecot/conf.d" : die;
my $CTX = Net::SSLeay::CTX_new() or die_now("SSL_CTX_new");
Net::SSLeay::CTX_set_mode($CTX,
    Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE() |
    Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER() |
    Net::SSLeay::MODE_AUTO_RETRY() | # don't fail SSL_read on renegotiation
    Net::SSLeay::MODE_RELEASE_BUFFERS() );
Net::SSLeay::CTX_use_PrivateKey_file($CTX, "$CONFDIR/dovecot.key", &Net::SSLeay::FILETYPE_PEM)
    or die_if_ssl_error("Can't load private key: $!");
Net::SSLeay::CTX_use_certificate_file($CTX, "$CONFDIR/dovecot.pem", &Net::SSLeay::FILETYPE_PEM)
    or die_if_ssl_error("Can't load certificate: $!");

while (1) {
    my $sockaddr = accept(my $conn, $S) or do {
        next if $! == EINTR;
        die "accept: $!";
    };

    $conn->printflush("* OK IMAP4rev1 Server\r\n");

    $conn->getline() =~ /\A(\S+) CAPABILITY\r\n\z/ or die;
    $conn->printflush("* CAPABILITY IMAP4rev1 STARTTLS\r\n");
    $conn->printflush("$1 OK CAPABILITY completed\r\n");

    $conn->getline() =~ /\A(\S+) STARTTLS\r\n\z/ or die;

    # These responses preceed the TLS handshake hence are not authenticated!
    $conn->print("$1 OK Begin TLS\r\n");
    $conn->print("* CAPABILITY IMAP4rev1 LOGINDISABLED X-injected\r\n");
    # Note: tag format must match Net::IMAP::InterIMAP->_cmd_init()
    $conn->printf("%06d OK CAPABILITY injected\r\n", $1+1);
    $conn->flush();

    my $ssl = Net::SSLeay::new($CTX) or die_if_ssl_error("SSL_new");
    Net::SSLeay::set_fd($ssl, $conn) or die_if_ssl_error("SSL_set_fd");
    Net::SSLeay::accept($ssl) and die_if_ssl_error("SSL_accept");

    Net::SSLeay::ssl_read_CRLF($ssl) =~ /\A(\S+) CAPABILITY\r\n\z/ or die_now("SSL_read");
    Net::SSLeay::ssl_write_CRLF($ssl, "* CAPABILITY IMAP4rev1 AUTH=LOGIN\r\n$1 OK CAPABILITY completed");

    Net::SSLeay::ssl_read_CRLF($ssl) =~ /\A(\S+) LOGIN .*\r\n\z/ or die_now("SSL_read");
    Net::SSLeay::ssl_write_CRLF($ssl, "$1 OK [CAPABILITY IMAP4rev1] LOGIN completed");

    Net::SSLeay::free($ssl);
    close($conn);

    last;
}

END {
    Net::SSLeay::CTX_free($CTX) if defined $CTX;
    if (defined $S) {
        shutdown($S, SHUT_RDWR) or warn "shutdown: $!";
        close($S) or print STDERR "Can't close: $!\n";
    }
}