#!/usr/bin/perl -w

##### MILTER FILTRO DE FLUJO POR USUARIO
#
# REQUIERE (crítico):
#  define(`confMILTER_MACROS_ENVRCPT', `{_}, {mail_addr}, {mail_mailer}, {rcpt_mailer}, {rcpt_addr}, {i}, {auth_authen}, {auth_type}, {if_addr}')
#
#  Instalacion:
#     cp userflux.pl /usr/local/sbin/userflux
#     chmod a+rx /usr/local/sbin/userflux
#     cp userflux.conf /etc/mail/userflux.conf
#     cp userflux_bw.conf /etc/mail/userflux_bw.conf
#     cp userflux.init  /etc/init.d/userflux
#  (ver notas para configuracion!)
#                  
#
##############################################################################

use threads;
use threads::shared;  # NECESARIO para que funcionen los locks y shared
                      # NOTA: en Sendmail::Milter, ":shared" funciona (!?),
                      # sin embargo, NO VA el ": locked" (lo ignora) ni
                      # el lock($xx) (ABORTA!) ni las funiones de threads.

use Sendmail::Milter qw(:all);
use Socket;
use NetAddr::IP;      # "apt-get install libnetaddr-ip-perl" NO SIRVE (no soporta IPV6)
                      # Traida de CPAN nueva version 4.x e instalada [EN MASTIN]
my $netaddrIPV6=0;    # Cambiar si esta soportado IPV6 por NetAddr::IP

# use POSIX qw(strftime);
use POSIX;           # Para el sighandler, para el "close"
# use Errno qw(ENOENT);

use Sys::Syslog;

use strict;

my $testing=0;  # TESTING mode. Works, but always return a SMFIS_CONTINUE.
                
my $MYSELF="";

my $Nintervals=24;         # Number of time intervals in the circular buffer
my $SizeInterval=3600;    # Time interval size in seconds
# my $SizeInterval=10;       # Time interval size in seconds
my $expire_time=24*60*60;  # Lifetime of a "from" record, 
                           # Must NOT be smaller than $SizeInterval*$Nintervals !


my @initialrecord;   # Initial time interval counter values for the record of a "from".
$initialrecord[0]=1; for my $j (1..$Nintervals) { $initialrecord[$j]=0; };


#############################################################################
# Our global settings file, may be overridden if passed as a command line
#   parameter to the main userflux.pl script.
#############################################################################
my $config_file = "/etc/mail/userflux.conf";


#################################################################
# Our global settings that may be overridden from the config file
#################################################################

# If you do/don't want to see debugging messages printed to stdout,
#   then set this appropriately.
my $verbose = 1;

# Black/White listing config file
my $config_bw_file = "/etc/mail/userflux_bw.conf";

# Set the output file
my $outfile="/var/log/userflux.out";    # Outfile path (NEED RESTART)
my $log=1;      # Output goes to logfile, no to stdout (NEED RESTART)
my $synclog=1;  # Non-buffered output (NEED RESTART, can overwrite, only for testing)
my $logmail=1;  # Output mail trace date+ip+from+to+action
my $syslog=1;   # Use syslog LOCAL3

# Set this if you want milter add a informative header
my $addheader=1;

# Set this to indicate the milter "name" that this milter will be 
#   identified by.  This must match the first parameter from the 
#   INPUT_MAIL_FILTER definition in the sendmail.mc configuration.
my $milter_filter_name = 'UserFlux';

# This parameter determines how the milter interfaces with the libmilter
#   API.  Normally, if using a milter on the same machine that is running
#   sendmail, it will be something like 'local:/var/run/userflux.sock', 
#   but if you want to run the milter on a different machine than is running 
#   sendmail, you will need to specify how to connect to that copy of 
#   sendmail by setting this to indicate the machine and port that the 
#   remote sendmail is listening for connections on with something 
#   similar to 'inet:2526@sendmail.server.org'.
# This parameter must match the S= option in the INPUT_MAIL_FILTER
#   definition in the sendmail.mc file.
# my $milter_socket_connection = 'local:/var/run/userflux.sock';
my $milter_socket_connection = 'inet:808010@147.156.1.149';

# Where the pid file should be stored for userflux
my $userflux_pid_file = '/var/run/userflux.pid';

# Set this to something nonzero to limit the number of children that the 
#   milter will spawn.  Since children are never recycled (there seems 
#   to be a problem doing that with Sendmail::Milter), threads,
#   once created, will exist until the milter is shutdown.  Each thread
#   also consumes a database connection, so limiting db connections and
#   memory footprint are both good reasons to set this.
# If your mail server handles a large amount of mail, you may need to 
#   increase this limit to avoid blocking, but the default limit is
#   already pretty high, and should be sufficient for all but very 
#   large sites.
# Setting to zero makes the number of threads unlimited.
my $maximum_milter_threads = 100;


# If you have very large amounts of traffic and want to reduce the number of 
#   queries the db has to handle (and don't need these features), then these
#   wildcard checks can be disabled.  Just set them to 0 if so.
# If both are enabled, relay_ip is considered to take precedence, and is 
#   checked first.  A match there will ignore the rcpt checks.
my $check_wildcard_relay_ip = 1;
my $check_wildcard_rcpt_to = 1;
my $check_wildcard_rcpt_from = 1;


