X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-accept;h=e704077bce8d6a163b0e5cf34e23e6578c0d1fea;hp=3432acb7d094afd6508523254e3715e30d3177f1;hb=refs%2Fheads%2Fmaster;hpb=851de39e0b19fb4bd49c386e0da048e987110b72 diff --git a/perlmail-accept b/perlmail-accept index 3432acb..4feb8ec 100755 --- a/perlmail-accept +++ b/perlmail-accept @@ -1,6 +1,6 @@ #! /usr/bin/perl # -# $Id$ +# $Id: perlmail-accept,v 1.40 2010/07/16 07:19:36 lace Exp $ # Copyright (C) 2002-2003 Jan Kratochvil # # This program is free software; you can redistribute it and/or modify @@ -19,7 +19,7 @@ use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; +$VERSION=do { my @r=(q$Revision: 1.40 $=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; use strict; use warnings; @@ -46,6 +46,10 @@ INIT { use File::Basename; BEGIN { use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname($0); + + # FIXME: +# use lib split /:/,$ENV{"PERL5LIB"}; + use PerlMail::Config; use PerlMail::Lib; } @@ -69,13 +73,13 @@ require HTTP::Request; require LWP::UserAgent; use URI::Escape 'uri_escape'; require WWW::SMS; -require Authen::SASL; # Sanity check for &Net::SMTP::auth +#require Authen::SASL; # Sanity check for &Net::SMTP::auth use MIME::Base64; use IPC::Open3; use POSIX ":sys_wait_h"; -our($Message,@AuditStored,$DoBell); +our($Message,@AuditStored,$DoBell,$Dry); my %alternates_host; # from @alternates_host my %dnsbl_whitelist; # from @dnsbl_whitelist @@ -92,7 +96,6 @@ $procmailFROM_MAILER=qr'^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )[^> my $opt_mode; my $opt_smstest; # 1 or $smscount my $opt_idle; -my $opt_dry; my $opt_single; @@ -125,8 +128,9 @@ sub inetd while (1) { local $/="\n"; + $!=undef(); my $length=; - confess "Unexpected EOF" if !defined $length; + confess "Unexpected EOF: $!" if !defined $length; confess "Missing EOL" if $length!~s/\n$//s; exit 0 if $length eq "BYE"; confess "Unrecognized length: $length" if $length!~/^\d+$/; @@ -166,7 +170,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]; @@ -192,6 +196,12 @@ sub body_first return $first; } +sub is_multipart +{ + return 0 if !$Audit->is_mime(); + return $Audit->is_multipart(); +} + sub mimehead { my($part)=@_; @@ -380,7 +390,10 @@ my($name)=@_; die "Nesting profile: $name" if 0x10<=(local $profile_eval_depth=$profile_eval_depth+1); return @$name if ref $name; - die "Profile not found: $name" if !exists $audit_profile{$name}; + if (!exists $audit_profile{$name}) { + cluck "Profile not found: $name"; + return "did"; + } my @this=@{$audit_profile{$name}}; return (profile_eval($'),@this[1..$#this]) if $this[0] && $this[0]=~/^=/; return @this; @@ -415,17 +428,23 @@ my($folder,$profile,%args)=@_; $profile=$store_profile if !$profile; my %do=map({ (!/=/ ? ($_=>1) : ($`=>$')); } profile_eval($profile)); Sys::Syslog::syslog("info","%s%s%s: %s: %s", - (!$opt_dry ? "" : "--dry: "), + (!$Dry ? "" : "--dry: "), (!$store_ignore ? "" : "IGNORED[$store_ignore]: "), map({ cut($_); } $folder,address_show(unmime($Audit->from())),unmime($Audit->subject())), ) - if $do{"syslog"} || $opt_dry; + if $do{"syslog"} || $Dry; $folder=~s/;.*$//s; - $folder="$Mail/".$' if $folder=~/^=/; push @AuditStored,$folder if $do{"did"}; - return if $store_ignore || $opt_dry; + return if $store_ignore || $Dry; $DoBell++ if $do{"bell"}; - write_message($folder) or die; + my $folder1="$Mail/".$' if $folder=~/^=/; + write_message($folder1) or die $folder1; + if ($Mail2) { + my $folder2="$Mail2/".$' if $folder=~/^=/; + my $old=umask 0117; + write_message($folder2) or die $folder2; + umask $old; + } smssend_tryall $store_ignorenewmail,$do{"sms"},%args if $do{"sms"}; } @@ -443,17 +462,28 @@ my($funcref,@funcargs)=@_; return @AuditStored!=$did_last; } +sub writeto +{ +my($filename)=@_; + + local *F; + open F,$filename or confess "open $filename: $!"; + print F $Message or confess "write $filename: $!"; + close F or confess "close $filename: $!"; + return 1; +} + # Never use Mail::Audit->store() as it will reformat MIME bodies and possibly corrupt OpenPGP! sub write_message { my($folder)=@_; - return 1 if $opt_dry; # simulate OK + return 1 if $Dry; # simulate OK local *F; open F,">>$folder" or do { warn "Append \"$folder\": $!"; return 0; }; { local $_; - ($_=Mail::Audit::audit_get_lock(\*F,$folder)) and do { warn "Lock \"$folder\": $!"; last; }; + ($_=$Audit->_audit_get_lock(\*F,$folder)) and do { warn "Lock \"$folder\": $!"; last; }; seek F,0,IO::Handle::SEEK_END or do { warn "Seek-end \"$folder\": $!"; last; }; # FIXME: Check for '^From ' to not to rely on our network peer print F $Message or do { warn "Write to \"$folder\": $!"; last; }; @@ -498,11 +528,13 @@ sub _spamchildcode my($err,$isspam)=@_; $err=$? if !defined $err; - return undef() if !WIFEXITED($?); - return undef() if WIFSIGNALED($?); - return undef() if WIFSTOPPED($?); - return $isspam||1 if WEXITSTATUS($?); # is-spam - return 0; # not-spam + 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 @@ -510,14 +542,20 @@ sub spamassassin { my($cmd)=@_; - $cmd||="$HOME/bin/spamassassin --exit-code"; - # spamassassin has exit code 1 if IS spam, code 0 if NOT spam + #$cmd||="nice spamassassin --exit-code 1 --mbox"; + $cmd||="spamc -c -s 50000000"; + # 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. local $ENV{"HOME"}=$HOME; # 2>/dev/null to prevent error messages to corrupt inetd() output of perlmail-accept(1) - open CHILD,"|$cmd --mbox >/dev/null 2>/dev/null" + open CHILD,"|$cmd &>/dev/null" + # Workaround: spamassassin-3.1.3-1.fc5 + #.q{|awk '/^X-Spam-Flag: YES$/{if (!body) exit 1;}/^$/{body=1;}'} + # Original: + #." >/dev/null 2>/dev/null" or return 0; print CHILD $Message; close CHILD; @@ -547,7 +585,7 @@ sub dnsbl { my($domain,$full,$timeout)=@_; - $timeout||=30; # sec + $timeout||=2; # sec $Mail::Audit::MAPS::host=$domain; for my $host (Received_for()) { next if $host!~/^([^:@]*):/; @@ -555,15 +593,18 @@ my($domain,$full,$timeout)=@_; # $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); + +# FIXME: Faking +# { +# package My::Audit::Faked; +# sub received { return @{$_[0]->{"received"}}; } +# } +# my $self_faked=Mail::Audit->new(); +# $self_faked->{"received"}=["[$ip]"]; +# bless $self_faked,"My::Audit::Faked"; +# my $code=Mail::Audit::rblcheck($self_faked,$timeout); + my $code=$Audit->rblcheck($timeout); + next if !$code; # Some 0.0.0.0 etc. found for , see: &Mail::Audit::MAPS::_checkit # Do not: $code!='1 Invalid IP address ' @@ -578,7 +619,7 @@ sub clamscan { my($cmd)=@_; - $cmd||='clamscan --no-summary -'; + $cmd||='nice 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); @@ -665,9 +706,12 @@ my($re,$justone,$header,$maybeaddress)=@_; if (ref $header) { $header=join(",",&$header()); } - else { + elsif ($justone) { $header=$Audit->get($header); } + else { + $header=join(",",$Audit->get($header)); + } return 0 if !$header; return $header=~/$maybeaddress/i if "Regexp" eq ref $maybeaddress; return $header=~/$re/i if !defined(my $want=($maybeaddress=~/^\<(.*)\>$/)[0]); @@ -679,7 +723,7 @@ my($re,$justone,$header,$maybeaddress)=@_; { $_->address()=~/$'/i; } elsif ($want=~/\@$/) { $_->user() =~/^(?:\Qmailto:\E)?\Q$`\E/i; } - elsif ($want=~/^\@/) + elsif ($want=~/^\@/&&defined $') { $_->host() =~/^\Q$'\E/i; } else { $_->address()=~/^(?:\Qmailto:\E)?\Q$want\E/i; } @@ -697,6 +741,7 @@ sub headeris { my($header,$string)=@_; + cluck if !defined $string; return _headercore(qr/\Q$string\E/i,1,$header,$string); } @@ -715,64 +760,6 @@ 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 $Getopt::Long::ignorecase=0; @@ -780,7 +767,7 @@ die "GetOptions error" if !Getopt::Long::GetOptions( "inetd" ,sub { $opt_mode=\&inetd; }, "stdin" ,sub { $opt_mode=\&stdin; }, "single!" ,\$opt_single, - "dry" ,\$opt_dry, + "dry" ,\$Dry, "smstest:s",sub { $opt_mode=\&stdin; $opt_smstest=($_[1] || 1); }, "idle!" ,\$opt_idle, "idletest" ,sub { syslogging_restore(); print((defined($_=useridle()) ? $_ : "")."\n"); exit 0; },