################################################################################
##                    Plugin ArchiveScan pour SpamAssassin                    ##
################################################################################


# Nom de notre plugin/package/objet
package Mail::SpamAssassin::Plugin::ArchiveScan;

# Import de la classe de base pour les plugins Spamassassin (classe de laquelle on va hériter)
use Mail::SpamAssassin::Plugin;

use strict;
use warnings;

# Packages permettant de gérer les archives
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use Archive::Rar;
use IO::String;

use File::LibMagic;
#use Text::Extract::Word;

use Mail::SpamAssassin::Logger;

# Pour pouvoir appeler les fonctions directement sans placer le nom de l'objet devant
use vars qw(@ISA);
@ISA = qw(Mail::SpamAssassin::Plugin);

# +============================================================================+
# |                 Constructeur de notre objet/package/plugin                 |
# +============================================================================+
sub new 
{
    my $class = shift;
    my $mailsaobject = shift; # mailsaobject = MAILSpamAssassinOBJECT
    
    # Pour savoir si la fonction est appelée depuis la classe ou l'objet (instance de cette classe) 
    # http://lhullier.developpez.com/tutoriels/perl/intro/#LXI-M
    $class = ref($class) || $class; 
    # Appel du constructeur de la classe mère pour initiliser l'objet
    my $self = $class->SUPER::new($mailsaobject);
    # On "bénit" pour associer notre objet (= faire une référence de notre objet) à la classe
    bless ($self, $class);
    
    $self->register_eval_rule('is_attachment_virus');
    
    return $self;
}


