#=============================================================================
# Doloforge::Service::Bulkmail : configure the Bulkmail internal service for any client/project
#
# Prepare service directories, and not much more...
#
# Full help :
#   perldoc Doloforge::Service::Bulkmail
#=============================================================================



package Doloforge::Service::Bulkmail;

use strict;

# This base class implements the constructor and help methods in a generic way.
use base qw(Doloforge::Service);

use File::Basename;
use File::Path;
use Date::Parse;
use Storable;
use Data::Dumper;


#=============================================================================
=encoding utf8

=head1 NAME

Doloforge::Service::Bulkmail : Configure the Bulkmail internal service for any client/project

=head1 SYNOPSIS

    # Update the full configuration, running each client/project/service update
    doloforge config --update

=head1 DESCRIPTION

Todo

=cut


#=============================================================================
# Method update
#
# Update the service configuration on the host, depending on
# client/project/service config files...
# This method receives :
#   option: context options passesd on the command-line (quite useless there)
#   client_conf: client configuration file contents (client.$name.yaml)
#   project_conf: project configuration file contents (project.$name.client.$name.yaml)

sub update {
    my $self = shift;

    my ($option, $client_conf, $project_conf) = @_;

    # Copy the service skeleton directory into the project local and shared directory.
    # The Apache skeleton have fe/htdocs/, fe/_logs/, etc. empty directories.
    # FIXME : user/group ownership shouldn't change the same way on local and shared ([local]/logs read-only) / this is the case since group ownership is doloforge, not client
    if ($self->has_role('nfs_role')) {
        $self->skel_copy(
            "$self->{global}->{dir}->{skel}/service/shared/$self->{name}",                  # Skeleton directory to copy (skel/service/shared/[service]/)
            "$self->{global}->{dir}->{shared}/$client_conf->{name}/$project_conf->{name}",  # Where to copy it
            $self->{config}->{developerdirs},                                               # reference to the developers directories, that will have to be chown'ed to the following ownership
            ($client_conf->{uid} or $client_conf->{name}),                                  # user/group id of the client who owns this project. Developers of the same group will have write-access to files there.
            ($client_conf->{gid} or $client_conf->{name}),                                  # user/group id of the client who owns this project. Developers of the same group will have write-access to files there.
        );
    }
}


#=============================================================================
# Method finish
#
# Called when the whole update processing is finished, in order to setup the platform-wide things.

sub finish {
    my $self = shift;

    # The vlogger logging main directory must pre-exist on application servers before we start Apache
    $self->dir_entry(1, "$self->{global}->{stage} shared $self->{name}/_logs",  # always create the dir (1), directory description in messages
        ($self->{global}->{stages}->{$self->{global}->{stage}}->{dir}->{shared} || $self->{global}->{dir}->{shared}).
            "/.doloforge/$self->{name}/_logs",                                  # directory name
        oct($self->{global}->{permissions}->{shared}->[0]) | 002,               # permission on creation and update (in decimal form, hence the oct()), PLUS world-writable, because every developer will add his own report...
        $self->{global}->{permissions}->{user}->[0],                            # user is the generic doloforge ID
        $self->{global}->{permissions}->{group}->[0],                           # group is the generic doloforge group
        undef,                                                                  # there is no skeleton for this very simple directory
    ) if ($self->has_role('nfs_role'));
}


#=============================================================================
# Method maintenance_on_mail
#
# Run maintenance tasks on the central mail server... or split on appserv + nfs roles

sub maintenance_on_mail {
    my $self = shift;

    # Only run on the allowed stage
    return unless ($self->{global}->{stage} eq $self->{config}->{stage});

    $self->info("Maintenance for $self->{name} on mail server");

    # Parse syslog to create an intermediary log file from many sources
    $self->_parse_syslog();
    # Create a set of bounce reports for use by the "doloforge bulkmail" command
    $self->_report_bounce();
    # Replicate the configuration on every host of the platform
    system($self->{global}->{commands}->{syncplatform}) if ($self->{global}->{commands}->{syncplatform});
}

sub maintenance_on_appserv {
    my $self = shift;

    # Only run on the allowed stage
    return unless ($self->{global}->{stage} eq $self->{config}->{stage});

    $self->info("Maintenance for $self->{name} on appserv");

    # Parse syslog to create an intermediary log file from many sources
    $self->_parse_syslog();
}

