Author: pawelz Date: Sun Feb 22 21:54:55 2009 GMT Module: SOURCES Tag: HEAD ---- Log message: - from http://jetmore.org/john/code/swaks
---- Files affected: SOURCES: swaks.pl (NONE -> 1.1) (NEW) ---- Diffs: ================================================================ Index: SOURCES/swaks.pl diff -u /dev/null SOURCES/swaks.pl:1.1 --- /dev/null Sun Feb 22 22:54:55 2009 +++ SOURCES/swaks.pl Sun Feb 22 22:54:49 2009 @@ -0,0 +1,2028 @@ +#!/usr/bin/perl + +# use 'swaks --help' to view documentation for this program +# if you want to be notified about future releases of this program, +# please send an email to [email protected] + +use strict; + +my($p_name) = $0 =~ m|/?([^/]+)$|; +my $p_version = "20061116.0"; +my $p_usage = "Usage: $p_name [--help|--version] (see --help for details)"; +my $p_cp = <<EOM; + Copyright (c) 2003-2006 John Jetmore <[email protected]> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +EOM +ext_usage(); # before we do anything else, check for --help + +my %O = (); +$| = 1; + +# need to rewrite header-HEADER opts before std option parsing +for (my $i = 0; $i < scalar(@ARGV); $i++) { + if ($ARGV[$i] =~ /^--h(?:eader)?-(.*)$/) { + $ARGV[$i] = "--header"; $ARGV[$i+1] = "$1: $ARGV[$i+1]"; + } +} +if (!load("Getopt::Long")) { + ptrans(12, "Unable to load Getopt::Long for option processing, Exiting"); + exit(1); +} +Getopt::Long::Configure("bundling_override"); +GetOptions( + 'l|input-file=s' => \$O{option_file}, # (l)ocation of input data + 'f|from:s' => \$O{mail_from}, # envelope-(f)rom address + 't|to:s' => \$O{mail_to}, # envelope-(t)o address + 'h|helo|ehlo|lhlo:s' => \$O{mail_helo}, # (h)elo string + 's|server:s' => \$O{mail_server}, # (s)erver to use + 'p|port:s' => \$O{mail_port}, # (p)ort to use + 'protocol:s' => \$O{mail_protocol}, # protocol to use (smtp, esmtp, lmtp) + 'd|data:s' => \$O{mail_data}, # (d)ata portion ('\n' for newlines) + 'timeout:s' => \$O{timeout}, # timeout for each trans (def 30s) + 'g' => \$O{data_on_stdin}, # (g)et data on stdin + 'm' => \$O{emulate_mail}, # emulate (M)ail command + 'q|quit|quit-after=s' => \$O{quit_after}, # (q)uit after + 'n|suppress-data' => \$O{suppress_data}, # do (n)ot print data portion + 'a|auth:s' => \$O{auth}, # force auth, exit if not supported + 'au|auth-user:s' => \$O{auth_user}, # user for auth + 'ap|auth-password:s' => \$O{auth_pass}, # pass for auth + 'am|auth-map=s' => \$O{auth_map}, # auth type map + #'ahp|auth-hide-password' => \$O{auth_hidepw}, # hide passwords when possible + 'apt|auth-plaintext' => \$O{auth_showpt}, # translate base64 strings + 'ao|auth-optional:s' => \$O{auth_optional}, # auth optional (ignore failure) + 'support' => \$O{get_support}, # report capabilties + 'li|local-interface:s' => \$O{lint}, # local interface to use + 'tls' => \$O{tls}, # use TLS + 'tlso|tls-optional' => \$O{tls_optional}, # use tls if available + 'tlsc|tls-on-connect' => \$O{tls_on_connect}, # use tls if available + 'S|silent+' => \$O{silent}, # suppress output to varying degrees + 'nsf|no-strip-from' => \$O{no_strip_from}, # Don't strip From_ line from DATA + 'nth|no-hints' => \$O{no_hints}, # Don't show transaction hints + 'hr|hide-receive' => \$O{hide_receive}, # Don't show reception lines + 'hs|hide-send' => \$O{hide_send}, # Don't show sending lines + 'stl|show-time-lapse:s' => \$O{show_time_lapse}, # print lapse for send/recv + 'ndf|no-data-fixup' => \$O{no_data_fixup}, # don't touch the data + 'pipe:s' => \$O{pipe_cmd}, # command to communicate with + 'socket:s' => \$O{socket}, # unix domain socket to talk to + 'body:s' => \$O{body_822}, # the content of the body of the DATA + 'attach-type|attach:s' => \...@{$o{attach_822}}, # A file to attach + 'ah|add-header:s' => \...@{$o{add_header}}, # replacement for %H DATA token + 'header:s' => \...@{$o{header}}, # replace header if exist, else add + 'dump' => \$O{dump_args}, # build options and dump + 'pipeline' => \$O{pipeline}, # attempt PIPELINING + 'force-getpwuid' => \$O{force_getpwuid} # use getpwuid building -f +) || exit(1); + +# lists of dependencies for features +%G::dependencies = ( + auth => { name => "Basic AUTH", opt => ['MIME::Base64'], + req => [] }, + auth_cram_md5 => { name => "AUTH CRAM-MD5", req => ['Digest::MD5'] }, + auth_cram_sha1 => { name => "AUTH CRAM-SHA1", req => ['Digest::SHA1'] }, + auth_ntlm => { name => "AUTH NTLM", req => ['Authen::NTLM'] }, + auth_digest_md5 => { name => "AUTH DIGEST-MD5", + req => ['Authen::DigestMD5'] }, + dns => { name => "MX Routing", req => ['Net::DNS'] }, + tls => { name => "TLS", req => ['Net::SSLeay'] }, + pipe => { name => "Pipe Transport", req => ['IPC::Open2'] }, + socket => { name => "Socket Transport", req => ['IO::Socket'] }, + date_manip => { name => "Date Manipulation", req => ['Time::Local'] }, + hostname => { name => "Local Hostname Detection", + req => ['Sys::Hostname'] }, + hires_timing => { name => "High Resolution Timing", + req => ['Time::HiRes'] }, +); + +if ($O{get_support}) { + test_support(); + exit(0); +} + +# We need to fix things up a bit and set a couple of global options +my $opts = process_args(\%O); + +if ($G::dump_args) { + test_support(); + print "dump_args = ", $G::dump_args ? "TRUE" : "FALSE", "\n"; + print "server_only = ", $G::server_only ? "TRUE" : "FALSE", "\n"; + print "show_time_lapse = ", $G::show_time_lapse ? "TRUE" : "FALSE", "\n"; + print "show_time_hires = ", $G::show_time_hires ? "TRUE" : "FALSE", "\n"; + print "auth_showpt = ", $G::auth_showpt ? "TRUE" : "FALSE", "\n"; + print "suppress_data = ", $G::suppress_data ? "TRUE" : "FALSE", "\n"; + print "no_hints = ", $G::no_hints ? "TRUE" : "FALSE", "\n"; + print "hide_send = ", $G::hide_send ? "TRUE" : "FALSE", "\n"; + print "hide_receive = ", $G::hide_receive ? "TRUE" : "FALSE", "\n"; + print "pipeline = ", $G::pipeline ? "TRUE" : "FALSE", "\n"; + print "silent = $G::silent\n"; + print "protocol = $G::protocol\n"; + print "type = $G::link{type}\n"; + print "server = $G::link{server}\n"; + print "sockfile = $G::link{sockfile}\n"; + print "process = $G::link{process}\n"; + print "from = $opts->{from}\n"; + print "to = $opts->{to}\n"; + print "helo = $opts->{helo}\n"; + print "port = $G::link{port}\n"; + print "tls = "; + if ($G::tls) { + print "starttls (", $G::tls_optional ? 'optional' : 'required', ")\n"; + } elsif ($G::tls_on_connect) { + print "on connect (required)\n"; + } else { print "no\n"; } + print "auth = "; + if ($opts->{a_type}) { + print $G::auth_optional ? 'optional' : 'yes', " type='", + join(',', @{$opts->{a_type}}), "' ", + "user='$opts->{a_user}' pass='$opts->{a_pass}'\n"; + } else { print "no\n"; } + print "auth map = ", join("\n".' 'x19, + map { "$_ = ". + join(', ', @{$G::auth_map_t{$_}}) + } (keys %G::auth_map_t) + ), "\n"; + print "quit after = $G::quit_after\n"; + print "local int = $G::link{lint}\n"; + print "timeout = $G::link{timeout}\n"; + print "data = <<.\n$opts->{data}\n"; + exit(0); +} + +# we're going to abstract away the actual connection layer from the mail +# process, so move the act of connecting into its own sub. The sub will +# set info in global hash %G::link +# XXX instead of passing raw data, have processs_opts create a link_data +# XXX hash that we can pass verbatim here +open_link(); + +sendmail($opts->{from}, $opts->{to}, $opts->{helo}, $opts->{data}, + $opts->{a_user}, $opts->{a_pass}, $opts->{a_type}); + +teardown_link(); + +exit(0); + +sub teardown_link { + if ($G::link{type} eq 'socket-inet' || $G::link{type} eq 'socket-unix') { + # XXX need anything special for tls teardown? + close($G::link{sock}); + ptrans(11, "Connection closed with remote host."); + } elsif ($G::link{type} eq 'pipe') { + delete($SIG{PIPE}); + $SIG{CHLD} = 'IGNORE'; + close($G::link{sock}{wr}); + close($G::link{sock}{re}); + ptrans(11, "Connection closed with child process."); + } +} + +sub open_link { + if ($G::link{type} eq 'socket-inet') { + ptrans(11, "Trying $G::link{server}:$G::link{port}..."); + $@ = ""; + $G::link{sock} = IO::Socket::INET->new(PeerAddr => $G::link{server}, + PeerPort => $G::link{port}, Proto => 'tcp', + Timeout => $G::link{timeout}, + LocalAddr => $G::link{lint}); + + if ($@) { + ptrans(12, "Error connecting $G::link{lint} " . + "to $G::link{server}:$G::link{port}:\n\t$@"); + exit(2); + } + ptrans(11, "Connected to $G::link{server}."); + } elsif ($G::link{type} eq 'socket-unix') { + ptrans(11, "Trying $G::link{sockfile}..."); + $SIG{PIPE} = 'IGNORE'; + $@ = ""; + $G::link{sock} = IO::Socket::UNIX->new(Peer => $G::link{sockfile}, + Timeout => $G::link{timeout}); + + if ($@) { + ptrans(12, "Error connecting to $G::link{sockfile}:\n\t$@"); + exit(2); + } + ptrans(11, "Connected to $G::link{sockfile}."); + } elsif ($G::link{type} eq 'pipe') { + $SIG{PIPE} = 'IGNORE'; + $SIG{CHLD} = 'IGNORE'; + ptrans(11, "Trying pipe to $G::link{process}..."); + eval{ + open2($G::link{sock}{re}, $G::link{sock}{wr}, $G::link{process}); + }; + if ($@) { + ptrans(12, "Error connecting to $G::link{process}:\n\t$@"); + exit(2); + } + select((select($G::link{sock}{wr}), $| = 1)[0]); + select((select($G::link{sock}{re}), $| = 1)[0]); + ptrans(11, "Connected to $G::link{process}."); + } else { + ptrans(12, "Unknown or unimplemented connection type " . + "$G::link{type}"); + exit(3); + } +} + +sub sendmail { + my $from = shift; # envelope-from + my $to = shift; # envelope-to + my $helo = shift; # who am I? + my $data = shift; # body of message (content after DATA command) + my $a_user = shift; # what user to auth with? + my $a_pass = shift; # what pass to auth with + my $a_type = shift; # what kind of auth (this must be set to to attempt) + my $ehlo = {}; # If server is esmtp, save advertised features here + + # start up tls if -tlsc specified + if ($G::tls_on_connect) { + if (start_tls()) { + ptrans(11, "TLS started w/ cipher $G::link{tls}{cipher}"); + } else { + ptrans(12, "TLS startup failed ($G::link{tls}{res})"); + exit(29); + } + } + + # read the server's 220 banner + do_smtp_gen(undef, '220') || do_smtp_quit(1, 21); + + # QUIT here if the user has asked us to do so + do_smtp_quit(1, 0) if ($G::quit_after eq 'connect'); + + # Send a HELO string + do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 22); + + # QUIT here if the user has asked us to do so + do_smtp_quit(1, 0) if ($G::quit_after eq 'first-helo'); + + # handle TLS here if user has requested it + if ($G::tls) { + do_smtp_quit(1, 29) if (!do_smtp_tls($ehlo) && !$G::tls_optional); + } + + # QUIT here if the user has asked us to do so + do_smtp_quit(1, 0) if ($G::quit_after eq 'tls'); + + #if ($G::link{tls}{active} && $ehlo->{STARTTLS}) { + if ($G::link{tls}{active} && !$G::tls_on_connect) { + # According to RFC3207, we need to forget state info and re-EHLO here + $ehlo = {}; + do_smtp_helo($helo, $ehlo, $G::protocol) || do_smtp_quit(1, 32); + } + + # QUIT here if the user has asked us to do so + do_smtp_quit(1, 0) if ($G::quit_after eq 'helo'); + + # handle auth here if user has requested it + if ($a_type) { + do_smtp_quit(1, 28) if (!do_smtp_auth($ehlo, $a_type, $a_user, $a_pass) + && !$G::auth_optional); + } + + # QUIT here if the user has asked us to do so + do_smtp_quit(1, 0) if ($G::quit_after eq 'auth'); + + # send MAIL + #do_smtp_gen("MAIL FROM:<$from>", '250') || do_smtp_quit(1, 23); + do_smtp_mail($from); # failures in this handled by smtp_mail_callback + + # QUIT here if the user has asked us to do so + do_smtp_quit(1, 0) if ($G::quit_after eq 'mail'); + + # send RCPT (sub handles multiple, comma-delimited recips + #do_smtp_rcpt($to) || do_smtp_quit(1, 24); + do_smtp_rcpt($to); # failures in this handled by smtp_rcpt_callback + # note that smtp_rcpt_callback increments + # $G::smtp_rcpt_failures at every failure. This and + # $G::smtp_rcpt_total are used after DATA for LMTP + + # QUIT here if the user has asked us to do so + do_smtp_quit(1, 0) if ($G::quit_after eq 'rcpt'); + + # send DATA + do_smtp_gen('DATA', '354') || do_smtp_quit(1, 25); + + # send the actual data + #do_smtp_gen($data, '250', undef, $G::suppress_data) || do_smtp_quit(1, 26); + # this was moved to a custom sub because the server will have a custom + # behaviour when using LMTP + do_smtp_data($data, $G::suppress_data) || do_smtp_quit(1, 26); + + # send QUIT + do_smtp_quit(0) || do_smtp_quit(1, 27); +} + +sub start_tls { + my %t = (); # This is a convenience var to access $G::link{tls}{...} + $G::link{tls} = \%t; + + Net::SSLeay::load_error_strings(); + Net::SSLeay::SSLeay_add_ssl_algorithms(); + Net::SSLeay::randomize(); + $t{con} = Net::SSLeay::CTX_new() || return(0); + Net::SSLeay::CTX_set_options($t{con}, &Net::SSLeay::OP_ALL); # error check + $t{ssl} = Net::SSLeay::new($t{con}) || return(0); + if ($G::link{type} eq 'pipe') { + Net::SSLeay::set_wfd($t{ssl}, fileno($G::link{sock}{wr})); # error check? + Net::SSLeay::set_rfd($t{ssl}, fileno($G::link{sock}{re})); # error check? + } else { + Net::SSLeay::set_fd($t{ssl}, fileno($G::link{sock})); # error check? + } + $t{active} = Net::SSLeay::connect($t{ssl}) == 1 ? 1 : 0; + $t{res} = Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()) + if (!$t{active}); + $t{cipher} = Net::SSLeay::get_cipher($t{ssl}); + + return($t{active}); +} + +sub ptrans { + my $c = shift; # transaction flag + my $m = shift; # message to print + my $b = shift; # be brief in what we print + my $o = \*STDOUT; + my $f; + + return if (($G::hide_send && int($c/10) == 2) || + ($G::hide_receive && int($c/10) == 3)); + + # global option silent controls what we echo to the terminal + # 0 - print everything + # 1 - don't show anything until you hit an error, then show everything + # received after that (done by setting option to 0 on first error) + # 2 - don't show anything but errors + # >=3 - don't print anything + if ($G::silent > 0) { + return if ($G::silent >= 3); + return if ($G::silent == 2 && $c%2 != 0); + if ($G::silent == 1) { + if ($c%2 != 0) { + return(); + } else { + $G::silent = 0; + } + } + } + + # 1x is program messages + # 2x is smtp send + # 3x is smtp recv + # x = 1 is info/normal + # x = 2 is error + # program info + if ($c == 11) { $f = '==='; } + # program error + elsif ($c == 12) { $f = '***'; $o = \*STDERR; } + # smtp send info + elsif ($c == 21) { $f = $G::link{tls}{active} ? ' ~>' : ' ->'; } + # smtp send error + elsif ($c == 22) { $f = $G::link{tls}{active} ? '*~>' : '**>'; } + # smtp recv info + elsif ($c == 31) { $f = $G::link{tls}{active} ? '<~ ' : '<- '; } + # smtp recv error + elsif ($c == 32) { $f = $G::link{tls}{active} ? '<~*' : '<**'; } + # something went unexpectedly + else { $c = '???'; } + + $f .= ' '; + $f = '' if ($G::no_hints && int($c/10) != 1); + + if ($b) { + # split to tmp list to prevent -w gripe + my @t = split(/\n/ms, $m); $m = scalar(@t) . " lines sent"; + } + $m =~ s/\n/\n$f/msg; + print $o "$f$m\n"; +} + +sub do_smtp_quit { + my $exit = shift; + my $err = shift; + + $G::link{allow_lost_cxn} = 1; + my $r = do_smtp_gen('QUIT', '221'); + $G::link{allow_lost_cxn} = 0; + + handle_disconnect($err) if ($G::link{lost_cxn}); + + if ($exit) { + teardown_link(); + exit $err; + } + + return($r); +} + +sub do_smtp_tls { + my $e = shift; # ehlo config hash + + if (!$e->{STARTTLS}) { + ptrans(12, "STARTTLS not supported"); + return $G::tls_optional ? 1 : 0; + } elsif (!do_smtp_gen("STARTTLS", '220')) { + return $G::tls_optional ? 1 : 0; + } elsif (!start_tls()) { + ptrans(12, "TLS startup failed ($G::link{tls}{res})"); + return $G::tls_optional ? 1 : 0; + } + + ptrans(11, "TLS started w/ cipher $G::link{tls}{cipher}"); + return(1); +} + +sub do_smtp_auth { + my $e = shift; # ehlo config hash + my $at = shift; # auth type + my $au = shift; # auth user + my $ap = shift; # auth password + + # the auth_optional stuff is handled higher up, so tell the truth about + # failing here + + # note that we don't have to check whether the modules are loaded here, + # that's done in the option processing - trust that an auth type + # wouldn't be in $at if we didn't have the correct tools. + + my $auth_attempted = 0; # set to true if we ever attempt auth + + foreach my $btype (@$at) { + # if server doesn't support, skip type (may change in future) + next if (!$e->{AUTH}{$btype}); + + foreach my $type (@{$G::auth_map_t{'CRAM-MD5'}}) { + if ($btype eq $type) { + return(1) if (do_smtp_auth_cram($au, $ap, $type)); + $auth_attempted = 1; + } + } + foreach my $type (@{$G::auth_map_t{'CRAM-SHA1'}}) { + if ($btype eq $type) { + return(1) if (do_smtp_auth_cram($au, $ap, $type)); + $auth_attempted = 1; + } + } + foreach my $type (@{$G::auth_map_t{'DIGEST-MD5'}}) { + if ($btype eq $type) { + return(1) if (do_smtp_auth_digest($au, $ap, $type)); + $auth_attempted = 1; + } + } + foreach my $type (@{$G::auth_map_t{'NTLM'}}) { + if ($btype eq $type) { + return(1) if (do_smtp_auth_ntlm($au, $ap, $type)); + $auth_attempted = 1; + } + } + foreach my $type (@{$G::auth_map_t{'PLAIN'}}) { + if ($btype eq $type) { + return(1) if (do_smtp_auth_plain($au, $ap, $type)); + $auth_attempted = 1; + } + } + foreach my $type (@{$G::auth_map_t{'LOGIN'}}) { + if ($btype eq $type) { + return(1) if (do_smtp_auth_login($au, $ap, $type)); + $auth_attempted = 1; + } + } + } + + if ($auth_attempted) { + ptrans(12, "No authentication type succeeded"); + } else { + ptrans(12, "No acceptable authentication types available"); + } + return(0); +} + +sub do_smtp_auth_ntlm { + my $u = shift; # auth user + my $p = shift; # auth password + my $as = shift; # auth type (since NTLM might be SPA or MSN) + my $r = ''; # will store smtp response + my $domain; + ($u,$domain) = split(/%/, $u); + + my $auth_string = "AUTH $as"; + do_smtp_gen($auth_string, '334') || return(0); + + my $d = db64(Authen::NTLM::ntlm()); + + $auth_string = eb64($d); + do_smtp_gen($auth_string, '334', \$r, '', $G::auth_showpt ? "$d" : '', + $G::auth_showpt ? \&unencode_smtp : '') || return(0); + + $r =~ s/^....//; # maybe something a little better here? + Authen::NTLM::ntlm_domain($domain); + Authen::NTLM::ntlm_user($u); + Authen::NTLM::ntlm_password($p); + $d = db64(Authen::NTLM::ntlm($r)); + + $auth_string = eb64($d); + do_smtp_gen($auth_string, '235', \$r, '', + $G::auth_showpt ? "$d" : '') || return(0); + + return(1); +} + +sub do_smtp_auth_digest { + my $u = shift; # auth user + my $p = shift; # auth password + my $as = shift; # auth string + my $r = ''; # will store smtp response + + my $auth_string = "AUTH $as"; + do_smtp_gen($auth_string, '334', \$r, '', '', + $G::auth_showpt ? \&unencode_smtp : '') + || return(0); + + $r =~ s/^....//; # maybe something a little better here? + $r = db64($r); + my $req = Authen::DigestMD5::Request->new($r); + my $res = Authen::DigestMD5::Response->new(); + $res->got_request($req); + # XXX using link{server} here is probably a bug, but I don;t know what else + # XXX to use yet on a non-inet-socket connection + $res->set('username' => $u, 'realm' => '', + 'digest-uri' => "smtp/$G::link{server}"); + $res->add_digest(password => $p); + my $d = $res->output(); + $auth_string = eb64($d); + + do_smtp_gen($auth_string, '334', \$r, '', $G::auth_showpt ? "$d" : '', + $G::auth_showpt ? \&unencode_smtp : '') + || return(0); + $r =~ s/^....//; # maybe something a little better here? + $r = db64($r); + $req->input($r); + return(0) if (!$req->auth_ok); + + do_smtp_gen("", '235', undef, '', + $G::auth_showpt ? "" : '') || return(0); + return(1); +} + +# This can handle both CRAM-MD5 and CRAM-SHA1 +sub do_smtp_auth_cram { + my $u = shift; # auth user + my $p = shift; # auth password + my $as = shift; # auth string + my $r = ''; # will store smtp response + + my $auth_string = "AUTH $as"; + do_smtp_gen($auth_string, '334', \$r, '', '', + $G::auth_showpt ? \&unencode_smtp : '') + || return(0); + + $r =~ s/^....//; # maybe something a little better here? + # specify which type of digest we need based on $as <<Diff was trimmed, longer than 597 lines>> _______________________________________________ pld-cvs-commit mailing list [email protected] http://lists.pld-linux.org/mailman/listinfo/pld-cvs-commit