# +============================================================================+
# |             Fonction principale d'evaluation des pieces jointes            |
# +============================================================================+
# Règle d'évaluation
# Retourne 0 ou 1 suivant les tests effectués
sub is_attachment_virus
{
    dbg("[ArchiveScan] ========================== Debut du plugin ArchiveScan =========================");
    
    my ($self, $pms) = @_;
    # $pms est un objet de type PerMsgStatus automatiquement envoyé par 
    # SpamAssassin et qui est le message à analyser. Voir la doc ici : 
    # http://spamassassin.apache.org/full/3.4.x/doc/Mail_SpamAssassin_PerMsgStatus.html
    
    my $return_code = 0;

    # Pour séparer les pieces jointes du corps du mail, on récupère ici les 
    # noeuds MIME qui ont un en-tête "Content-Disposition" et dont la valeur de 
    # celui-ci contient ("attachment") OU ("inline" ET qui est dans les formats
    # que l'on recherche).
    my @attachments = ();
    my @mail_parts = $pms->{msg}->find_parts(qr@^.*$@, 1);
    foreach my $mp (@mail_parts)
    {
        if(defined($mp->get_header("content-disposition")) &&
           defined($mp->get_header("content-transfer-encoding")))
        {
            # Récupération du nom de la piece jointe
            my $archive_content_disposition = $mp->get_header("content-disposition");
            $archive_content_disposition =~ m@.*filename="(?<filename>.*)".*@;
            my $archive_filename = $+{filename};
            #dbg("[ArchiveScan] >>> Archive filename : " . $archive_filename);
            
            if($mp->get_header("content-disposition") =~ m/.*attachment.*/ ||
               ($mp->get_header("content-disposition") =~ m/.*inline.*/ &&
                $archive_filename =~ m@^.*\.(zip|rar|cab|dat)$@i))
            {
                if(scalar(@attachments) <= 1)
                {
                    push(@attachments, $mp);
                }
                # Si on a plus d'un piece jointe, on s'arrête là
                else
                {
                    dbg("[ArchiveScan] L'email a plus d'une piece jointe, on laisse passer.");
                    return 0;
                }
            }
        } elsif(defined($mp->get_header("content-transfer-encoding")) && defined($mp->get_header("Content-Type")))
        {
                 dbg("[ArchiveScan] Pas de disposition mais content-type");
                 my $archive_content_type = $mp->get_header("content-type");
                 $archive_content_type =~ m@.*name="(?<filename>.*)".*@;
                 my $archive_filename = $+{filename};
                 $_ = $archive_filename;
                 if (defined($archive_filename) && m/\.doc/i) {
                     dbg("[ArchiveScan] >>> Archive filename : " . $archive_filename);
                     push(@attachments, $mp);
                 }
        }
    }

    # Si on a un seul fichier joint
    if(scalar(@attachments) == 1)
    {
        $a = $attachments[0];
        my $archive_filename = "";
        dbg("[ArchiveScan] Il y a bien qu'une seule piece jointe.");
        dbg("[ArchiveScan] >>> Content-Type : " . $a->get_header("content-type"));
        dbg("[ArchiveScan] >>> Content-transfer-encoding : " . $a->get_header("content-transfer-encoding"));
        if ($a->get_header("content-disposition")) {
            dbg("[ArchiveScan] >>> Content-disposition : " . $a->get_header("content-disposition"));
            my $archive_content_disposition = $a->get_header("content-disposition");
            $archive_content_disposition =~ m@.*filename="(?<filename>[a-zA-Z0-9_+-. ()]*)".*@;
            $archive_filename = $+{filename};
            if (not $+{filename} ) {
               $archive_content_disposition =~ m@.*filename=(?<filename>[a-zA-Z0-9_+-. ()]*)$@;
               $archive_filename = $+{filename};
            }
        } elsif ($a->get_header("content-type")) {
            dbg("[ArchiveScan] >>> Content-type : " . $a->get_header("content-type"));
            my $archive_content_type = $a->get_header("content-type");
            $archive_content_type =~ m@.*name="(?<filename>[a-zA-Z0-9_+-. ()]*)".*@;
            $archive_filename = $+{filename};
            if (not $+{filename}) {
               $archive_content_type =~ m@.*name=(?<filename>[a-zA-Z0-9_+-. ()]*)$@;
               $archive_filename = $+{filename};
            }
        }
        dbg("[ArchiveScan] >>> Archive filename : '" . $archive_filename . "'");
        # On vérifie que le fichier est bien un Zip ou un Rar et que l'encodage 
        # est bien en base64
        # Pour le format (zip/rar) on se base maintenant sur l'extension du 
        # fichier ("Windows Style") au lieu du type MIME car certaines archives
        # n'étaient pas détectés.  
        #my $archive_content_type = $a->get_header("content-type");
        #if($archive_content_type =~ m@.*(application/(x-)?zip(-compressed)?|application/x-rar(-compressed)?).*@ &&
        if(($archive_filename =~ m@^.*\.(zip|rar|cab|dat|doc)$@i &&
           lc($a->get_header("content-transfer-encoding")) =~ /^base64$/))
        {
            dbg("[ArchiveScan] La piece jointe est bien un Zip/Rar/Cab/Dat/Doc");
            
            my $archive_data = $a->decode();
            
            # On regarde la taille du fichier
            # Normalement l'encodage est du ascii donc 1 caractère = 1 octet
            if(length($archive_data) < 1024*1024)
            {
                dbg("[ArchiveScan] L'archive fait bien moins de 1024 Ko.");
                
                # +------------------------------------------------------------+
                # |                         Format Zip                         |
                # +------------------------------------------------------------+
                # Ancienne méthode se basant sur le type MIME
                #if($archive_content_type =~ m@.*(application/(x-)?zip(-compressed)?|WinRAR\.ZIP).*@)
                if($archive_filename =~ m@^.*\.zip$@i)
                {
                    dbg("[ArchiveScan] L'archive est au format Zip.");
                    
                    # Ouverture du fichier zip depuis la mémoire (= depuis une variable)
                    my $zip_io = IO::String->new($archive_data);
                    my $zip_object = Archive::Zip->new();
                    $zip_object->readFromFileHandle($zip_io);
                    # Si on a un seul fichier dans le zip on continue
                    if($zip_object->numberOfMembers() == 1)
                    {
                        dbg("[ArchiveScan] Il y a bien un seul fichier dans le Zip.");
                        # Si le fichier dans l'archive zip a une extension suspecte
                        if(($zip_object->memberNames())[0] =~ /\.(com|exe|scr|vbs|doc\.js)$/)
                        {
                            dbg("[ArchiveScan] Le fichier du Zip porte une extension suspecte. C'est un SPAM !");
                            $return_code = 1;
                        }
                    }
                }
                # +------------------------------------------------------------+
                # |                         Format Rar                         |
                # +------------------------------------------------------------+
                # Ancienne méthode se basant sur le type MIME
                #if($archive_content_type =~ m@.*application/x-rar(-compressed)?.*@)
                elsif($archive_filename =~ m@^.*\.rar$@i)
                {
                    dbg("[ArchiveScan] L'archive est au format Rar.");
                    
                    # Création d'un fichier temporaire dans lequel on va
                    # stocker notre archive. En effet, la bibliothèque Perl
                    # Archive::Rar ne nous permet d'ouvrir des Rar que 
                    # depuis des fichiers du disque et non directement 
                    # depuis la mémoire
                    open(my $tmp_rar, ">", "/tmp/spamassassin-archive-plugin-temporary-rar-file.rar");
                    print $tmp_rar $archive_data;
                    close($tmp_rar);
                    
                    my $rar_object = Archive::Rar->new( -archive => "/tmp/spamassassin-archive-plugin-temporary-rar-file.rar");
                    $rar_object->List();
                    # Si on a un seul fichier dans le rar on continue
                    if($rar_object->GetBareList() == 1)
                    {
                        dbg("[ArchiveScan] Il y a bien un seul fichier dans le Rar.");
                        # Si le fichier dans l'archive zip a une extension suspecte
                        if(($rar_object->GetBareList())[0] =~ /\.(com|exe|scr|vbs)$/)
                        {
                            dbg("[ArchiveScan] Le fichier du Rar porte une extension suspecte. C'est un SPAM !");
                            $return_code = 1;
                        }
                    }
                    # On supprime le fichier temporaire
                    unlink("/tmp/spamassassin-archivescan-plugin-temporary-rar-file.rar");
                }
                # +------------------------------------------------------------+
                # |                         Format Cab                         |
                # +------------------------------------------------------------+
                elsif($archive_filename =~ m@^.*\.cab$@i)
                {
                    dbg("[ArchiveScan] L'archive est au format Cab.");
                    
                    # Création d'un fichier temporaire dans lequel on va
                    # stocker notre archive. En effet, la bibliothèque Perl
                    # Archive::Rar ne nous permet d'ouvrir des Rar que 
                    # depuis des fichiers du disque et non directement 
                    # depuis la mémoire
                    my $cab = Archive::Cabinet->new("mycab.cab") or die "Couldn't open CAB.\n";



#                    open(my $tmp_rar, ">", "/tmp/spamassassin-archive-plugin-temporary-rar-file.rar");
#                    print $tmp_rar $archive_data;
#                    close($tmp_rar);
#                    
#                    my $rar_object = Archive::Rar->new( -archive => "/tmp/spamassassin-archive-plugin-temporary-rar-file.rar");
#                    $rar_object->List();
#                    # Si on a un seul fichier dans le rar on continue
#                    if($rar_object->GetBareList() == 1)
#                    {
#                        dbg("Il y a bien un seul fichier dans le Rar.");
#                        # Si le fichier dans l'archive zip a une extension suspecte
#                        if(($rar_object->GetBareList())[0] =~ /\.(com|exe|scr|vbs)$/)
#                        {
#                            dbg("[ArchiveScan] Le fichier du Rar porte une extension suspecte. C'est un SPAM !");
#                            $return_code = 1;
#                        }
#                    }
#                    # On supprime le fichier temporaire
#                    unlink("/tmp/spamassassin-archivescan-plugin-temporary-rar-file.rar");
                }
                # +------------------------------------------------------------+
                # |                         Format Doc                         |
                # +------------------------------------------------------------+
                elsif($archive_filename =~ m@^.*\.doc$@i)
                {
                    dbg("[ArchiveScan] L'archive est au format doc (Word).");
                    
                    my $f = unpack("a[2]", $archive_data);
                    dbg("[ArchiveScan] >>> Deux premiers octets de la piece jointe au format binaire : '$f'");
                    $f = unpack("H[2]", $archive_data);
                    dbg("[ArchiveScan] >>> Deux premiers octets de la piece jointe au format hexadecimal : '$f'");
                    
                    if($f eq "20")
                    {
                        dbg("[ArchiveScan] Le fichier .doc n'est pas binaire. C'est un SPAM !");
                        $return_code = 1;
                    }
                    else
                    {
                        dbg("[ArchiveScan] Le fichier .doc est bien un fichier binaire.");
                        
                        my $unpacked_data = unpack("a*", $archive_data);
                        if($unpacked_data =~ m@vba@i &&
                           ($unpacked_data =~ m@VBE6\.DLL@
                            || $unpacked_data =~ m@dialer\.exe@
                            || $unpacked_data =~ m@SO\.DLL@
                            || $unpacked_data =~ m@VbMethod@
                            || $unpacked_data =~ m@modClientTCP@
                            || $unpacked_data =~ m@MSO\.DLL@
                            || $unpacked_data =~ m@vbaProject\.bin@))
                        {
                            dbg("[ArchiveScan] Il contient du vba (plusieurs chaines typiques trouvees a l'interieur)");
                            
                            my $magic = File::LibMagic->new();
                            my $fh;
                            open( $fh, '<', \$archive_data);
                            my $info = $magic->info_from_handle($fh);
                            #my $info = $magic->info_from_string($archive_data2);
                            my $file_description = $info->{description};
                            close $fh;
                            
                            dbg("[ArchiveScan] >>> File description : " . $info->{description});
                            
                            my $page_number = '';
                            my $char_number = '';
                            $file_description =~ m@.*Number of Pages: (?<pages>\d+).*@;
                            $page_number = $+{pages};
                            $file_description =~ m@Number of Characters: (?<chars>\d+)@;
                            $char_number = $+{chars};
                            
                            if($page_number ne '' || $char_number ne '')
                            {
                                if($page_number == 1 &&
                                   $char_number < 50 &&
                                   length($archive_data) < 200*1024)
                                {
                                    dbg("[ArchiveScan] Le fichier doc ne fait qu'une seule page, contient moins de 50 caracteres et fait moins de 200 Ko. It's a Spam !");
                                    $return_code = 1;
                                }
                            }
                            else
                            {
                                dbg("[ArchiveScan] On n'a pas pu determiner le nombre de caracteres et le nombre de pages du fichier doc, mais on dit que c'est un spam.");
                                $return_code = 1;
                            }
                        }
                        
#                        my $magic = File::LibMagic->new();
#                        
#                        my $info = $magic->info_from_string($archive_data);
#                        # Prints a description like "ASCII text"
#                        dbg("[ArchiveScan] >>> Description : " . $info->{description});
#                        # Prints a MIME type like "text/plain"
#                        dbg("[ArchiveScan] >>> MIME-Type : " . $info->{mime_type});
#                        # Prints a character encoding like "us-ascii"
#                        dbg("[ArchiveScan] >>> Encoding : " . $info->{encoding});
#                        # Prints a MIME type with encoding like "text/plain; charset=us-ascii"
#                        dbg("[ArchiveScan] >>> MIME with encoding : " . $info->{mime_with_encoding});
#                        
#                        
#                        # Ouverture du fichier .doc depuis la mémoire (= depuis une variable)
#                        my $doc_io = IO::String->new($archive_data);
#                        my $file = Text::Extract::Word->new($doc_io);
#                        dbg("[ArchiveScan] >>> Contenu du fichier (texte) : '" . $file->get_text(":raw") . "'");
#                        
#                        dbg("[ArchiveScan] >>> Le fichier doc en complet en binaire : q" . unpack("a*", $archive_data));
                    }
                    
                }
                # +------------------------------------------------------------+
                # |                         Format Dat                         |
                # +------------------------------------------------------------+
                elsif($archive_filename =~ m@^.*\.dat$@i && $archive_filename ne "winmail.dat")
                {
                    dbg("[ArchiveScan] Le fichier est au format Dat et ne s'appel pas 'winmail.dat', donc on considere que c'est un spam");
                    $return_code = 1;
                }
            }
        }
        elsif($archive_filename =~ m@^.*\.doc$@i &&
              lc($a->get_header("content-transfer-encoding")) =~ /^(7bit|8bit)$/)
        {
            dbg("[ArchiveScan] Le fichier .doc mais l'encodage est du '7bit' ou '8bit'. C'est un SPAM !");
            $return_code = 1;
        }
    }
    
    dbg("[ArchiveScan] =========================== Fin du plugin ArchiveScan ==========================");
    
    return $return_code;
}

