1#/usr/bin/perl 2 3my @Id = split(/ /,'$Id checks.pl,v 1.q 2010/01/22 11:49:30 stas_degteff Exp $'); 4 5# Several checks for messages (perl hook for HPT) 6# (c) 2010 Grumbler 7# 8# This program is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation; either version 2 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18 19# The checksfilter() subroutine should 20# 21# usage example: 22# ============== 23# BEGIN{ require "checks.pl" } 24# sub filter() { 25# my $r=checksfilter(); 26# return $r if( length($r)>0 ); 27# ...some other functions... 28# } 29# sub process_pkt{} 30# sub after_unpack{} 31# sub before_pack{} 32# sub pkt_done{} 33# sub scan{} 34# sub route{} 35# sub hpt_exit{} 36# ============== 37 38## Settings: 39# 40@fromrobotnames = ( # Names if remote robots, don't pass these messages to local robots 41 "MAILER-DAEMON", 42 "areafix", 43 "filefix", 44 "devnull" 45 ); 46@myrobotnames = ( # Names of local robots 47 "areafix", 48 "filefix", 49 "mirror robot", 50 "ping-pong robot", 51 "Messages check robot" 52 ); 53 54my $maxmailsize=10485760; # 1 Mb # max message is allowed 55my $check_msgsize=1; # Check and stop big messages 56my $check_CHRS=1; # Check violates FTS - CHRS kludge 57my $check_CHRS_IMBPC=0; # Check violates FTS - "^ACHRS: IBMPC 2" is obsoleted 58my $check_CHRS_FIDO7=1; # Check violates FTS - "^ACHRS: FIDO7 2", "^ACHRS: +7_FIDO 2" 59my $bounce_nondelivery=0; # Bounce about non-delivery mail 60my $bounce_violates=0; # Bounce about FTS violates 61 62my $reportArea="ERRORS"; 63 64my $myname="Messages check robot"; # Robot name, uses in report 65my $bounce_subj="$myname bounce"; # Subject of bounce message 66 67my $sysopname="Sysop"; # Report destination name 68my $sysopaddr=$myaddr.".1"; # Report destination address 69my $report_subj="$myname report"; # Subject of report message 70my $report_origin="$myname: HPT-perl hook"; # Origin of report message 71 72################################################################################ 73my $report_tearline="$Id[1] $Id[2]"; 74(my $file=$Id[1]) =~ s/,v$//; 75undef @Id; 76$myaddr=(myaddr())[0] if( !scalar($myaddr) or ($myaddr eq "") ); 77 78$check_msgsize=0 if($maxmailsize<=0); 79 80sub checksfilter{ 81 my $msgid=undef; 82 if( $text =~ /^(.*\r)?\x01MSGID: ([^\r]+)\r/m ){ 83 $msgid = "$2"; 84 } 85 my $pid_eid=undef; 86 if( $text =~ /^(.*\r)?\x01[PE]ID: ([^\r]+)\r/m ){ 87 $pid_eid = "$2"; 88 } 89 my $tearline=undef; 90 if( $text =~ /^(.*\r)?--- ([^\r]+)\r/m ){ 91 $tearline = "$2"; 92 } 93 94 if( ! scalar($area) ) # if netmail 95 { 96 97 # Checks for robots 98 my $fromrobot = grep( /$fromname/i, @fromrobotnames ); 99 my $torobot = grep( /$toname/i, @myrobotnames ); 100 return "Message from robot to robot" if( $fromrobot and $torobot ); 101 undef $fromrobot; 102 103 my $tomyaddr = grep( /$toaddr/i, myaddr() ); 104 if( $torobot and ! $tomyaddr ) 105 { 106 my $msgtext=$text; 107 $msgtext =~ s/\x01/@/gm; 108 $msgtext =~ s/\n/\\x0A/gm; 109 $msgtext =~ s/\rSEEN-BY/\rSEEN+BY/gm; 110 $msgtext =~ s/\r---([ \r])/\r-+-\1/gm; 111 $msgtext =~ s/\r \* Origin: /\r + Origin: /gm; 112 my $bounce_subj = "Message to not my robot"; 113 my $bouncetext = "Hello!\r\rYou send message to alien robot via my node. Please send this message directly!.\r" 114 . "Original message header:\r From: \"$fromname\" $fromaddr\r To: \"$toname\" $toaddr\r" 115 . " Date: $date\r Subj: $subject\r Attr: $attr\r Received from: $pktfrom\r" 116 . "Original message text:\r*=========*\r$msgtext\r*=========*\r" 117 . "\r--- $report_tearline"; 118 putMsgInArea("",$myname,$fromname,$myaddr,$fromaddr,$bounce_subj,"","Uns Pvt Loc",$bouncetext,1); 119 return $bounce_subj; 120 } 121 122 undef $torobot; 123 } # if netmail 124 125 # Check for big message 126 if ($check_msgsize>0) 127 { 128 do {use bytes; $len=length($text)}; 129 if ($len > $maxmailsize) 130 { 131 if( $bounce_nondelivery ) 132 { 133 my $bouncetext = "Hello, $fromname!\r\rRegretfully I inform you that your message is rejected because of the excessive size.\r" 134 . "Details of rejected message:\r" 135 . "From: $fromname, $fromaddr\r" 136 . "To: $toname" . (scalar($area)? $toaddr : "") . "\r" 137 . "Subject: $subject\r" 138 . (scalar($area)? "Area: $area\r" : "") 139 . (scalar($msgid)? "MsgID: $msgid\r" : "") 140 . (scalar($tid_eid)? "TID: $tid_eid\r" : "") 141 . (scalar($tearline)? "Tearline: $tearline\r" : "") 142 . "Size: $len bytes\r" 143 . "\rSysop of the $myaddr may pass this message manually later or it may conclusively remove this message.\r" 144 . "\r--- $report_tearline\r * Origin: $report_origin ($myaddr)\r"; 145 putMsgInArea("",$myname,$fromname,$myaddr,$fromaddr,$bounce_subj,"","Uns Pvt Loc",$bouncetext,1); 146 } 147 w_log('C', "Perl($file): Message from $fromaddr " 148 .(scalar($area)? "in $area":"to $toaddr") 149 . " too large, drop into badarea" 150 . ( $bounce_nondelivery? ", bounce created." : "." ) ); 151 return "Message too large - must be approved manually"; # drop into badarea 152 } 153 } 154 155 # check for CHRS kludge 156 if( $check_CHRS>0 ) 157 { 158 my @chrs = grep /^\x01CHRS:/, split(/\r/,$text); 159 if( $#chrs > -1 ) 160 { 161 my $msgtext=""; 162 if( $#chrs > 0 ) 163 { 164 $msgtext .="* Error: CHRS kludge more one, extra CHRS kludges will ignored\r"; 165 } 166 $chrs[0] =~ s/^\x01/\@/; 167 if( $chrs[0] !~ /^\@CHRS:\s+[[:alnum:]-]+\s+[1-4]$/ ) 168 { 169 $msgtext .="* Error: invalid CHRS kludge, should be \"@CHRS: <charset> <level>\" where <level> is number 1..4 and <charset> is (alphanumberic) charset name:\r " . $chrs[0] . "\r"; 170 } 171 if( $check_CHRS_IMBPC>0 && $chrs[0] =~ /(IBMPC)/ ) 172 { 173 $msgtext .="* Warning: Charset name IBMPC is deprecated: \"" . $chrs[0] . "\"\r"; 174 if( $fromaddr =~ m(^2:[56][0-9][0-9]{2}?/) ) 175 { 176 $msgtext .=" It's recommended: \@CHRS: CP866 2\r"; 177 if( ($pid_eid =~ /GED/i) or ($tearline =~ /(GED|Golded)/i) ) 178 { 179 $msgtext ." To fix, set \"XLATLOCALSET CP866\" in golded.cfg " 180 ."for your Golded on Windows or DOS\r"; 181 } 182 } 183 } 184 if( $check_CHRS_FIDO7>0 && $chrs[0] =~ /(FIDO|\+7)/ ) 185 { 186 $msgtext .="* Error: Your charset is invalid (and russian fido uses charset CP866 usually):\r" 187 ." Present: " . $chrs[0] . "\r" 188 ." Recommended: \@CHRS: CP866 2\r" 189 ; 190 if( ($pid_eid =~ /GED/i) or ($tearline =~ /(GED|Golded)/i) ) 191 { 192 $msgtext ." To fix, set \"XLATLOCALSET CP866\" in golded.cfg " 193 ."for your Golded on Windows or DOS\r"; 194 } 195 } 196 if( $msgtext ) 197 { 198 if( $bounce_violates ) 199 { 200 my $bouncetext = "Hello, $fromname!\r\r" 201 . "Regretfully I inform you that your message is violates Fidonet standard.\r" 202 . "These message is passed via my node, but I asks for you to fix misconfiguration." 203 . "Details of message:\r" 204 . "From: $fromname, $fromaddr\r" 205 . "To: $toname" . (scalar($area)? $toaddr : "") . "\r" 206 . "Subject: $subject\r" 207 . (scalar($area)? "Area: $area\r" : "") 208 . (scalar($msgid)? "MsgID: $msgid\r" : "") 209 . "\r\rInformation about invalid kludge:\r" 210 . $msgtext 211 . "\r--- $report_tearline\r * Origin: $report_origin ($myaddr)\r"; 212 putMsgInArea("",$myname,$fromname,$myaddr,$fromaddr,$bounce_subj,"","Uns Pvt Loc",$bouncetext,1); 213 } 214 $msgtext = "Hello!\r\rMessage with invalid kludge is detected:\r" 215 . "From: $fromname, $fromaddr\r" 216 . "To: $toname" . (scalar($area)? $toaddr : "") . "\r" 217 . "Subject: $subject\r" 218 . (scalar($area)? "Area: $area\r" : "") 219 . (scalar($msgid)? "MsgID: $msgid\r" : "") 220 . ( $bounce_violates? "Bounce to $fromname are created.\r" : "" ) 221 . "\r\rInformation about invalid kludge:\r" 222 . $msgtext 223 . "\r--- $report_tearline\r * Origin: $report_origin ($myaddr)\r"; 224 putMsgInArea($reportArea,$myname,$sysopname,$myaddr,$sysopaddr,$report_subj,"","Uns Loc",$msgtext,1); 225 } 226 } 227 } 228} 229 230w_log('U',"$file is loaded"); 2311; 232