# The more important setting: how many messages/day will be allowed
# for checked users?
my $max_menssages_per_day=200;

# AND, list of "From" DOMAINS you want to check. If empty, ALL
my @list_of_domains_to_check=("uv.es","alumni.uv.es");

# Interval between DB dumps
my $dump_interval=15*60;   # 15 min (in seconds)

# File path for DB dumps
my $dump_file="/var/spam/userflux/userflux_DB.txt";  

# Each how may dumps we expire records, cleaning the table?
my $dumps_for_cleaning=2;


#############################################################
# End of options for use in external config file
#############################################################


# Global vars that should probably not be in the external config file
my $syslogopen=0;

# estas no son shared, asi cada thread lo lee cuando ve que se ha modificado
# (las variables de configuracion no son shared tampoco)
my $config_mtime=0;
my $config_bw_mtime=0;

# ..... Global state, shared vars
my %fromtab : shared;       # THE table!

my $finaldump : shared =0;     # Stop if this is a "finaldump" (triggered by HUP)   
my $restartmyself : shared =0; # Stop and restart (triggerted by USR1)

my $innet: shared;         # lock variable

my @blackdom : shared;
my @whitedom : shared;
my @whiteaddr : shared;
my @blackaddr : shared;
my @whitefrom : shared;
my @blackfrom : shared;


#############################################################################
#
# Milter Callback Functions:
#
#  Each of these callbacks is actually called with a first argument
#  that is blessed into the pseudo-package Sendmail::Milter::Context. You can
#  use them like object methods of package Sendmail::Milter::Context.
#
#  $ctx is a blessed reference of package Sendmail::Milter::Context to something
#  yucky, but the Mail Filter API routines are available as object methods
#  (sans the smfi_ prefix) from this
#
#############################################################################

# ------ RCPT ------------------------------------------------------------------------------
# Here we perform the bulk of the work, since here we have individual recipient
#   information, and can act on it.

