source: A2P/a2p/e-adresse.pl @ 14

#! /usr/bin/perl
#
# Copyright (c) 2004-2007 - Consultas, PKG.fr
#
# This file is part of A2P.
#
# A2P is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# A2P is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with A2P; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
# $Id: e-adresse.pl 3 2007-10-18 16:20:19Z guillaume $
#
# Program to handle service XML structure to send e-mail and return a status
#

# System libraries
use strict;

# A2P libraries
use A2P::EService::Tools qw( try abort get_conf get_id get_lib
                             get_useragent get_work );
use A2P::EService::SimpleXML ;

BEGIN {
    our $REVISION = sprintf "%s", q$Rev: 906 $ =~ /(\d[0-9.]+)\s+/ ;
}
our $REVISION ;

# Step 0: Read configuration and load libraries
my ( $service ) = $0 =~ m|([^/.]+)(\.pl)*$| ;

# Expected lists in configuration
my @getfromconf = qw( timeout SMTP body attachment From To Cc Bcc ) ;

try "Reading $service rev$REVISION configuration" ;
my $conf = &get_conf( $service, @getfromconf );
abort "Configuration not generated" unless ( ref($conf) =~ /^HASH/i );

try "Loading libraries" ;
map { &get_lib(@{$_}) or abort "$_ not found" } (
    # Library to use        supported version
    [ "Net::SMTP"     =>      2.29        ],
    [ "MIME::Types"   =>      1.17        ],
    [ "MIME::Lite"    =>      3.01        ],
    [ "Mail::Address" =>      1.74        ]
    ) ;

# Step 1: Get pdf file and e-adresse file as job list
try "Reading job to do" ;
my @job = &get_work() ;

try "Checking '@job' work to do" ;
abort unless ( @job == 2 and grep { defined and $_ } @job == 2 );

my ( $pdf, $xmlfile ) = @job ;

# Step 2: Read e-adresse file and verify its format
try "Loading new $service XML file" ;
my $xml = new A2P::EService::SimpleXML($xmlfile);
abort "Bad '$xmlfile' XML file"
    unless ( defined($xml) and $xml );

my $name = $xml->name ;
abort "Unexpected '$name' root node for $xmlfile"
    unless ( $name =~ /^eadresse$/ );

# Read attributs for the mail
try "Reading mail attributs" ;
my $xmlid        = $xml->attribut('id') ;
my $importance   = $xml->attribut('importance')   || 'normal' ;
my $sensitivity  = $xml->attribut('sensitivity')  || 'normal' ;
my $notification = $xml->attribut('notification') || 'no'     ;
my $confirmation = $xml->attribut('confirmation') || 'none'   ;

# Read recipients
try "Reading mail recipients" ;
my @from = $xml->nodes( 'rcpt', { type => qr/^from$/ }, 'name' );
my @to   = $xml->nodes( 'rcpt', { type => qr/^to|$/  }, 'name' );
my @cc   = $xml->nodes( 'rcpt', { type => qr/^cc$/   }, 'name' );
my @bcc  = $xml->nodes( 'rcpt', { type => qr/^bcc$/  }, 'name' );

# Basic checks on recipients
try "Checking From recipient" ;
abort "Only one From recipient supported" unless ( @from < 2 );
abort "No From recipient found" unless @from ;
try "Checking To recipients" ;
abort "No To recipient found" unless @to ;

# Recomposition
foreach my $key (qw(From To Cc Bcc)) {
    my $keyconf = $conf->{$key} ;
    next unless (defined($keyconf) and ref($keyconf) =~ /^HASH/i);
    next unless (defined($keyconf->{active}) and $keyconf->{active});

    my @address = grep { defined }
        ( $keyconf->{address}, { name => $keyconf->{name} } );

    abort "Bad $key reconfiguration with '@address'"
        unless ( @address == 2 );

    $keyconf->{replace} = 1 if ( $key eq 'From' );

    if (defined($keyconf->{replace}) and $keyconf->{replace}) {
        eval '@' . lc($key) . ' = ( \@address )' ;

    } else {
        eval 'push @' . lc($key) . ', \@address' ;
    }
}

# Sub to recompose recipient in RFC standard
sub recipient {
    return $_[0] unless ( ref($_[0]) =~ /^ARRAY/i );
    my ( $content, $attributs ) = @{$_[0]} ;
    my $name = exists($attributs->{name}) ? $attributs->{name} : "" ;
    return $content unless ($name);
    my $address = new Mail::Address( $name, $content) ;
    return $address->format ;
}

