cgi-bin/LJ/DoSendEmail.pm

   1 package LJ::DoSendEmail;
   2 use strict;
   3 use Net::DNS qw(mx);
   4 use LJ::User::EmailStatus;
   5 require 'sysban.pl';
   6
   7 ## Class prop
   8 my $resolver;
   9 my $status  = '';
  10 my $code    = '';
  11 my $error   = '';
  12 my $details = '';
  13
  14 ## Class accessors
  15 sub error {
  16     my $class = shift;
  17     $error = $_[0] if @_ > 0;
  18     return $error;
  19 }
  20
  21 sub status {
  22     my $class = shift;
  23     $status = $_[0] if @_ > 0;
  24     return $status;
  25 }
  26
  27 sub code {
  28     my $class = shift;
  29     $code = $_[0] if @_ > 0;
  30     return $code;
  31 }
  32
  33
  34 sub details {
  35     my $class = shift;
  36     $details = $_[0] if @_ > 0;
  37     return $details;
  38 }
  39
  40 ##
  41 ## Send function
  42 ##
  43 # status_code:
  44 #   undef   - OK
  45 #   0       - cannot connect to MX-host or email domain.
  46 #   5xx     - smtp-status
  47 #
  48 #sub log_complete_status {
  49 #    my $status_code = shift;
  50 #    my $emails      = shift;    # One email if scalar or list of emails if array ref.
  51 #    my $message     = shift;
  52 #
  53 #    LJ::User::Email->mark($status_code, $emails, $message);
  54 #}
  55
  56 sub set_resolver { $resolver = $_[1] }
  57 sub resolver { $resolver ||= Net::DNS::Resolver->new() }
  58
  59
  60 use constant OK => 0;
  61 use constant NO_RCPT => 1;
  62 use constant NO_SUPPORTED_RCPT => 2;
  63 use constant CONNECTION_FAILED => 3;
  64 use constant SMTP_ERROR_NO_RCPT_ON_SERVER => 4;
  65 use constant SMTP_ERROR_PERMANENT         => 5;
  66 use constant SMTP_ERROR_GENERAL           => 6;
  67
  68 ##
  69 ## ->send(
  70 ##      $rcpt,
  71 ##      {
  72 ##          from         = From
  73 ##          data         = raw email with headers and bod
  74 ##          timeout      = Maximum time, in seconds, to wait for a response from the SMTP server (perldoc Net::SMTP). Default: 300
  75 ##          sender_id    = ...
  76 ##          hello_domain = ... (optional)
  77 ##      }
  78 ## )
  79 ##
  80 ## Returns one of constants defined above.
  81 sub send {
  82     my $class = shift;
  83     my ($rcpt, $opts) = @_;
  84
  85     ## do not issuing banned emails
  86     return NO_SUPPORTED_RCPT if LJ::sysban_check('email_domain', $rcpt);
  87
  88     ## read params
  89     my $from         = $opts->{from}; # Envelope From
  90     my $data         = $opts->{data};
  91     my $timeout      = $opts->{timeout} || 300;
  92     my $hello_domain = $opts->{hello_domain} || $LJ::DOMAIN;
  93
  94     ## flush class properties
  95     $class->status('');
  96     $class->code('');
  97     $class->error('');
  98     $class->details('');
  99
 100     ## is there other side? ))
 101     return NO_RCPT unless $rcpt;
 102
 103     my ($host) = $rcpt =~ /\@(.+?)$/;
 104     return NO_SUPPORTED_RCPT unless $host;
 105
 106     my @ex = ();
 107     if ($LJ::IS_DEV_SERVER){
 108         @ex = ('127.0.0.1'); ## use local relay
 109         # @ex = ('172.19.1.1');
 110         if ($opts->{internal_relays}) {
 111             warn "internal_relays";
 112             @ex = ('172.19.1.1');
 113         }
 114     } elsif ( $opts->{internal_relays} && scalar(@LJ::INTERNAL_MAIL_RELAYS) ) {
 115         @ex = @LJ::INTERNAL_MAIL_RELAYS;
 116     } else {
 117         ## give me the numbers!
 118         my @mailhosts = mx(resolver(), $host);
 119         @ex = map { $_->exchange } @mailhosts;
 120     }
 121
 122     # seen in wild:  no MX records, but port 25 of domain is an SMTP server.  think it's in SMTP spec too?
 123     @ex = ($host) unless @ex;
 124
 125     my $smtp = Net::SMTP::BetterConnecting->new(
 126                                                 \@ex,
 127                                                 Hello          => $hello_domain,
 128                                                 PeerPort       => 25,
 129                                                 ConnectTimeout => 4,
 130                                                 );
 131
 132     # TODO: Need to handle the exact reason why we have no smtp connection here. In case of DNS related problems,
 133     #       or target host connection failure we need to handle a error here. It should make sense when we
 134     #       have some global problems on our side
 135     unless ($smtp) {
 136         $class->error("Connection failed to domain '$host', MXes: [@ex]");
 137
 138         return CONNECTION_FAILED;
 139     }
 140
 141     ## Maximum time, in seconds, to wait for a response from the SMTP server
 142     $smtp->timeout($timeout);
 143     # FIXME: need to detect timeouts to log to errors, so people with ridiculous timeouts can see that's why we're not delivering mail
 144
 145     my ($this_domain) = $from =~ /\@(.+)/;
 146
 147     # remove bcc
 148     my $body = $data;
 149        $body =~ s/^(.+?\r?\n\r?\n)//s;
 150     my $headers = $1;
 151        $headers =~ s/^bcc:.+\r?\n//mig; ## remove
 152
 153     ## sender_id should provide as much info for debug as possible.
 154     ## For emails that send TheSchwartz worker is may be a
 155     ##      $job->handle->as_string.
 156     ##
 157     ## Also $sender_id is used as mail id.
 158     my $sender_id = $opts->{sender_id};
 159     unless ($sender_id){
 160         ## generate it.
 161         require Sys::Hostname;
 162         $sender_id = Sys::Hostname::hostname();
 163         $sender_id =~ s/[^-]+//;
 164
 165         $sender_id .= "-" . $$ . "-" . time();
 166     }
 167
 168     # unless they specified a message ID, let's prepend our own:
 169     unless ($headers =~ m!^message-id:.+!mi) {
 170         my $rand = LJ::rand_chars(8);
 171         my $message_id = qq|<sch-$sender_id-$rand\@$this_domain>|;
 172         $headers = "Message-ID: $message_id\r\n" . $headers;
 173     }
 174
 175     ## _do_send returns nothing on success or failed command on error.
 176     my $res = $class->_do_send($smtp, $from, $rcpt, $sender_id,
 177                                $headers, $body);
 178     $class->status($smtp->status);
 179     eval { $class->code( $smtp->code ) };
 180     my $details = eval { $smtp->code . " " . $smtp->message };
 181     $smtp->quit; ##
 182
 183     if ($res){ ## ERROR
 184         ## handle 5xx errors
 185         # ...
 186         # #? $class->on_5xx_rcpt($job, $rcpt, $details->());
 187
 188         $class->error("Permanent failure during $res phase to [$rcpt]: $details \n");
 189
 190         ## log error
 191         LJ::User::EmailStatus->handle_code(code => 5, email => $rcpt);
 192
 193         ## handle other errors
 194         if ($res eq "TO"){
 195         ## Permanent error
 196         ## no need to retry attempts
 197             return SMTP_ERROR_NO_RCPT_ON_SERVER;
 198         }
 199
 200         if ($class->status == 5){
 201             return SMTP_ERROR_PERMANENT;
 202         }
 203
 204         return SMTP_ERROR_GENERAL;
 205     }
 206
 207
 208     ## flush errors if they are.
 209     LJ::User::EmailStatus->handle_code(code => 0, email => $rcpt);
 210
 211     ##
 212     return OK;
 213 }
 214
 215 ## Send SMTP commands to server.
 216 ##      On success returns nothing
 217 ##      On error returns a command that failed.
 218 sub _do_send {
 219     my $class = shift;
 220     my ($smtp, $env_from, $rcpt, $mail_id, $headers, $body) = @_;
 221
 222     my ($this_domain) = $env_from =~ /\@(.+)/;
 223
 224     ## Send command MAIL to server.
 225     my $res = $smtp->mail($env_from);
 226
 227     ## In case of error return name of command that failed.
 228     return "MAIL" unless $res;
 229
 230     ## Provide recipient to server
 231     $res = $smtp->to($rcpt);
 232     return "TO" unless $res; # return error
 233
 234     # have to add a fake "Received: " line in here, otherwise some
 235     # stupid over-strict MTAs like bellsouth.net reject it thinking
 236     # it's spam that was sent directly (it was).  Called
 237     # "NoHopsNoAuth".
 238     $mail_id =~ s/-/00/;  # not sure if hyphen is allowed in
 239     my $date = _rfc2822_date(time());
 240     my $rcvd = qq{Received: from localhost (theschwartz [127.0.0.1])
 241                       by $this_domain (TheSchwartzMTA) with ESMTP id $mail_id;
 242                       $date
 243                   };
 244     $rcvd =~ s/\s+$//;
 245     $rcvd =~ s/\n\s+/\r\n\t/g;
 246     $rcvd .= "\r\n";
 247
 248     ## Send commands to server. On error returns the stage name.
 249     return "DATA"     unless $smtp->data;
 250     return "DATASEND" unless $smtp->datasend($rcvd . $headers . $body);
 251     return "DATAEND"  unless $smtp->dataend;
 252
 253     return; # OK
 254 }
 255
 256
 257 sub _rfc2822_date {
 258     my $time = shift;
 259     my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday) =
 260         gmtime($time);
 261     my @days = qw(Sun Mon Tue Wed Thu Fri Sat Sun);
 262     my @mon  = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 263     return sprintf("%s, %d %s %4d %02d:%02d:%02d +0000 (UTC)",
 264                    $days[$wday], $mday, $mon[$mon], $year+1900, $hour, $min, $sec);
 265 }
 266
 267 package Net::SMTP::BetterConnecting;
 268 use strict;
 269 use base 'Net::SMTP';
 270 use Net::Config;
 271 use Net::Cmd;
 272
 273 # Net::SMTP's constructor could use improvement, so this is it:
 274 #     -- retry hosts, even if they connect and say "4xx service too busy", etc.
 275 #     -- let you specify different connect timeout vs. command timeout
 276 sub new {
 277     my $self = shift;
 278     my $type = ref($self) || $self;
 279     my ($host, %arg);
 280     if (@_ % 2) {
 281         $host = shift;
 282         %arg  = @_;
 283     } else {
 284         %arg  = @_;
 285         $host = delete $arg{Host};
 286     }
 287
 288     my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
 289     my $obj;
 290     my $timeout         = $arg{Timeout} || 120;
 291     my $connect_timeout = $arg{ConnectTimeout} || $timeout;
 292
 293     my $h;
 294     foreach $h (@{ref($hosts) ? $hosts : [ $hosts ]}) {
 295         $obj = $type->IO::Socket::INET::new(PeerAddr => ($host = $h),
 296                                             PeerPort => $arg{Port} || 'smtp(25)',
 297                                             LocalAddr => $arg{LocalAddr},
 298                                             LocalPort => $arg{LocalPort},
 299                                             Proto    => 'tcp',
 300                                             Timeout  => $connect_timeout,
 301                                             )
 302             or next;
 303
 304         $obj->timeout($timeout);  # restore the original timeout
 305         $obj->autoflush(1);
 306         $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
 307
 308         my $res = $obj->response();
 309         unless ($res == CMD_OK) {
 310             $obj->close();
 311             $obj = undef;
 312             next;
 313         }
 314
 315         last if $obj;
 316     }
 317
 318     return undef unless $obj;
 319
 320     ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
 321     ${*$obj}{'net_smtp_host'}       = $host;
 322     (${*$obj}{'net_smtp_banner'})   = $obj->message;
 323     (${*$obj}{'net_smtp_domain'})   = $obj->message =~ /\A\s*(\S+)/;
 324
 325     unless ($obj->hello($arg{Hello} || "")) {
 326         $obj->close();
 327         return undef;
 328     }
 329
 330     return $obj;
 331 }
 332
 333 1;