sub maintenance_on_nfs {
    my $self = shift;

    # Only run on the allowed stage
    return unless ($self->{global}->{stage} eq $self->{config}->{stage});

    $self->info("Maintenance for $self->{name} on nfs");

    # Get external bounce files created via maintenance_on_mail on non-cluster hosts
    system($self->{global}->{commands}->{syncexternal}) if ($self->{global}->{commands}->{syncexternal});
    # Create a set of bounce reports for use by the "doloforge bulkmail" command
    $self->_report_bounce();
}


#=============================================================================
# Method _parse_syslog
#
# Parse the syslog files to get Delivery Status Notifications out of them.
# The sources of these DSNs are Postfix itself, the "doloforge bulkmail
# command, a maildrop-like piped service from Postfix, that parses incoming
# DSN emails, etc...
# All of these agents generate log lines that are parsed here.

sub _parse_syslog {
    my $self = shift;

    #-----------------------------------------------------------------------------
    # The log file to parse (at first, we simply ignore log rotations, ie. mail.log.0 will have a bit of contents that we do not check)
    my $maillog = $self->{config}->{maillog};

    # logtail stores the location of the last tail in the log file, and the inode of that file.
    my $logtaildir = "$self->{global}->{dir}->{varlib}/bulkmail/logtail";
    unless (-d $logtaildir) {
        $self->warn("Creating $logtaildir directory");
        mkpath($logtaildir);
    }
    # The process will create a set of timestamped files in the service's shared directory
    my $bouncedir = "$self->{global}->{dir}->{shared}/.doloforge/bulkmail/bounces";
    unless (-d $bouncedir) {
        $self->warn("Creating $bouncedir directory");
        mkpath($bouncedir);
    }
    # Remove special chars from the bounce file name
    my $bouncefile = $self->now();
    $bouncefile =~ s/\W+/-/g;
    $bouncefile .= ".$self->{global}->{host}.log";

    $self->info("Parsing $self->{config}->{maillog} log using $logtaildir, output to $bouncedir/$bouncefile");

    # Read the lines not yet read from the log file - let logtail deal with the details...
    my @cmd = ('logtail', "-f$maillog", "-o$logtaildir/".basename($maillog));
    push(@cmd, '-t') unless ($maillog =~ m/^\//); # don't update the logtail location if the log file name doesn't start with "/", denoting a relative file path, typical of test environment

    # Create the parsed log file out of the logtail contents
    open(LOG, '-|', @cmd) or $self->error("Can't pipe from ".join(' ', @cmd).": $!");
    open(BOUNCE, ">$bouncedir/$bouncefile") or $self->error("Can't create bounce file $bouncedir/$bouncefile: $!");
    while (my $line = <LOG>) {
        chomp($line);
        # Test each regular expression stored in the service config file
        foreach my $dsnregexp (@{$self->{config}->{dsnregexp}}) {
            # If the regexp matches, create the parsed contents from the config (which should form a line containing "date, email, type, dsn, message")
            if ($line =~ qr($dsnregexp->{regexp})) {
                print BOUNCE join("\t", eval $dsnregexp->{fields}), "\n";
                last;
            }
        }
    }
    close(LOG);
    close(BOUNCE);

    # Remove the log file if it is empty
    $self->info("Removing empty file $bouncedir/$bouncefile"), unlink("$bouncedir/$bouncefile") if (-z "$bouncedir/$bouncefile");
}


#=============================================================================
# Method _report_bounce
#
# Use the parsed log files to create a set of various bounce reports, containing
# only the bouncing email addresses, as defined by various algorithms.

sub _report_bounce {
    my $self = shift;

    #-----------------------------------------------------------------------------
    # Now prepare the synthesis of all those log files
    #   - just get the bounce-type lines
    #   - keep a single state for each email address (the last one)
    # FIXME This is just a simplistic first pass !!!
    # Ideally , we should follow this:
    #   ----- HARD -----
    #   200 - Adresse email non valide (mauvaise syntaxe)
    #   201 - Adresse email non valide
    #   501 - Adresse email inexistante
    #   505 - Nom de domaine invalide
    #   509 - Accès refusé
    #   510 5.1.1 - Adresse serveur inconnu
    #   511 5.1.3 - Mauvaise syntaxe serveur
    #   520 5.4.0 - Problème réseau indéterminé
    #   521 5.4.6 - Boucle posant problème
    #   522 5.5.0 - Problème de protocole
    #   523 5.7.1 - Message refusé
    #   515 4.4.1 - Aucune réponse de l'hôte
    #   ----- SOFT -----
    #   300 - Desabonnement manuel
    #   502 - Adresse email suspendue
    #   503 - Message considéré comm du spam
    #   504 - Relaying interdit
    #   506 5.2.2 - Boite email pleine
    #   507 - La transaction a échoué
    #   508 5.2.3 - Email trop long
    #   512 5.1.6 - Boite email déplacée
    #   513 4.0.0 - Erreur temporaire
    #   514 4.2.0 - Boite email existante en erreur temporaire
    #   516 4.4.7 - Délai de livraison expiré
    #   517 5.0.0 - Erreur non définie
    #   518 4.2.2 - Boite email pleine temporairement
    #   519 5.3.0 - Système existant mais problème indéfini
    my $bouncedir = "$self->{global}->{dir}->{shared}/.doloforge/bulkmail/bounces";
    my $reportdir = "$self->{global}->{dir}->{shared}/.doloforge/bulkmail/report";
    unless (-d $reportdir) {
        $self->warn("Creating $reportdir directory");
        mkpath($reportdir);
    }

    # Processing data, that can be read from disk, then written to at the end of the process, to be used as a cache betwwen runs
    # retrieve() is architecture-dependent ("Byte order is not compatible"), but this file can be safely ignored.
    #my $data = retrieve("$bouncedir/_data_cache") if (-e "$bouncedir/_data_cache");
    my $data = eval { retrieve("$reportdir/_data_cache") } if (-e "$reportdir/_data_cache");
    # Just get rid of all cache if it's data doesn't match the current cache version (kind of contents in the data)
    my $cache_version = 5;
    $data = undef if ($data->{_version} != $cache_version);
    $data->{_version} = $cache_version;
    my $now = time;

    # Read the bounce log files, starting from the oldest not read yet
    my ($logfile);
    foreach my $bouncefile (sort(glob("$bouncedir/*.log"))) {
        $logfile = basename($bouncefile);
        next unless ($logfile gt $data->{_last_log}); # Don't read the log if it's older than the last one read from cache

        my $timestamp = (stat($bouncefile))[9];
        next if ($self->{config}->{removeold} and ($timestamp < $now - $self->{config}->{removeold})); # Don't read the log if it's timestamp is too old to contain significant data anymore

        $self->info("Reading $bouncefile for report, timestamp=$timestamp");

        open(BOUNCE, "<$bouncefile") or $self->error("Can't open bounce file $bouncefile for parsing: $!");
        while (<BOUNCE>) {
            chomp;
            my ($date, $email, $type, $dsn, $message) = split("\t", $_, 5);
            # Don't store information about delivered emails even though a recipient with "delivered" + "bounced" is theoretically interesting
            #   VmPeak: 407888 kB with 2.0.0
            #   VmPeak:  50432 kB without 2.0.0
            # Only keep 2.x.x codes if they occur AFTER a 4.x.x or 5.x.x code
            next if (($dsn =~ m/^2\./) and not exists($data->{email}->{$email}));
            # Actually parse the date from the log line, instead of relying of the file's timestamp, because many file log lines mays not be parsed chronologically
            my $ts = str2time($date);
            # FIXME : stocker les timestamp au format ISO, lisible est aussi facilement comparables
            # Store as much info as needed to generate all possible reports
            $data->{email}->{$email}->{firstseen} = $ts if (not exists($data->{email}->{$email}->{firstseen}) or $data->{email}->{$email}->{firstseen} > $ts);
            # Si on a un 2.0.0 et un 5.7.1 à la même seconde sur 2 serveurs, le lastdsn=5 devrait avoir raison, car le 2 est probablement juste un transfert interne (ex. laetitia.vanalderwiert@etudiant.univ-reims.fr Oct 24 12:09:23, schell.severine@libertysurf.fr, lbm.magenta@infonie.fr)
            $data->{email}->{$email}->{lastdsn} = $dsn if ($data->{email}->{$email}->{lastseen} == $ts and $data->{email}->{$email}->{lastdsn} lt $dsn);
            $data->{email}->{$email}->{lastseen} = $ts, $data->{email}->{$email}->{lastdsn} = $dsn if ($data->{email}->{$email}->{lastseen} < $ts);
            #$data->{email}->{$email}->{lastseen} = $ts, $data->{email}->{$email}->{lastdsn} = $dsn if ($data->{email}->{$email}->{lastseen} <= $ts);
            $data->{email}->{$email}->{dsn}->{$dsn} = $ts if ($data->{email}->{$email}->{dsn}->{$dsn} < $ts);
        }
        close(BOUNCE);
    }
    $data->{_last_log} = $logfile;

    # Remove old email data, to keep size under control
    if ($self->{config}->{removeold}) {
        foreach (keys(%{$data->{email}})) {
            delete($data->{email}->{$_}) if ($data->{email}->{$_}->{lastseen} < $now - $self->{config}->{removeold});
        }
    }
    $data->{_emails} = scalar(keys(%{$data->{email}}));

    # Store the data cache (Storable machine-readable format, and Data::Dumper human-readable)
    store($data, "$reportdir/_data_cache");
#    open(DATA, ">$reportdir/_data_cache.txt");
#    print DATA "# Both cache files can be removed at any time, if the source logs are still laying around\n# vim:ft=perl\n";
#    print DATA Data::Dumper->new([$data], ['data'])->Indent(1)->Sortkeys(1)->Quotekeys(0)->Dump();
#    close(DATA);

    # Create the bounce report file
    #my $reportfile = $self->now();
    #$reportfile =~ s/\W+/-/g;
    #$reportfile = "report_$reportfile.csv";
    #my $reportfile = "report.csv";
    #$self->info("Creating report $reportdir/$reportfile, classes $reportdir/bounce_*.csv");
    $self->info("Creating classes $reportdir/bounce_*.csv");
    #open(REPORT, ">$reportdir/$reportfile") or $self->error("Can't create report file $reportdir/$reportfile: $!");
    open(HARD, ">$reportdir/bounce_hard.csv") or $self->error("Can't create bounce file $reportdir/bounce_hard.csv: $!");
    open(SOFT, ">$reportdir/bounce_soft.csv") or $self->error("Can't create bounce file $reportdir/bounce_soft.csv: $!");

    # Globally count emails by class
    my %class;

    # Each email is evaluated separately, and stored in the report in alphabetical order
    foreach my $email (sort(keys(%{$data->{email}}))) {
        my $state = $data->{email}->{$email};

        # Get the bounce status class out of the various DSNs for each address, compared using the config file definition
        my $class = 2;  # By default, an email is considered good; each higher DSN will increase it's status (ie. move it into a failed address)

        # If the last DSN seen for this address is a Success, which thus appeared AFTER a failure (see "($dsn =~ m/^2\./)" above),
        # then we consider that Success a definitive one and don't look further...
        unless ($state->{lastdsn} =~ m/^2\./) {
            # Test each DSN seen for this email
            foreach my $dsn (sort(keys(%{$state->{dsn}}))) {

                # Test each regular expression stored in the service config file
                foreach my $dsnclass (@{$self->{config}->{dsnclass}}) {
                    # If the TimeToLive for the regexp is expired, don't evaluate it
                    next if (exists($dsnclass->{ttl}) and ($state->{dsn}->{$dsn} < $now - $dsnclass->{ttl} * 3600));

                    # If the regexp matches, get the class out of it and do not continue
                    if ($dsn =~ qr($dsnclass->{regexp})) {
                        # Only increase the class, ie. "permament" is more significant than "transient", which is more significant than "OK"
                        $class = $dsnclass->{class} if ($dsnclass->{class} > $class);
                        last;
                    }
                }
            }
        }

        # Write the emails in the various reports, depending on the class of the bounce
        #print REPORT "$email\t$class\n";
        print HARD "$email\n" if ($class == 5);
        print SOFT "$email\n" if ($class == 4);
        $class{all}++;
        $class{$class}++;
    }
    #close(REPORT);
    close(HARD);
    close(SOFT);
    $self->info("Number of emails by class: ".join(', ', map { "$_=$class{$_}" } sort(keys(%class))));

    #$self->memory_usage("_report_bounce END");
}



1;
__END__

=head1 AUTHOR

Nicolas Huillard <F<nicolas@huillard.net>>, Dolomède

=head1 SEE ALSO

doloforge(1)

=cut
