1use vtrack; 2use nidx qw(ncheck hub region nodeline); 3sub w_log; 4# -------------------------------------------------------------------- 5sub filter { 6 if (!defined $area) { process_netmail(); } else { process_echomail(); } 7 undef $change if $kill; # need not to change if it's killed anyway 8 return ''; 9} 10# -------------------------------------------------------------------- 11sub process_netmail { 12 w_log "process_netmail(): $sfrom ($from) -> $sto ($to) [".attr2str($attr)."]; pkt from $pktfrom (secure=$secure)"; 13 my @points = qw(2:463/180.8 2:550/180.8); 14 (my $to3 = $to) =~ s/\.\d+$//; 15 (my $from3 = $from) =~ s/\.\d+$//; 16 my $aux = "pkt from $pktfrom, ".($secure ? "" : "un")."secure"; 17 # kill netmail to me from daemons 18 # ping 19 if (me($to) && (lc $sto eq 'ping')) { 20 if ($attr & RRC) { 21 post('MAIL.BAD', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 22 "\x01Reason: Ping request with RRC flag\r".$text, 0); 23 $kill = 1; 24 return; 25 } 26 my $dt = strftime("%d %b %Y %H:%M:%S"); 27 response('ping', $sfrom, $from, "Ping reply", 28 "Your message has reached my system at $dt", 29 "��� ᮮ�襭�� ���⨣�� ���� ��⥬� $dt"); 30 $kill = 1; 31 return; 32 } 33 # rrq/arq to me 34 if (me($to) && $attr & (RRQ|ARQ)) { 35 if ($sto =~ /areafix|hpt|crashmail|ffix|allfix|filefix|vtrack/io) { 36 post('MAIL.BAD', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 37 "\x01Reason: RRQ/ARQ to robot\r".$text, 0); 38 $kill = 1; 39 return; 40 } 41 if ($attr & RRC) { 42 post('MAIL.BAD', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 43 "\x01Reason: RRQ/ARQ with RRC flag\r".$text, 0); 44 $kill = 1; 45 return; 46 } 47 my $dt = strftime("%d %b %Y %H:%M:%S"); 48 response('rrq', $sfrom, $from, "Return receipt response", 49 "Your message has been received at $dt", 50 "��� ᮮ�饭�� ����祭� $dt"); 51 } 52 # move my personal mail to inbox, send copy to my point 53 if ( me($to) && $sto =~ /(?:^val|k?hok?hlo|sysop)/io ) { 54 post('MAIL.RCV', $sfrom, $sto, $from, $to, $subj, $date, 55 ($attr|RCV)&~LOC, $text, 0); 56 $offs = gmtoff(); $offs = ($offs) ? sprintf("%+g", $offs) : ''; 57 my $fwd = "\x01Forwarded by $to \@".strftime("%Y%m%d.%H%M%S")."UTC$offs\r"; 58 post('NETMAIL', $sfrom, $sto, $from, '2:550/180.8', $subj, $date, 59 ($attr|TRS|K_S)&~(LOC|ATT|FRQ|URQ|KFS|TFS|HLD|CRA|DIR|IMM|ARQ|RRQ), $fwd.$text, 3); 60 $new_mail++; 61 $kill = 1; 62 return; 63 } 64 # save a copy of my home point mail here 65 if ( $to =~ m!(?:463|550)/180\.8$!o && $sto =~ /(?:^val|k?hok?hlo|sysop)/io ) { 66 my $fwd = "\x01Forwarded for $to \@".strftime("%Y%m%d.%H%M%S")."UTC$offs\r"; 67 post('MAIL.RCV', $sfrom, $sto, $from, '2:550/180', $subj, $date, 68 ($attr|RCV)&~LOC, $fwd.$text, 1); 69 } 70 # move other mail to my node to local netmail for robots to process 71 if ( me($to) ) { 72 return if $sto =~ /^(areafix|areamgr|hpt)$/oi; # hpt process on fly 73 post('MAIL.LOC', $sfrom, $sto, $from, $to, $subj, $date, $attr&~LOC, $text, 0); 74 $kill = 1; 75 return; 76 } 77 # not for me -- rewrite message flags 78 my $unsafe = HLD|CRA|DIR|IMM|LOC|A_S; 79 if ($attr & $unsafe) { $attr &= ~$unsafe; $change = 1; } 80 if (!($attr & (TRS|K_S))) { $attr |= TRS|K_S; $change = 1; } 81 # not for me -- fix fileattaches (path, KFS) 82 if ($attr & ATT) { 83 if ($attr & TFS) { $attr &= ~TFS; $change = 1; } 84 if (!($attr & KFS)) { $attr |= KFS; $change = 1; } 85 $change |= att_conv(); 86 } 87 # move messages from me to bad 88 if ( me($from) ) { 89 post('MAIL.BAD', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 90 "\x01Reason: Non-local message from me ($aux)\r".$text, 3); 91 $kill = 1; 92 return; 93 } 94 # move messages with unknown sender and recipient to bad 95 if ( !me($to3) && !me($from3) && !ncheck($from3) && !ncheck($to3) ) { 96 post('MAIL.BAD', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 97 "\x01Reason: Sender and recipient unlisted ($aux)\r".$text, 3); 98 $kill = 1; 99 return; 100 } 101 # move unsecure messages with unknown sender to bad 102 if ( !$secure && !ncheck($pktfrom) ) { 103 post('MAIL.BAD', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 104 "\x01Reason: Unsecure and pkt sender unknown ($aux)\r".$text, 3); 105 $kill = 1; 106 return; 107 } 108 # reject messages with unknown my point 109 if ( me($to3) && !in(\@points, $to) ) { 110 post('MAIL.BAD', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 111 "\x01Reason: Unknown my point ($aux)\r".$text, 3); 112 bounce('warn', $sfrom, $from, "Mail delivery warning", 113 "your message reached its destination node, but destination point is unknown", 114 "��� ᮮ�饭�� ��諮 �� 㧥� �����祭��, �� � ���� ��� ⠪��� �����"); 115 $kill = 1; 116 return; 117 } 118 # reject messages with unknown recipient 119 if ( !me($from) && !me($to3) && !ncheck($to3) ) { 120 bounce('nl', $sfrom, $from, "Mail delivery failure", 121 "recipient node address is unlisted", 122 "���� 㧫� �����⥫� �� ������ � �������"); 123 att_kill(); $kill = 1; 124 return; 125 } 126 # reject attaches to unprotected links 127 if ( !me($from) && !me($to3) && ($attr & ATT) && !$links{$to3} && !$links{$to} ) { 128 bounce('', $sfrom, $from, "Mail delivery failure", 129 "attaches to non-direct links are not allowed", 130 "���� �� ������� ������ �� ࠧ�襭�"); 131 att_kill(); $kill = 1; 132 return; 133 } 134 # check netmail loops 135 my $lc = loop_cnt(); 136 my $la = loop_age(0); 137 if ($lc > 7 || $la > 7) { 138 bounce('', $sfrom, $from, "Mail delivery failure", 139 "too many loops detected", 140 "ᮮ�饭�� ��横�������� �� ��宦����� �१ ��� 㧥�"); 141 att_kill(); $kill = 1; 142 return; 143 } 144 elsif ($lc > 0) { 145 post('MAIL.HLD', $sfrom, $sto, $from, $to, $subj, $date, $attr, 146 "\x01vtrack: Hold until \@".strftime("%Y%m%d.%H%M%S", time+24*3600)." at $config{addr}[0]\r".$text, 3); 147 $kill = 1; 148 return; 149 } 150 # check max age 151 if (age() > 30) { 152 bounce('', $sfrom, $from, "Mail delivery failure", 153 "message is already too old", 154 "c���饭�� 誮� ��"); 155 att_kill(); $kill = 1; 156 return; 157 } 158 # incomplete file attaches - hold message for an hour 159 if ( !me($from) && !att_check() ) { 160 post('MAIL.HLD', $sfrom, $sto, $from, $to, $subj, $date, $attr, 161 "\x01vtrack: Hold until \@".strftime("%Y%m%d.%H%M%S", time+3600)." at $config{addr}[0]\r".$text, 3); 162 $kill = 1; 163 return; 164 } 165} 166# -------------------------------------------------------------------- 167sub process_echomail { 168 w_log "process_echomail(): area $area, $sfrom -> $sto; pkt from $pktfrom (secure=$secure)"; 169 my $aux = "pkt from $pktfrom, ".($secure ? "" : "un")."secure"; 170 # should not even be here 171 if (!$secure) { 172 post('BADECHO', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 173 "\x01Reason: Echomail in unsecure packet ($aux)\r".$text, 0); 174 $kill = 1; 175 return; 176 } 177 # carbon copy personal mail 178 if ( lc $sto eq 'val khokhlov' ) { 179 post('PERSONAL', $sfrom, $sto, $from, $to, $subj, $date, $attr & ~(LOC), 180 "AREA:$area\r".$text, 0); 181 } 182} 183# -------------------------------------------------------------------- 184sub scan { 185 if ($area !~ /^(?:NETMAIL|MAIL\.)/io) { w_log "scan(): area $area; $sfrom -> $sto"; } 186 else { w_log "scan(): netmail $sfrom ($from) -> $sto ($to) [".attr2str($attr)."] in area $area"; } 187 # hold messages 188 if (uc $area eq 'MAIL.HLD') { 189 if ($text =~ /(?:^|\r)\x01vtrack:[^\@]*\@(\d{4})(\d{2})(\d{2})\.(\d{2})(\d{2})(\d{2})/) { 190 my $t = mktime($6, $5, $4, $3, $2-1, $1); 191 if ($t >= time) { return 'to be held for '.($t - time).'s'; } 192 $text =~ s/(^|\r)\x01vtrack:[^\r]+\r/$1/; 193 } 194 post('NETMAIL', $sfrom, $sto, $from, $to, $subj, $date, $attr, $text, 0); 195 $kill = 1; $new_mail++; 196 return 'moved to netmail'; 197 } 198 # netmail areas 199 elsif (uc $area eq 'NETMAIL' || $area =~ /^[Mm][Aa][Ii][Ll]\./o) { 200 # strip vtrack kludges - they're supposed to be local 201 if ($text =~ /(^|\r)\x01(vtrack:|Reason:)[^\r]+\r/) { 202 $text =~ s/(^|\r)\x01(vtrack:|Reason:)[^\r]+\r/$1/g; 203 $change = 1; 204 } 205 # my outgoing messages - move to sent 206 if (!($attr & K_S) && (uc $area eq 'MAIL.RCV' || 207 (uc $area eq 'NETMAIL' && me($from) && ($attr & LOC)))) { 208 post('MAIL.SNT', $sfrom, $sto, $from, $to, $subj, $date, $attr|SNT, $text, 0); 209 } 210 # check attached files 211 if (!me($from) && !att_check()) { 212 bounce('warn', $sfrom, $from, "Mail delivery warning", 213 "some of the attached files are absent - sending message without them", 214 "������� �� �ਠ��祭��� 䠩��� ���������� - ᮮ�饭�� 㩤�� ��� ���"); 215 } 216 # warn about unknown sender address 217 if ( !($attr & LOC) && !me($from3) && !ncheck($from) ) { 218 bounce('warn nl', $sto, $to, "Mail delivery warning", 219 "sender node address is unlisted - please don't reply via standard routing", 220 "���� 㧫� ��ࠢ�⥫� �� ������ � ������� - ��������, �� �⢥砩� �� �⠭���⭮�� ��⨭��"); 221 } 222 # don't keep messages in work area 223 $kill = 1; 224 return ''; 225 } 226 # others 227 return ''; 228} 229# -------------------------------------------------------------------- 230sub route { 231 w_log "route(): msg $sfrom ($from) -> $sto ($to) [".attr2str($attr)."]"; 232 $route = undef; $flavour = undef; my @routes; $addvia = 0; 233 (my $to3 = $to) =~ s/\.\d+$//; 234 my ($tohub, $toreg) = (hub($to3), region($to3)); 235 # route my points 236 if (me($to3)) { $flavour = HLD; $route = $to; } 237 # route local direct messages 238 elsif ($attr & (LOC|DIR)) { $flavour = DIR; $route = $to; } 239 # protected links direct hub-routing 240 elsif (defined $links{$to3}) { $route = $to3; } 241 elsif ($to3 !~ m!^2:550?/! && defined $links{$tohub}) { $route = $tohub; } 242 # n463 243 elsif ($tohub eq '2:463/0' || $tohub eq '2:463/59') { $route = '2:463/59'; } 244 elsif ($tohub eq '2:463/220') { $route = '2:463/220'; } 245 elsif ($tohub eq '2:463/2223') { $route = '2:463/2223'; } 246 elsif ($to3 =~ m!^2:463/!) { @routes = qw'2:463/220 2:463/59 2:463/2223'; } 247 # n464 248 elsif ($to3 =~ m!^2:464/!) { @routes = qw'2:464/910 2:550/4077'; } 249 # n465 250 elsif ($to3 =~ m!^2:465/!) { @routes = qw'2:465/204 2:5020/52'; } 251 # n467 252 elsif ($to3 =~ m!^2:467/!) { @routes = qw'2:5080/111 2:5020/52'; } 253 # n469 254 elsif ($to3 =~ m!^2:469/!) { @routes = qw'2:469/418 2:463/220'; } 255 # n5010 256 elsif ($to3 =~ m!^2:5010/!) { @routes = qw'2:5010/252 2:5020/52'; } 257 # n5080 258 elsif ($to3 =~ m!^2:5080/!) { @routes = qw'2:5080/111 2:5020/52'; } 259 # n550 260 elsif ($to3 eq '2:550/4077' || $to3 eq '2:550/5012') { $flavour = CRA; $route = '2:550/4077'; } 261 # r45 262 elsif ($toreg eq '2:45') { @routes = qw'2:450/42 2:5020/52'; } 263 # r46 264 elsif ($toreg eq '2:46') { @routes = qw'2:463/220 2:5020/52'; } 265 # r50 266 elsif ($toreg eq '2:50') { @routes = qw'2:5020/52 2:463/220'; } 267 # r55 268 elsif ($toreg eq '2:55') { @routes = qw'2:550/0 2:550/4077'; } 269 # world 270 else { $route = '2:550/0'; } 271 # check re-packing 272 my $rep = pack_age(); my $lim = 2; my $try = 0; 273 if (@routes) { 274 # how many tries was made 275 while ($rep > $lim) { $try++; $lim *= 2; } 276 w_log "route(): [note] try ".($try+1)." of ".scalar(@routes) if $try > 0; 277 # try link 278 $try = 0 if $try >= @routes; 279 ($flavour, $route) = $routes[$try] =~ /^([cihd])?(.*)/o; 280 } 281 if (!defined $rep) { 282 # ping 283 my $dt = strftime("%d %b %Y %H:%M:%S"); 284 if (defined $route && (lc $sto eq 'ping')) { 285 response('tracert', $sfrom, $from, "Traceroute reply", 286 "Your message was routed to $route by my system at $dt", 287 "��� ᮮ�襭�� ���ࠢ���� �� $route � ���� ��⥬� $dt"); 288 } 289 # arq 290 if ($attr & ARQ) { 291 response('arq', $sfrom, $from, "Audit response", 292 "Your message was routed to $route by my system at $dt", 293 "��� ᮮ�襭�� ���ࠢ���� �� $route � ���� ��⥬� $dt"); 294 } 295 # add via 296 addvia($route) if defined $route; 297 } 298 # set flavour from links, if unknows - to hold 299 $flavour = (defined $links{route}) ? $links{$route}{flavour} : 0 unless defined $flavour; 300 w_log "route(): route='$route', flavour='".flv2str($flavour)."'; defined=".(defined $flavour ? 1 : 0); 301 return $route; 302} 303# -------------------------------------------------------------------- 304sub hpt_start { 305 nidx::init($config{'nodelistDir'}, nidx, {soft_net=>1, ok_zone=>[1..6], w_log=>1}); 306 nidx::update('nodelist\.\d{3}', 'net_463\.\d{3}:2:46'); 307 $new_mail = $new_echo = 0; 308} 309 310sub hpt_exit { 311 nidx::done; 312 close FLG if $new_mail && open FLG, ">/home/val/fido/flags/pack.now"; 313 close FLG if $new_echo && open FLG, ">/home/val/fido/flags/scan.now"; 314} 315 316sub in { 317 my ($arr, $val) = @_; 318 for my $v (@$arr) { return 1 if $v eq $val; } 319 return 0; 320} 321# -------------------------------------------------------------------- 322# bounce($type, $toname, $toaddr, $subj, $eng, $rus) 323sub bounce { 324 my ($type, $_sto, $_to, $_subj, $eng, $rus) = @_; 325 my $fromstr = sprintf("%-36s%-17s%s", $sfrom, $from, strftime("%d %b %y %H:%M:%S", $date)); 326 my $tostr = sprintf("%-36s%-17s", $sto, $to); 327 (my $kludges = msg_kludges()) =~ tr[\x01][\@]; 328 (my $vias = msg_vias()) =~ tr[\x01][\@]; 329 my ($eng_hdr, $rus_hdr, $eng_nls, $rus_nls); 330 if ($type =~ /warn/) { 331 $eng_hdr = 'Your message is accepted for delivery with the following warning:'; 332 $rus_hdr = '��� ᮮ�饭�� �ਭ�� � ���⠢�� � ���騬 �।�०������:'; 333 } else { 334 $eng_hdr = 'Delivery of your message is cancelled because of the following reason:'; 335 $rus_hdr = '���⠢�� ��襣� ᮮ�饭�� �४�饭� �� ���饩 ��稭�:'; 336 } 337 if ($type =~ /nl/) { 338 $eng_nls = $rus_nls = join ' ', nidx::nodelists; 339 $eng_nls = "Following nodelists used for check: $eng_nls\n"; 340 $rus_nls = "�� ��થ �ᯮ�짮���� ��������: $rus_nls\n"; 341 } 342 my $s = <<EOM 343Greetings, $_sto! 344 345$eng_hdr 346 * $eng 347${eng_nls}Original message follows 348 349$rus_hdr 350 * $rus 351${rus_nls}�ਣ����쭮� ᮮ�饭�� ��� ���� 352 353=<==========================================================================<= 354 From: $fromstr 355 To : $tostr 356 Subj: $subj 357============================================================================== 358$kludges 359 360... message body skipped ... ⥪�� ᮮ�饭�� �ய�饭 ... 361 362$vias 363=<==========================================================================<= 364 365--- $hpt_ver+vtrack $VERSION 366EOM 367; 368 post('NETMAIL', 'vtrack', $_sto, '2:550/180', $_to, $_subj, time, PVT|LOC|K_S, $s, 1); 369 $new_mail++; 370} 371# -------------------------------------------------------------------- 372# response($type, $toname, $toaddr, $subj, $eng, $rus) 373sub response { 374 my ($type, $_sto, $_to, $_subj, $eng, $rus) = @_; 375 my $fromstr = sprintf("%-36s%-17s%s", $sfrom, $from, strftime("%d %b %y %H:%M:%S", $date)); 376 my $tostr = sprintf("%-36s%-17s", $sto, $to); 377 (my $vias = msg_vias()) =~ tr[\x01][\@]; 378 my $s = <<EOM 379Greetings, $_sto! 380 381$eng 382Original message header and Via lines follow 383 384$rus 385��������� �ਣ����쭮�� ᮮ�饭�� � ��ப� Via ���� ���� 386 387=<==========================================================================<= 388 From: $fromstr 389 To : $tostr 390 Subj: $subj 391============================================================================== 392$vias 393=<==========================================================================<= 394 395--- $hpt_ver+vtrack $VERSION 396EOM 397; 398 post('NETMAIL', 'vtrack', $_sto, '2:550/180', $_to, $_subj, time, PVT|LOC|K_S|RRC, $s, 1); 399 $new_mail++; 400} 401