This repository has been archived on 2024-04-08. You can view files and clone it, but cannot push or open issues or pull requests.
fidohub/tools/filter.pl

468 lines
12 KiB
Perl
Executable File

# $Id$
# Template for perl hook
#
# API functions:
#
# w_log([level, ]str);
# outputs a string to hpt log
# no printf() format, use sprintf()!
#
# crc32(str)
# returns CRC-32 of string
#
# alike(s1, s2)
# return Levenstein distance between parameters (smaller -> more alike)
#
# putMsgInArea(area, fromname, toname, fromaddr, toaddr,
# subject, date, attr, text, addkludges);
# post to first netmail area if area eq "";
# set current date if date eq "";
# set fromaddr to ouraka if fromaddr eq "";
# attr -- binary or text string (i.e. "pvt loc k/s") (text form DEPRECATED!);
# date -- unixtime, as in time()
# addkludges can be:
# 0 not to add any kludges
# 1 to add required kludges (will add duplicates if they exist)
# 2 to add missing kludges (will never modify existing ones)
# 3 to update or add required kludges corresponding to addresses and flags
# required kludges are: (netmail) INTL, TOPT, FMPT; (all) FLAGS, MSGID
#
# myaddr()
# returns array of our addresses
# DEPRECATED! use @{$config{addr}} instead
#
# nodelistDir()
# returns nodelistDir from config
# DEPRECATED! use $config{nodelistDir} instead
#
# str2attr(att)
# converts attribute string to binary message attributes
#
# attr2str(attr)
# converts binary flags to string representation (Pvt Loc K/s)
#
# flv2str(flavour)
# converts binary flag, corresponding to flavour, to string (direct, crash)
#
# date2fts(time)
# converts unixtime to fts-1 format string ("dd mmm yy hh:mm:ss")
#
# fts2date(fts1)
# converts date in fts-1 format string to unixtime
#
# mktime(sec, min, hour, wday, mon, year[, wday, yday[, dst]])
# makes unixtime like POSIX mktime, but year:
# year 0..69 -> 2000..2069, 70..1900 -> 1970..3800, other -> as-is
# month'es: 0 - January, 1 - February, ..., 11 - December (as in POSIX)
# dst - daylight saving time flag (1 or 0)
# WARNING: dst can result in +/-1 hour mismatch; use mktime(localtime) for
# correct unixtime
#
# strftime(format, unixtime)
# strftime(format, sec, min, hour, wday, mon, year[, wday, yday[, dst]])
# converts unixtime or a time structure to string according to format
# man strftime() for details
#
# gmtoff([unixtime])
# returns difference between local time and UTC in hours (e.g., can be +4.5)
# if unixtime is omitted, current time used
#
# WARNING: Don't redefine already predefined variable via my() or local().
# otherwise their values will not be put back into hpt.
#
#use strict;
#== GLOBAL CONFIGURATION PARAMETERS - DO NOT CHANGE ==#
#http://ftsc.org/docs/fsc-0036.001
$DEBUG_MODE = 1;
$MSG_PRIVATE = 0x0001; #/ Private Message
$MSG_CRASH = 0x0002; #/ Crash Priority Message
$MSG_READ = 0x0004; #/ Read by addressee
$MSG_SENT = 0x0008; #/ Sent Okay
$MSG_FILE = 0x0010; #/ File Attached
$MSG_FWD = 0x0020; #/ Being forwarded
$MSG_ORPHAN = 0x0040; #/ Unknown destination
$MSG_KILL = 0x0080; #/ Kill after mailing
$MSG_LOCAL = 0x0100; #/ Message originated here
$MSG_HOLD = 0x0200; #/ Hold for pickup
$MSG_X2 = 0x0400; #/ Reserved - Sent
$MSG_FREQ = 0x0800; #/ Requesting a file
$MSG_RREQ = 0x1000; #/ Return RCPT requested
$MSG_RRCT = 0x2000; #/ Return RCPT
$MSG_RAUD = 0x4000; #/ Request Audit Trail
$MSG_UREQ = 0x8000; #/ Request File Update
#== LOCAL CONFIGURATION ==#
# Message area to post route messages.
$ROUTE_NOTICE = 'PVT_TEST';
$FILTER_ORIGIN = 'Alterant MailHUB at your service'; # Text to add to tearline
$FILTER_TEARLINE = 'HPT-perl hook';
$FILTER_FROM = 'Hub Robot';
$SEMAFORE_DIR = '/fido/semafore';
@MY_POINTS = (
'10:1/1.1'
);
sub bounce
{
my($fromname,$fromaddr,$toname,$toaddr,$date,$subject,$text,$reason,$myaddr) = @_;
my($bouncetext);
if ($DEBUG_MODE==1) {
w_log('1',"filter-hub.pl: bounce: Bouncing message back to [$fromaddr]");
}
$text =~ tr/\r/\n/;
$text =~ s/\n\x01/\n\@/gs;
$text =~ s/^\x01/\@/s;
$bouncetext = <<EOF;
Hello $fromname.
Your message failed to be processed at this hub with reason:
$reason
Is this incorrect? If so let me know via netmail or deon\@leenooks.net
Orignal message:
============================================================================
FROM: $fromname ($fromaddr)
TO : $toname ($toaddr)
SUBJ: $subject
DATE: $date
============================================================================
$text
============================================================================
--- $FILTER_TEARLINE
* Origin: $FILTER_ORIGIN ($myaddr)
EOF
$attr = ($MSG_LOCAL | $MSG_KILL | $MSG_PRIVATE | $MSG_RRCPT);
putMsgInArea('',$FILTER_FROM,$fromname,$myaddr,$fromaddr,'Unable to deliver your Netmail','',$attr,add_tz($bouncetext),1);
if ($ROUTE_NOTICE) {
putMsgInArea($ROUTE_NOTICE,$FILTER_FROM,$fromname,$toaddr,$fromaddr,$subject,$date,$MSG_LOCAL,
add_tz("Unable to deliver Netmail\rhpt> $reason.\r\r".$text),0);
$newecho = 1;
}
$newnet = 1;
return $reason;
}
sub testmsg_config
{
if ($DEBUG_MODE==1) {
w_log('1','filter-hub.pl: testmsg_config');
}
# Work out origin address to use.
# testarea list, value "1" for ordinary areas, value "2" for passthrough areas.
if ($pktfrom =~ /^10:/) {
$myaddr = '10:1/1'; # Robot address
$testarea{'PVT_TEST'} = 1; # Echobase is exists
if ($DEBUG_MODE) {
w_log('1',"filter.pl: testmail_config: PRIVATE NET source using [$myaddr]");
}
} else {
w_log('1',"filter.pl: testmail_config: DEFAULT packet source ($pktfrom) using default [$config{addr}[0]]");
$myaddr=$config{addr}[0];
}
}
sub route_config
{
if ($DEBUG_MODE==1) {
w_log('1',"filter-hub.pl: route_config for [$toaddr]");
}
if ($toaddr =~ /^10:/) {
$check_exists = 1;
$myaddr = '10:1/1';
} else {
w_log('1',"filter.pl: route_config: DEFAULT packet toddr ($toaddr) using default [$config{addr}[0]]");
$check_exists = 0;
$myaddr=$config{addr}[0];
}
}
# == LOCAL FUNCTIONS ==
sub add_tz
{
my ($msg) = @_;
$TZ = strftime("%z",localtime());
$TZ =~ s/^\+//;
# Add a TZ kludge
return "\x01TZUTC: $TZ\r".$msg;
}
BEGIN{
require "/usr/local/bin/filter-testmsg.pl";
require "/usr/local/bin/filter-hub.pl";
require "/usr/local/bin/filter-route.pl";
}
sub filter
{
# predefined variables:
# $fromname, $fromaddr, $toname,
# $toaddr (for netmail),
# $area (for echomail),
# $subject, $text, $pktfrom, $date, $attr
# $secure (defined if message from secure link)
# return "" or reason for moving to badArea
# set $kill for kill the message (not move to badarea)
# set $change to update $text, $subject, $fromaddr, $toaddr,
# $fromname, $toname, $attr, $date
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: filter');
}
testmsg();
my $r=filter_hub();
w_log('1',"filter.pl: filter_hub [$r].");
return $r if (length($r)>0);
my $r=validate_route();
w_log('1',"filter.pl: validate_route [$r].");
return $r if (length($r)>0);
# If we get here, and a netmail, we'll trigger a pack
if (! $area && $toaddr)
{
$newnet = 1;
}
return '';
}
sub put_msg
{
# predefined variables:
# $fromname, $fromaddr, $toname, $toaddr,
# $area (areatag in config),
# $subject, $text, $date, $attr
# return:
# 0 not to put message in base
# 1 to put message as usual
# 2 to put message without recoding
# set $change to update $text, $subject, $fromaddr, $toaddr,
# $fromname, $toname, $attr, $date
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: put_msg');
}
return 1;
}
sub scan
{
# predefined variables:
# $area, $fromname, $fromaddr, $toname,
# $toaddr (for netmail),
# $subject, $text, $date, $attr
# return "" or reason for dont packing to downlinks
# set $change to update $text, $subject, $fromaddr, $toaddr,
# $fromname, $toname, $attr, $date
# set $kill to 1 to delete message after processing (even if it's not sent)
# set $addvia to 0 not to add via string when packing
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: scan');
}
return '';
}
sub export
{
# predefined variables:
# $area, $fromname, $toname, $subject, $text, $date, $attr,
# $toaddr (address of link to export this message to),
# return "" or reason for dont exporting message to this link
# set $change to update $text, $subject, $fromname, $toname, $attr, $date
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: export');
}
return '';
}
sub route
{
# $addr = dest addr
# $from = orig addr
# $fromname = from user name
# $toname = to user name
# $date = message date and time
# $subj = subject line
# $text = message text
# $attr = message attributes
# $route = default route address (by config rules)
# $flavour = default route flavour (by config rules)
# set $change to update $text, $subject, $fromaddr, $toaddr,
# $fromname, $toname, $attr
# set $flavour to flag, corresponding to flavour,
# or string hold|normal|crash|direct|immediate
# set $addvia to 0 not to add via string when packing
# return route addr or "" for default routing
return '';
}
sub tossbad
{
# $fromname, $fromaddr, $toname,
# $toaddr (for netmail),
# $area (for echomail),
# $subject, $text, $pktfrom, $date, $attr
# $reason
# return non-empty string for kill the message
# set $change to update $text, $subject, $fromaddr, $toaddr,
# $fromname, $toname, $attr
return '';
}
sub hpt_start
{
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: hpt_start');
}
}
sub hpt_exit
{
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: hpt_end');
}
local(*F);
untie %nodelist if $nltied;
untie %msg if $msgtied;
$nltied = $msgtied = 0;
close(F) if $newnet && open(F,">$SEMAFORE_DIR/newnet.now");
close(F) if $newecho && open(F,">$SEMAFORE_DIR/newecho.now");
close(F) if $newhtick && open(F,">$SEMAFORE_DIR/newhtick.now");
}
sub process_pkt
{
# $pktname - name of pkt
# $secure - defined for secure pkt
# return non-empty string for rejecting pkt (don't process, rename to *.flt)
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: process_pkt');
}
return '';
}
sub pkt_done
{
# $pktname - name of pkt
# $rc - exit code (0 - OK)
# $res - reason (text line)
# 0 - OK ($res undefined)
# 1 - Security violation
# 2 - Can't open pkt
# 3 - Bad pkt format
# 4 - Not to us
# 5 - Msg tossing problem
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: pkt_done');
}
}
sub after_unpack
{
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: after_unpack');
}
}
sub before_pack
{
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: before_pack');
}
}
sub on_echolist
{
# $_[0] - type (0: %list, 1: %query, 2: %unlinked)
# $_[1] - reference to array of echotags
# $_[2] - link aka
# $_[3] - max tag length in @{$_[1]}
# return:
# 0 to generate hpt-standard list
# 1 to return $report value as result
# 2 to use $report value as list and append hpt standard footer
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: on_echolist');
}
return 0;
}
sub on_afixcmd
{
# $_[0] - command code (see #define's in areafix.h)
# $_[1] - link aka
# $_[2] - request line
# return:
# 0 to process command by hpt logic
# 1 to skip hpt logic and return $report value as result
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: on_afixcmd');
}
return 0;
}
sub on_afixreq
{
# predefined variables:
# $fromname, $fromaddr, $toname, $toaddr. $subject, $text, $pktfrom
# return:
# 0 to ignore any changes
# 1 to update request parameters from above-mentioned variables
# (note: only $fromaddr and $text are meaningful for processing)
if ($DEBUG_MODE==1) {
w_log('1','filter.pl: on_afixreq');
}
return 0;
}
sub on_robotmsg
{
# process messages generated by robots
# predefined variables:
# $type, $fromname, $fromaddr, $toname, $toaddr. $subject, $text
#
# $type is one of the following: "afix", "ffix", "tosysop", or undef
# for messages from areafix, filefix, messages generated to sysop
# and of unknown origin, respectively.
#
# return:
# 0 to ignore any changes
# 1 to update message fields
if ($DEBUG_MODE==1) {
w_log('1',"filter.pl: on_robotmsg [$type]");
}
if ($type eq "areafix") {
$newnet = 1;
} elsif ($type eq "filefix") {
$newhtick = 1;
}
return 0;
}