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