sub envrcpt_callback : locked
{
  my ($ctx,$rcpt_to) = @_;
  
  if ($rcpt_to ne '<>' and $rcpt_to =~ /\A<(.*)>\Z/) {  # Remove outer angle brackets if present
    $rcpt_to = $1;
    }

  # Reloading config if changed... pero hay que hacer las variables "shared" para que
  # se enteren TODAS las threads! (NO: cada una lo lee cuando pasa por aqui si
  # el config_mtime NO es shared)
#  load_config(); 
  
  # Get the time in seconds
  my $timestamp = time();

  # print  strftime("\n=== %Y-%m-%d %H:%M:%S ===\n", localtime($timestamp)) if ($verbose);
  print  "\n===", scalar localtime ($timestamp) ,"===\n" if ($verbose);
  
  # declare our info vars
  my $headertoadd="Internal: not set";
  my $rowids=0;
  
  # Get the remote hostname and ip in the form "[ident@][hostname] [ip]"
  my $tmp = $ctx->getsymval("{_}");  
  my ($relay_ip, $relay_name, $relay_ident, $relay_maybe_forged);
  if ($tmp =~ /\A(\S*@|)(\S*) ?\[(.*)\]( \(may be forged\)|)\Z/) {
    $relay_ident = $1;
    $relay_name = $2;
    $relay_ip = $3;
    $relay_maybe_forged = (length($4) > 0 ? 1 : 0);
  }
  my $relay_name_reversed = reverse($relay_name);
        
  # Collect the rest of the info for our checks
  my $mail_mailer = $ctx->getsymval("{mail_mailer}");
  my $mail_from   = $ctx->getsymval("{mail_addr}");
  my $rcpt_mailer = $ctx->getsymval("{rcpt_mailer}");
  my $recipient   = $ctx->getsymval("{rcpt_addr}");
  my $queue_id    = $ctx->getsymval("{i}");
  my $authen      = $ctx->getsymval("{auth_authen}");
  my $authtype    = $ctx->getsymval("{auth_type}");
  my $ifaddr      = $ctx->getsymval("{if_addr}");

  # ... 
  my $ipv6_relay=1 if $relay_ip=~ /^IPv6:/;
  
  # If IP6, (Postgres et al) want address without "IPv6"
  $ifaddr=~ s/^IPv6://;  $relay_ip=~ s/^IPv6://; 

  my $Nrelay_ip; 
  { # Bloque para el lock.
    lock($innet);   # Para evitar problemas NetAddr::IP no es reentrante
    if ($ipv6_relay) {
      if ($netaddrIPV6) { $Nrelay_ip = new6 NetAddr::IP $relay_ip;  } 
      else { print "**No IPV6 support, relay: $relay_ip!\n" if ($verbose); }
      }
    else  { $Nrelay_ip = new NetAddr::IP $relay_ip;   }
    if (not defined $Nrelay_ip) { print "**No Nrelay_ip: $relay_ip!\n" if ($verbose); }
  }
  # ...

  print  "  Relay: $tmp - If_Addr: $ifaddr\n" if ($verbose);
  print  "  RelayIP: $relay_ip - RelayName: $relay_name - RelayIdent: $relay_ident - PossiblyForged: $relay_maybe_forged\n" if ($verbose);
  print  "  From: $mail_from - To: $recipient\n" if ($verbose);
  print  "  InMailer: $mail_mailer - OutMailer: $rcpt_mailer - QueueID: $queue_id\n" if ($verbose);

  # Only do our processing if the inbound mailer is an smtp variant.
  #   A lot of spam is sent with the null sender address <>.  Sendmail reports 
  #   that and other "local looking" from addresses as using the local mailer, 
  #   even though they are coming from off-site.  So we have to exclude the 
  #   "local" mailer from the checks since it lies.
  if (($mail_mailer !~ /smtp\Z/i) and 
      ($mail_mailer !~ /\Alocal\Z/i) and
      ($mail_mailer !~ /\Arelay\Z/i)
      ) {
    # we aren't using an smtp-like mailer, so bypass checks
    print  "  Mail delivery is not using an smtp-like mailer.  Skipping checks.\n" if ($verbose);
    if ($addheader) { $headertoadd="Skipped, not smtp mailer"; }
    if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Skipped, not smtp mailer"); }
    goto PASS_MAIL;
  }

  # Check to see if the mail is looped back on a local interface and skip checks if so
  if ($ifaddr eq $relay_ip) {
    print  "  Mail delivery is sent from a local interface.  Skipping checks.\n" if ($verbose);
    if ($addheader) { $headertoadd="Skipped, from local interface"; }
    if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Skipped, from local interface"); }
    goto PASS_MAIL;
  }

  # Special handling for the null sender.  Spammers use the null sender a ton, but 
  # so do things like Exim's callback  sender verification spam checks.  
  # UPDATE: Postfix appears to use <postmaster@some.domain> instead of the null 
  #   sender for it's SMTP callbacks, so added that as another workaround check.
  if ($mail_from eq "" or $mail_from =~ /^postmaster@/i ) {
    print  "  Sender is \"$mail_from\". Ignoring - continue.\n" if ($verbose);
    if ($addheader) { $headertoadd="Sender is system user. Skipped"; }
    if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Skipped, from system user"); }
    goto PASS_MAIL;
    }
  
  #if ($testing) { ### SIUV ###
  #  print  "*** $mail_from => $rcpt_to USER FLOW CHECKED! Please try again later (TEMPFAIL-CONT)\n" if ($verbose);
  #  return SMFIS_CONTINUE;
  #  }

  # If authentified, the From is the authen ID!
  if (defined($authen) and $authen ne "") {
    print  "  AuthType: $authtype - Credentials: $authen\n" if ($verbose);
    print  "  Mail delivery is authenticated.  From $mail_from is now $authen.\n" if ($verbose);
    $mail_from=$authen;
    }

  # ......... WHITE/BLACK IP LISTING..........................
  # Check wildcard black or whitelisting based on ip address or subnet
  #   Do the check in such a way that more exact matches are returned first
  if ($check_wildcard_relay_ip and defined $Nrelay_ip) {
    lock($innet);   # Para evitar problemas NetAddr::IP no es reentrante
  
    print "  Check Black/Whitelisting for relay ip\n" if ($verbose);
    
    my ($blacklisted,$whitelisted)=(0,0);
    for my $black (@blackaddr) { 
      my $Nblack;
      eval {
        if ($netaddrIPV6) { $Nblack=new6 NetAddr::IP $black; }
        else { $Nblack=new NetAddr::IP $black; }
        $blacklisted=1 if($Nblack->contains($Nrelay_ip)); 
        }
      }
    for my $white (@whiteaddr) {  
      my $Nwhite; 
      eval {
        if ($netaddrIPV6) { $Nwhite=new6 NetAddr::IP $white; }
        else { $Nwhite=new NetAddr::IP $white; }
        $whitelisted=1 if($Nwhite->contains($Nrelay_ip)); 
        }
      }
    
    if ($blacklisted) {
      print  "  Blacklisted Relay.  Skipping checks and rejecting the mail.\n" if ($verbose);
      if ($addheader) { $headertoadd="Blacklisted relay $tmp. Rejected"; }
      if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Blacklisted IP - reject"); }
      goto REJECT_MAIL;
      }
    if ($whitelisted) {
      print  "  Whitelisted Relay.  Skipping checks and passing the mail.\n" if ($verbose);
      if ($addheader) { $headertoadd="Whitelisted relay $tmp. User email not accounted"; }
      if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Whitelisted IP - continue"); }
      goto PASS_MAIL;
      } 
    }
  else { print "  NOT Checking Black/Whitelisting for relay ip\n" if ($verbose); }


  # ......... WHITE/BLACK RCPT DOMAIN LISTING........
  # See if this recipient (or domain/subdomain) is wildcard white/blacklisted
  if ($check_wildcard_rcpt_to) {
    
    print "  Check Black/Whitelisting for RCPT $rcpt_to\n" if ($verbose);
    
    # Pull out the domain of the recipient
    my $tstr = $rcpt_to;
    $tstr =~ /@([^@]*)\Z/;  # strip off everything before and including the last @
    my $rcpt_domain = $1; 
    if (not defined $rcpt_domain) { $rcpt_domain=""; }

    # extracts superdomains and add them to the domains to check
    # match exact domain when it is preceded by "@" in list (NO subdomain matching
    # in this case: "@uv.es" doesn't match "alumni.uv.es"; "uv.es" match.
    my @rcpt_domains=($rcpt_to,"\@$rcpt_domain"); 
    $tstr = $rcpt_domain;
    while(index($tstr, ".") > 0) { 
      push @rcpt_domains,$tstr; 
      $tstr =~ s/\A[^.]*\.(.*)\Z/$1/;  # strip off the leftmost domain part
      }

    # search lists
    my ($blacklisted,$whitelisted)=(0,0);
    for my $d (@rcpt_domains) { 
      for my $black (@blackdom) {  $blacklisted=1 if($d eq $black); };
      for my $white (@whitedom) {  $whitelisted=1 if($d eq $white); };
      }
    if ($blacklisted) {
      print  "  Blacklisted Recipient.  Skipping checks and rejecting the mail.\n" if ($verbose);
      if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Blacklisted rcpt"); }
      if ($addheader) { $headertoadd="Blacklisted rcpt $rcpt_to. Rejected"; }
      goto REJECT_MAIL;
      }
    if ($whitelisted) {
      print  "  Whitelisted Recipient.  Skipping checks and passing the mail.\n" if ($verbose);
      if ($addheader) { $headertoadd="Whitelisted rcpt $rcpt_to. User email not accounted"; }
      if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Whitelisted rcpt - continue"); }
      goto PASS_MAIL;
      } 
    }
  else { print "  NOT Checking recipient (or domain/subdomain) white/blacklisted\n" if ($verbose); }

  # ......... WHITE/BLACK FROM DOMAIN LISTING........
  # See if this recipient (or domain/subdomain) is wildcard white/blacklisted
  if ($check_wildcard_rcpt_from) {
    
    print "  Check Black/Whitelisting for FROM $mail_from\n" if ($verbose);
    
    # Pull out the domain of the recipient
    my $tstr = $mail_from;
    $tstr =~ /@([^@]*)\Z/;  # strip off everything before and including the last @
    my $from_domain = $1;
    if (not defined $from_domain) { $from_domain=""; }

    # extracts superdomains and add them to the domains to check
    my @from_domains=($mail_from);
    $tstr = $from_domain;
    while(index($tstr, ".") > 0) { 
      push @from_domains,$tstr; 
      $tstr =~ s/\A[^.]*\.(.*)\Z/$1/;  # strip off the leftmost domain part
      }

    # search lists
    my ($blacklisted,$whitelisted)=(0,0);
    for my $d (@from_domains) { 
      for my $black (@blackfrom) {  $blacklisted=1 if($d eq $black); };
      for my $white (@whitefrom) {  $whitelisted=1 if($d eq $white); };
      }
    if ($blacklisted) {
      print  "  Blacklisted From.  Skipping checks and rejecting the mail.\n" if ($verbose);
      if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Blacklisted from"); }
      if ($addheader) { $headertoadd="Blacklisted from $mail_from. Rejected"; }
      goto REJECT_MAIL;
      }
    if ($whitelisted) {
      print  "  Whitelisted From.  Skipping checks and passing the mail.\n" if ($verbose);
      if ($addheader) { $headertoadd="Whitelisted from $mail_from. User email not accounted"; }
      if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Whitelisted from - continue"); }
      goto PASS_MAIL;
      } 
    }
  else { print "  NOT Checking From (or domain/subdomain) white/blacklisted\n" if ($verbose); }

  # ....... MANTENIMIENTO DE LA LISTA CIRCULAR ......................
  #  tpuntero: tiempo en el puntero
  #  ipuntero: indice en el buffer circular del puntero
  #  circulo: buffer circular de 24h
  # my $NHORAS=24;  -- parametrizar el tamagno del buffer en horas con esta constante y
  #                    ponerla en configuracion!
  my $tnow=time();      # ahora, en sg
  my $total=0;          # flujo total medido

  if (defined $fromtab{$mail_from}) {
    print  "  RECORD FOUND=". $fromtab{$mail_from}."\n" if ($verbose);
    my ($tpuntero,$ipuntero,@circulo)=split /\|/,$fromtab{$mail_from};
    my $hnow=$ipuntero + int( ($tnow-$tpuntero)/$SizeInterval );  # Numero de intervalos en la diferencia (HORAS)
                         # indice de ahora en buffer... si este no fuera circular
    my $inow=$hnow%24;   # indice de ahora en buffer 
    print "  read: tpun=$tpuntero, ipun=$ipuntero, hnow=$hnow, inow=$inow\n" if ($verbose);
    $tnow=($hnow-$ipuntero)*$SizeInterval+$tpuntero;  # Renormaliza en nuevo puntero al principio del intervalo
    
    if ($hnow==$ipuntero) { $circulo[$inow]++; }
    else {
      if ($hnow <= 23) {
        for my $i ( ($ipuntero+1)..($inow-1) ) { $circulo[$i]=0; }
        $circulo[$inow]=1;
        }
      else {
        if ($hnow <= ($ipuntero+24) ) {
          for my $i ( ($ipuntero+1)..23 )  { $circulo[$i]=0; }
          for my $i (     0..($inow-1)  )  { $circulo[$i]=0; }
          $circulo[$inow]=1;
          }
        else {
          for my $i ( 0..23 ) { $circulo[$i]=0; }
          $circulo[$inow]=1;
          }
        }
      }
    $fromtab{$mail_from}=join '|',($tnow,$inow,@circulo);

    
    # ... Comprobacion del limite!
    for my $n (@circulo) { $total += $n; }
    if ($total > $max_menssages_per_day) {
      print  "  Too Many messages/day ($total) from $mail_from.  Delaying message.\n" if ($verbose);
      if ($addheader) { $headertoadd="Too Many ($total) messages/day from $mail_from.  Delaying message."; }
      if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Too many ($total) messages. Delaying - "); }
      goto DELAY_MAIL;
      }
    }
  else {
      $fromtab{$mail_from}=join '|',( $tnow,0,@initialrecord); 
      $total=1;
      }
  
  print  "  RECORD STORE=". $fromtab{$mail_from}."\n" if ($verbose);
  print  "  User $mail_from checked flow ($total) OK - passing the mail.\n" if ($verbose);
  if ($addheader) { $headertoadd="User e-mail Flow checked by Userflux"; }
  if ($logmail) { logmail($queue_id,$relay_ip,$mail_from,$rcpt_to,"Flow ($total) OK - continue"); }
  goto PASS_MAIL;
  

  ###########################################################################
  #
  # Here we have the goto tags for finishing the mail processing
  # logging done and headertoadd already set
  # MUST set always privdata
  #
  ###########################################################################

  # Predeclare privdata, since many of these gotos use it
  my $privdata;

  # .............................................................................
  REJECT_MAIL:
  if ($testing) { goto PASS_MAIL; }
  
  # Save our privdata for the next callback 
  $ctx->setpriv("0\x00$mail_from\x00$rcpt_to\x00$headertoadd");
  
  # Set the reply code to a unique message (for debugging) - this dsn is what is normally the default
  $ctx->setreply("551", "5.7.1", "Blacklisted. (USERFLUX REJECT)");
  
  # Issue a temporary failure for this message.  Connection may or may not continue.
  return SMFIS_REJECT;

  # .............................................................................
  DELAY_MAIL:
  if ($testing) { goto PASS_MAIL; }
  
  # Save our privdata for the next callback 
  $ctx->setpriv("0\x00$mail_from\x00$rcpt_to\x00$headertoadd");
  
  # Set the reply code to a unique message (for debugging) - this dsn is what is normally the default
  $ctx->setreply("451", "4.7.1", "Too many messages/day from $mail_from. Please try again later. (USERFLUX DELAY)");
  
  # Issue a temporary failure for this message.  Connection may or may not continue.
  return SMFIS_TEMPFAIL;

  # .............................................................................
  PASS_MAIL:
  
  # Save our privdata for the next callback
  $ctx->setpriv("0\x00$mail_from\x00$rcpt_to\x00$headertoadd");

  # And indicate the message should continue processing.
  return SMFIS_CONTINUE;

}