# Advanced check of recipients
try "Scanning recipients" ;
@from = map { &recipient($_) } @from ;
@to   = map { &recipient($_) } @to   ;
@cc   = map { &recipient($_) } @cc   ;
@bcc  = map { &recipient($_) } @bcc  ;

# Read subject and text of the mail
try "Getting subject" ;
my @subject = $xml->nodes( 'subject' );

try "Checking subject" ;
abort "Only one subject supported" unless ( @subject < 2 );
abort "No subject found" unless @subject ;

# Extract the subject
my ( $subject ) = @subject ;
chomp $subject ;
abort "Subject must not contain line feed" if ( $subject =~ /\n/ms );

# This last call must be done after nodes calls to avoid getting the content of
# nodes in the body.
try "Getting mail body" ;
my @body = $xml->nodes( 'body' );

try "Checking mail body" ;
abort "Only one body node supported" unless ( @body < 2 );
abort "No body found" unless @body ;
my ( $body ) = @body ;

# Set unique id for this mail and user-agent
my $mailid     = &get_id( $xmlid ) ;
my $user_agent = &get_useragent() ;

# Step 3: Prepare the mail and attach the PDF to the mail
try "Preparing the mail" ;

# Legal values
my %supported = (
    Disposition => {'inline' => 1, 'attachment' => 1},
    Type => {'multipart/mixed' => 1 , 'text/plain' => 1,
        'application/pdf' => 1},
    Encoding => {'7bit' => 1, '8bit' => 1, 'quoted-printable' => 0,
        'base64' => 1},
    Charset => {'iso-8859-1' => 1, 'UTF-8' => 1},
    Importance => {'low' => 1, 'normal' => 1, 'high'=> 1},
    Sensitivity => {'normal' => 1, 'confidential' => 'Company-Confidential',
        'private' => 'Private', 'personal' => 'Personal'},
    Notification => {'no' => 1, 'yes' => 1},
    Confirmation => { 'no' => 1, 'none' => 1, 'yes' => 1 }
    );

# Preparing headers
my ( $from ) = @from;

my $mail = MIME::Lite -> new (
    From          => $from,
    To            => \@to,
    Cc            => \@cc,
    Bcc           => \@bcc,
    Subject       => $subject,
    Type          => 'multipart/mixed',
    'Message-ID'  => $mailid,
    'User-Agent:' => $user_agent,
    'Return-Path' => $from
    );

# Preparing optionnal headers
abort "Bad xml attribute importance: $importance"
    unless(exists($supported{Importance} -> {$importance}) and
    $supported{Importance} -> {$importance});
$mail -> add('Importance' => $importance)
    unless($importance eq 'normal');

abort "Bad xml attribute sensitivity: $sensitivity"
    unless(exists($supported{Sensitivity} -> {$sensitivity}) and
    $supported{Sensitivity} -> {$sensitivity});
$mail -> add('Sensitivity' => $supported{Sensitivity} -> {$sensitivity})
    unless($sensitivity eq 'normal');

abort "Bad xml attribute notification: $notification"
    unless(exists($supported{Notification} -> {$notification}) and
    $supported{Notification} -> {$notification});
$mail -> add('Return-Receipt-To' => $from)
    unless($notification eq 'no');

abort "Bad xml attribute confirmation: $confirmation"
    unless(exists($supported{Confirmation} -> {$confirmation}) and
    $supported{Confirmation} -> {$confirmation});
$mail -> add('Disposition-Notification-To' => $from)
    unless($confirmation eq 'no' or $confirmation eq 'none');

# Preparing and attach body message
my $attr = $conf -> {body};

my $dispo = defined($attr -> {disposition})?
                $attr -> {disposition}:'inline';
abort "Bad conf for mail disposition: $dispo"
    unless(exists($supported{Disposition} -> {$dispo}) and
    $supported{Disposition} -> {$dispo});
my $type = defined($attr -> {type})?$attr -> {type}:'TEXT';
abort "Bad conf for mail type: $type"
    unless(exists($supported{Type} -> {$type}) and
    $supported{Type} -> {$type});
my $encoding = defined($attr -> {encoding})?
    $attr -> {encoding}:'8bit';
abort "Bad conf for mail encoding: $encoding"
    unless(exists($supported{Encoding} -> {$encoding}) and
    $supported{Encoding} -> {$encoding});
my $charset = defined($attr -> {charset})?
    $attr -> {charset}:'iso-8859-1';
