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