X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-accept;h=f0586186a74496fe76cfd0a37446e4904de6dbf0;hp=55bef4a30e6dd252c943dcd0bbef5ccb38ab0d1c;hb=e32c697b3f60065a62cec197b507d0557183fe8a;hpb=2a51f3d04a7e9ddd4268ef31e425073cbdad167a diff --git a/perlmail-accept b/perlmail-accept index 55bef4a..f058618 100755 --- a/perlmail-accept +++ b/perlmail-accept @@ -69,6 +69,10 @@ require HTTP::Request; require LWP::UserAgent; use URI::Escape 'uri_escape'; require WWW::SMS; +require Authen::SASL; # Sanity check for &Net::SMTP::auth +use MIME::Base64; +use IPC::Open3; +use POSIX ":sys_wait_h"; our($Message,@AuditStored,$DoBell); @@ -131,8 +135,10 @@ sub inetd $length==($_=read STDIN,$message,$length) or confess "Got $_ out of required $length bytes"; $length==length $message or confess "False read return ".length($message)." instead of $length"; { - local *STDOUT; # FIXME: fd's inherited by spawned processes are not closed this way! - local *STDERR; # FIXME: fd's inherited by spawned processes are not closed this way! + # Do not: local *STDOUT; # FIXME: fd's inherited by spawned processes are not closed this way! + # local *STDERR; # FIXME: fd's inherited by spawned processes are not closed this way! + # as IPC::Open3 and IPC::Open2 will not redirect the output + # and send it to the original socket instead! local $DoBell=0; process $message; if ($DoBell) { @@ -160,7 +166,7 @@ sub useridle my($idlebest,$linebest); for my $utmp (User::Utmp::getut(),{ "ut_line"=>"psaux" }) { local $_; - next if defined($_=$utmp->{"ut_type"}) && $_!=User::Utmp::USER_PROCESS; + next if defined($_=$utmp->{"ut_type"}) && $_!=User::Utmp::USER_PROCESS(); next if defined($_=$utmp->{"ut_user"}) && !$valid_users{$_}; my $line="/dev/".$utmp->{"ut_line"}; my $atime=(stat $line)[8]; @@ -186,6 +192,12 @@ sub body_first return $first; } +sub is_multipart +{ + return 0 if !$Audit->is_mime(); + return $Audit->is_multipart(); +} + sub mimehead { my($part)=@_; @@ -487,13 +499,28 @@ my($message)=@_; # utility functions: +sub _spamchildcode +{ +my($err,$isspam)=@_; + + $err=$? if !defined $err; + return undef() if !WIFEXITED($?); + return undef() if WIFSIGNALED($?); + return undef() if WIFSTOPPED($?); + return 0 if !WEXITSTATUS($?); + return $isspam||1 if 1==WEXITSTATUS($?); # isspam + cluck "Possible FIXME or your system is broken (WEXITSTATUS==".WEXITSTATUS($?).")"; + return 0; # simulate as not spam +} + # return: true (error-message or "1") if is spam sub spamassassin { my($cmd)=@_; - $cmd||="$HOME/bin/spamassassin --exit-code"; - # spamassassin has exit code 1 if IS spam, code 0 if NOT spam + $cmd||="spamassassin --exit-code 1"; + # spamassassin has the specified exit code if IS spam, code 0 if NOT spam + # See &_spamchildcode for the code 1. local *CHILD; local $SIG{"PIPE"}=sub { warn "spamassassin gave me SIGPIPE: broken pipe"; }; # prevent Razor2's: Can't call method "log" on unblessed reference at Razor2/Client/Agent.pm line 212. @@ -502,16 +529,12 @@ my($cmd)=@_; open CHILD,"|$cmd --mbox >/dev/null 2>/dev/null" or return 0; print CHILD $Message; - my $return=close CHILD; - return undef() if !WIFEXITED($?); - return undef() if WIFSIGNALED($?); - return undef() if WIFSTOPPED($?); - return 1 if WEXITSTATUS($?); # is-spam - return 0; # not-spam + close CHILD; + return _spamchildcode; } # NOTE: returns undef() if !wantarray and the first header is unrecognized -# Returns also hosts +# Returns always HOST:IP pair(s). sub Received_for { my @r=(); @@ -528,27 +551,72 @@ sub Received_for # Extended Mail::Audit::MAPS # $domain,$full,[$timeout] +# Returns false if valid, code if spam detected. sub dnsbl { my($domain,$full,$timeout)=@_; $timeout||=30; # sec $Mail::Audit::MAPS::host=$domain; - my @hosts=map({ s/^.*://; "[$_]"; } # strip DNS part - grep({ /^([^:@]*):/ # $1 is DNS name, $' is IP address - && !$alternates_host{$1} # leave only foreign hosts - && !$dnsbl_whitelist{$'}; } (Received_for())) - ); - splice @hosts,1 if !$full && @hosts; # "&& @hosts" to prevent: WARN: splice() offset past end of array - { - package My::Audit::Faked; - sub received { return @{$_[0]->{"received"}}; } + for my $host (Received_for()) { + next if $host!~/^([^:@]*):/; + my $ip=$'; + # $1 is DNS name, $ip is IP address + next if $alternates_host{$1}; # leave only foreign hosts + next if $dnsbl_whitelist{$ip}; + { + package My::Audit::Faked; + sub received { return @{$_[0]->{"received"}}; } + } + my $self_faked={ + "received"=>["[$ip]"], + }; + bless $self_faked,"My::Audit::Faked"; + my $code=Mail::Audit::rblcheck($self_faked,$timeout); + next if !$code; + # Some 0.0.0.0 etc. found for , see: &Mail::Audit::MAPS::_checkit + # Do not: $code!='1 Invalid IP address ' + # as it causes warn. + return $code if $code ne '1 Invalid IP address '; + return if !$full; } - my $self_faked={ - "received"=>[@hosts], - }; - bless $self_faked,"My::Audit::Faked"; - return Mail::Audit::rblcheck($self_faked,$timeout); +} + +# Returns true if IS virus; the message will contain the virus name +sub clamscan +{ +my($cmd)=@_; + + $cmd||='clamscan --no-summary -'; + # clamscan has exit code 1 if IS virus , code 0 if NOT virus + # Do not use IPC::Open2 as it would try to use our STDERR which is not valid by: local *STDERR; + local(*WR,*RD,*ERR); + local $SIG{"PIPE"}=sub { warn "clamscan '$cmd' gave me SIGPIPE: broken pipe"; }; + my $pid=open3(\*WR,\*RD,\*ERR,$cmd.' 2>&1') + or do { cluck "IPC::Open3 $cmd: $!"; return 0; }; + print WR $Message; + close WR or do { cluck "close WR of $cmd: $!"; return 0; }; + my $status=do { local $/=undef(); ; }; + close RD or do { cluck "close RD of $cmd: $!"; return 0; }; + # Do not: $status.=do { local $/=undef(); ; }; + # close ERR or do { cluck "close ERR of $cmd: $!"; return 0; }; + # (FIXME) as it causes: Use of uninitialized value in + # waitpid fills $? for: &_spamchildcode + local $SIG{"ALRM"}=sub { warn "Timeout $clamscan_waitpid_timeout sec waiting for child $cmd"; }; + alarm $clamscan_waitpid_timeout; + # Do not: WNOHANG + # as it would not be enough for clamscan(1) even after all close-s above. + my $pidcheck=waitpid($pid,0); + alarm 0; + my $err=$?; + $pidcheck && $pidcheck==$pid + or do { cluck "waitpid for $cmd returned $pidcheck!=$pid"; return 0; }; + $status=~s/^stdin: //mg; + # Prevent: LibClamAV Warning: PGP encoded attachment not scanned + $status=~s/^.*\bwarning:.*\n//img; + $status=~s/\n$//; + return $status if $status ne "OK" && $status; + return _spamchildcode $err,$status; } sub muttrc_aliases @@ -656,6 +724,63 @@ my($header,$map)=@_; $Audit->replace_header($header,$text); } +# LMTP engine: +use Net::Cmd qw(CMD_OK CMD_MORE); +{ + package My::Net::SMTP::LMTP; + require Net::SMTP; + our @ISA=qw(Net::SMTP); + use Net::SMTP; + use Net::Cmd qw(CMD_OK); + use Carp qw(confess cluck); + + # Do not: sub _HELO + # as it would not set {'net_smtp_esmtp'} + sub _EHLO { shift->command("LHLO", @_)->response() == CMD_OK } + + sub clucked + { + my($self,$func,@args)=@_; + + do { return $_ if defined $_; } for $self->$func(@args); + cluck $func; + return; + } +} + + +sub lmtp_deliver +{ +my($admin_user,$admin_pwd,$user_from,$user_to)=@_; + + my $lmtp=My::Net::SMTP::LMTP->clucked("new","localhost","Port"=>"lmtp", +# "Debug"=>1, + ) or return; + bless $lmtp,"My::Net::SMTP::LMTP"; +# Prevent: +# due to: +# $lmtp->auth(Authen::SASL->new( +# "mechanism"=>"PLAIN", +# "callback"=>{ +# "user"=>$admin_user, +# "pass"=>$admin_pwd, +# # Prevent: "authname"=>$admin_user +# # as it causes: DIE: Unknown callback: 'authname'. (user|auth|language|pass) +# })); + # FIXME: Authentication hack: + $lmtp->command("AUTH PLAIN")->response()==CMD_MORE + or do { cluck "auth announce"; return; }; + $lmtp->clucked("command",encode_base64($user_from."\x00".$admin_user."\x00".$admin_pwd)) or return; + $lmtp->clucked("mail",$user_from) or return; + $lmtp->clucked("to",$user_to) or return; + $lmtp->clucked("data"); # Do not: or return; + # Prevent: 554 5.6.0 Message contains invalid header + (my $data=$Message)=~s/\AFrom .*\r?\n//; + $lmtp->clucked("datasend",$data) or return; + $lmtp->clucked("dataend") or return; + $lmtp->clucked("quit") or return; +} + # MAIN