1# 2# MailScanner - SMTP Email Processor 3# Copyright (C) 2002 Julian Field 4# 5# $Id: Exim.pm 3638 2006-06-17 20:28:07Z sysjkf $ 6# 7# This program is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by 9# the Free Software Foundation; either version 2 of the License, or 10# (at your option) any later version. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16# 17# You should have received a copy of the GNU General Public License 18# along with this program; if not, write to the Free Software 19# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20# 21# https://www.mailscanner.info 22# 23 24package MailScanner::Sendmail; 25 26use strict 'vars'; 27use strict 'refs'; 28no strict 'subs'; # Allow bare words for parameter %'s 29 30use vars qw($VERSION); 31 32use Data::Dumper; 33use IO::Pipe; 34use Carp; 35use Encode; 36 37### The package version, both in 1.23 style *and* usable by MakeMaker: 38$VERSION = substr q$Revision: 3638 $, 10; 39 40# Command-line options you need to give to sendmail to sensibly process 41# a message that is piped to it. Still need to add the envelope sender 42# address argument for -f. This is usually local postmaster. 43my @SendmailOptions = qw"-t -oi -oem -F MailScanner -f"; 44my $UnsortedBatchesLeft; 45 46 47# Attributes are 48# 49# $DFileRegexp set by new 50# $HFileRegexp set by new 51# $TFileRegexp set by new 52# $QueueFileRegexp set by new 53# $LockType set by new 54# 55 56 57# If the sendmail and/or sendmail2 config variables aren't set, then 58# set them to something sensible. This will need to be different 59# for Exim. 60sub initialise { 61 MailScanner::Config::Default('sendmail', '/usr/sbin/exim'); 62 MailScanner::Config::Default('sendmail2', 63 MailScanner::Config::Value('sendmail'). 64 ' -C /etc/exim/exim_send.conf'); 65 $UnsortedBatchesLeft = 0; # Disable queue-clearing mode 66} 67 68# Constructor. 69# Takes dir => directory queue resides in 70sub new { 71 my $type = shift; 72 my $this = {}; 73 74 # These need to be improved 75 # No change for V4 76 $this->{DFileRegexp} = '^([-\\w]*)-D$'; 77 $this->{HFileRegexp} = '^([-\\w]*)-H$'; 78 $this->{TFileRegexp} = '^([-\\w]*)-T$'; 79 $this->{QueueFileRegexp} = '^([-\\w]*)-[A-Z]$'; 80 81 $this->{LockType} = "posix"; 82 83 bless $this, $type; 84 return $this; 85} 86 87# Required vars are: 88# 89# DFileRegexp: 90# A regexp that will verify that a filename is a valid 91# "DFile" name and leave the queue id in $1 if it is. 92# 93# HFileRegexp: 94# A regexp that will verify that a filename is a valid 95# "HFile" name and leave the queue id in $1 if it is. 96# 97# TFileRegexp: 98# A regexp that will verify that a filename is a valid 99# "TFile" name and leave the queue id in $1 if it is. 100# 101# QueueFileRegexp: 102# A regexp that will match any legitimate queue file name 103# and leave the queue id in $1. 104# 105# LockType: 106# The way we should usually do spool file locking for 107# this MTA ("posix" or "flock") 108# 109# Required subs are: 110# 111# DFileName: 112# Take a queue ID and return 113# filename for data queue file 114# 115# HFileName: 116# Take a queue ID and return 117# filename for envelope queue file 118# 119# TFileName: 120# Take a queue ID and return 121# filename for temp queue file 122# 123# BuildMessageCmd: 124# Return the shell command to take a mailscanner header file 125# and an MTA message file, and build a plain text message 126# (complete with headers) 127# 128# ReadQf: 129# Read an envelope queue file (sendmail qf) and build 130# an array of lines which together form all the mail headers. 131# 132# AddHeader: 133# Given a current set of headers (string), and another header 134# (key string, value string), return the set of headers with the new one 135# added. 136# 137# DeleteHeader: 138# Given a current set of headers (string), and another header 139# (string), return the set of headers with the new one removed. 140# 141# ReplaceHeader: 142# Given a current set of headers (string), and another header 143# (key string, value string), return the set of headers with the new one 144# in place of any existing occurence of the header. 145# 146# AppendHeader: 147# Given a current set of headers (string), another header 148# (key string, value string), and a separator string, 149# return the set of headers with the new value 150# appended to any existing occurrence of the header. 151# 152# PrependHeader: 153# Given a current set of headers (string), another header 154# (key string, value string), and a separator string, 155# return the set of headers with the new value 156# prepended to the front of any existing occurrence of the header. 157# Do the header matching in a case-insensitive way. 158# 159# TextStartsHeader: 160# Given a current set of headers (string), another header (string) 161# and a search string, 162# return true if the search string appears at the start of the 163# text of the header. 164# Do the matching in a case-insensitive way. 165# 166# ConstructHeaders: 167# Build a set of headers (in a string) ready to go into an MTA 168# envelope file. 169# 170# ReadEnvelope: 171# Given filehandle open for reading, read envelope lines into 172# string and return it. 173# 174# SplitEnvelope: 175# Given complete envelope string, separate out header lines and 176# return 2 strings, one containing the main part of the envelope, 177# the other containing the headers. 178# 179# MergeEnvelope: 180# Given main envelope body (from SplitEnvelope at the moment) and 181# string of headers, merge them to form a complete envelope. 182# 183# MergeEnvelopeParts: 184# Given filehandle open for reading, merge envelope data (excepting 185# headers) from filehandle with headers from string, and return new 186# envelope data in string, ready to be written back to new 187# envelope queue file. 188# 189# AddRecipients: 190# Return list of QF file lines for the passed recipients, which 191# are comma-separated (with optional spaces with the commas). 192# Not implemented for Exim yet. 193# 194# KickMessage: 195# Given id, tell MTA to make a delivery attempt. 196# 197# CreateQf: 198# Given a Message object, return a string containing the entire 199# header file for this MTA. 200# 201 202# Do conditional once at include time 203 204#my($MTA) = MailScanner::Config::Value('mta'); 205# 206#print STDERR "MTA is \"" . MailScanner::Config::Value('mta') . "\"\n"; 207# 208# print STDER "We are running exim\n"; 209# 210# MailScanner::Log::InfoLog("Configuring mailscanner for exim..."); 211 212sub DFileName { 213 my($this, $id) = @_; 214 return "$id-D"; 215} 216 217# No change for V4 218sub HFileName { 219 my($this, $id) = @_; 220 return "$id-H"; 221} 222 223# No change for V4 224sub TFileName { 225 my($this, $id) = @_; 226 return "$id-T"; 227} 228 229# Per-message log file is specific to Exim 230sub LFileName { 231 my($this, $id) = @_; 232 return "../msglog/$id"; 233} 234 235# sub BuildMessageCmd { 236# my($this, $hfile, $dfile) = @_; 237# return "$global::sed -e '1d' \"$dfile\" | $global::cat \"$hfile\" -"; 238# } 239 240sub ReadQf { 241 my($this, $message, $getipfromheader) = @_; 242 243 my($RQf) = $message->{store}{inhhandle}; 244 245 my %metadata; 246 my($InHeader, $InSubject, $InDel, @headers, $msginfo, $from, @to, $subject); 247 my($ip, $sender, %acl, %aclc, %aclm, $line, $acltype); 248 my(@rcvdiplist); 249 #my($read1strcvd, $ipfromheader); 250 251 #print STDERR "ReadQf for " . $message->{id} . "\n"; 252 253 # Seek to the start of the file in case anyone read the file 254 # between me opening it and locking it. 255 seek($RQf, 0, 0); 256 257 # queue file name 258 chomp($metadata{id} = <$RQf>); 259 # username, uid, gid that submitted message 260 chomp(($metadata{user},$metadata{uid},$metadata{gid}) = split / /, <$RQf>); 261 # envelope-sender (in <>) 262 $sender = <$RQf>; 263 chomp $sender; 264 $sender =~ s/^<\s*//; # leading and 265 $sender =~ s/\s*>$//; # trailing <> 266 #$sender = lc($sender); 267 $metadata{sender} = $sender; 268 #$message->{from} = $sender; 269 $message->{from} = lc($sender); 270 #JKF Don't want the < or > 271 #JKF chomp($metadata{sender} = <$RQf>); 272 #JKF $message->{from} = lc $metadata{sender}; 273 # time msg received (seconds since epoch) 274 # + number of delay warnings sent 275 chomp(($metadata{rcvtime},$metadata{warncnt}) = split / /, <$RQf>); 276 277 # Loop through -line section, setting metadata 278 # items corresponding to Exim's names for them, 279 # and tracking them in %{$metadata{dashvars}} 280 while (chomp($line = <$RQf>)) { 281 $line =~ s/^--?(\w+) ?// or last; 282 # ACLs patch starts here 283 #$metadata{dashvars}{$1} = 0; 284 #$line eq "" and $metadata{"dv_$1"} = 1, next; 285 #$metadata{"dv_$1"} = $line; 286 #$metadata{dashvars}{$1} = 1; 287 # ACLs can be -acl or -aclc or -aclm. 288 $acltype = $1; 289 if($acltype =~ /^acl[cm]?$/) { 290 # we need to handle acl vars differently 291 if($line =~ /^(\w+|_[[:alnum:]_]+) (\d+)$/) { 292 my $buf; 293 my $pos = $1; 294 my $len = $2; 295 if ($acltype eq "acl") { 296 $acl{$pos}->[0] = []; 297 } elsif ($acltype eq "aclc") { 298 $aclc{$pos}->[0] = []; 299 } elsif ($acltype eq "aclm") { 300 $aclm{$pos}->[0] = []; 301 } else { 302 # invalid format 303 last; 304 } 305 (read($RQf, $buf, $len + 1)==$len+1) or last; 306 if($buf =~ /\n$/) { 307 chomp $buf; 308 } else { 309 # invalid format 310 last; 311 } 312 if ($acltype eq "acl") { 313 $acl{$pos}->[0] = $buf; 314 } elsif ($acltype eq "aclc") { 315 $aclc{$pos}->[0] = $buf; 316 } elsif ($acltype eq "aclm") { 317 $aclm{$pos}->[0] = $buf; 318 } else { 319 # invalid format 320 last; 321 } 322 } else { 323 # this is a weird format, and we're not sure how to handle it 324 last; 325 } 326 } else { 327 $metadata{dashvars}{$1} = 0; 328 $line eq "" and $metadata{"dv_$1"} = 1, next; 329 $metadata{"dv_$1"} = $line; 330 $metadata{dashvars}{$1} = 1; 331 } 332 next; 333 } 334 $metadata{aclvars} = \%acl; 335 $metadata{aclcvars} = \%aclc; 336 $metadata{aclmvars} = \%aclm; 337 338 # If it was an invalid queue file, log a warning and tell caller 339 unless (defined $line) { 340 #MailScanner::Log::WarnLog("Batch: Ignoring invalid queue file for " . 341 # "message %s", $metadata{id}); 342 return 0; 343 } 344 345 # FIXME: we haven't really defined what $message{clientip} should 346 # be when it's a locally-submitted message... so the rest of 347 # the code probably doesn't deal with it well. 348 # 349 # JKF: Sendmail apparently generates "root@localhost" as the client ip 350 # address, which I currently don't handle at all, oops! 351 # It *doesn't* contain a numerical IP address, as opposed to SMTP 352 # connections from localhost, which get a numerical IP address as normal. 353 # So how do we describe them? Personally I think we should always treat 354 # them as normal messages, maybe just coming from 127.0.0.1. I'm not 355 # convinced that created messages should be handled differently from 356 # messages from 127.0.0.1, as that will discourage users from doing silly 357 # things like not scanning created messages. 358 # I have changed the sendmail code so it puts in 127.0.0.1. 359 # 360 # OK, well I'll probably try having a look at what it would take to 361 # differentiate it later, then... (i.e. put 'local' back in and see 362 # what breaks) 363 # 364 $message->{clientip} = (exists $metadata{dv_host_address} && 365 defined $metadata{dv_host_address})? 366 $metadata{dv_host_address}: 367 "127.0.0.1"; 368 $message->{clientip} =~ s/^(\d+\.\d+\.\d+\.\d+)(\..*)?/$1/; 369 $message->{clientip} =~ s/^([a-f\d]*)(:[a-f\d]*){6}.*$/$1$2/; 370 371 # Deal with b-tree of non-recipients 372 $metadata{nonrcpts} = {}; 373 if ($line ne "XX") { 374 my $nodecount=0; 375 my ($branches, $address) = split / /, $line; 376 $metadata{nonrcpts}{$address} = 1; 377 substr($branches,0,1) eq "Y" and $nodecount++; 378 substr($branches,1,1) eq "Y" and $nodecount++; 379 while ($nodecount) { 380 chomp($line = <$RQf>); 381 unless ($line) { 382 #MailScanner::Log::WarnLog("Batch: Ignoring invalid queue file for " . 383 # "message %s", $metadata{id}); 384 return 0; 385 } 386 # $line eq "" and **** --- invalid queue file - JKF won't get here if bad 387 ($branches, $address) = split / /, $line; 388 $nodecount--; 389 $metadata{nonrcpts}{$address} = 1; 390 substr($branches,0,1) eq "Y" and $nodecount++; 391 substr($branches,1,1) eq "Y" and $nodecount++; 392 } 393 } 394 395# This way would actually build a b-tree to store them 396# but we leave the efficiency thing to perl's hash implementation 397# above. 398# if ($line ne "XX") { 399# my @nodestack; 400# my ($branches, $address) = split / /, $line; 401# my $noderef; 402# $metadata{nonrecpts}{address} = $address; 403# $metadata{nonrecpts}{l} = {}; 404# $metadata{nonrecpts}{r} = {}; 405# substr($branches,0,1) eq "Y" and push @nodestack,$metadata{nonrecpts}{l}; 406# substr($branches,1,1) eq "Y" and push @nodestack,$metadata{nonrecpts}{r}; 407# while ($#nodestack >= 0) { 408# chomp($line = <$RQf>); 409# # $line eq "" and **** --- invalid queue file 410# ($branches, $address) = split / /, $line; 411# $noderef = pop @nodestack; 412# $noderef->{address} = $address; 413# $noderef->{l} = {}; 414# $noderef->{r} = {}; 415# substr($branches,0,1) eq "Y" and push @nodestack,$noderef->{l}; 416# substr($branches,1,1) eq "Y" and push @nodestack,$noderef->{r}; 417# } 418# } 419 420 # Get number of recipients 421 chomp($metadata{numrcpts} = <$RQf>); 422 #print STDERR "Number of recips = " . $metadata{numrcpts} . "\n"; 423 424 # Read in recipient list 425 for (my $i=0; $i<$metadata{numrcpts};$i++) { 426 chomp($line = <$RQf>); 427 #print STDERR "Read $line\n"; 428 unless (defined $line && $line ne "") { 429 #MailScanner::Log::WarnLog("Batch: Ignoring invalid queue file for " . 430 # "message %s", $metadata{id}); 431 return 0; 432 } 433 # $line eq "" and ***** -- invalid queue file 434 push @{$metadata{rcpts}}, $line; 435 unless (exists $metadata{nonrcpts}{$line}) { 436 # Add recipient to message data 437 # but deal with "special" lines first 438 # (when "one_time" option is being used) 439 # strips old "special" content <4.10 440 #print STDERR "Line before1 = **$line**\n"; 441 $line =~ s/ \d+,\d+,\d+$//; 442 #BROKEN # strips new "special" content >= 4.10 443 #BROKEN $line =~ s/ (\d+),\d+#01$//; 444 #BROKEN if (defined $1) { 445 #BROKEN $line = substr($line, 0, length($line)-$1-1); 446 #BROKEN } 447 # Patch contributed by Simon Walter. 448 # strips new "special" content >= 4.10 449 #print STDERR "Line before2 = **$line**\n"; 450 if ($line =~ s/ (\d+),\d+#1$//) { 451 #print STDERR "Line after 2 = **$line**\n"; 452 #print STDERR "Dollar 1 = **$1**\n"; 453 #print STDERR "Length = **" . length($line) . "**\n"; 454 $line = substr($line, 0, length($line)-$1-1) if defined $1; 455 } 456 #print STDERR "Line after 1 = **$line**\n"; 457 458 push @{$message->{to}}, $line; 459 } 460 } 461 462 # This line should be blank 463 chomp($line = <$RQf>); 464 if ($line) { 465 #MailScanner::Log::WarnLog("Batch: Ignoring invalid queue file for " . 466 # "message %s", $metadata{id}); 467 return 0; 468 } 469 470 # Now the message headers start 471 $InHeader = 0; 472 $InSubject = 0; 473 $InDel = 0; 474 475 # OK, don't let's confuse envelope and header data. 476 # None of these headers are actually used to determine where 477 # to deliver or anything like that. 478 # $message->{headers} should be an array of message header lines, 479 # and is (to be) regarded as RO. 480 # $metadata{headers} on the other hand needs to contain *all* 481 # information necessary to regenerate a queue file, so needs to 482 # track Exim's flags on the headers. %metadata will/must only 483 # be modified by functions in this package. 484 # 485 # I thought this loop was ugly when I wrote it... I've tidied 486 # it up a bit, but its beauty is only skin-deep, if that. 487 # --nwp 488 489 my $header = {}; 490 while (<$RQf>) { 491 # chomp()ing here would screw the header length calculations 492 $line = $_; 493 $line =~ s/\0//g; # Delete all null bytes 494 495 if ($InHeader) { 496 497 # We are expecting a continuation line... 498 $InHeader -= (length($line)); 499 if ($InHeader < 0) { 500 MailScanner::Log::NoticeLog("Header ($line) too long (wanted " . 501 "$InHeader) -- using it anyway!!"); 502 $InHeader = 0; 503 } 504 $line =~ /^[\t ]/ 505 or MailScanner::Log::NoticeLog("Header continuation ($line) doesn't" . 506 " begin with LWSP -- using it anyway!!"); 507 508 # Push line onto simple @headers array unless it's one 509 # that Exim's flagged as deleted... 510 push @headers, $line unless $InDel; 511 512 # Add it to metadata header object too. 513 $header->{body} .= $line; 514 515 # Is this header one that we need to have directly available 516 # (currently only subject) 517 $InSubject and chomp($message->{subject} .= $line); 518 519 # Track whether we're still in the middle of anything 520 $InDel = ($InDel && $InHeader); 521 $InSubject = ($InSubject && $InHeader); 522 523 # Very important 524 next; 525 } 526 527 # Looking for first line of a header... 528 if ($line =~ /^([\d]{3,})([A-Z* ]) (.*)/s) { 529 # If we've got a header built, push it onto metadata 530 # headers array and clear the decks ready to build 531 # another one. 532 if (exists $header->{name}) { 533 push @{$metadata{headers}},$header; 534 $header = {}; 535 } 536 # Has Exim flagged this header as deleted? 537 $InDel = ((my $flagchar = $2) eq '*'); 538 # got one... track length 539 $InHeader = $1 - (length($3)); 540 if ($InHeader < 0) { 541 MailScanner::Log::WarnLog("Header too long! -- using it anyway!!"); 542 $InHeader = 0; 543 } 544 my $headerstring = $3; 545 # Actually header names *MUST* only contain 546 # ASCII 33-126 decimal inclusive... 547 # ...but we'll be gentle, just in case. 548 # Note that spaces are *not* required after the colon, 549 # and if present are considered to be part of the field 550 # data, so must not be (carelessly) modified. *shrug*. 551 # We *do* want newlines to be included in $2, hence 552 # /s modifier and use of \A and \Z instead of ^ and $. 553 # Note that we have (arbitrarily, we think) decided to 554 # count the delimiting colon as part of the field name. 555 $headerstring =~ /\A([^: ]+:)(.*)\Z/s; # or ***** 556 $header->{name} = $1; 557 $header->{body} = $2; 558 $header->{flag} = $flagchar; 559 $metadata{vanishedflags}{$flagchar} = 0; 560 561 # Ignore it if it's flagged as deleted 562 unless ($InDel) { 563 # It's not deleted, so push it onto headers array 564 push @headers, $headerstring; 565 # And if it's the subject, deal with it + track it 566 if ("subject:" eq lc $1) { 567 # Make $metadata{subject} and the relevant header 568 # entry point to the same object, just to save hunting 569 # for it later. 570 $metadata{subject} = $header; 571 # And just stick an unfolded string into message subject 572 # attribute. 573 chomp($message->{subject} = $2); 574 $InSubject = 1; 575 } 576 if ("received:" eq lc $1) { 577 my $received = $2; 578 my $rcvdip = '127.0.0.1'; 579 if ($received =~ /\[(\d+\.\d+\.\d+\.\d+)\]/i) { 580 $rcvdip = $1; 581 #unless ($read1strcvd) { 582 # $ipfromheader = $1; 583 # $read1strcvd = 1; 584 #} 585 } elsif ($received =~ /\[([\dabcdef.:]+)\]/i) { 586 $rcvdip = $1; 587 #unless ($read1strcvd) { 588 # $ipfromheader = $1; 589 # $read1strcvd = 1; 590 #} 591 } 592 push @rcvdiplist, $rcvdip; 593 } 594 } 595 # Track anything we may be in the middle of 596 $InDel = ($InDel && $InHeader); 597 $InSubject = ($InSubject && $InHeader); 598 next; 599 } 600 601 # Weren't expecting a continuation, but didn't find 602 # something that looked like the first line of a header 603 # either... 604 MailScanner::Log::WarnLog("Apparently invalid line in queue file!". 605 "- continuing anyway."); 606 } 607 608 # If we were told to read the IP from the header and it was there... 609 $getipfromheader = @rcvdiplist if $getipfromheader>@rcvdiplist; 610 # If they wanted the 2nd Received from address, give'em element 1 of list 611 $message->{clientip} = $rcvdiplist[$getipfromheader-1] if 612 $getipfromheader>0; 613 614 #$message->{clientip} = $ipfromheader 615 # if $getipfromheader && $read1strcvd && $ipfromheader ne ""; 616 617 # We should have the last header built but not pushed 618 # onto the metadata headers array at this point... 619 exists $header->{name} and push @{$metadata{headers}},$header; 620 621 # Decode ISO subject lines into UTF8 622 # Needed for UTF8 support in MailWatch 2.0 623 eval { 624 $message->{utf8subject} = Encode::decode('MIME-Header',$message->{subject}); 625 }; 626 if($@) { 627 # Eval failed - store a copy of the subject before MIME::WordDecoder 628 # is run, as this appears to destroy the characters of some subjects 629 $message->{utf8subject} = $message->{subject}; 630 } 631 632 # Decode the ISO encoded Subject line 633 # Over-ride the default default character set handler so it does it 634 # much better than the MIME-tools default handling. 635 MIME::WordDecoder->default->handler('*' => \&MailScanner::Message::WordDecoderKeep7Bit); 636 # Decode the ISO encoded Subject line 637 638 # Remove any wide characters so that WordDecoder can parse 639 # mime_to_perl_string is ignoring the built-in handler that was set earlier 640 # https://github.com/MailScanner/v5/issues/253 641 my $safesubject = $message->{subject}; 642 $safesubject =~ tr/\x00-\xFF/#/c; 643 644 my $TmpSubject; 645 eval { 646 $TmpSubject = MIME::WordDecoder::mime_to_perl_string($safesubject); 647 }; 648 if ($@) { 649 # Eval failed - return unaltered subject 650 $TmpSubject = $message->{subject}; 651 } 652 if ($TmpSubject ne $message->{subject}) { 653 # The mime_to_perl_string function dealt with an encoded subject, as it did 654 # something. Allow up to 10 trailing spaces so that SweepContent 655 # is more kind to us and doesn't go and replace the whole subject, 656 # thinking that it is malicious. Total replacement and hence 657 # destruction of unicode subjects is rather harsh when we are just 658 # talking about a few spaces. 659 $TmpSubject =~ s/ {1,10}$//; 660 $message->{subject} = $TmpSubject; 661 } 662 #old $message->{subject} = MIME::WordDecoder::unmime($message->{subject}); 663 664 # I'd prefer that $message->{headers} not exist; 665 # it's an incitement to do bad things that defeat 666 # the point of hiding the internal implementation 667 # of the object. 668 chomp @headers; # :( 669 $message->{headers} = \@headers; 670 $message->{metadata} = \%metadata; 671 672 #print STDERR Dumper($message->{metadata}); 673 return 1; 674} 675 676# FIXME: Check out requesting no dsn via esmtp - can't see how spool 677# can record this data. 678 679# Merge header data from @headers into metadata :( 680 681sub AddHeadersToQf { 682 my($this, $message, $headers) = @_; 683 684 my($header, $h, @newheaders); 685 686 #print STDERR Dumper($message->{headers}); 687 688 if (defined $headers) { 689 @newheaders = split(/\n/, $headers); 690 } else { 691 @newheaders = @{$message->{headers}}; 692 } 693 694 return RealAddHeadersToQf($this,$message,\@newheaders); 695} 696 697 698sub RealAddHeadersToQf { 699 my ($this, $message, $headerref) = @_; 700 701 my @newheaders = @$headerref; 702 703 # Out-of-date comment but still explains problem. 704 705 # Would prefer to be taking in an explicitly passed array 706 # and do away with $message->{headers} altogether. 707 708 # Could use $message->Headers to return an arrayref if/ 709 # when necessary, then call this with the ref if/when you 710 # want to merge them back in. 711 712 # Essentially I'd like the headers to be considered "ours", 713 # to be modified one-at-a-time via the method provided 714 # (AddHeader, ReplaceHeader, DeleteHeader etc.) 715 716 # But using MIME::tools makes this impossible, as they do 717 # not distinguish between "their" headers and "our" headers, 718 # and just return us a whopping great string of all of them. 719 720 # Grrrrrrrr..... 721 722 # OK, we'll assume & hope that the "special" flags Exim 723 # gives headers aren't important to it, and just pull in 724 # the headers that we're given. This offends my delicate 725 # sensibilities, but I need to get this working *soon*. 726 727 # --nwp 20021006 728 729 my @realheaders = (); 730 my $header = {}; 731 my $line; 732 733 # :( 734 $message->{metadata}{headers} = []; 735 736 my $InHeader = 0; 737 my $InSubject = 0; 738 my $InDel = 0; 739 740 foreach (@newheaders) { 741 # This line to identify problems rather than just work 742 # round them (which costs efficiency). 743 s/\n\Z// and MailScanner::Log::DieLog("BUG! header line '$_' should not have newline."); 744 745 # This line for safety but inefficiency 746 chomp($line = $_); 747 748 if ($InHeader && ($line =~ /^[\t ]/)) { 749 750 # Continuation 751 752 # Add it to metadata header object (already 753 # built the rest) 754 $header->{body} .= $line . "\n"; 755 756 # Don't reset $InHeader as there could be more lines. 757 758 # Very important 759 next; 760 } 761 elsif ($line =~ /^([^: ]+:)(.*)$/) { 762 # Actually header names *MUST* only contain 763 # ASCII 33-126 decimal inclusive... 764 # ...but we'll be gentle, just in case. 765 # Note that spaces are *not* required after the colon, 766 # and if present are considered to be part of the field 767 # data, so must not be (carelessly) modified. *shrug*. 768 # We shouldn't have any terminating newlines at this point. 769 # Note that we have (arbitrarily, we think) decided to 770 # count the delimiting colon as part of the field name. 771 772 # Push any previous header to right place... 773 if ($InHeader) { 774 push @{$message->{metadata}{headers}}, $header; 775 $header = {}; 776 } 777 778 # Set up new header 779 $InHeader = 1; 780 $header->{name} = $1; 781 $header->{body} = $2 . "\n"; 782 # Ugly ugly ugly 783 $header->{flag} = " "; 784 785 # Important 786 next; 787 } 788 else { 789 # Not a continuation and not a valid header start 790 MailScanner::Log::WarnLog("Don't know what to do with line '$line' in header array!"); 791 $InHeader = 0; 792 } 793 } 794 795 # We should have the last header built but not pushed 796 # onto the metadata headers array at this point... 797 exists $header->{name} and push @{$message->{metadata}{headers}},$header; 798 799 # Since we've just generated a bunch of headers with no "special" 800 # flags, note that they've *all* gone missing: 801 foreach (keys %{$message->{metadata}{vanishedflags}}) { 802 $message->{metadata}{vanishedflags}{$_} = 1; 803 } 804 805 return 1; 806} 807 808 809sub AddStringOfHeadersToQf { 810 my ($this, $message, $headers) = @_; 811 812 my @headers; 813 814 @headers = split(/\n/, $headers); 815 816 return RealAddHeadersToQf($this, $message, \@headers); 817} 818 819 820sub AddHeader { 821 my($this, $message, $newkey, $newvalue) = @_; 822 my($newheader); 823 824 # need an equivalent to "assert"... 825 #defined $newvalue or croak("not enough args to AddHeader!\n"); 826 # Sometimes the spam report is undef 827 $newvalue = " " unless defined $newvalue; 828 829 # Sanitise new header value - one leading space and one trailing newline. 830 #$newvalue = ((substr($newvalue,0,1) eq " ")?$newvalue:" $newvalue"); 831 $newvalue =~ s/^ */ /; 832 $newvalue =~ s/\n*\Z/\n/; 833 834 $newheader = { name => $newkey, body => $newvalue, flag => " " }; 835 # DKIM: Add header at top if adding headers at top 836 if ($message->{newheadersattop}) { 837 unshift @{$message->{metadata}{headers}}, $newheader; 838 } else { 839 push @{$message->{metadata}{headers}}, $newheader; 840 } 841 842 return 1; 843} 844 845 846# This is how we build the entry that goes in the -H file 847# sprintf("%03d ", length($newheader)+1) . $newheader . "\n"; 848 849 850# Delete a header from the message's metadata structure 851sub DeleteHeader { 852 my($this, $message, $key) = @_; 853 854 my $usingregexp = ($key =~ s/^\/(.*)\/$/$1/)?1:0; 855 856 # Add a colon if they forgot it. 857 $key .= ':' unless $usingregexp || $key =~ /:$/; 858 # If it's not a regexp, then anchor it and sanitise it. 859 $key = quotemeta($key) unless $usingregexp; 860 861 # Delete header by flagging it as deleted rather than by 862 # actually deleting it; might help with debugging. 863 # Also keep track of any flags that we've managed to "vanish". 864 my($hdrnum, $line); 865 my $metadata = $message->{metadata}; 866 for ($hdrnum=0; $hdrnum<@{$metadata->{headers}}; $hdrnum++) { 867 # Skip if they are using a header name and it doesn't match 868 # Quotemeta the header name we are checking as we have done it to $key. 869 next if !$usingregexp && 870 lc(quotemeta($metadata->{headers}[$hdrnum]{name})) ne lc $key; 871 # Skip if they are using a regexp and it doesn't match 872 $line = $metadata->{headers}[$hdrnum]{name} . $metadata->{headers}[$hdrnum]{body}; 873 next if $usingregexp && $line !~ /$key/i; 874 # Have found the right line 875 $metadata->{headers}[$hdrnum]{flag} ne " " 876 and $metadata->{vanishedflags}{$metadata->{headers}[$hdrnum]{flag}} = 1; 877 $metadata->{headers}[$hdrnum]{flag} = "*"; 878 } 879} 880 881sub UniqHeader { 882 my($this, $message, $key) = @_; 883 884 my $hdrnum; 885 my $foundat = -1; 886 my $metadata = $message->{metadata}; 887 for ($hdrnum=0; $hdrnum<@{$metadata->{headers}}; $hdrnum++) { 888 next unless lc $metadata->{headers}[$hdrnum]{name} eq lc $key; 889 890 # Have found the header line, skip it if we haven't seen it before 891 ($foundat = $hdrnum), next if $foundat == -1; 892 893 # Have found the right line 894 $metadata->{headers}[$hdrnum]{flag} ne " " 895 and $metadata->{vanishedflags}{$metadata->{headers}[$hdrnum]{flag}} = 1; 896 $metadata->{headers}[$hdrnum]{flag} = "*"; 897 } 898} 899 900 901# We need to delete *all* instances of the header in 902# question, as this is used e.g. to replace previous 903# mailscanner disposition headers with the "right" one, 904# and we don't want lots of old ones left lying aorund. 905# Shame, as it means I will have to regenerate header 906# flags on output. 907 908sub ReplaceHeader { 909 my($this, $message, $key, $newvalue) = @_; 910 911 # DKIM: Don't do DeleteHeader if adding all headers at top 912 $this->DeleteHeader($message, $key) unless $message->{dkimfriendly}; 913 $this->AddHeader($message, $key, $newvalue); 914 915 return 1; 916} 917 918 919# Return a reference to a header object called "$name" 920# (case-insensitive) 921# FOR INTERNAL USE ONLY 922 923sub FindHeader { 924 my($this, $message, $name, $includedeleted) = @_; 925 926 defined $includedeleted or $includedeleted = 0; 927 928 $includedeleted and $includedeleted = 1; 929 930 for (my $ignoreflag = 0; 931 $ignoreflag < 1 + $includedeleted; 932 $ignoreflag++) { 933 foreach (@{$message->{metadata}{headers}}) { 934 lc $_->{name} eq lc $name and ($ignoreflag or $_->{flag} ne '*') and return $_; 935 } 936 } 937 938 return undef; 939} 940 941 942sub AppendHeader { 943 my($this, $message, $key, $newvalue, $sep) = @_; 944 945 my $header = FindHeader($this, $message, $key); 946 947 if (defined $header) { 948 # Found it :) 949 chomp($header->{body}); 950 $header->{body} .= $sep . $newvalue . "\n"; 951 } 952 else { 953 # Didn't find it :( 954 $this->AddHeader($message, $key, $newvalue); 955 } 956 return 1; 957} 958 959 960sub PrependHeader { 961 my($this, $message, $key, $newvalue, $sep) = @_; 962 963 my $header = FindHeader($this, $message, $key); 964 965 if (defined $header) { 966 # Found it :) 967 #$header->{body} = $newvalue . $sep . $header->{body}; 968 chomp($header->{body}); 969 $header->{body} =~ s/^($sep|\s)*/ $newvalue$sep/; 970 $header->{body} .= "\n"; 971 } 972 else { 973 # Didn't find it :( 974 $this->AddHeader($message, $key, $newvalue); 975 } 976 return 1; 977} 978 979 980sub TextStartsHeader { 981 my($this, $message, $key, $text) = @_; 982 983 my $header = FindHeader($this, $message, $key); 984 985 if (defined $header) { 986 return (($header->{body} =~ /^\s*\Q$text\E/i)?1:0); 987 } 988 else { 989 return 0; 990 } 991} 992 993sub TextEndsHeader { 994 my($this, $message, $key, $text) = @_; 995 996 my $header = FindHeader($this, $message, $key); 997 998 if (defined $header) { 999 return (($header->{body} =~ /\Q$text\E$/i)?1:0); 1000 } 1001 else { 1002 return 0; 1003 } 1004} 1005 1006 1007#sub ConstructHeaders { 1008# my($headers) = @_; 1009# $headers =~ s/^\S/H$&/mg; 1010# return $headers; 1011#} 1012 1013#sub ReadEnvelope { 1014# my($fh) = @_; 1015# my $envelope = ""; 1016# 1017# while(<$fh>) { 1018# last if /^\./; # Bat book section 23.9.19 1019# $envelope .= $_; 1020# } 1021# return $envelope; 1022#} 1023 1024#sub SplitEnvelope { 1025# my($envelope) = @_; 1026# 1027# my ($headers,$newenvelope); 1028# my(@envelope) = split "\n", $envelope; 1029# 1030# my $InHeader = 0; 1031# 1032# while($_ = shift @envelope) { 1033# last if /^\./; # Bat book section 23.9.19 1034# if (/^H/) { 1035# $InHeader = 1; 1036# $headers .= "$_\n"; 1037# next; 1038# } 1039# if (/^\s/ && $InHeader) { 1040# $headers .= "$_\n"; 1041# next; 1042# } 1043# $InHeader = 0; 1044# $newenvelope .= "$_\n"; 1045# } 1046# 1047# return ($newenvelope,$headers); 1048# } 1049 1050# sub MergeEnvelope { 1051# my ($envelope,$headers) = @_; 1052# return "$envelope$headers.\n"; 1053# } 1054 1055# sub MergeEnvelopeParts { 1056# my($fh, $headers) = @_; 1057# 1058# my $envelope = ""; 1059# my $InHeader = 0; 1060# 1061# while(<$fh>) { 1062# last if /^\./; # Bat book section 23.9.19 1063# ($InHeader = 1),next if /^H/; 1064# next if /^\s/ && $InHeader; 1065# $InHeader = 0; 1066# $envelope .= $_; 1067# } 1068# 1069# $envelope .= $headers; 1070# $envelope .= ".\n"; 1071# return $envelope; 1072# } 1073 1074 1075# FIXME: Document what format are we supposed to be passed 1076# recipients in (assuming just plain email address, no quotes, 1077# no angle brackets, no nuffin' for now)... 1078 1079sub AddRecipients { 1080 my $this = shift; 1081 my($message, @recips) = @_; 1082 my($recip); 1083 foreach $recip (@recips) { 1084 $message->{metadata}{numrcpts}++; 1085 push @{$message->{metadata}{rcpts}}, "$recip"; 1086 exists $message->{metadata}{nonrpcts}{$recip} and 1087 delete $message->{metadata}{nonrpcts}{$recip}; 1088 } 1089} 1090 1091 1092# Delete recipient from recipient list unless they are already 1093# also on nonrcpt list? 1094 1095# Delete the original recipient from the message. We'll add some 1096# using AddRecipients later. 1097 1098sub DeleteRecipients { 1099 my $this = shift; 1100 my($message) = @_; 1101 1102 $message->{metadata}{numrcpts} = 0; 1103 $message->{metadata}{rcpts} = []; 1104 $message->{metadata}{nonrcpts} = {}; 1105 1106 return 1; 1107} 1108 1109 1110# Ask MTA to deliver message(s) from queue 1111 1112sub KickMessage { 1113 my $pid; 1114 my($messages, $sendmail2) = @_; 1115 my(@ids, @ThisBatch); 1116 # Build a list @ids of all the message ids 1117 foreach (values(%{$messages})) { 1118 push @ids, split(" ", $_); 1119 } 1120 1121 while(@ids) { 1122 @ThisBatch = splice @ids, $[, 30; 1123 1124 # This code is the simpler version of the #JJH code below here. 1125 my $idlist = join(' ', @ThisBatch); 1126 $idlist .= ' &' if MailScanner::Config::Value('deliverinbackground'); 1127 #print STDERR "About to do \"Sendmail2 -Mc $idlist\"\n"; 1128 # Change out of the current working directory that no longer exists 1129 # before calling exim 1130 system('cd ' . MailScanner::Config::Value('outqueuedir') . ' && ' . 1131 MailScanner::Config::Value('sendmail2') . ' -Mc ' . $idlist); 1132 1133 #JJH # JJH's version 1134 #JJH if(MailScanner::Config::Value('deliverinbackground')) { 1135 #JJH # fork twice so that we don't have to reap :-) 1136 #JJH $pid = fork; 1137 #JJH # jjh 2004-03-12 don't waitpid here, too slow. 1138 #JJH #waitpid $pid, 0 if $pid > 0; 1139 #JJH return if $pid > 0 or not defined $pid; 1140 #JJH $pid = fork; 1141 #JJH exit if $pid > 0 or not defined $pid; 1142 #JJH exec(split(/ +/, MailScanner::Config::Value('sendmail2')), '-Mc', @ThisBatch); 1143 #JJH } else { 1144 #JJH system(split(/ +/, MailScanner::Config::Value('sendmail2')), '-Mc', @ThisBatch); 1145 #JJH } 1146 } 1147 1148} 1149 1150 1151# Serialize metadata into a string for output into 1152# -H file... 1153# INTERNAL USE ONLY 1154 1155sub CreateQf { 1156 my($message) = @_; 1157 1158 my $i; 1159 my $Qfile = ""; 1160 my $metadata = $message->{metadata}; 1161 1162 # Add id line 1163 $Qfile .= $metadata->{id}. "\n"; 1164 1165 # Add user, uid, gid line 1166 $Qfile .= $metadata->{user} . " "; 1167 $Qfile .= $metadata->{uid} . " "; 1168 $Qfile .= $metadata->{gid} . "\n"; 1169 1170 # Add sender line 1171 $Qfile .= '<' . $metadata->{sender} . ">\n"; 1172 # JKF Need the < and > round the sender $Qfile .= $metadata->{sender} . "\n"; 1173 1174 # Add time received and warning count 1175 $Qfile .= $metadata->{rcvtime} . " "; 1176 $Qfile .= $metadata->{warncnt} . "\n"; 1177 1178 # Add -<item_name> lines 1179 foreach (keys %{$metadata->{dashvars}}) { 1180 $Qfile .= "-" . $_; 1181 $metadata->{dashvars}{$_} and $Qfile .= " " . $metadata->{"dv_$_"}; 1182 $Qfile .= "\n"; 1183 } 1184 1185 # ACLs patch starts here 1186 # Add the separate ACL Vars 1187 my %acl = %{$metadata->{aclvars}}; 1188 my %aclc = %{$metadata->{aclcvars}}; 1189 my %aclm = %{$metadata->{aclmvars}}; 1190 foreach(keys %acl){ 1191 if($acl{$_}) { 1192 $Qfile .= "-acl " . $_ . " " . length($acl{$_}->[0]) . "\n"; 1193 $Qfile .= $acl{$_}->[0] . "\n"; 1194 } 1195 } 1196 foreach(keys %aclc){ 1197 if($aclc{$_}) { 1198 $Qfile .= "-aclc " . $_ . " " . length($aclc{$_}->[0]) . "\n"; 1199 $Qfile .= $aclc{$_}->[0] . "\n"; 1200 } 1201 } 1202 foreach(keys %aclm){ 1203 if($aclm{$_}) { 1204 $Qfile .= "-aclm " . $_ . " " . length($aclm{$_}->[0]) . "\n"; 1205 $Qfile .= $aclm{$_}->[0] . "\n"; 1206 } 1207 } 1208 1209 # Add non-recipients 1210 $Qfile .= BTreeString($metadata->{nonrcpts}); 1211 1212 # Add number of recipients 1213 $Qfile .= $metadata->{numrcpts} . "\n"; 1214 1215 # Add recipients 1216 foreach (@{$metadata->{rcpts}}) { 1217 $Qfile .= "$_\n"; 1218 } 1219 1220 # Add blank line 1221 $Qfile .= "\n"; 1222 1223 # Add headers from $metadata->{headers}... 1224 # First we need to check the "special" flags. 1225 # Then we need to write out headers to a 1226 # string, calculating length as we go. 1227 my %flags = (); 1228 foreach (keys %{$metadata->{vanishedflags}}) { 1229 $metadata->{vanishedflags}{$_} and FindAndFlag($metadata->{headers}, "$_"); 1230 } 1231# MailScanner::Log::InfoLog(Dumper($metadata->{headers})); 1232 foreach (@{$metadata->{headers}}) { 1233 my $htext = $_->{name} . $_->{body}; 1234 # We want exactly one \n at the end of each header 1235 # but this *should* be inefficient and unnecessary 1236 # $htext =~ s/\n*\Z/\n/; 1237 $Qfile .= sprintf("%03d", length($htext)) . $_->{flag} . ' ' . $htext; 1238 } 1239 1240 return $Qfile; 1241} 1242 1243 1244# Find relevant header and flag it as special 1245# INTERNAL USE ONLY 1246 1247sub FindAndFlag { 1248 my ($headerary, $flag) = @_; 1249 1250 # Must be lower-case 1251 my %headers = ( 1252 B => "bcc", 1253 C => "cc", 1254 F => "from", 1255 I => "message-id", 1256 R => "reply-to", 1257 S => "sender", 1258 T => "to", 1259 P => "received", 1260 ); 1261 1262 # We don't do: 1263 # * - deleted 1264 # - nothing special 1265 # We should only be asked to do message-id if there 1266 # definitely was one flagged to start with... 1267 $flag =~ /[BCFIRSTP]/ or return 0; 1268 1269 my $foundone = 0; 1270 foreach (@$headerary) { 1271 1272 $_->{flag} ne " " and next; 1273 $headers{uc($flag)}.":" eq lc $_->{name} or next; 1274 1275 # OK, found one 1276 $foundone = 1; 1277 $_->{flag} = $flag; 1278 # End if we only want one of this header 1279 $flag ne 'R' and last; 1280 } 1281 1282 return $foundone; 1283} 1284 1285 1286# Build string representing a balanced b-tree 1287# of the keys of the hash passed in. 1288# INTERNAL USE ONLY 1289 1290sub BTreeString { 1291 my ($hashref) = @_; 1292 1293 my $treeref = BTreeHash($hashref); 1294 1295 my $treestring = BTreeDescend($treeref); 1296 1297 $treestring or $treestring = "XX\n"; 1298 1299 return $treestring; 1300} 1301 1302 1303# Build a not-too-unbalanced b-tree from keys of a 1304# hash and return a reference to the tree. 1305# INTERNAL USE ONLY 1306 1307sub BTreeHash { 1308 my ($hashref) = @_; 1309 1310 my @nodes = keys %$hashref; 1311 my $treeref = {}; 1312 my @nodequeue = ($treeref); 1313 my $data; 1314 my $currentnode; 1315 1316 while ($data = pop @nodes) { 1317 $currentnode = pop @nodequeue 1318 or MailScanner::Log::DieLog("Ran out of nodes in BTreeHash - shouldn't happen!"); 1319 unshift @nodequeue, ($currentnode->{left} = {}); 1320 unshift @nodequeue, ($currentnode->{right} = {}); 1321 $currentnode->{data} = $data; 1322 } 1323 1324 return $treeref; 1325} 1326 1327 1328# Descend a b-tree passed in a hash reference, 1329# generating a string representing the tree 1330# as we go. 1331# INTERNAL USE ONLY 1332 1333sub BTreeDescend { 1334 my ($treeref) = @_; 1335 1336 exists $treeref->{data} or return ""; 1337 1338 my $string = ""; 1339 $string .= (exists $treeref->{left}{data}?"Y":"N"); 1340 $string .= (exists $treeref->{right}{data}?"Y":"N"); 1341 $string .= " " . $treeref->{data} . "\n"; 1342 1343 $string .= BTreeDescend($treeref->{left}); 1344 $string .= BTreeDescend($treeref->{right}); 1345 1346 return $string; 1347} 1348 1349 1350# Append, add or replace a given header with a given value. 1351sub AddMultipleHeaderName { 1352 my $this = shift; 1353 my($message, $headername, $headervalue, $separator) = @_; 1354 1355 my($multiple) = MailScanner::Config::Value('multipleheaders', $message); 1356 $this->AppendHeader ($message, $headername, $headervalue, $separator) 1357 if $multiple eq 'append'; 1358 1359 $this->AddHeader ($message, $headername, $headervalue) 1360 if $multiple eq 'add'; 1361 1362 $this->ReplaceHeader($message, $headername, $headervalue) 1363 if $multiple eq 'replace'; 1364} 1365 1366# Append, add or replace a given header with a given value. 1367sub AddMultipleHeader { 1368 my $this = shift; 1369 my($message, $headername, $headervalue, $separator) = @_; 1370 1371 my($multiple) = MailScanner::Config::Value('multipleheaders', $message); 1372 $this->AppendHeader ($message, 1373 MailScanner::Config::Value(lc($headername), $message), 1374 $headervalue, $separator) 1375 if $multiple eq 'append'; 1376 1377 $this->AddHeader ($message, 1378 MailScanner::Config::Value(lc($headername), $message), 1379 $headervalue) 1380 if $multiple eq 'add'; 1381 1382 $this->ReplaceHeader($message, 1383 MailScanner::Config::Value(lc($headername), $message), 1384 $headervalue) 1385 if $multiple eq 'replace'; 1386} 1387 1388 1389# Send an email message containing all the headers and body in a string. 1390# Also passed in the sender's address. 1391sub SendMessageString { 1392 my $this = shift; 1393 my($message, $email, $sender) = @_; 1394 1395 my($fh); 1396 1397 #print STDERR '|' . MailScanner::Config::Value('sendmail', $message) . 1398 # ' ' . $SendmailOptions . '-f ' . "'$sender'" . "\n"; 1399 #$fh = new FileHandle; 1400 #$fh->open('|' . MailScanner::Config::Value('sendmail', $message) . 1401 # " $SendmailOptions '" . $sender . "'") 1402 1403 $fh = new IO::Pipe; 1404 $fh->writer(split(/ +/, MailScanner::Config::Value('sendmail', $message)), 1405 @SendmailOptions, $sender) 1406 or MailScanner::Log::WarnLog("Could not send email message, %s", $!), return 0; 1407 #$fh->open('|$global::cat >> /tmp/1'); 1408 $fh->print($email); 1409 #print STDERR $email; 1410 #$fh->close(); 1411 #1; 1412 1413 return $fh->close(); 1414} 1415 1416 1417# Send an email message containing the attached MIME entity. 1418# Also passed in the sender's address. 1419sub SendMessageEntity { 1420 my $this = shift; 1421 my($message, $entity, $sender) = @_; 1422 1423 my($fh); 1424 1425 #print STDERR '|' . MailScanner::Config::Value('sendmail', $message) . 1426 # ' ' . $SendmailOptions . '-f ' . $sender . "\n"; 1427 #$fh = new FileHandle; 1428 #$fh->open('|' . MailScanner::Config::Value('sendmail', $message) . 1429 # " $SendmailOptions '" . $sender . "'") 1430 $fh = new IO::Pipe; 1431 $fh->writer(split(/ +/, MailScanner::Config::Value('sendmail', $message)), 1432 @SendmailOptions, $sender) 1433 or MailScanner::Log::WarnLog("Could not send email entity, %s", $!), return 0; 1434 #$fh->open('|$global::cat >> /tmp/2'); 1435 $entity->print($fh); 1436 #$entity->print(\*STDERR); 1437 #$fh->close(); 1438 #1; 1439 1440 return $fh->close(); 1441} 1442 1443 1444# Create a MessageBatch object by reading the queue and filling in 1445# the passed-in batch object. 1446 1447sub CreateBatch { 1448 my $this = shift; 1449 my($batch, $onlyid) = @_; 1450 1451 my($queuedirname, $queuedir, $MsgsInQueue, $mtime); 1452 my($DirtyMsgs, $DirtyBytes, $CleanMsgs, $CleanBytes); 1453 my($HitLimit1, $HitLimit2, $HitLimit3, $HitLimit4); 1454 my($MaxCleanB, $MaxCleanM, $MaxDirtyB, $MaxDirtyM); 1455 my(%ModDate, $mta, $file, $tmpdate, $invalidfiles); 1456 my(@SortedFiles, $id, $newmessage, @queuedirnames); 1457 my($batchempty, $CriticalQueueSize, $headerfileumask); 1458 my($getipfromheader); 1459 1460 # Old code left over from single queue dir 1461 #$queuedirname = $global::MS->{inq}{dir}; 1462 #chdir $queuedirname or MailScanner::Log::DieLog("Cannot cd to dir %s to read " . 1463 # "messages, %s", $queuedirname, $!); 1464 1465 $queuedir = new DirHandle; 1466 $MsgsInQueue = 0; 1467 #print STDERR "Inq = " . $global::MS->{inq} . "\n"; 1468 #print STDERR "dir = " . $global::MS->{inq}{dir} . "\n"; 1469 @queuedirnames = @{$global::MS->{inq}{dir}}; 1470 1471 ($MaxCleanB, $MaxCleanM, $MaxDirtyB, $MaxDirtyM) 1472 = MailScanner::MessageBatch::BatchLimits(); 1473 #print Dumper(\@queuedirnames); 1474 1475 # If there are too many messages in the queue, start processing in 1476 # directory storage order instead of date order. 1477 $CriticalQueueSize = MailScanner::Config::Value('criticalqueuesize'); 1478 $getipfromheader = MailScanner::Config::Value('getipfromheader'); 1479 1480 # Set what we will need the umask to be 1481 $headerfileumask = $global::MS->{work}->{fileumask}; 1482 1483 do { 1484 $batch->{messages} = {}; 1485 # Statistics logging 1486 $batch->{totalbytes} = 0; 1487 $batch->{totalmessages} = 0; 1488 1489 # 1490 # Now do the actual work 1491 # 1492 $MsgsInQueue= 0; 1493 $DirtyMsgs = 0; 1494 $DirtyBytes = 0; 1495 $CleanMsgs = 0; 1496 $CleanBytes = 0; 1497 %ModDate = (); 1498 @SortedFiles = (); 1499 $HitLimit1 = 0; 1500 $HitLimit2 = 0; 1501 $HitLimit3 = 0; 1502 $HitLimit4 = 0; 1503 $invalidfiles = ""; 1504 1505 # Loop through each of the inq directories 1506 # Patch to combat starving in emergency queue mode 1507 #foreach $queuedirname (@queuedirnames) { 1508 my @aux_queuedirnames=@queuedirnames; 1509 while( defined($queuedirname=splice(@aux_queuedirnames, 1510 ($UnsortedBatchesLeft<=0 ? 0 :int(rand(@aux_queuedirnames))),1))) { 1511 1512 # FIXME: Probably as a result of in-queue spec being 1513 # tainted, $queuedirname is tainted... work out exactly why! 1514 $queuedirname =~ /(.*)/; 1515 $queuedirname = $1; 1516 1517 #print STDERR "Scanning dir $queuedirname\n"; 1518 unless (chdir $queuedirname) { 1519 MailScanner::Log::WarnLog("Cannot cd to dir %s to read messages, %s", 1520 $queuedirname, $!); 1521 next; 1522 } 1523 1524 $queuedir->open('.') 1525 or MailScanner::Log::DieLog("Cannot open queue dir %s for reading " . 1526 "message batch, %s", $queuedirname, $!); 1527 $mta = $global::MS->{mta}; 1528 #print STDERR "Searching " . $queuedirname . " for messages\n"; 1529 1530 # Read in modification dates of the qf files & use them in date order 1531 while (defined($file = $queuedir->read())) { 1532 # Optimised by binning the 50% that aren't H files first 1533 next unless $file =~ /$mta->{HFileRegexp}/; 1534 #print STDERR "Found message file $file\n"; 1535 $MsgsInQueue++; # Count the size of the queue 1536 push @SortedFiles, "$queuedirname/$file"; 1537 if ($UnsortedBatchesLeft<=0) { 1538 # Running normally 1539 $tmpdate = (stat($file))[9]; # 9 = mtime 1540 next unless -f _; 1541 next if -z _; # Skip 0-length qf files 1542 $ModDate{"$queuedirname/$file"} = $tmpdate; # Push msg into list 1543 #print STDERR "Stored message file $file\n"; 1544 } 1545 } 1546 $queuedir->close(); 1547 } 1548 1549 # Not sorting the queue will save us considerably more time than 1550 # just skipping the sort operation, as it will enable the next bit 1551 # of code to just use the files nearest the beginning of the directory. 1552 # This should make the directory lookups much faster on filesystems 1553 # with slow directory lookups (e.g. anything except xfs). 1554 $UnsortedBatchesLeft = 40 1555 if $CriticalQueueSize>0 && $MsgsInQueue>=$CriticalQueueSize; 1556 # SortedFiles is array of full pathnames now, not just filenames 1557 if ($UnsortedBatchesLeft>0) { 1558 $UnsortedBatchesLeft--; 1559 } else { 1560 @SortedFiles = sort { $ModDate{$a} <=> $ModDate{$b} } keys %ModDate; 1561 } 1562 1563 $batchempty = 1; 1564 my $maxattempts = MailScanner::Config::Value('procdbattempts'); 1565 1566 # Keep going until end of dir or have reached every imposed limit. This 1567 # now processes the files oldest first to make for fairer queue cleanups. 1568 umask $headerfileumask; # Started creating files 1569 while (defined($file = shift @SortedFiles) && 1570 $HitLimit1+$HitLimit2+$HitLimit3+$HitLimit4<1) { 1571 # In accelerated mode, so we don't know anything about this file 1572 if ($UnsortedBatchesLeft>0) { 1573 my @stats = stat $file; 1574 next unless -f _; 1575 next if -z _; 1576 $mtime = $stats[9]; 1577 } else { 1578 $mtime = $ModDate{$file}; 1579 } 1580 1581 # must separate next two lines or $1 gets re-tainted by being part of 1582 # same expression as $file [mumble mumble grrr mumble mumble] 1583 #print STDERR "Reading file $file from list\n"; 1584 # Split pathname into dir and file again 1585 ($queuedirname, $file) = ($1,$2) if $file =~ /^(.*)\/([^\/]+)$/; 1586 next unless $file =~ /$mta->{HFileRegexp}/; 1587 $id = $1; 1588 # If they want a particular message id, ignore it if it doesn't match 1589 next if $onlyid ne "" && $id ne $onlyid; 1590 1591 #print STDERR "Adding $id to batch\n"; 1592 1593 # Lock and read the qf file. Skip this message if the lock fails. 1594 $newmessage = MailScanner::Message->new($id, $queuedirname, 1595 $getipfromheader); 1596 if ($newmessage && $newmessage->{INVALID}) { 1597 #if ($newmessage eq 'INVALID') { 1598 $invalidfiles .= "$id "; 1599 undef $newmessage; 1600 next; 1601 } 1602 next unless $newmessage; 1603 $newmessage->WriteHeaderFile(); # Write the file of headers 1604 1605 # JKF 20090301 Skip this message if $id has been scanned 1606 # too many times. 1607 # JKF 20090301 Read the number of times this message id has 1608 # been processed. If over the limit, then ignore it. 1609 # JKF 20090301 Should ideally make it in a batch of its own, 1610 # and try that once or twice, *then* skip it. But let's try 1611 # a simple version first. 1612 # Just do a "next" if we want to skip the message. 1613 if ($maxattempts) { 1614 my $nexttime = time + 120 + int(rand(240)); # 4 +- 2 minutes 1615 #my $nexttime = time + 10 + int(rand(20)); # 4 +- 2 minutes 1616 my @attempts = $MailScanner::ProcDBH->selectrow_array( 1617 $MailScanner::SthSelectRows, undef, $id); 1618 #my @attempts = $MailScanner::ProcDBH->selectrow_array( 1619 #"SELECT id,count,nexttime FROM processing WHERE (id='" . $id . "')"); 1620 #print STDERR "id = \"$attempts[0]\"\n"; 1621 #print STDERR "count = \"$attempts[1]\"\n"; 1622 #print STDERR "nexttime = \"$attempts[2]\"\n"; 1623 if (@attempts && $attempts[1]>=$maxattempts) { 1624 MailScanner::Log::WarnLog("Warning: skipping message %s as it has been attempted too many times", $id); 1625 # JKF 20090301 next; 1626 # Instead of just skipping it, quarantine it and notify 1627 # the local postmaster. 1628 $newmessage->QuarantineDOS(); 1629 #print STDERR "Moving $attempts[0], $attempts[1], $attempts[2] into archive table\n"; 1630 $MailScanner::SthDeleteId->execute($id); 1631 #$MailScanner::ProcDBH->do( 1632 # "DELETE FROM processing WHERE id='" . $id . "'"); 1633 $MailScanner::SthInsertArchive->execute($attempts[0], $attempts[1], 1634 $attempts[2]); 1635 #$MailScanner::ProcDBH->do( 1636 # "INSERT INTO archive (id, count, nexttime) " . 1637 # "VALUES ('$attempts[0]', $attempts[1], $attempts[2])"); 1638 } elsif (defined $attempts[1]) { 1639 # We have tried this message before 1640 if (time>=$attempts[2]) { 1641 # Time for next attempt has arrived 1642 $MailScanner::SthIncrementId->execute($nexttime, $id); 1643 #$MailScanner::ProcDBH->do( 1644 # "UPDATE processing SET count=count+1, nexttime=$nexttime " . 1645 # " WHERE id='" . $id . "'"); 1646 MailScanner::Log::InfoLog( 1647 "Making attempt %d at processing message %s", 1648 $attempts[1]+1, $id); 1649 #print STDERR "Incremented $id\n"; 1650 } else { 1651 # Not time for next attempt yet, so ignore the message 1652 $newmessage->DropFromBatch(); 1653 next; 1654 } 1655 } else { 1656 # We have never seen this message before 1657 $MailScanner::SthInsertProc->execute($id, 1, $nexttime); 1658 #$MailScanner::ProcDBH->do( 1659 # "INSERT INTO processing (id, count, nexttime) " . 1660 # "VALUES ('" . $id . "', 1, $nexttime)"); 1661 #print STDERR "Inserted $id\n"; 1662 } 1663 } 1664 1665 $batch->{messages}{"$id"} = $newmessage; 1666 $newmessage->{mtime} = $mtime; 1667 $batchempty = 0; 1668 1669 if (MailScanner::Config::Value("scanmail", $newmessage) =~ /[12]/ || 1670 MailScanner::Config::Value("virusscan", $newmessage) =~ /1/ || 1671 MailScanner::Config::Value("dangerscan", $newmessage) =~ /1/) { 1672 $newmessage->NeedsScanning(1); 1673 $DirtyMsgs++; 1674 $DirtyBytes += $newmessage->{size}; 1675 $HitLimit3 = 1 1676 if $DirtyMsgs>=$MaxDirtyM; 1677 $HitLimit4 = 1 1678 if $DirtyBytes>=$MaxDirtyB; 1679 # Moved this further up 1680 #$newmessage->WriteHeaderFile(); # Write the file of headers 1681 } else { 1682 $newmessage->NeedsScanning(0); 1683 $CleanMsgs++; 1684 $CleanBytes += $newmessage->{size}; 1685 $HitLimit1 = 1 1686 if $CleanMsgs>=$MaxCleanM; 1687 $HitLimit2 = 1 1688 if $CleanBytes>=$MaxCleanB; 1689 # Moved this further up 1690 #$newmessage->WriteHeaderFile(); # Write the file of headers 1691 } 1692 } 1693 umask 0077; # Safety net as stopped creating files 1694 1695 # Wait a bit until I check the queue again 1696 sleep(MailScanner::Config::Value('queuescaninterval')) if $batchempty; 1697 } while $batchempty; # Keep trying until we get something 1698 1699 # Log the number of invalid messages found 1700 MailScanner::Log::NoticeLog("New Batch: Found invalid queue files: %s", 1701 $invalidfiles) 1702 if $invalidfiles; 1703 # Log the size of the queue if it is more than 1 batch 1704 MailScanner::Log::InfoLog("New Batch: Found %d messages waiting", 1705 $MsgsInQueue) 1706 if $MsgsInQueue > ($DirtyMsgs+$CleanMsgs); 1707 1708 MailScanner::Log::InfoLog("New Batch: Forwarding %d unscanned messages, " . 1709 "%d bytes", $CleanMsgs, $CleanBytes) 1710 if $CleanMsgs; 1711 MailScanner::Log::InfoLog("New Batch: Scanning %d messages, %d bytes", 1712 $DirtyMsgs, $DirtyBytes) 1713 if $DirtyMsgs; 1714 1715 #MailScanner::Log::InfoLog("New Batch: Archived %d $ArchivedMsgs messages", 1716 # $ArchivedMsgs) 1717 # if $ArchivedMsgs; 1718 1719 $batch->{dirtymessages} = $DirtyMsgs; 1720 $batch->{dirtybytes} = $DirtyBytes; 1721 1722 # Logging stats 1723 $batch->{totalmessages} = $DirtyMsgs + $CleanMsgs; 1724 $batch->{totalbytes} = $DirtyBytes + $CleanBytes; 1725 1726 #print STDERR "Dirty stats are $DirtyMsgs msgs, $DirtyBytes bytes\n"; 1727} 1728 1729 1730# Return the array of headers from this message, optionally with a 1731# separator on the end of each one. 1732# This is designed to be used to produce the input headers for the message, 1733# ie. the headers of the original message. It produces 1 line per list 1734# element, not 1 header per list element. 1735sub OriginalMsgHeaders { 1736 my $this = shift; 1737 my($message, $separator) = @_; 1738 1739 return @{$message->{headers}} unless $separator; 1740 1741 # There is a separator 1742 my($h,@result); 1743 foreach $h (@{$message->{headers}}) { 1744 push @result, $h . $separator; 1745 } 1746 return @result; 1747 1748 #defined $separator or $separator = ""; 1749 # 1750 #my @headers =(); 1751 #my $header = ""; 1752 #foreach (@{$message->{metadata}{headers}}) { 1753 # chomp ($header = $_->{name}.$_->{body}); 1754 # $header .= $separator; 1755 # push @headers, $header; 1756 #} 1757 # 1758 #return @headers; 1759} 1760 1761 1762sub CheckQueueIsFlat { 1763 my ($dir) = @_; 1764 1765 # FIXME: What is the purpose of this? 1766 1767 return 1; 1768} 1769 17701; 1771