# ---- EOM --------------------------------------------------------------------------------
# The eom callback is called after a message has been successfully passed.
# It is also the only callback where we can change the headers or body.
# NOTE: It is only called once for a message, even if that message
#   had multiple recipients.  We have to handle updating the row for each
#   recipient here, and it takes a bit of trickery.
# NOTE: We will always get either an abort or an eom callback for any
#   particular message, but never both.

sub eom_callback : locked
{
  my $ctx = shift;

  # Get our status and check to see if we need to do anything else
  my $privdata_data = $ctx->getpriv();

  # NO deberia ser necesario, pero si se produce un problema con 
  # las threads, ocurre esto, por lo que hay que preveerlo
  if(not defined $privdata_data) {
    print "***EOM PRIVDATA undefined. Bypassing all tests\n";
    return SMFIS_CONTINUE;
    }

  print  "  IN EOM CALLBACK - PrivData: $privdata_data\n" if ($verbose);

  # parse and store the data
  my $rowids;
  my $mail_from;
  my $rcpt_to;
  my $headertoadd="";

  # save the useful data
  if ($privdata_data =~ /\A([-\d,]+)\x00(.*)\x00(.*)\x00(.*)\Z/) {
    $rowids = $1;
    $mail_from = $2;
    $rcpt_to = $3;
    $headertoadd = $4;
  }
  if (not defined $rowids or not defined $mail_from or not defined $rcpt_to or not defined $headertoadd) {
    print  "ERROR: Invalid privdata in envrcpt callback!\n";
    print  "  PRIVDATA: $privdata_data\n";
    }

  # Clear our private data on this context
  $ctx->setpriv(undef);
  
  # Add a header to the message (if desired)
  if ($addheader and not $ctx->addheader("X-Userflux", $headertoadd)) 
    { print  "  * Error adding header!\n"; }
    
  # And we handled everything successfully, so continue
  return SMFIS_CONTINUE;
    
}