1; # Code de retour de chargement du module





# +============================================================================+
# |                               Documentation                                |
# +============================================================================+

# Installation
# ~~~~~~~~~~~~
#
# Dépendances
# -----------
#
# apt-get install libarchive-zip-perl libio-string-perl rar libmagic-dev
# perl -MCPAN -e 'install Archive::Rar'
# perl -MCPAN -e 'install Archive::Cabinet'
# perl -MCPAN -e 'install File::LibMagic'
# --- OLD --- perl -MCPAN -e 'install Text::Extract::Word'
#
# Si problème d'installation via CPAN, utiliser la commande ci-dessous :
# (source : http://www.perlmonks.org/?node_id=995156)
# curl -L http://cpanmin.us | perl - --self-upgrade
# ou suivre la procédure d'installation manuelle ici
# http://perl.about.com/od/packagesmodules/qt/perlcpan.htm
#
# Déploiement
# -----------
#
# Script à déployer sur Bora, Mistral, Blizzard, Yeti, Merlin avec la commande
# suivante :
# for s in bora mistral blizzard yeti merlin; do scp /etc/spamassassin/ArchiveScan.pm root@${s}:/etc/spamassassin/ArchiveScan.pm; done
# Puis recharger la configuration des hôtes ainsi :
# for s in bora mistral blizzard yeti merlin; do ssh root@${s} 'service spamassassin reload'; done