abort "Bad conf for mail charset: $charset"
    unless(exists($supported{Charset} -> {$charset}) and
    $supported{Charset} -> {$charset});

my $msg = MIME::Lite -> new (
    Disposition => $dispo,
    Type        => $type,
    Encoding    => $encoding,
    Data        => $body,
    );
$msg -> attr('content-type.charset' => $charset);
$mail -> attach($msg);

# Attach the PDF
my ( $filename ) = $pdf =~ m|([^/]*)$|;
my $attachment = $conf -> {attachment};

unless (defined($attachment->{skip}) and $attachment->{skip}) {
    $dispo = defined($attachment -> {disposition})?
                    $attachment -> {disposition}:'inline';
    abort "Bad conf for attachment disposition: $dispo"
        unless(exists($supported{Disposition} -> {$dispo}) and
        $supported{Disposition} -> {$dispo});
    $type = defined($attachment -> {type})?
        $attachment -> {type}:'application/pdf';
    abort "Bad conf for attachment type: $type"
        unless(exists($supported{Type} -> {$type}) and
        $supported{Type} -> {$type});
    $encoding = defined($attachment -> {encoding})?
        $attachment -> {encoding}:'base64';
    abort "Bad conf for attachment encoding: $encoding"
        unless(exists($supported{Encoding} -> {$encoding}) and
        $supported{Encoding} -> {$encoding});

    # By default, we are trying to extract name from subject using
    # eventually a regex an sprintf template from configuration
    my $pdfname_re = qr/:\s+([^#]+)\s+#\s+([^#]+)\s+#\s+([^#]+)\s+#/ ;
    my $pdfname_printf = '%s-%s-%s.pdf' ;
    if (!defined($attachment -> {name})
    or $attachment -> {name} =~ /^from subject$/i) {
        # Get regexp from conf if available
        $pdfname_re = $attachment -> {name_re}
            if (defined($attachment -> {name_re})
            and ref($attachment -> {name_re}) =~ /^Regexp/i);

        # Get template name if available
        $pdfname_printf = $attachment -> {name_printf}
            if (defined($attachment -> {name_printf})
            and $attachment -> {name_printf} );

        my @elements = $subject =~ $pdfname_re ;
        $filename = sprintf( $pdfname_printf, @elements );
        abort "Can't compute valid pdfname from '@elements' and $pdfname_printf"
            unless ( $filename and $filename =~ /^.+\.pdf$/i );
    }

    $mail -> attach (
        Disposition => $dispo,
        Type        => $type,
        Encoding    => $encoding,
        Path        => $pdf,
        Filename    => $filename,
        );
}

# Step 4: Send the mail
try "Send the mail" ;

$! = 0;
my $SMTP = $conf->{SMTP} ;
my %supported_smtp = (
    'smtp'      => 1 ,
    'sub'       => 1 ,
    'sendmail'  => 1
    );

abort "No server defined"
    unless ( defined($conf -> {SMTP}) and $conf -> {SMTP} );

our $host = "" ;
my $sent = 0 ;

my @send_errors = () ;
$SIG{__DIE__} = sub {
        my ( $mesg ) = "@_" =~ /^(.*) at \(eval.*$/ms ;
        push @send_errors, $host . ": $mesg" ;
    } ;

# Check also the order
my @types = grep { exists($supported_smtp{$_}) and $supported_smtp{$_} }
    keys %{$SMTP} ;
abort "No supported type in configuration" unless @types ;

if (exists($SMTP->{order})) {
    my @order = @{$SMTP->{order}} ;
    my @newlist = () ;
    while (@order) {
        my $next = shift @order ;
        push @newlist, $next if ( grep { /^$next$/ } @types );
    }
    # Check we still have the same number of types
    abort "Bad order list in configuration" unless ( @newlist == @types );
    @types = @newlist ;
}

foreach my $type ( @types ) {

    my $server = $SMTP -> {$type};
    foreach $host (keys %{$server}) {
        if ($type eq 'smtp') {
            my $port = $server -> {$host} || 25 ;
            $sent ++ and last
                if eval '$mail->send($type, $host, Port => $port)' ;

        } elsif ($type eq 'sendmail') {
            my @args = @{$server -> {$host}} ;
            $sent ++ and last
                if eval '$mail->send($type, @args)' ;

        } elsif ($type eq 'sub') {
            my $sub = $server -> {$host} ;
            $sent ++ and last
                if eval '$mail->send($type, $sub, $host)' ;
        }
    }

    last if $sent ;
}

abort "@send_errors" unless $sent ;

# Step 5: Report status

exit(0);