1#!/usr/bin/perl -w 2 3# Test Apple's BDAT/CHUNKING/BINARYMIME extension to postfix. 4 5# Copyright (c) 2013 Apple Inc. All Rights Reserved. 6# 7# @APPLE_LICENSE_HEADER_START@ 8# 9# This file contains Original Code and/or Modifications of Original Code 10# as defined in and that are subject to the Apple Public Source License 11# Version 2.0 (the 'License'). You may not use this file except in 12# compliance with the License. Please obtain a copy of the License at 13# http://www.opensource.apple.com/apsl/ and read it before using this 14# file. 15# 16# The Original Code and all software distributed under the License are 17# distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER 18# EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES, 19# INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY, FITNESS 20# FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT. Please 21# see the License for the specific language governing rights and 22# limitations under the License. 23# 24# @APPLE_LICENSE_HEADER_END@ 25 26use strict; 27use IO::Socket::INET; 28use Getopt::Long; 29use IPC::Open3; 30use Digest::HMAC_MD5; 31use APR::Base64; 32use List::Util 'shuffle'; 33use MIME::QuotedPrint; 34use feature 'state'; 35 36sub usage 37{ 38 die <<EOT; 39Usage: $0 --host smtp+imap-server --user name --password pw 40Options: 41 --bufsiz n output buffer size 42 --buftag tag output buffer flushes 43 --debug 44 --deliveries n number of messages to deliver and check 45 --light don't test with random binary gibberish 46 --test test message generation 47 --quiet 48 --verbose 49EOT 50} 51 52my %opts; 53GetOptions(\%opts, 54 'bufsiz=i', 55 'buftag', 56 'debug', 57 'deliveries=i', 58 'host=s', 59 'light', 60 'password=s', 61 'quiet', 62 'test', 63 'user=s', 64 'verbose', 65) || usage(); 66 67$opts{deliveries} = 1000 unless defined($opts{deliveries}); 68usage() unless $opts{deliveries} > 0; 69usage() unless $opts{host}; 70if ($opts{host} !~ /\./) { 71 print STDERR "Warning: --host $opts{host} is not fully-qualified and probably won't work.\n"; 72} 73usage() unless $opts{user}; 74usage() unless $opts{password}; 75 76$| = 1; 77 78my ($smtppid, $imappid); 79local $SIG{__DIE__} = sub { 80 kill(9, $smtppid) if defined $smtppid; 81 kill(9, $imappid) if defined $imappid; 82}; 83 84my $reply; 85 86my %typefuncs = ( 87 "" => [\&header_plain, \&body_plain], 88 "text/plain" => [\&header_plain, \&body_plain], 89 "message/rfc822" => [\&header_message, \&body_message], 90 "application/octet-stream" => [\&header_gibberish, \&body_gibberish], 91 "multipart/mixed" => [\&header_mixed, \&body_mixed], 92); 93if ($opts{light}) { 94 $typefuncs{"application/octet-stream"} = $typefuncs{"text/plain"}; 95} 96my @types = keys %typefuncs; 97 98my @encodings_top = ("", "7bit", "8bit", "binary"); 99my @encodings_sub = (@encodings_top, "base64", "quoted-printable"); 100my %encodingfuncs = ( 101 "" => \&clean_7bit, 102 "7bit" => \&clean_7bit, 103 "8bit" => \&clean_8bit, 104 "binary" => \&clean_binary, 105 "base64" => \&clean_base64, 106 "quoted-printable" => \&clean_qp, 107); 108 109my $top_encoding; 110 111if ($opts{test}) { 112 my ($raw, $clean, $rawsections, $cleansections, $fetchable) = message("body=binarymime", "test"); 113 my @rawsections = @$rawsections; 114 my @cleansections = @$cleansections; 115 my @fetchable = @$fetchable; 116 print "=== RAW ===\n$raw". 117 "\n=== CLEAN ===\n$clean". 118 "\n=== RAW SECTIONS ===\n".join("//\n",@rawsections). 119 "\n=== CLEAN SECTIONS ===\n".join("//\n",@cleansections). 120 "\n=== FETCHABLE ===\n".join("//\n",@fetchable). 121 "\n=== END ===\n"; 122 my $sanity = ""; 123 $sanity .= $_ for @rawsections; 124 die "Internal consistency botch: sectioned message does not match whole.\nRaw:\n$raw\nSectioned:\n$sanity\n" 125 unless $sanity eq $raw; 126 $sanity = ""; 127 $sanity .= $_ for @cleansections; 128 die "Internal consistency botch: sectioned message does not match whole.\nClean:\n$clean\nSectioned:\n$sanity\n" 129 unless $sanity eq $clean; 130 open RAW, ">/tmp/chunking.raw" or die; 131 print RAW $raw; 132 close RAW; 133 open CLEAN, ">/tmp/chunking.clean" or die; 134 print CLEAN $clean; 135 close CLEAN; 136 open RAWSECTIONS, ">/tmp/chunking.rawsections" or die; 137 print RAWSECTIONS join("//\n",@rawsections); 138 close RAWSECTIONS; 139 open CLEANSECTIONS, ">/tmp/chunking.cleansections" or die; 140 print CLEANSECTIONS join("//\n",@cleansections); 141 close CLEANSECTIONS; 142 open FETCHABLE, ">/tmp/chunking.fetchable" or die; 143 print FETCHABLE join("//\n",@fetchable); 144 close FETCHABLE; 145 #system("xdiff -a /tmp/chunking.raw /tmp/chunking.clean /tmp/chunking.cleansections"); 146 exit 0; 147} 148 149# try connecting via imaps, imap + starttls, imap, in that order 150my ($to_imap, $from_imap); 151print "connecting (imaps)...\n" unless $opts{quiet}; 152my @imapargv = ("/usr/bin/openssl", "s_client", "-ign_eof", 153 "-connect", "$opts{host}:imaps"); 154push @imapargv, "-quiet" unless $opts{verbose}; 155$imappid = open3(\*TO_IMAP, \*FROM_IMAP, \*FROM_IMAP, @imapargv); 156sub openssl_imap_happy_or_clean_up 157{ 158 my $label = shift or die; 159 160 if (!defined($imappid)) { 161 print "$label: couldn't run openssl: $!\n" if $opts{verbose}; 162 } else { 163 while ($reply = <FROM_IMAP>) { 164 print "<OPENSSL< $reply" if $opts{verbose}; 165 $reply =~ s/[\r\n]+$//; 166 return 1 if $reply =~ /^\S+ OK /; 167 if ($reply =~ /^connect:/i || $reply =~ /errno/) { 168 print "$label: $reply\n" if $opts{verbose}; 169 last; 170 } 171 } 172 if (!defined($reply)) { 173 print "$label: EOF\n" if $opts{verbose}; 174 } 175 } 176 177 close(TO_IMAP); 178 close(FROM_IMAP); 179 if (defined($imappid)) { 180 kill(9, $imappid); 181 waitpid($imappid, 0); 182 undef $imappid; 183 } 184 return 0; 185} 186if (openssl_imap_happy_or_clean_up("$opts{host}:imaps")) { 187 $to_imap = IO::Handle->new_from_fd(*TO_IMAP, "w"); 188 $from_imap = IO::Handle->new_from_fd(*FROM_IMAP, "r"); 189 if (!defined($to_imap) || !defined($from_imap)) { 190 die "IO::Handle.new_from_fd: $!\n"; 191 } 192} else { 193 print "connecting (imap + starttls)...\n" unless $opts{quiet}; 194 @imapargv = ("/usr/bin/openssl", "s_client", "-ign_eof", 195 "-connect", "$opts{host}:imap", "-starttls", "imap"); 196 push @imapargv, "-quiet" unless $opts{verbose}; 197 $imappid = open3(\*TO_IMAP, \*FROM_IMAP, \*FROM_IMAP, @imapargv); 198 if (openssl_imap_happy_or_clean_up("$opts{host}:imap + starttls")) { 199 $to_imap = IO::Handle->new_from_fd(*TO_IMAP, "w"); 200 $from_imap = IO::Handle->new_from_fd(*FROM_IMAP, "r"); 201 if (!defined($to_imap) || !defined($from_imap)) { 202 die "IO::Handle.new_from_fd: $!\n"; 203 } 204 } else { 205 print "connecting (imap)...\n" unless $opts{quiet}; 206 $to_imap = IO::Socket::INET->new( 207 PeerAddr => $opts{host}, 208 PeerPort => 'imap(143)', 209 Proto => 'tcp', 210 Type => SOCK_STREAM, 211 Timeout => 30, 212 ); 213 $from_imap = $to_imap; 214 if (!defined($to_imap) || !defined($from_imap)) { 215 die "IO::Socket::INET.new: $!\n"; 216 } 217 218 $reply = $from_imap->getline(); 219 die "I/O error\n" if $from_imap->error; 220 imap_printS($reply) if $opts{verbose}; 221 $reply =~ s/[\r\n]+$//; 222 if ($reply !~ /\* OK (\[.*\] )?Dovecot.* ready\./) { 223 die "Bad greeting: <$reply>\n"; 224 } 225 } 226} 227$to_imap->autoflush(1); 228 229print "capability...\n" unless $opts{quiet}; 230imap_send_data("c capability\r\n"); 231imap_flush(); 232my $imap_auth_plain = 0; 233my $imap_auth_cram_md5 = 0; 234while ($reply = $from_imap->getline()) { 235 imap_printS($reply) if $opts{verbose}; 236 $reply =~ s/[\r\n]+$//; 237 if ($reply =~ /^c /) { 238 if ($reply !~ /c OK (\[.*\])?/) { 239 die "Capability failed: <$reply>\n"; 240 } 241 last; 242 } 243 $imap_auth_plain = 1 if $reply =~ /CAPABILITY.*AUTH=PLAIN/i; 244 $imap_auth_cram_md5 = 1 if $reply =~ /CAPABILITY.*AUTH=CRAM-MD5/i; 245} 246die "I/O error\n" if $from_imap->error; 247if (!$imap_auth_plain && !$imap_auth_cram_md5) { 248 die "$opts{host} supports neither PLAIN nor CRAM-MD5 auth so I don't know how to log in.\n"; 249} 250 251print "logging in...\n" unless $opts{quiet}; 252my $imap_auth = $imap_auth_cram_md5 ? "CRAM-MD5" : "PLAIN"; 253imap_send_data("a authenticate $imap_auth\r\n"); 254imap_flush(); 255$reply = $from_imap->getline(); 256die "I/O error\n" if $from_imap->error; 257imap_printS($reply) if $opts{verbose}; 258$reply =~ s/[\r\n]+$//; 259if ($reply !~ /^\+/) { 260 die "Authenticate failed: <$reply>\n"; 261} 262if ($imap_auth_cram_md5) { 263 my ($challenge) = ($reply =~ /^\+ (.*)/); 264 $challenge = APR::Base64::decode($challenge); 265 print "Decoded challenge: $challenge\n" if $opts{verbose}; 266 my $digest = Digest::HMAC_MD5::hmac_md5_hex($challenge, $opts{password}); 267 $imap_auth = APR::Base64::encode("$opts{user} $digest"); 268} else { 269 $imap_auth = APR::Base64::encode("\0$opts{user}\0$opts{password}"); 270} 271$imap_auth .= "\r\n"; 272imap_send_data($imap_auth); 273imap_flush(); 274while ($reply = $from_imap->getline()) { 275 imap_printS($reply) if $opts{verbose}; 276 $reply =~ s/[\r\n]+$//; 277 if ($reply =~ /^a /) { 278 if ($reply !~ /a OK /) { 279 die "Login failed: <$reply>\n"; 280 } 281 last; 282 } 283} 284die "I/O error\n" if $from_imap->error; 285 286print "create scratchbox...\n" unless $opts{quiet}; 287imap_send_data("b create scratchbox\r\n"); 288imap_flush(); 289while ($reply = $from_imap->getline()) { 290 imap_printS($reply) if $opts{verbose}; 291 $reply =~ s/[\r\n]+$//; 292 if ($reply =~ /^b /) { 293 last; 294 } 295} 296die "I/O error\n" if $from_imap->error; 297 298print "select...\n" unless $opts{quiet}; 299imap_send_data("c select inbox\r\n"); 300imap_flush(); 301my $inbox_message_count; 302while ($reply = $from_imap->getline()) { 303 imap_printS($reply) if $opts{verbose}; 304 $reply =~ s/[\r\n]+$//; 305 if ($reply =~ /^c OK /) { 306 last; 307 } elsif ($reply =~ /^\* (\d+) EXISTS/i) { 308 $inbox_message_count = $1; 309 } 310} 311die "I/O error\n" if $from_imap->error; 312 313print "idle...\n" unless $opts{quiet}; 314imap_send_data("i idle\r\n"); 315imap_flush(); 316my $imap_idle = 0; 317while ($reply = $from_imap->getline()) { 318 imap_printS($reply) if $opts{verbose}; 319 $reply =~ s/[\r\n]+$//; 320 if ($reply =~ /^\+ /) { 321 $imap_idle = 1; 322 last; 323 } elsif ($reply =~ /^i /) { 324 die "Idle failed: <$reply>\n"; 325 } 326} 327die "I/O error\n" if $from_imap->error; 328 329# try connecting via submission + starttls, smtp + starttls, smtp, in that order 330my $submission = 0; 331my ($to_smtp, $from_smtp); 332print "connecting (submission + starttls)...\n" unless $opts{quiet}; 333my @smtpargv = ("/usr/bin/openssl", "s_client", "-ign_eof", 334 "-connect", "$opts{host}:submission", "-starttls", "smtp"); 335push @smtpargv, "-quiet" unless $opts{verbose}; 336$smtppid = open3(\*TO_SMTP, \*FROM_SMTP, \*FROM_SMTP, @smtpargv); 337sub openssl_smtp_happy_or_clean_up 338{ 339 my $label = shift or die; 340 341 if (!defined($smtppid)) { 342 print "$label: couldn't run openssl: $!\n" if $opts{verbose}; 343 } else { 344 while ($reply = <FROM_SMTP>) { 345 print "<OPENSSL< $reply" if $opts{verbose}; 346 $reply =~ s/[\r\n]+$//; 347 return 1 if $reply =~ /^250 /; 348 if ($reply =~ /^connect:/i || $reply =~ /errno/) { 349 print "$label: $reply\n" if $opts{verbose}; 350 last; 351 } 352 } 353 if (!defined($reply)) { 354 print "$label: EOF\n" if $opts{verbose}; 355 } 356 } 357 358 close(TO_SMTP); 359 close(FROM_SMTP); 360 if (defined($smtppid)) { 361 kill(9, $smtppid); 362 waitpid($smtppid, 0); 363 undef $smtppid; 364 } 365 return 0; 366} 367if (openssl_smtp_happy_or_clean_up("$opts{host}:submission + starttls")) { 368 $to_smtp = IO::Handle->new_from_fd(*TO_SMTP, "w"); 369 $from_smtp = IO::Handle->new_from_fd(*FROM_SMTP, "r"); 370 if (!defined($to_smtp) || !defined($from_smtp)) { 371 die "IO::Handle.new_from_fd: $!\n"; 372 } 373 $submission = 1; 374} else { 375 print "connecting (smtp + starttls)...\n" unless $opts{quiet}; 376 @smtpargv = ("/usr/bin/openssl", "s_client", "-ign_eof", 377 "-connect", "$opts{host}:smtp", "-starttls", "smtp"); 378 push @smtpargv, "-quiet" unless $opts{verbose}; 379 $smtppid = open3(\*TO_SMTP, \*FROM_SMTP, \*FROM_SMTP, @smtpargv); 380 if (openssl_smtp_happy_or_clean_up("$opts{host}:smtp + starttls")) { 381 $to_smtp = IO::Handle->new_from_fd(*TO_SMTP, "w"); 382 $from_smtp = IO::Handle->new_from_fd(*FROM_SMTP, "r"); 383 if (!defined($to_smtp) || !defined($from_smtp)) { 384 die "IO::Handle.new_from_fd: $!\n"; 385 } 386 } else { 387 print "connecting (smtp)...\n" unless $opts{quiet}; 388 $to_smtp = IO::Socket::INET->new( 389 PeerAddr => $opts{host}, 390 PeerPort => 'smtp(25)', 391 Proto => 'tcp', 392 Type => SOCK_STREAM, 393 Timeout => 30, 394 ); 395 $from_smtp = $to_smtp; 396 if (!defined($to_smtp) || !defined($from_smtp)) { 397 die "IO::Socket::INET.new: $!\n"; 398 } 399 400 $reply = $from_smtp->getline(); 401 die "I/O error\n" if $from_smtp->error; 402 smtp_printS($reply) if $opts{verbose}; 403 $reply =~ s/[\r\n]+$//; 404 if ($reply !~ /^220 /) { 405 die "Bad greeting: <$reply>\n"; 406 } 407 } 408} 409$to_smtp->autoflush(1); 410 411my $submit_burl = 0; 412if ($submission) { 413 print "ehlo...\n" unless $opts{quiet}; 414 smtp_send_data("ehlo bdat.pl\r\n"); 415 smtp_flush(); 416 my $submit_auth_plain = 0; 417 my $submit_auth_cram_md5 = 0; 418 while ($reply = $from_smtp->getline()) { 419 smtp_printS($reply) if $opts{verbose}; 420 $reply =~ s/[\r\n]+$//; 421 $submit_auth_plain = 1 if $reply =~ /^\d+.AUTH.*PLAIN/i; 422 $submit_auth_cram_md5 = 1 if $reply =~ /^\d+.AUTH.*CRAM-MD5/i; 423 if ($reply =~ /^\d+.BURL/) { 424 if ($reply !~ /^\d+.BURL$/) { 425 die "Unexpected BURL arguments: <$reply>\n"; 426 } 427 $submit_burl = 1; 428 } 429 if ($reply =~ /^\d+ /) { 430 if ($reply !~ /^2/) { 431 die "Ehlo failed: <$reply>\n"; 432 } 433 last; 434 } 435 } 436 die "I/O error\n" if $from_smtp->error; 437 if (!$submit_auth_plain && !$submit_auth_cram_md5) { 438 print STDERR "Submission server supports neither PLAIN nor CRAM-MD5 auth so I don't know how to log in.\n"; 439 print STDERR "Continuing without BURL\n"; 440 $submit_burl = 0; 441 } elsif (!$submit_burl) { 442 print STDERR "Submission server does not support BURL\n"; 443 print STDERR "Continuing without BURL\n"; 444 } else { 445 print "logging in...\n" unless $opts{quiet}; 446 my $submit_auth = $submit_auth_cram_md5 ? "CRAM-MD5" : "PLAIN"; 447 smtp_send_data("auth $submit_auth\r\n"); 448 smtp_flush(); 449 while ($reply = $from_smtp->getline()) { 450 smtp_printS($reply) if $opts{verbose}; 451 $reply =~ s/[\r\n]+$//; 452 if ($reply =~ /^\d+/) { 453 if ($reply !~ /^3/) { 454 die "Auth failed: <$reply>\n"; 455 } 456 last; 457 } 458 } 459 die "I/O error\n" if $from_smtp->error; 460 if ($submit_auth_cram_md5) { 461 my ($challenge) = ($reply =~ /^\d+ (.*)/); 462 $challenge = APR::Base64::decode($challenge); 463 print "Decoded challenge: $challenge\n" if $opts{verbose}; 464 my $digest = Digest::HMAC_MD5::hmac_md5_hex($challenge, $opts{password}); 465 smtp_send_data(APR::Base64::encode("$opts{user} $digest") . "\r\n"); 466 } else { 467 smtp_send_data(APR::Base64::encode("\0$opts{user}\0$opts{password}") . "\r\n"); 468 } 469 smtp_flush(); 470 while ($reply = $from_smtp->getline()) { 471 smtp_printS($reply) if $opts{verbose}; 472 $reply =~ s/[\r\n]+$//; 473 if ($reply =~ /^\d+ /) { 474 if ($reply !~ /^2/) { 475 die "Auth failed: <$reply>\n"; 476 } 477 last; 478 } 479 } 480 die "I/O error\n" if $from_smtp->error; 481 } 482} 483 484print "ehlo...\n" unless $opts{quiet}; 485smtp_send_data("ehlo bdat.pl\r\n"); 486smtp_flush(); 487my $smtp_binarymime; 488my $smtp_chunking; 489my $smtp_burl_imap; 490while ($reply = $from_smtp->getline()) { 491 smtp_printS($reply) if $opts{verbose}; 492 $reply =~ s/[\r\n]+$//; 493 $smtp_binarymime = 1 if $reply =~ /^250[- ]BINARYMIME$/; 494 $smtp_chunking = 1 if $reply =~ /^250[- ]CHUNKING$/; 495 $smtp_burl_imap = 1 if $reply =~ /^250[- ]BURL imap$/; 496 if ($reply =~ /^\d+ /) { 497 if ($reply !~ /250 /) { 498 die "Ehlo failed: <$reply>\n"; 499 } 500 last; 501 } 502} 503die "I/O error\n" if $from_imap->error; 504die "$opts{host} did not advertise BINARYMIME in ehlo reply\n" 505 unless $smtp_binarymime; 506die "$opts{host} did not advertise CHUNKING in ehlo reply\n" 507 unless $smtp_chunking; 508warn "$opts{host} did not advertise BURL imap in ehlo reply; continuing without BURL\n" 509 if $submit_burl && !$smtp_burl_imap; 510 511my $ok = 1; 512my $expect_OK; 513my $explanation; 514for my $delivery (1..$opts{deliveries}) { 515 $expect_OK = 1; 516 undef $explanation; 517 my $status = deliver($delivery); 518 if ($status < 0) { 519 $ok = 0; 520 last; 521 } elsif ($status == 0) { 522 print "rset...\n" unless $opts{quiet}; 523 smtp_send_data("rset\r\n"); 524 smtp_flush(); 525 while ($reply = $from_smtp->getline()) { 526 smtp_printS($reply) if $opts{verbose}; 527 $reply =~ s/[\r\n]+$//; 528 if ($reply =~ /^\d+ /) { 529 if ($reply !~ /250 /) { 530 die "Rset failed: <$reply>\n"; 531 } 532 last; 533 } 534 } 535 die "I/O error\n" if $from_smtp->error; 536 } 537} 538 539print "quit...\n" unless $opts{quiet}; 540smtp_send_data("quit\r\n"); 541smtp_flush(); 542while ($reply = $from_smtp->getline()) { 543 smtp_printS($reply) if $opts{verbose}; 544 $reply =~ s/[\r\n]+$//; 545 if ($reply =~ /^\d+ /) { 546 if ($reply !~ /221 /) { 547 die "Quit failed: <$reply>\n"; 548 } 549 last; 550 } 551} 552die "I/O error\n" if $from_smtp->error; 553 554$to_smtp->close(); 555if (defined($smtppid)) { 556 $from_smtp->close(); 557 waitpid($smtppid, 0); 558 undef $smtppid; 559} 560 561print "logout...\n" unless $opts{quiet}; 562if ($imap_idle) { 563 imap_send_data("done\r\n"); 564 imap_flush(); 565 while ($reply = $from_imap->getline()) { 566 imap_printS($reply) if $opts{verbose}; 567 $reply =~ s/[\r\n]+$//; 568 if ($reply =~ /^i /) { 569 if ($reply !~ /i OK (\[.*\])?/) { 570 die "Idle failed: <$reply>\n"; 571 } 572 last; 573 } 574 } 575 die "I/O error\n" if $from_imap->error; 576 $imap_idle = 0; 577} 578imap_send_data("z logout\r\n"); 579imap_flush(); 580while ($reply = $from_imap->getline()) { 581 imap_printS($reply) if $opts{verbose}; 582 $reply =~ s/[\r\n]+$//; 583 if ($reply =~ /^z /) { 584 if ($reply !~ /z OK (\[.*\])?/) { 585 die "Logout failed: <$reply>\n"; 586 } 587 last; 588 } 589} 590die "I/O error\n" if $from_imap->error; 591 592$to_imap->close(); 593if (defined($imappid)) { 594 $from_imap->close(); 595 waitpid($imappid, 0); 596 undef $imappid; 597} 598 599if ($ok) { 600 print "All tests passed.\n"; 601 exit 0; 602} else { 603 print "At least one test failed.\n"; 604 exit 1; 605} 606 607sub deliver 608{ 609 my $delivery = shift or die; 610 611 my $dtag = "deliver$delivery"; 612 my $ctag = "check$delivery"; 613 614 my @formats = ("", " body=8bitmime", " body=binarymime"); 615 my $r = int(rand(10)); 616 if ($r < 2) { 617 $r = 0; 618 } elsif ($r < 4) { 619 $r = 1; 620 } else { 621 $r = 2; 622 } 623 my $format = $formats[$r]; 624 if (int(rand(20)) == 0) { 625 failif(1, "sent no MAIL Fail: command"); 626 } else { 627 print "$dtag (mail)...\n" unless $opts{quiet}; 628 smtp_send_data("mail from: $dtag$format\r\n"); 629 smtp_flush(); 630 while ($reply = $from_smtp->getline()) { 631 smtp_printS($reply) if $opts{verbose}; 632 $reply =~ s/[\r\n]+$//; 633 if ($reply =~ /^\d+ /) { 634 if ($reply !~ /^250 /) { 635 die "Mail failed: <$reply>\n"; 636 } 637 last; 638 } 639 } 640 die "I/O error\n" if $from_smtp->error; 641 } 642 643 if (int(rand(20)) == 0) { 644 failif(1, "sent no RCPT command"); 645 } else { 646 print "$dtag (rcpt)...\n" unless $opts{quiet}; 647 smtp_send_data("rcpt to: $opts{user}\r\n"); 648 smtp_flush(); 649 while ($reply = $from_smtp->getline()) { 650 smtp_printS($reply) if $opts{verbose}; 651 $reply =~ s/[\r\n]+$//; 652 if ($reply =~ /^\d+ /) { 653 if ($expect_OK) { 654 if ($reply !~ /^250 /) { 655 print STDERR "Fail: Rcpt failed but should have succeeded: <$reply>\n"; 656 return -1; 657 } 658 } else { 659 if ($reply =~ /^250 /) { 660 print STDERR "Fail: Rcpt command succeeded but should have failed ($explanation): <$reply>\n"; 661 return -1; 662 } else { 663 print "Success: Rcpt command failed as it should have ($explanation): <$reply>\n" unless $opts{quiet}; 664 return 0; 665 } 666 } 667 last; 668 } 669 } 670 die "I/O error\n" if $from_smtp->error; 671 } 672 673 my ($message, $cleaned, $rawsections, $cleansections, $fetchable) = message($format, $dtag); 674 my @rawsections = @$rawsections; 675 my @cleansections = @$cleansections; 676 my @fetchable = @$fetchable; 677 print "=== RAW ===\n$message". 678 "\n=== CLEAN ===\n$cleaned". 679 "\n=== RAW SECTIONS ===\n".join("//\n",@rawsections). 680 "\n=== CLEAN SECTIONS ===\n".join("//\n",@cleansections). 681 "\n=== FETCHABLE ===\n".join("//\n", (map { defined($_) ? $_ : "" } @fetchable)). 682 "\n=== END ===\n" 683 if $opts{debug}; 684 die "Internal consistency botch: rawsections has ".scalar(@rawsections)." but fetchable has ".scalar(@fetchable)."\n" 685 unless @rawsections == @fetchable; 686 die "Internal consistency botch: cleansections has ".scalar(@cleansections)." but fetchable has ".scalar(@fetchable)."\n" 687 unless @cleansections == @fetchable; 688 my @fragments; 689 my $burl_ok; 690 if (int(rand(2)) == 0) { 691 # break the message up into random fragments, don't use burl 692 my $consumed = ""; 693 my $remaining = $message; 694 my $stuck = 0; 695 do { 696 my $cut = int(rand(length($remaining) + 1)); # 0 is ok 697 my $fragment = substr($remaining, 0, $cut); 698 699 # postfix does not handle fragmented header labels (e.g., "Fr" + "om: foo") 700 # or fragmented MIME separators (e.g., "--Apple-Ma" + "il-57-197753312--") 701 # also avoid breaking a header at a space (e.g., "From: foo" + " <foo@bar.baz") 702 # or breaking any CRLF 703 my $linestart = "$consumed$fragment"; 704 $linestart =~ s/.*\n//s; 705 my $linecont = substr($remaining, $cut); 706 $linecont =~ s/\n.*//s; 707 if (($linestart !~ /^[!-9;-~][ -9;-~]*$/ || $linecont !~ /^[ -9;-~]*:/) && 708 ($linestart !~ /^[!-9;-~][ -9;-~]*:/ || $linecont !~ /^[ \t]/) && 709 "$linestart$linecont" !~ /^--sep\d+(--)?\r?\z/ && 710 $linestart !~ /\r\z/) { 711 $remaining = substr($remaining, $cut); 712 $consumed .= $fragment; 713 push @fragments, $fragment; 714 $stuck = 0; 715 } else { 716 print "NOT cutting: |$linestart|<-HERE->|$linecont|\n...".substr($consumed,-20)."|<-HERE->|".substr($remaining,0,20)."...\n" if $opts{debug}; 717 if (++$stuck >= 1000) { 718 print "Can't fragment this message, giving up on it.\n" unless $opts{quiet}; 719 return 0; 720 } 721 } 722 } while (length $remaining > 0); 723 $burl_ok = 0; 724 725 my $sanity = ""; 726 $sanity .= $_ for @fragments; 727 die "Internal consistency botch: fragmented message does not match whole.\nWhole:\n$message\nFragmented:\n$sanity\n" 728 unless $sanity eq $message; 729 } else { 730 # break the message up into natural fragments, can use burl 731 @fragments = @fetchable; 732 $burl_ok = 1; 733 734 my $sanity = ""; 735 $sanity .= $_ for @rawsections; # sanity needs headers 736 die "Internal consistency botch: sectioned message does not match whole.\nRaw:\n$message\nSectioned:\n$sanity\n" 737 unless $sanity eq $message; 738 $sanity = ""; 739 $sanity .= $_ for @cleansections; # sanity needs headers 740 die "Internal consistency botch: sectioned message does not match whole.\nClean:\n$cleaned\nSectioned:\n$sanity\n" 741 unless $sanity eq $cleaned; 742 } 743 744 my $secno = 0; 745 my $lasturl; 746 for my $fragno (1..@fragments) { 747 my $fragment = $fragments[$fragno - 1]; 748 ++$secno if defined $fragment; 749 750 my $r = int(rand(20)); 751 if ($r == 0) { 752 print "$dtag (data)...\n" unless $opts{quiet}; 753 smtp_send_data("data\r\n"); 754 smtp_flush(); 755 failif($fragno > 1, "mixed BDAT/BURL/DATA commands"); 756 failif(scalar($format =~ /binarymime/i), "DATA with BINARYMIME"); 757 while ($reply = $from_smtp->getline()) { 758 smtp_printS($reply) if $opts{verbose}; 759 $reply =~ s/[\r\n]+$//; 760 if ($reply =~ /^\d+ /) { 761 if ($expect_OK) { 762 if ($reply !~ /^3\d\d /) { 763 print STDERR "Fail: Data failed but should have succeeded: <$reply>\n"; 764 return -1; 765 } 766 } else { 767 if ($reply =~ /^[23]\d\d /) { 768 print STDERR "Fail: Data succeeded but should have failed ($explanation): <$reply>\n"; 769 return -1; 770 } else { 771 print "Success: Data failed as it should have ($explanation): <$reply>\n" unless $opts{quiet}; 772 return 0; 773 } 774 } 775 last; 776 } 777 } 778 die "I/O error\n" if $from_smtp->error; 779 780 print "$dtag (message)...\n" unless $opts{quiet}; 781 smtp_send_data($message); # send $message not $fragment 782 #smtp_send_data("\r\n") unless $message =~ /\r\n$/s; 783 die unless $message =~ /\r\n\z/; 784 smtp_send_data(".\r\n"); 785 smtp_flush(); 786 while ($reply = $from_smtp->getline()) { 787 smtp_printS($reply) if $opts{verbose}; 788 $reply =~ s/[\r\n]+$//; 789 if ($reply =~ /^\d+ /) { 790 if ($expect_OK) { 791 if ($reply !~ /^250 /) { 792 print STDERR "Fail: Data transaction failed but should have succeeded: <$reply>\n"; 793 return -1; 794 } 795 } else { 796 if ($reply =~ /^250 /) { 797 print STDERR "Fail: Data transaction succeeded but should have failed ($explanation): <$reply>\n"; 798 return -1; 799 } else { 800 print "Success: Data transaction failed as it should have ($explanation): <$reply>\n" unless $opts{quiet}; 801 return 0; 802 } 803 } 804 last; 805 } 806 } 807 die "I/O error\n" if $from_smtp->error; 808 809 last; # sent whole message, go check receipt 810 } elsif ($r <= 8 && $smtp_burl_imap && $burl_ok && defined($fragment) && 811 $rawsections[$fragno - 2] !~ /Content-transfer-encoding: binary/i && 812 $fragment !~ /Content-transfer-encoding: binary/i) { 813 print "$dtag (burl append)...\n" unless $opts{quiet}; 814 imap_send_data("done\r\n"); 815 imap_flush(); 816 while ($reply = $from_imap->getline()) { 817 imap_printS($reply) if $opts{verbose}; 818 $reply =~ s/[\r\n]+$//; 819 if ($reply =~ /^i /) { 820 if ($reply !~ /i OK (\[.*\])?/) { 821 die "Idle failed: <$reply>\n"; 822 } 823 last; 824 } 825 } 826 die "I/O error\n" if $from_imap->error; 827 $imap_idle = 0; 828 829 my $size = length($message); 830 imap_send_data("a$dtag append scratchbox {$size}\r\n"); 831 imap_flush(); 832 $reply = $from_imap->getline(); 833 die "I/O error\n" if $from_imap->error; 834 imap_printS($reply) if $opts{verbose}; 835 $reply =~ s/[\r\n]+$//; 836 if ($reply ne "+ OK") { 837 die "Append failed: <$reply>\n"; 838 } 839 imap_send_data("$message\r\n"); 840 imap_flush(); 841 while ($reply = $from_imap->getline()) { 842 imap_printS($reply) if $opts{verbose}; 843 $reply =~ s/[\r\n]+$//; 844 if ($reply =~ /^a$dtag /) { 845 if ($reply !~ /a$dtag OK /) { 846 die "Append failed: <$reply>\n"; 847 } 848 last; 849 } 850 } 851 die "I/O error\n" if $from_imap->error; 852 my ($uidvalidity, $uid) = ($reply =~ /\[APPENDUID (\d+) (\d+)\]/); 853 die "Append reply missing APPENDUID: <$reply>\n" unless defined $uid; 854 855 print "$dtag (burl genurlauth)...\n" unless $opts{quiet}; 856 imap_send_data("g$dtag genurlauth imap://$opts{user}\@$opts{host}/scratchbox;uidvalidity=$uidvalidity/;uid=$uid/;section=$secno;urlauth=submit+$opts{user} internal\r\n"); 857 imap_flush(); 858 my $url; 859 while ($reply = $from_imap->getline()) { 860 imap_printS($reply) if $opts{verbose}; 861 $reply =~ s/[\r\n]+$//; 862 if ($reply =~ /^g$dtag /) { 863 if ($reply !~ /g$dtag OK /) { 864 die "Genurlauth failed: <$reply>\n"; 865 } 866 last; 867 } elsif ($reply =~ /^\* GENURLAUTH "(.*)"/i || 868 $reply =~ /^\* GENURLAUTH (.*)/i) { 869 $url = $1; 870 $lasturl = $1; 871 } 872 } 873 die "I/O error\n" if $from_imap->error; 874 die "Genurlauth returned no URL\n" unless defined $url; 875 876 print "$dtag (burl idle)...\n" unless $opts{quiet}; 877 imap_send_data("i idle\r\n"); 878 imap_flush(); 879 while ($reply = $from_imap->getline()) { 880 imap_printS($reply) if $opts{verbose}; 881 $reply =~ s/[\r\n]+$//; 882 if ($reply =~ /^\+ /) { 883 $imap_idle = 1; 884 last; 885 } elsif ($reply =~ /^i /) { 886 die "Idle failed: <$reply>\n"; 887 } 888 } 889 die "I/O error\n" if $from_imap->error; 890 891 my $last = $fragno == @fragments ? " last" : ""; 892 print "$dtag (burl$last)...\n" unless $opts{quiet}; 893 smtp_send_data("burl $url$last\r\n"); 894 smtp_flush(); 895 while ($reply = $from_smtp->getline()) { 896 smtp_printS($reply) if $opts{verbose}; 897 $reply =~ s/[\r\n]+$//; 898 if ($reply =~ /^\d+ /) { 899 if ($expect_OK) { 900 if ($reply !~ /^250 /) { 901 print STDERR "Fail: Burl failed but should have succeeded: <$reply>\n"; 902 return -1; 903 } 904 } else { 905 if ($reply =~ /^250 /) { 906 print STDERR "Fail: Burl succeeded but should have failed ($explanation): <$reply>\n"; 907 return -1; 908 } else { 909 print "Success: Burl failed as it should have ($explanation): <$reply>\n" unless $opts{quiet}; 910 return 0; 911 } 912 } 913 last; 914 } 915 } 916 die "I/O error\n" if $from_smtp->error; 917 } else { 918 $fragment = $rawsections[$fragno - 1] unless defined $fragment; 919 920 my $last = $fragno == @fragments ? " last" : ""; 921 print "$dtag (bdat$last)...\n" unless $opts{quiet}; 922 my $size = length($fragment); 923 smtp_send_data("bdat $size$last\r\n"); 924 smtp_send_data($fragment); 925 smtp_flush(); 926 while ($reply = $from_smtp->getline()) { 927 smtp_printS($reply) if $opts{verbose}; 928 $reply =~ s/[\r\n]+$//; 929 if ($reply =~ /^\d+ /) { 930 if ($expect_OK) { 931 if ($reply !~ /^250 /) { 932 print STDERR "Fail: Bdat failed but should have succeeded: <$reply>\n"; 933 return -1; 934 } 935 } else { 936 if ($reply =~ /^250 /) { 937 print STDERR "Fail: Bdat succeeded but should have failed ($explanation): <$reply>\n"; 938 return -1; 939 } else { 940 print "Success: Bdat failed as it should have ($explanation): <$reply>\n" unless $opts{quiet}; 941 return 0; 942 } 943 } 944 last; 945 } 946 } 947 die "I/O error\n" if $from_smtp->error; 948 } 949 } 950 951 while (int(rand(4)) == 0) { 952 # make sure extra bdat or burl fails 953 # make sure bdat input is properly eaten on error 954 my $cmd = defined $lasturl ? "burl" : "bdat"; 955 my $last = int(rand(2)) == 0 ? " last" : ""; 956 print "$dtag ($cmd$last)...\n" unless $opts{quiet}; 957 if ($cmd eq "burl") { 958 smtp_send_data("burl $lasturl$last\r\n"); 959 } else { 960 smtp_send_data("bdat 6$last\r\nfail\r\n"); 961 } 962 smtp_flush(); 963 failif(1, "BURL/BDAT after DATA or LAST"); 964 while ($reply = $from_smtp->getline()) { 965 smtp_printS($reply) if $opts{verbose}; 966 $reply =~ s/[\r\n]+$//; 967 if ($reply =~ /^\d+ /) { 968 if ($reply =~ /^250 /) { 969 print STDERR "Fail: Extra bdat/burl succeeded but should have failed ($explanation): <$reply>\n"; 970 return -1; 971 } 972 last; 973 } 974 } 975 die "I/O error\n" if $from_smtp->error; 976 } 977 978 # now verify correct receipt 979 print "waiting for receipt...\n" unless $opts{quiet}; 980 die unless $imap_idle; 981 my ($exists, $recent); 982 my $keepalive = 0; 983 while ($reply = $from_imap->getline()) { 984 imap_printS($reply) if $opts{verbose}; 985 $reply =~ s/[\r\n]+$//; 986 if ($reply =~ /^\* (\d+) EXISTS/i) { 987 $exists = $1; 988 } elsif ($reply =~ /^\* (\d+) RECENT/i) { 989 $recent = $1; 990 } elsif ($reply =~ /^\* OK/) { 991 ++$keepalive; 992 } 993 last if defined $exists and defined $recent; 994 last if $keepalive >= 2; # 2 minutes per... 995 } 996 die "I/O error\n" if $from_imap->error; 997 imap_send_data("done\r\n"); 998 imap_flush(); 999 while ($reply = $from_imap->getline()) { 1000 imap_printS($reply) if $opts{verbose}; 1001 $reply =~ s/[\r\n]+$//; 1002 if ($reply =~ /^i /) { 1003 if ($reply !~ /i OK (\[.*\])?/) { 1004 die "Idle failed: <$reply>\n"; 1005 } 1006 last; 1007 } 1008 } 1009 die "I/O error\n" if $from_imap->error; 1010 $imap_idle = 0; 1011 1012 if (!defined($exists)) { 1013 # idle failed for some reason. try closing and reselecting the inbox 1014 print STDERR "Warning: IMAP IDLE command did not inform of the new message.\n" . 1015 "Trying to recover but the message may be stuck in the queue....\n"; 1016 1017 print "close...\n" unless $opts{quiet}; 1018 imap_send_data("x close\r\n"); 1019 imap_flush(); 1020 while ($reply = $from_imap->getline()) { 1021 imap_printS($reply) if $opts{verbose}; 1022 $reply =~ s/[\r\n]+$//; 1023 if ($reply =~ /^x /) { 1024 last; 1025 } 1026 } 1027 die "I/O error\n" if $from_imap->error; 1028 1029 print "select...\n" unless $opts{quiet}; 1030 imap_send_data("c select inbox\r\n"); 1031 imap_flush(); 1032 while ($reply = $from_imap->getline()) { 1033 imap_printS($reply) if $opts{verbose}; 1034 $reply =~ s/[\r\n]+$//; 1035 if ($reply =~ /^c OK /) { 1036 last; 1037 } elsif ($reply =~ /^\* (\d+) EXISTS/i) { 1038 $exists = $1; 1039 } 1040 } 1041 die "I/O error\n" if $from_imap->error; 1042 1043 die "Can't determine number of messages in INBOX\n" 1044 if !defined($exists); 1045 } 1046 if ($exists <= $inbox_message_count) { 1047 print STDERR "Fail: Message not delivered. (EXISTS $exists now, $inbox_message_count before)\n"; 1048 return -1; 1049 } 1050 $inbox_message_count = $exists; 1051 1052 my $cleaned_len = length($cleaned); 1053 1054 print "fetch...\n" unless $opts{quiet}; 1055 imap_send_data("$ctag fetch $exists rfc822\r\n"); 1056 imap_flush(); 1057 my $verify = ""; 1058 my $verify_size = 0; 1059 while ($reply = $from_imap->getline()) { 1060 imap_printS($reply) if $opts{verbose}; 1061 $reply =~ s/[\r\n]+$//; 1062 if ($reply =~ /^$ctag /) { 1063 if ($reply !~ /$ctag OK (\[.*\])?/) { 1064 die "Fetch failed: <$reply>\n"; 1065 } 1066 last; 1067 } elsif ($reply =~ /^\* (\d+) FETCH .*{(\d+)}/i) { 1068 if ($1 != $exists) { 1069 die "Fetch returned wrong message $1, expected $exists\n"; 1070 } elsif ($2 < $cleaned_len) { 1071 print STDERR "Fetch returned wrong size $2, expected >= $cleaned_len\n"; 1072 } 1073 $verify_size = $2; 1074 } else { 1075 $verify .= "$reply\r\n"; 1076 } 1077 } 1078 die "I/O error\n" if $from_imap->error; 1079 $verify =~ s/\)\r\n$//; 1080 if ($verify_size < $cleaned_len || 1081 !message_fuzzy_equal($verify, $cleaned)) { 1082 print STDERR "Fail: Fetched data does not match delivered message.\nFormat: $format\nOriginal:\n$message\nExpected:\n$cleaned\nGot:\n$verify\n"; 1083 return -1; 1084 } 1085 1086 print "idle...\n" unless $opts{quiet}; 1087 imap_send_data("i idle\r\n"); 1088 imap_flush(); 1089 while ($reply = $from_imap->getline()) { 1090 imap_printS($reply) if $opts{verbose}; 1091 $reply =~ s/[\r\n]+$//; 1092 if ($reply =~ /^\+ /) { 1093 $imap_idle = 1; 1094 last; 1095 } elsif ($reply =~ /^i /) { 1096 die "Idle failed: <$reply>\n"; 1097 } 1098 } 1099 die "I/O error\n" if $from_imap->error; 1100 1101 print "Success: Delivery and fetch succeeded and matched.\n" unless $opts{quiet}; 1102 return $expect_OK; 1103} 1104 1105sub message 1106{ 1107 my $format = shift; 1108 my $tag = shift or die; 1109 my $message = ""; 1110 my $cleaned = ""; 1111 my @rawsections = (); 1112 my @cleansections = (); 1113 my @fetchable = (); 1114 my $encoding; 1115 do { 1116 # 33% chance for 7bit, 8bit, binary 1117 $encoding = $encodings_top[int(rand(@encodings_top - 1)) + 1]; 1118 } while (!sub_encoding_allowed($encoding)); 1119 # 16% "", 16% 7bit, 33% 8bit, 33% binary 1120 $encoding = "" if $encoding eq "7bit" && int(rand(2)) == 0; 1121 my $type; 1122 do { 1123 # like above 1124 $type = $types[int(rand(@types - 1)) + 1]; 1125 } while (!type_encoding_allowed($type, $encoding)); 1126 $type = "" if $type eq "text/plain" && int(rand(2)) == 0; 1127 my @funcs = @{$typefuncs{$type}}; 1128 my $header_func = $funcs[0]; 1129 my $body_func = $funcs[1]; 1130 my ($type_header, $context) = $header_func->($type); 1131 1132 my $am_top = !defined($top_encoding); 1133 1134 my @headers; 1135 push @headers, "Message-Id: <$tag-".int(rand(2_000_000_000))."\@bdat.pl>"; 1136 push @headers, "From: Bdat Script <bdat\@bdat.pl>"; 1137 push @headers, "To: $opts{user}\@$opts{host}"; 1138 push @headers, $type_header unless $type eq ""; 1139 push @headers, "Content-Transfer-Encoding: $encoding" unless $encoding eq ""; 1140 push @headers, "Subject: test message $tag from bdat.pl pid $$"; 1141 push @headers, "MIME-Version: 1.0"; 1142 @headers = shuffle(@headers); 1143 push @headers, ""; 1144 my $header = join("\r\n", @headers) . "\r\n"; 1145 $message .= $header; 1146 push @rawsections, $header if $am_top; 1147 if ($format =~ /binarymime/) { 1148 if ($type =~ /multipart/ || $type =~ /message/) { 1149 $header =~ s/(content-transfer-encoding): binary/$1: 7bit/i; 1150 } else { 1151 $header =~ s/(content-transfer-encoding): binary/$1: base64/i; 1152 } 1153 } 1154 $cleaned .= $header; 1155 1156 if ($am_top) { 1157 $top_encoding = $encoding; 1158 push @cleansections, $header; 1159 push @fetchable, undef; # top-level headers not available via urlfetch 1160 } 1161 my ($fullpart, $cleanpart, $rawsectionspart, $cleansectionspart, $fetchablepart) = $body_func->($format, $encoding, $context); 1162 $message .= $fullpart; 1163 $cleaned .= $cleanpart; 1164 if ($am_top) { 1165 undef $top_encoding; 1166 push @rawsections, @$rawsectionspart; 1167 push @cleansections, @$cleansectionspart; 1168 push @fetchable, @$fetchablepart; 1169 1170 die unless @rawsections == @cleansections; 1171 if (@rawsections > 0 && 1172 $rawsections[$#rawsections] eq $cleansections[$#cleansections] && 1173 substr($rawsections[$#rawsections], -2) ne "\r\n") { 1174 die if substr($message, -2) eq "\r\n"; 1175 die if substr($cleaned, -2) eq "\r\n"; 1176 $message .= "\r\n"; 1177 $cleaned .= "\r\n"; 1178 $rawsections[$#rawsections] .= "\r\n"; 1179 $cleansections[$#cleansections] .= "\r\n"; 1180 $fetchable[$#fetchable] .= "\r\n" if defined($fetchable[$#fetchable]); 1181 } 1182 } else { 1183 push @rawsections, $message; 1184 push @cleansections, $cleaned; 1185 push @fetchable, $cleaned; 1186 } 1187 1188 return ($message, $cleaned, \@rawsections, \@cleansections, \@fetchable); 1189} 1190 1191sub header_plain 1192{ 1193 my $type = shift; 1194 my $header = "Content-type: $type"; 1195 return ($header, undef); 1196} 1197 1198sub body_plain 1199{ 1200 my $format = shift; 1201 my $encoding = shift; 1202 1203 my @words = ("", "I", "hi", "cod", "sole", "shark", "salmon", "walleye", 1204 "flounder", "orange roughy"); 1205 push @words, <<EOT; 1206Four score and seven years ago our fathers brought forth on this 1207continent a new nation, conceived in Liberty, and dedicated to the 1208proposition that all men are created equal. 1209 1210Now we are engaged in a great civil war, testing whether that nation, or 1211any nation, so conceived and so dedicated, can long endure. We are met 1212on a great battle-field of that war. We have come to dedicate a portion 1213of that field, as a final resting place for those who here gave their 1214lives that that nation might live. It is altogether fitting and proper 1215that we should do this. 1216 1217But, in a larger sense, we can not dedicate... we can not consecrate... 1218we can not hallow this ground. The brave men, living and dead, who 1219struggled here, have consecrated it, far above our poor power to add or 1220detract. The world will little note, nor long remember what we say here, 1221but it can never forget what they did here. It is for us the living, 1222rather, to be dedicated here to the unfinished work which they who 1223fought here have thus far so nobly advanced. It is rather for us to be 1224here dedicated to the great task remaining before us -- that from these 1225honored dead we take increased devotion to that cause for which they 1226gave the last full measure of devotion -- that we here highly resolve 1227that these dead shall not have died in vain -- that this nation, under 1228God, shall have a new birth of freedom -- and that government of the 1229people, by the people, for the people, shall not perish from the earth. 1230EOT 1231 my $word = $words[int(rand(@words))]; 1232 chomp $word; 1233 $word = "$word\n"; 1234 $word .= "\n" x int(rand(3)); 1235 $word =~ s/\n/\r\n/gs; 1236 1237 my $clean = $encodingfuncs{$encoding}->($format, $word); 1238 $word = $clean if $encoding eq "base64" || $encoding eq "quoted-printable"; 1239 return ($word, $clean, [$word], [$clean], [$word]); 1240} 1241 1242sub header_message 1243{ 1244 return header_plain(shift); 1245} 1246 1247sub body_message 1248{ 1249 my $format = shift; 1250 1251 return message($format, "encapsulated"); 1252} 1253 1254sub header_gibberish 1255{ 1256 return header_plain(shift); 1257} 1258 1259sub body_gibberish 1260{ 1261 my $format = shift; 1262 my $encoding = shift; 1263 1264 my ($gibberish, $clean); 1265 do { 1266 $gibberish = ""; 1267 1268 my $length = int(rand(5000)) + 1; 1269 $gibberish .= chr(int(rand(256))) for (1..$length); 1270 if ($encoding =~ /8bit/) { 1271 $gibberish =~ s/\0//g; # 8bit forbids NUL 1272 1 while $gibberish =~ s/(\A|[^\r])\n/$1\r\n/g; # 8bit is line-oriented 1273 1 while $gibberish =~ s/\r([^\n]|\z)/\r\n$1/g; # 8bit is line-oriented 1274 $gibberish .= "\r\n" unless substr($gibberish, -2) eq "\r\n"; 1275 } 1276 1277 $clean = $encodingfuncs{$encoding}->($format, $gibberish); 1278 1279 # . at beginning of line will be removed, so try again 1280 } while (($encoding ne "binary" || $format !~ /binarymime/) && ($gibberish =~ /^\./m || $clean =~ /^\./m)); 1281 1282 $gibberish = $clean if $encoding eq "base64" || $encoding eq "quoted-printable"; 1283 return ($gibberish, $clean, [$gibberish], [$clean], [$gibberish]); 1284} 1285 1286sub header_mixed 1287{ 1288 my $type = shift; 1289 my $sep = "sep" . int(rand(2_000_000_000)); 1290 my $header = "Content-type: $type;\r\n\tboundary=$sep"; 1291 return ($header, $sep); 1292} 1293 1294sub body_mixed 1295{ 1296 my $format = shift; 1297 my $encoding = shift; 1298 my $sep = shift or die; 1299 my $nparts = int(rand(5)) + 1; 1300 1301 # preamble 1302 my ($data, $clean, @rawsections, @cleansections, @fetchable); 1303 $data .= "preamble\r\n"; 1304 $clean .= "preamble\r\n"; 1305 push @rawsections, "preamble\r\n"; 1306 push @cleansections, "preamble\r\n"; 1307 push @fetchable, undef; 1308 1309 for my $partno (1..$nparts) { 1310 my $partencoding; 1311 do { 1312 $partencoding = $encodings_sub[int(rand(@encodings_sub - 1)) + 1]; 1313 } while (!sub_encoding_allowed($partencoding)); 1314 $partencoding = "" if $partencoding eq "7bit" && int(rand(2)) == 0; 1315 my $parttype; 1316 do { 1317 $parttype = $types[int(rand(@types - 1)) + 1]; 1318 } while (!type_encoding_allowed($parttype, $partencoding)); 1319 $parttype = "" if $parttype eq "text/plain" && int(rand(2)) == 0; 1320 my @partfuncs = @{$typefuncs{$parttype}}; 1321 my $partheader_func = $partfuncs[0]; 1322 my $partbody_func = $partfuncs[1]; 1323 my ($parttype_header, $partcontext) = $partheader_func->($parttype); 1324 1325 my @partheaders; 1326 push @partheaders, $parttype_header unless $parttype eq ""; 1327 push @partheaders, "Content-transfer-encoding: $partencoding" unless $partencoding eq ""; 1328 push @partheaders, "Mime-version: 1.0" if int(rand(2)) == 0; 1329 push @partheaders, "Content-disposition: inline" if int(rand(2)) == 0; 1330 @partheaders = shuffle(@partheaders); 1331 unshift @partheaders, "\r\n--$sep"; 1332 push @partheaders, ""; 1333 my $partheader = join("\r\n", @partheaders) . "\r\n"; 1334 $data .= $partheader; 1335 push @rawsections, $partheader; 1336 if ($format =~ /binarymime/) { 1337 if ($parttype =~ /multipart/ || $parttype =~ /message/) { 1338 $partheader =~ s/(content-transfer-encoding): binary/$1: 7bit/i; 1339 } else { 1340 $partheader =~ s/(content-transfer-encoding): binary/$1: base64/i; 1341 } 1342 } 1343 $clean .= $partheader; 1344 push @cleansections, $partheader; 1345 push @fetchable, undef; 1346 1347 my ($partfull, $partclean, undef, undef, undef) = $partbody_func->($format, $partencoding, $partcontext); 1348 if ($partno < $nparts && int(rand(2)) == 0 && $partfull eq $partclean) { 1349 # make sure sections not ending with linebreaks work 1350 # but only if the clean hasn't already been folded into base64 1351 if (substr($partfull, -2) eq "\r\n") { 1352 $partfull =~ s/\r\n\z//; 1353 $partclean =~ s/\r\n\z//; 1354 } elsif (substr($partfull, -1) eq "\n") { 1355 $partfull =~ s/\n\z//; 1356 $partclean =~ s/\n\z//; 1357 } 1358 } 1359 $data .= $partfull; 1360 $clean .= $partclean; 1361 push @rawsections, $partfull; # don't need divided subsections 1362 push @cleansections, $partclean; # don't need divided subsections 1363 push @fetchable, $partfull; # don't need divided subsections 1364 } 1365 $data .= "\r\n--$sep--\r\n"; 1366 $clean .= "\r\n--$sep--\r\n"; 1367 push @rawsections, "\r\n--$sep--\r\n"; 1368 push @cleansections, "\r\n--$sep--\r\n"; 1369 push @fetchable, undef; 1370 1371 # epilogue 1372 $data .= "epilogue\r\n"; 1373 $clean .= "epilogue\r\n"; 1374 push @rawsections, "epilogue\r\n"; 1375 push @cleansections, "epilogue\r\n"; 1376 push @fetchable, undef; 1377 1378 return ($data, $clean, \@rawsections, \@cleansections, \@fetchable); 1379} 1380 1381sub type_encoding_allowed 1382{ 1383 my $type = shift; 1384 my $encoding = shift; 1385 1386 if ($type =~ m,message/, || $type =~ m,multipart/,) { 1387 return $encoding ne "base64" && $encoding ne "quoted-printable"; 1388 } elsif ($type =~ m,application/,) { 1389 return $encoding ne "" && $encoding ne "7bit"; 1390 } 1391 return 1; 1392} 1393 1394sub sub_encoding_allowed 1395{ 1396 my $sub_encoding = shift; 1397 1398 return 1 if !defined($top_encoding); 1399 if ($sub_encoding eq "8bit") { 1400 return $top_encoding eq "8bit" || $top_encoding eq "binary"; 1401 } elsif ($sub_encoding eq "binary") { 1402 return $top_encoding eq "binary"; 1403 } 1404 return 1; 1405} 1406 1407sub clean_7bit 1408{ 1409 my $format = shift; 1410 my $data = shift; 1411 return $data; 1412} 1413 1414sub clean_8bit 1415{ 1416 my $format = shift; 1417 my $data = shift; 1418 return $data; 1419} 1420 1421sub clean_binary 1422{ 1423 my $format = shift; 1424 my $data = shift; 1425 return ($format =~ /binarymime/) ? clean_base64($format, $data) : $data; 1426} 1427 1428sub clean_base64 1429{ 1430 my $format = shift; 1431 my $raw = shift; 1432 my $b64 = APR::Base64::encode($raw); 1433 $b64 =~ s/(.{76})(?=.)/$1\r\n/g; 1434 return $b64; 1435} 1436 1437sub clean_qp 1438{ 1439 my $format = shift; 1440 my $raw = shift; 1441 my $qp = encode_qp($raw, "\r\n"); 1442 return $qp; 1443} 1444 1445sub message_fuzzy_equal 1446{ 1447 my $actual = shift; 1448 my $expected = shift; 1449 1450 # SMTP adds/modifies headers; perform fuzzy match 1451 $actual =~ s/\*\*\*JUNK MAIL\*\*\* //i; 1452 $actual =~ s/^(Date|Return-Path|Delivered-To|Received|X-Virus-Scanned|X-Amavis-Alert|X-Spam-[a-z]+): [^\n]+(\n\s[^\n]+)*\n//mgi; 1453 1454 # during delivery of non-8bit-conforming gibberish, NUL becomes 0x80 and CRLF is enforced 1455 $actual =~ s/\0/\200/g; 1456 $expected =~ s/\0/\200/g; 1457 $actual =~ s/\r{2,}\n/\r\n/g; 1458 $expected =~ s/\r{2,}\n/\r\n/g; 1459 1 while $actual =~ s/(\A|[^\r])\n/$1\r\n/g; 1460 1 while $actual =~ s/\r([^\n]|\z)/\r\n$1/g; 1461 1 while $expected =~ s/(\A|[^\r])\n/$1\r\n/g; 1462 1 while $expected =~ s/\r([^\n]|\z)/\r\n$1/g; 1463 1464 # the Content-Transfer-Encoding header(s) may be reordered but must still match 1465 my @actual_encodings; 1466 my @expected_encodings; 1467 while ($actual =~ s/^Content-Transfer-Encoding: ([^\n]+(\n\s[^\n]+)*)\n//mi) { 1468 my $cte = $1; 1469 $cte =~ s/\r//g; 1470 push @actual_encodings, $cte; 1471 } 1472 while ($expected =~ s/^Content-Transfer-Encoding: ([^\n]+(\n\s[^\n]+)*)\n//mi) { 1473 my $cte = $1; 1474 $cte =~ s/\r//g; 1475 push @expected_encodings, $cte; 1476 } 1477 my $actual_encodings = join(",", @actual_encodings); 1478 my $expected_encodings = join(",", @expected_encodings); 1479 1480 print "=== EDITED ACTUAL (Content-Transfer-Encodings: $actual_encodings) ===\n$actual\n" . 1481 "=== EDITED EXPECTED (Content-Transfer-Encodings: $expected_encodings) ===\n$expected\n" . 1482 "=== END ===\n" if $opts{debug}; 1483 return 1 if $actual_encodings eq $expected_encodings && 1484 ($actual eq $expected || $actual eq "$expected\r\n"); 1485 return 0; 1486} 1487 1488sub imap_flush 1489{ 1490 imap_send_data(undef); 1491} 1492 1493sub imap_send_data 1494{ 1495 my $data = shift; 1496 1497 state $bufsiz = undef; 1498 state $buf = ""; 1499 1500 my $flush; 1501 if (defined($data)) { 1502 if (!defined($bufsiz)) { 1503 $bufsiz = $opts{bufsiz}; 1504 if (!defined($bufsiz)) { 1505 my $r = int(rand(3)); 1506 if ($r == 0) { 1507 $bufsiz = 0; 1508 } elsif ($r == 1) { 1509 $bufsiz = int(rand(64)) + 1; 1510 } else { 1511 $bufsiz = int(rand(4096)) + 1; 1512 } 1513 } 1514 } 1515 1516 $buf .= $data; 1517 $flush = length($buf) >= $bufsiz; 1518 } else { 1519 $flush = 1; 1520 } 1521 1522 if ($flush && length($buf)) { 1523 imap_printC($buf) if $opts{verbose}; 1524 $to_imap->print($buf); 1525 1526 undef $bufsiz; 1527 $buf = ""; 1528 } 1529} 1530 1531sub smtp_flush 1532{ 1533 smtp_send_data(undef); 1534} 1535 1536sub smtp_send_data 1537{ 1538 my $data = shift; 1539 1540 state $bufsiz = undef; 1541 state $buf = ""; 1542 1543 my $flush; 1544 if (defined($data)) { 1545 if (!defined($bufsiz)) { 1546 $bufsiz = $opts{bufsiz}; 1547 if (!defined($bufsiz)) { 1548 my $r = int(rand(3)); 1549 if ($r == 0) { 1550 $bufsiz = 0; 1551 } elsif ($r == 1) { 1552 $bufsiz = int(rand(64)) + 1; 1553 } else { 1554 $bufsiz = int(rand(4096)) + 1; 1555 } 1556 } 1557 } 1558 1559 $buf .= $data; 1560 $flush = length($buf) >= $bufsiz; 1561 } else { 1562 $flush = 1; 1563 } 1564 1565 if ($flush && length($buf)) { 1566 smtp_printC($buf) if $opts{verbose}; 1567 $to_smtp->print($buf); 1568 1569 undef $bufsiz; 1570 $buf = ""; 1571 } 1572} 1573 1574sub imap_printC 1575{ 1576 my $msg = shift; 1577 imap_printX("C", $msg); 1578 print "~FLUSH~" if $opts{buftag}; 1579} 1580 1581sub imap_printS 1582{ 1583 imap_printX("S", @_); 1584} 1585 1586sub imap_printX 1587{ 1588 my $tag = shift; 1589 my $msg = shift; 1590 1591 state $lastdir = ""; 1592 state $lastmsg = "\n"; 1593 1594 if ($tag eq "C") { 1595 if ($lastdir ne "C") { 1596 print "~NO LINE TERMINATOR~\n" if $lastmsg !~ /\n$/; 1597 print ">"x72 . "\n"; 1598 $lastdir = "C"; 1599 } 1600 } else { 1601 if ($lastdir ne "S") { 1602 print "~NO LINE TERMINATOR~\n" if $lastmsg !~ /\n$/; 1603 print "<"x72 . "\n"; 1604 $lastdir = "S"; 1605 } 1606 } 1607 print $msg; 1608 $lastmsg = $msg; 1609} 1610 1611sub smtp_printC 1612{ 1613 my $msg = shift; 1614 smtp_printX("C", $msg); 1615 print "~FLUSH~" if $opts{buftag}; 1616} 1617 1618sub smtp_printS 1619{ 1620 smtp_printX("S", @_); 1621} 1622 1623sub smtp_printX 1624{ 1625 my $tag = shift; 1626 my $msg = shift; 1627 1628 state $lastdir = ""; 1629 state $lastmsg = "\n"; 1630 1631 if ($tag eq "C") { 1632 if ($lastdir ne "C") { 1633 print "~NO LINE TERMINATOR~\n" if $lastmsg !~ /\n$/; 1634 print ">"x72 . "\n"; 1635 $lastdir = "C"; 1636 } 1637 } else { 1638 if ($lastdir ne "S") { 1639 print "~NO LINE TERMINATOR~\n" if $lastmsg !~ /\n$/; 1640 print "<"x72 . "\n"; 1641 $lastdir = "S"; 1642 } 1643 } 1644 print $msg; 1645 $lastmsg = $msg; 1646} 1647 1648sub failif 1649{ 1650 my $what = shift; 1651 my $why = shift; 1652 1653 if ($what && $expect_OK) { 1654 $expect_OK = 0; 1655 $explanation = $why; 1656 } 1657} 1658