fidohub/tools/filter.pl

# $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;
}