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

Last change on this file since 5 was 3, checked in by guillaume, 17 years ago
  • AUTHORS: Ajout des différents contributeurs
  • COPYING: Ajout de la licence GPL v3
  • a2p: Préparation des sources pour leur publication sous GPL
  • Property svn:executable set to *
  • Property svn:keywords set to Id
File size: 12.2 KB
RevLine 
[3]1#! /usr/bin/perl
2#
3# Copyright (c) 2004-2007 - Consultas, PKG.fr
4#
5# This file is part of A2P.
6#
7# A2P is free software; you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation; either version 2 of the License, or
10# (at your option) any later version.
11#
12# A2P is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with A2P; if not, write to the Free Software
19# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
20#
21# $Id: e-adresse.pl 3 2007-10-18 16:20:19Z g $
22#
23# Program to handle service XML structure to send e-mail and return a status
24#
25
26# System libraries
27use strict;
28
29# A2P libraries
30use A2P::EService::Tools qw( try abort get_conf get_id get_lib
31                             get_useragent get_work );
32use A2P::EService::SimpleXML ;
33
34BEGIN {
35    our $REVISION = sprintf "%s", q$Rev: 906 $ =~ /(\d[0-9.]+)\s+/ ;
36}
37our $REVISION ;
38
39# Step 0: Read configuration and load libraries
40my ( $service ) = $0 =~ m|([^/.]+)(\.pl)*$| ;
41
42# Expected lists in configuration
43my @getfromconf = qw( timeout SMTP body attachment From To Cc Bcc ) ;
44
45try "Reading $service rev$REVISION configuration" ;
46my $conf = &get_conf( $service, @getfromconf );
47abort "Configuration not generated" unless ( ref($conf) =~ /^HASH/i );
48
49try "Loading libraries" ;
50map { &get_lib(@{$_}) or abort "$_ not found" } (
51    # Library to use        supported version
52    [ "Net::SMTP"     =>      2.29        ],
53    [ "MIME::Types"   =>      1.17        ],
54    [ "MIME::Lite"    =>      3.01        ],
55    [ "Mail::Address" =>      1.74        ]
56    ) ;
57
58# Step 1: Get pdf file and e-adresse file as job list
59try "Reading job to do" ;
60my @job = &get_work() ;
61
62try "Checking '@job' work to do" ;
63abort unless ( @job == 2 and grep { defined and $_ } @job == 2 );
64
65my ( $pdf, $xmlfile ) = @job ;
66
67# Step 2: Read e-adresse file and verify its format
68try "Loading new $service XML file" ;
69my $xml = new A2P::EService::SimpleXML($xmlfile);
70abort "Bad '$xmlfile' XML file"
71    unless ( defined($xml) and $xml );
72
73my $name = $xml->name ;
74abort "Unexpected '$name' root node for $xmlfile"
75    unless ( $name =~ /^eadresse$/ );
76
77# Read attributs for the mail
78try "Reading mail attributs" ;
79my $xmlid        = $xml->attribut('id') ;
80my $importance   = $xml->attribut('importance')   || 'normal' ;
81my $sensitivity  = $xml->attribut('sensitivity')  || 'normal' ;
82my $notification = $xml->attribut('notification') || 'no'     ;
83my $confirmation = $xml->attribut('confirmation') || 'none'   ;
84
85# Read recipients
86try "Reading mail recipients" ;
87my @from = $xml->nodes( 'rcpt', { type => qr/^from$/ }, 'name' );
88my @to   = $xml->nodes( 'rcpt', { type => qr/^to|$/  }, 'name' );
89my @cc   = $xml->nodes( 'rcpt', { type => qr/^cc$/   }, 'name' );
90my @bcc  = $xml->nodes( 'rcpt', { type => qr/^bcc$/  }, 'name' );
91
92# Basic checks on recipients
93try "Checking From recipient" ;
94abort "Only one From recipient supported" unless ( @from < 2 );
95abort "No From recipient found" unless @from ;
96try "Checking To recipients" ;
97abort "No To recipient found" unless @to ;
98
99# Recomposition
100foreach my $key (qw(From To Cc Bcc)) {
101    my $keyconf = $conf->{$key} ;
102    next unless (defined($keyconf) and ref($keyconf) =~ /^HASH/i);
103    next unless (defined($keyconf->{active}) and $keyconf->{active});
104
105    my @address = grep { defined }
106        ( $keyconf->{address}, { name => $keyconf->{name} } );
107
108    abort "Bad $key reconfiguration with '@address'"
109        unless ( @address == 2 );
110
111    $keyconf->{replace} = 1 if ( $key eq 'From' );
112
113    if (defined($keyconf->{replace}) and $keyconf->{replace}) {
114        eval '@' . lc($key) . ' = ( \@address )' ;
115
116    } else {
117        eval 'push @' . lc($key) . ', \@address' ;
118    }
119}
120
121# Sub to recompose recipient in RFC standard
122sub recipient {
123    return $_[0] unless ( ref($_[0]) =~ /^ARRAY/i );
124    my ( $content, $attributs ) = @{$_[0]} ;
125    my $name = exists($attributs->{name}) ? $attributs->{name} : "" ;
126    return $content unless ($name);
127    my $address = new Mail::Address( $name, $content) ;
128    return $address->format ;
129}
130
131# Advanced check of recipients
132try "Scanning recipients" ;
133@from = map { &recipient($_) } @from ;
134@to   = map { &recipient($_) } @to   ;
135@cc   = map { &recipient($_) } @cc   ;
136@bcc  = map { &recipient($_) } @bcc  ;
137
138# Read subject and text of the mail
139try "Getting subject" ;
140my @subject = $xml->nodes( 'subject' );
141
142try "Checking subject" ;
143abort "Only one subject supported" unless ( @subject < 2 );
144abort "No subject found" unless @subject ;
145
146# Extract the subject
147my ( $subject ) = @subject ;
148chomp $subject ;
149abort "Subject must not contain line feed" if ( $subject =~ /\n/ms );
150
151# This last call must be done after nodes calls to avoid getting the content of
152# nodes in the body.
153try "Getting mail body" ;
154my @body = $xml->nodes( 'body' );
155
156try "Checking mail body" ;
157abort "Only one body node supported" unless ( @body < 2 );
158abort "No body found" unless @body ;
159my ( $body ) = @body ;
160
161# Set unique id for this mail and user-agent
162my $mailid     = &get_id( $xmlid ) ;
163my $user_agent = &get_useragent() ;
164
165# Step 3: Prepare the mail and attach the PDF to the mail
166try "Preparing the mail" ;
167
168# Legal values
169my %supported = (
170    Disposition => {'inline' => 1, 'attachment' => 1},
171    Type => {'multipart/mixed' => 1 , 'text/plain' => 1,
172        'application/pdf' => 1},
173    Encoding => {'7bit' => 1, '8bit' => 1, 'quoted-printable' => 0,
174        'base64' => 1},
175    Charset => {'iso-8859-1' => 1, 'UTF-8' => 1},
176    Importance => {'low' => 1, 'normal' => 1, 'high'=> 1},
177    Sensitivity => {'normal' => 1, 'confidential' => 'Company-Confidential',
178        'private' => 'Private', 'personal' => 'Personal'},
179    Notification => {'no' => 1, 'yes' => 1},
180    Confirmation => { 'no' => 1, 'none' => 1, 'yes' => 1 }
181    );
182
183# Preparing headers
184my ( $from ) = @from;
185
186my $mail = MIME::Lite -> new (
187    From          => $from,
188    To            => \@to,
189    Cc            => \@cc,
190    Bcc           => \@bcc,
191    Subject       => $subject,
192    Type          => 'multipart/mixed',
193    'Message-ID'  => $mailid,
194    'User-Agent:' => $user_agent,
195    'Return-Path' => $from
196    );
197
198# Preparing optionnal headers
199abort "Bad xml attribute importance: $importance"
200    unless(exists($supported{Importance} -> {$importance}) and
201    $supported{Importance} -> {$importance});
202$mail -> add('Importance' => $importance)
203    unless($importance eq 'normal');
204
205abort "Bad xml attribute sensitivity: $sensitivity"
206    unless(exists($supported{Sensitivity} -> {$sensitivity}) and
207    $supported{Sensitivity} -> {$sensitivity});
208$mail -> add('Sensitivity' => $supported{Sensitivity} -> {$sensitivity})
209    unless($sensitivity eq 'normal');
210
211abort "Bad xml attribute notification: $notification"
212    unless(exists($supported{Notification} -> {$notification}) and
213    $supported{Notification} -> {$notification});
214$mail -> add('Return-Receipt-To' => $from)
215    unless($notification eq 'no');
216
217abort "Bad xml attribute confirmation: $confirmation"
218    unless(exists($supported{Confirmation} -> {$confirmation}) and
219    $supported{Confirmation} -> {$confirmation});
220$mail -> add('Disposition-Notification-To' => $from)
221    unless($confirmation eq 'no' or $confirmation eq 'none');
222
223# Preparing and attach body message
224my $attr = $conf -> {body};
225
226my $dispo = defined($attr -> {disposition})?
227                $attr -> {disposition}:'inline';
228abort "Bad conf for mail disposition: $dispo"
229    unless(exists($supported{Disposition} -> {$dispo}) and
230    $supported{Disposition} -> {$dispo});
231my $type = defined($attr -> {type})?$attr -> {type}:'TEXT';
232abort "Bad conf for mail type: $type"
233    unless(exists($supported{Type} -> {$type}) and
234    $supported{Type} -> {$type});
235my $encoding = defined($attr -> {encoding})?
236    $attr -> {encoding}:'8bit';
237abort "Bad conf for mail encoding: $encoding"
238    unless(exists($supported{Encoding} -> {$encoding}) and
239    $supported{Encoding} -> {$encoding});
240my $charset = defined($attr -> {charset})?
241    $attr -> {charset}:'iso-8859-1';
242abort "Bad conf for mail charset: $charset"
243    unless(exists($supported{Charset} -> {$charset}) and
244    $supported{Charset} -> {$charset});
245
246my $msg = MIME::Lite -> new (
247    Disposition => $dispo,
248    Type        => $type,
249    Encoding    => $encoding,
250    Data        => $body,
251    );
252$msg -> attr('content-type.charset' => $charset);
253$mail -> attach($msg);
254
255# Attach the PDF
256my ( $filename ) = $pdf =~ m|([^/]*)$|;
257my $attachment = $conf -> {attachment};
258
259unless (defined($attachment->{skip}) and $attachment->{skip}) {
260    $dispo = defined($attachment -> {disposition})?
261                    $attachment -> {disposition}:'inline';
262    abort "Bad conf for attachment disposition: $dispo"
263        unless(exists($supported{Disposition} -> {$dispo}) and
264        $supported{Disposition} -> {$dispo});
265    $type = defined($attachment -> {type})?
266        $attachment -> {type}:'application/pdf';
267    abort "Bad conf for attachment type: $type"
268        unless(exists($supported{Type} -> {$type}) and
269        $supported{Type} -> {$type});
270    $encoding = defined($attachment -> {encoding})?
271        $attachment -> {encoding}:'base64';
272    abort "Bad conf for attachment encoding: $encoding"
273        unless(exists($supported{Encoding} -> {$encoding}) and
274        $supported{Encoding} -> {$encoding});
275
276    # By default, we are trying to extract name from subject using
277    # eventually a regex an sprintf template from configuration
278    my $pdfname_re = qr/:\s+([^#]+)\s+#\s+([^#]+)\s+#\s+([^#]+)\s+#/ ;
279    my $pdfname_printf = '%s-%s-%s.pdf' ;
280    if (!defined($attachment -> {name})
281    or $attachment -> {name} =~ /^from subject$/i) {
282        # Get regexp from conf if available
283        $pdfname_re = $attachment -> {name_re}
284            if (defined($attachment -> {name_re})
285            and ref($attachment -> {name_re}) =~ /^Regexp/i);
286
287        # Get template name if available
288        $pdfname_printf = $attachment -> {name_printf}
289            if (defined($attachment -> {name_printf})
290            and $attachment -> {name_printf} );
291
292        my @elements = $subject =~ $pdfname_re ;
293        $filename = sprintf( $pdfname_printf, @elements );
294        abort "Can't compute valid pdfname from '@elements' and $pdfname_printf"
295            unless ( $filename and $filename =~ /^.+\.pdf$/i );
296    }
297
298    $mail -> attach (
299        Disposition => $dispo,
300        Type        => $type,
301        Encoding    => $encoding,
302        Path        => $pdf,
303        Filename    => $filename,
304        );
305}
306
307# Step 4: Send the mail
308try "Send the mail" ;
309
310$! = 0;
311my $SMTP = $conf->{SMTP} ;
312my %supported_smtp = (
313    'smtp'      => 1 ,
314    'sub'       => 1 ,
315    'sendmail'  => 1
316    );
317
318abort "No server defined"
319    unless ( defined($conf -> {SMTP}) and $conf -> {SMTP} );
320
321our $host = "" ;
322my $sent = 0 ;
323
324my @send_errors = () ;
325$SIG{__DIE__} = sub {
326        my ( $mesg ) = "@_" =~ /^(.*) at \(eval.*$/ms ;
327        push @send_errors, $host . ": $mesg" ;
328    } ;
329
330# Check also the order
331my @types = grep { exists($supported_smtp{$_}) and $supported_smtp{$_} }
332    keys %{$SMTP} ;
333abort "No supported type in configuration" unless @types ;
334
335if (exists($SMTP->{order})) {
336    my @order = @{$SMTP->{order}} ;
337    my @newlist = () ;
338    while (@order) {
339        my $next = shift @order ;
340        push @newlist, $next if ( grep { /^$next$/ } @types );
341    }
342    # Check we still have the same number of types
343    abort "Bad order list in configuration" unless ( @newlist == @types );
344    @types = @newlist ;
345}
346
347foreach my $type ( @types ) {
348
349    my $server = $SMTP -> {$type};
350    foreach $host (keys %{$server}) {
351        if ($type eq 'smtp') {
352            my $port = $server -> {$host} || 25 ;
353            $sent ++ and last
354                if eval '$mail->send($type, $host, Port => $port)' ;
355
356        } elsif ($type eq 'sendmail') {
357            my @args = @{$server -> {$host}} ;
358            $sent ++ and last
359                if eval '$mail->send($type, @args)' ;
360
361        } elsif ($type eq 'sub') {
362            my $sub = $server -> {$host} ;
363            $sent ++ and last
364                if eval '$mail->send($type, $sub, $host)' ;
365        }
366    }
367
368    last if $sent ;
369}
370
371abort "@send_errors" unless $sent ;
372
373# Step 5: Report status
374
375exit(0);
Note: See TracBrowser for help on using the repository browser.