# --- ABORT ---------------------------------------------------------------------------------
# The abort callback is called even if the message is rejected, even if we
#   are the one that rejected it.  So we ignore it unless we were passing
#   the message and need to increment the aborted count to know something
#   other than this milter caused it to fail.
# However, there is an additional gotcha.  The abort callback may be called
#   before we have a RCPT TO.  In that case, we also ignore it, since we
#   haven't yet done anything in the database regarding the message.
# NOTE: It is only called once for a message, even if that message
#   had multiple recipients.  
sub abort_callback
{
  my $ctx = shift;

  # Clear our private data on this context
  $ctx->setpriv(undef);

  return SMFIS_CONTINUE;

}



#######################################################################
# Other functions
#######################################################################

#------------------------------------------------------------------------------
sub logmail
{
  my ($queue_id,$relay_ip,$mail_from,$rcpt_to,$mess)=@_;
  if ($logmail) { 
    if ($syslog) {
      if (not $syslogopen) { openlog "userflux","",'LOG_LOCAL3'; $syslogopen=1; }
      syslog 'LOG_INFO',"$queue_id $relay_ip <$mail_from> to <$rcpt_to> $mess.\n"; 
      }
    else {
      print scalar localtime(time()),": $queue_id $relay_ip <$mail_from> to <$rcpt_to> $mess.\n"; 
      }
    }
}

