468 lines
12 KiB
Perl
Executable File
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
|
|
|
|
Original 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;
|
|
}
|