# Débuggage
# ~~~~~~~~~

# Lignes de commande servant à tester un mail avec spamassassin :
#
# 1) spamassassin -D < example_spam.eml
# ou
# 2) spamassassin -D < example_spam > output 2>&1 && less output && rm -f output
# ou
# 3) spamc --tests -c < example_spam_zip.eml
# 
# L'exemple 2 permet d'avoir la sortie dans `less`.
# L'exemple 3 est moins pratique car il soumet le mail au démon SpamAssassin et
# nécessite donc de recharger ce dernier lorsque l'on a effectué un changement
# dans le plugin ou les règles. Mais il a l'avantage de pouvoir tester la 
# configuration qui tourne actuellement.

# Lien vers la racine de la documentation de SpamAssassin :
# http://spamassassin.apache.org/full/3.4.x/doc/

# Lien vers le README de SpamAssassin
# http://svn.apache.org/repos/asf/spamassassin/branches/3.4/README

# Voir des examples de plugins fournis avec SpamAssassin dans :
# /usr/share/perl5/Mail/SpamAssassin/Plugin/

# Pour tester le chargement des modules :
# spamassassin --lint
# (il est aussi possible de rajoute `-D` pour avoir plus de détails)
# Plus d'infos ici  : http://wiki.apache.org/spamassassin/HowToDebug