#------------------------------------------------------------------------------
# This saves the table. ALSO, this
# deletes expired records every dumps_for_cleaning dumps.
my $thrid=0;  # THREAD ID (NO SHARED!)
my $stop : shared =0;
my $ndumps : shared =0;
sub dump_table : locked
{
  my ($dumpnow)=@_;

  # Esto genera un thread id que puede ser útil para logs.
  if ($thrid==0) { srand; $thrid=int (rand() *100); }
  # print "CHECK (",$thrid,") ",scalar (keys %fromtab),"\n";
  
  my $now=time();
  
  if ($stop) { 
    # So we don't stop other threads while dumping
    print "*** DUMPING TABLE (",$thrid,"): Another thread is dumping!\n" if ($verbose);
    return; 
    }
  else {
    $stop=1;
    
    if ($dumpnow or ($now - (stat($dump_file))[9]) > $dump_interval) {
      if (not open (FIDUMP,">$dump_file.tmp") ) {
        print "*** DUMPING TABLE (",$thrid,") Can't write to $dump_file nor expire records!!!: $!\n";
        die;
        }
      else {
        print "DUMPING TABLE (",$thrid,")\n";
        # lock($innet);   # Para evitar problemas con otras threads!
        my $gcount=0;  
        my $gxcount=0; 
        while (my ($key,$val)=each %fromtab ) {
          $gcount++;
          print FIDUMP "G\t$key\t$val\n";
          if ( ($ndumps % $dumps_for_cleaning) ==0) {
            my ($from_record_time)= split /\|/,$val,2;
            if ($from_record_time < ($now-$expire_time) ) { 
              delete $fromtab{$key}; $gxcount++;
              print "EXPIRED FROM RECORD $from_record_time<$now-$expire_time: $key $val\n" 
                if ($verbose);
              }
            }
          }
        print FIDUMP "N\tNFROM\t$gcount\n";
        close FIDUMP;
        print "DUMPED TABLE (",$thrid,") $gcount from entries";
        if ( ($ndumps % $dumps_for_cleaning) ==0) {
          print ", expired  $gxcount records";
          }
        print "\n";
        }
      rename "$dump_file.tmp",$dump_file;   # Solo la da por buena si termina!
      $ndumps++;
      
      if ($finaldump) { 
        if ($restartmyself) 
          { print "STOPPING AND RESTARTING MYSELF!!\n"; `$MYSELF`; }
        else { print "STOPPING\n"; }
        exit(0);
        } 
      }            
    $stop=0;
    }
}

#------------------------------------------------------------------------------
# Calls dump_table every 60 seconds to 
sub periodicdump
{
  print "Spawned dump/clean thread. Will do each $dump_interval seconds\n";
  my $cnt=0;
  while (1) {
    sleep $dump_interval;
    $cnt++;
    # print "DUMP $cnt\n";
    dump_table(1);
    }
}


#------------------------------------------------------------------------------
sub finaldump
{
  print "STOPPING after dump\n";
  $finaldump=1;
  dump_table(1);
}


#------------------------------------------------------------------------------
sub finaldumprestart
{
  print "STOPPING and RESTARTING after next dump\n";
  $finaldump=1; $restartmyself=1;
  # dump_table(1);
}


#------------------------------------------------------------------------------
sub load_table()
{
  print "LOADING TABLE ";
      
  if (not open (FIDUMP,"<$dump_file") ) {
    print "*** Can't read $dump_file. Beginning with an empty table !!!\n";
    }
  else {
    my $gcount=0;   my $rcount=0;
    while (<FIDUMP>) {
      chomp;
      my ($rtype,$key,$val)=split "\t";
      if ($rtype eq 'G') { $fromtab{$key}=$val; $gcount++; }
      if ($rtype eq 'N') { print "[$val $key] "; }
      }
    print "readed $gcount from entries\n";
    close FIDUMP;
    }
}

#------------------------------------------------------------------------------
sub load_config() : locked {

  # Reloading config if changed
  # my $NEWconfig_mtime=(stat($config_file))[9];
  # print "CONFIG TIME\n";  
  
  if ($config_mtime != (stat($config_file))[9] ) { 

    print "Loading Config File ($$): $config_file\n";
    if (not $config_file =~ /^\//) 
      { die "***Config file must be an absolute path: $config_file\n"; }

    open(CONFIG,"<$config_file") or die "***Reading $config_file : $!\n"; 
    my $allconfig=join '',(<CONFIG>);
    eval $allconfig;
    if ($@ ne '') { die "Error in config file $config_file: $@"; }
    close CONFIG;
    
    $config_mtime=(stat($config_file))[9];
    # print "CONFIG TIME: $config_mtime\n";  
    }
    
  # ........... White/Black listing config ....................
  # Reloading config if changed
  if ($config_bw_mtime != (stat($config_bw_file))[9] ) { 

    print "Loading Black/Whitelist ($$): $config_bw_file\n";
    if (not $config_bw_file =~ /^\//) 
      { die "***Config file must be an absolute path: $config_bw_file\n"; }

    open(BWCONF,"<$config_bw_file") or die "***Reading $config_bw_file : $!\n"; 
    @whiteaddr=(); @blackaddr=(); @whitedom=(); @blackdom=();
  
    while(<BWCONF>){
      chomp;
      next if (/^ *$/);
      next if (/^#/);
      my ($acl,$whitelist,$adom,$value) = split / +/;
      if (lc($adom) eq "addr") { 
        # ... Convierto la  12.5.136.144/24 a bits (32-24 bits a 0 al final)
        my $baddr=$value; my $ipv6=0;
        #if ($value =~ /:/) { $ipv6=1; }
        #if ($ipv6) { $baddr = new6 NetAddr::IP $value; }
        #else { $baddr = new NetAddr::IP $value; }
        
        if (lc ($whitelist) eq "whitelist") {
          # print "WHITE ADDR $value\n";
          push @whiteaddr,$baddr;
          }
        elsif ( lc ($whitelist) eq "blacklist") {
          # print "BLACK ADDR $value\n";
          push @blackaddr,$baddr;
          }
        else { print "**Invalid whitelist/blacklist field ($whitelist): $_\n"; }
        }
      elsif (lc($adom) eq "rcpt") { 
        if (lc ($whitelist) eq "whitelist") {
          # print "-- WHITE RCPT $value\n";
          push @whitedom,$value;
          }
        elsif ( lc ($whitelist) eq "blacklist") {
          # print "-- BLACK RCPT $value\n";
          push @blackdom,$value;
          }
        else { print "**Invalid whitelist/blacklist field ($whitelist) : $_\n"; }
        }
      elsif (lc($adom) eq "from") { 
        if (lc ($whitelist) eq "whitelist") {
          # print "-- WHITE FROM $value\n";
          push @whitefrom,$value;
          }
        elsif ( lc ($whitelist) eq "blacklist") {
          # print "-- BLACK FROM $value\n";
          push @blackfrom,$value;
          }
        else { print "**Invalid whitelist/blacklist field ($whitelist) : $_\n"; }
        }
      else { print "**Invalid addr/rcpt/from field ($adom): $_\n"; }
      }
    close BWCONF;

    $config_bw_mtime=(stat($config_bw_file))[9];
    # print "CONFIG TIME: $config_bw_mtime\n";  
    }
}

#------------------------------------------------------------------------------
sub print_config 
{
  print "==Configuracion B/W leida:\n";
  
  for $a (@whiteaddr) { 
    #if ($a->version == 6) { print $a,"=IPV6 WHITE\n"; }
    #else { print $a->addr,'/',$a->bits,"=IPV4 WHITE\n"; } # Tambien funciona asi
    if ($a =~ /:/) { print "$a=IPV6 WHITE\n"; }
    else { print "$a=IPV4 WHITE\n"; } # Tambien funciona asi
    }
  for $a (@blackaddr) { 
    #if ($a->version == 6) { print $a,"=IPV6 WHITE\n"; }
    #else { print $a,"=IPV4 WHITE\n"; }
    if ($a =~ /:/) { print "$a=IPV6 WHITE\n"; }
    else { print "$a=IPV4 WHITE\n"; }
    }
  for my $d (@whitedom) { print "$d WHITERCPT\n"; }
  for my $d (@blackdom) { print "$d BLACKRCPT\n"; }
  for my $d (@whitefrom) { print "$d WHITEFROM\n"; }
  for my $d (@blackfrom) { print "$d BLACKFROM\n"; }
  print "==\n";
  
}
 
#------------------------------------------------------------------------------
# Daemonize this program
use POSIX qw(setsid);
sub daemonize {
  chdir '/'               or die "Can't chdir to /: $!";
  open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
  if ($log) {
    open STDOUT, ">>$outfile"
                          or die "Can't write to $outfile: $!";
    }
  else {
    open STDOUT, '>/dev/null'
                          or die "Can't write to /dev/null: $!";
    }
  defined(my $pid = fork) or die "Can't fork: $!";
  exit if $pid;           # el padre termina
  setsid                  or die "Can't start a new session: $!";
  open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
}

#------------------------------------------------------------------------------
# Main

# Define el tipo de Dispatcher! (PARA EL PMILTER!)
# $ENV{"PMILTER_DISPATCHER"}='postfork';
# $ENV{"PMILTER_DISPATCHER"}='ithread';

my %my_callbacks =
(
#       'connect' =>    \&connect_callback,
#       'helo' =>       \&helo_callback,
#       'envfrom' =>    \&envfrom_callback,
        'envrcpt' =>    \&envrcpt_callback,
#       'header' =>     \&header_callback,
#       'eoh' =>        \&eoh_callback,
#       'body' =>       \&body_callback,
        'eom' =>        \&eom_callback,
        'abort' =>      \&abort_callback,
#       'close' =>      \&close_callback,
);

### BEGIN:
{
  if (scalar(@ARGV) > 1) {
    print  "Usage: perl $0 [config_file]\n\n"
      . "Please refer to documentation regarding changes to the configuration file\n"
      . "  where options that used to be specified on the command line are now\n"
      . "  set in the configuration file.\n"
      . "As an option, the path to the config file may be specified on the command line\n"
      . "  (to avoid modifying the filter script).\n";
    exit;
  }

  $MYSELF=$0;

  # CIERRA todo posible open fd => Para cuando restartea (los sockets NO parece que
  # tengan el "close-on-exec" y los hereda... en mal estado)!!. Deja 0,1,2 abiertos.
  POSIX::close( $_ ) for 3 .. 1024;

  # If the config file was specified on the command line, use it
  if (defined($ARGV[0])) {
    $config_file = $ARGV[0];
  }

  # Make sure there are no errors in the config file before we start, and load the socket info
  load_config();
  print_config();

  print("VERBOSE=1\n") if ($verbose);

  if ($synclog) { $|=1; } 
  
  # Stop on HUP, stop and restart on USR1
  # (no funciona!: algo debe desactivar los signals de perl)
  # $SIG{'USR1'} = \&finaldump; 
  my $sigset = POSIX::SigSet->new();
  my $action = POSIX::SigAction->new('finaldump',
                                     $sigset,
                                     &POSIX::SA_NODEFER);
  my $action2 = POSIX::SigAction->new('finaldumprestart',
                                     $sigset,
                                     &POSIX::SA_NODEFER);
  POSIX::sigaction(&POSIX::SIGHUP, $action);
  POSIX::sigaction(&POSIX::SIGTERM, $action);
  POSIX::sigaction(&POSIX::SIGUSR1, $action2);

  # Daemonize, open outfile and redirect stderr
  daemonize;

  print  "---STARTING userflux milter. ",scalar localtime(time),"\n";
  
  # Load saved table!
  load_table();
  
  # Spawn a thread to periodically dump table
  my $dumpthr = threads->new(\&periodicdump);
  if (not defined $dumpthr) { print "*** Can't start dump thread\n"; }
  $dumpthr->detach;

  # Record pid to file
  if (defined $userflux_pid_file) {
    open(PIDF, ">$userflux_pid_file") ||
      (print  "Unable to record PID to '$userflux_pid_file': $!\n" and exit 35);
    print PIDF "$$\n";
    close PIDF;
  }

  print  "Using connection '$milter_socket_connection' for filter $milter_filter_name\n";

  if ($milter_socket_connection =~ /^local:(.+)$/i) {
    my $unix_socket = $1;

    if (-e $unix_socket) {
      print  "Attempting to unlink local UNIX socket '$unix_socket' ... ";

      if (unlink($unix_socket) == 0) {
        print  "failed.\n";
        exit;
      }
      print  "successful.\n";
    }
  }

  if (not Sendmail::Milter::setconn("$milter_socket_connection")) {
    print  "Failed to set up connection: $?\n";
    exit;
    }

  #  The flags parameter is optional. SMFI_CURR_ACTS sets all of the
  #  current version's filtering capabilities.
  #
  if (not Sendmail::Milter::register("$milter_filter_name", \%my_callbacks, SMFI_CURR_ACTS)) {
    print  "Failed to register callbacks for $milter_filter_name.\n";
    exit;
  }
  print  "Starting Sendmail::Milter $Sendmail::Milter::VERSION engine.\n";
                          
  # Parameters to main are max num of interpreters, num requests to service before recycling threads
  # We don't set it to recycle children, as that seems to cause coredumps. (NOTE: anyway the milter code
  # RECYCLES the interpreter, shuting down and recreating it. This doesn't reduce number of interpreters,
  # only reinitializes them)
  if (Sendmail::Milter::main($maximum_milter_threads, 0)) {
    # NO sale por aquí cuando se le manda un Kill ?
    print  "Successful exit from the Sendmail::Milter engine.\n";
    sleep 10;  # NECESARIO?? PARA QUE TODAS LAS Threads terminen y 
               # no interfieran con el DUMP!
    $finaldump=1;
    dump_table(1);
  }
  else {
    print  "Unsuccessful exit from the Sendmail::Milter engine.\n";
  }

}

# Thread end?
#END {
#  }


