a408b03b946518f7dcb9df4260b3e0983c5ebb18
[kivitendo-erp.git] / SL / Mailer.pm
1 #=====================================================================
2 # LX-Office ERP
3 # Copyright (C) 2004
4 # Based on SQL-Ledger Version 2.1.9
5 # Web http://www.lx-office.org
6 #
7 #=====================================================================
8 #
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
13 #
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program; if not, write to the Free Software
20 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
21 # MA 02110-1335, USA.
22 #======================================================================
23
24 package Mailer;
25
26 use Email::Address;
27 use Email::MIME::Creator;
28 use Encode;
29 use File::MimeInfo::Magic;
30 use File::Slurp;
31 use List::UtilsBy qw(bundle_by);
32
33 use SL::Common;
34 use SL::DB::EmailJournal;
35 use SL::DB::EmailJournalAttachment;
36 use SL::DB::Employee;
37 use SL::Template;
38 use SL::Version;
39
40 use strict;
41
42 my $num_sent = 0;
43
44 my %mail_delivery_modules = (
45   sendmail => 'SL::Mailer::Sendmail',
46   smtp     => 'SL::Mailer::SMTP',
47 );
48
49 my %type_to_table = (
50   sales_quotation         => 'oe',
51   request_quotation       => 'oe',
52   sales_order             => 'oe',
53   purchase_order          => 'oe',
54   invoice                 => 'ar',
55   credit_note             => 'ar',
56   purchase_invoice        => 'ap',
57   letter                  => 'letter',
58   purchase_delivery_order => 'delivery_orders',
59   sales_delivery_order    => 'delivery_orders',
60   dunning                 => 'dunning',
61 );
62
63 sub new {
64   my ($type, %params) = @_;
65   my $self = { %params };
66
67   bless $self, $type;
68 }
69
70 sub _create_driver {
71   my ($self) = @_;
72
73   my %params = (
74     mailer   => $self,
75     form     => $::form,
76     myconfig => \%::myconfig,
77   );
78
79   my $module = $mail_delivery_modules{ $::lx_office_conf{mail_delivery}->{method} };
80   eval "require $module" or return undef;
81
82   return $module->new(%params);
83 }
84
85 sub _cleanup_addresses {
86   my ($self) = @_;
87
88   foreach my $item (qw(to cc bcc)) {
89     next unless $self->{$item};
90
91     $self->{$item} =~ s/\&lt;/</g;
92     $self->{$item} =~ s/\$<\$/</g;
93     $self->{$item} =~ s/\&gt;/>/g;
94     $self->{$item} =~ s/\$>\$/>/g;
95   }
96 }
97
98 sub _create_message_id {
99   my ($self) = @_;
100
101   $num_sent  +=  1;
102   my $domain  =  $self->{from};
103   $domain     =~ s/.*\@//;
104   $domain     =~ s/>.*//;
105
106   return  "kivitendo-" . SL::Version->get_version . "-" . time() . "-${$}-${num_sent}\@$domain";
107 }
108
109 sub _create_address_headers {
110   my ($self) = @_;
111
112   # $self->{addresses} collects the recipients for use in e.g. the
113   # SMTP 'RCPT TO:' envelope command. $self->{headers} collects the
114   # headers that make up the actual email. 'BCC' should not be
115   # included there for certain transportation methods (SMTP).
116
117   $self->{addresses} = {};
118
119   foreach my $item (qw(from to cc bcc)) {
120     $self->{addresses}->{$item} = [];
121     next if !$self->{$item};
122
123     my @header_addresses;
124
125     foreach my $addr_obj (Email::Address->parse($self->{$item})) {
126       push @{ $self->{addresses}->{$item} }, $addr_obj->address;
127       next if $self->{driver}->keep_from_header($item);
128
129       my $phrase = $addr_obj->phrase();
130       if ($phrase) {
131         $phrase =~ s/^\"//;
132         $phrase =~ s/\"$//;
133         $addr_obj->phrase($phrase);
134       }
135
136       push @header_addresses, $addr_obj->format;
137     }
138
139     push @{ $self->{headers} }, ( ucfirst($item) => join(', ', @header_addresses) ) if @header_addresses;
140   }
141 }
142
143 sub _create_attachment_part {
144   my ($self, $attachment) = @_;
145
146   my %attributes = (
147     disposition  => 'attachment',
148     encoding     => 'base64',
149   );
150
151   my $attachment_content;
152   my $file_id       = 0;
153   my $email_journal = $::instance_conf->get_email_journal;
154
155   if (ref($attachment) eq "HASH") {
156     $attributes{filename}     = $attachment->{name};
157     $file_id                  = $attachment->{id}   || '0';
158     $attributes{content_type} = $attachment->{type} || 'application/pdf';
159     $attachment_content       = $attachment->{content};
160     $attachment_content       = eval { read_file($attachment->{path}) } if !$attachment_content;
161
162   } else {
163     $attributes{filename} =  $attachment;
164     $attributes{filename} =~ s:.*\Q$self->{fileid}\E:: if $self->{fileid};
165     $attributes{filename} =~ s:.*/::g;
166
167     my $application             = ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/) ? 'text' : 'application';
168     $attributes{content_type}   = File::MimeInfo::Magic::magic($attachment);
169     $attributes{content_type} ||= "${application}/$self->{format}" if $self->{format};
170     $attributes{content_type} ||= 'application/octet-stream';
171     $attachment_content         = eval { read_file($attachment) };
172   }
173
174   return undef if $email_journal > 1 && !defined $attachment_content;
175
176   $attachment_content ||= ' ';
177   $attributes{charset}  = $self->{charset} if $self->{charset} && ($attributes{content_type} =~ m{^text/});
178
179   my $ent;
180   if ( $attributes{content_type} eq 'message/rfc822' ) {
181     $ent = Email::MIME->new($attachment_content);
182   } else {
183     $ent = Email::MIME->create(
184       attributes => \%attributes,
185       body       => $attachment_content,
186     );
187   }
188
189   # Due to a bug in Email::MIME it's not enough to hand over the encoded file name in the "attributes" hash in the
190   # "create" call. Email::MIME iterates over the keys in the hash, and depending on which key it has already seen during
191   # the iteration it might revert the encoding. As Perl's hash key order is randomized for each Perl run, this means
192   # that the file name stays unencoded sometimes.
193   # Setting the header manually after the "create" call circumvents this problem.
194   $ent->header_set('Content-disposition' => 'attachment; filename="' . encode('MIME-Q', $attributes{filename}) . '"');
195
196   push @{ $self->{mail_attachments}} , SL::DB::EmailJournalAttachment->new(
197     name      => $attributes{filename},
198     mime_type => $attributes{content_type},
199     content   => ( $email_journal > 1 ? $attachment_content : ' '),
200     file_id   => $file_id,
201   );
202
203   return $ent;
204 }
205
206 sub _create_message {
207   my ($self) = @_;
208
209   my @parts;
210
211   if ($self->{message}) {
212     push @parts, Email::MIME->create(
213       attributes => {
214         content_type => $self->{content_type},
215         charset      => $self->{charset},
216         encoding     => 'quoted-printable',
217       },
218       body_str => $self->{message},
219     );
220
221     push @{ $self->{headers} }, (
222       'Content-Type' => qq|$self->{content_type}; charset="$self->{charset}"|,
223     );
224   }
225
226   push @parts, grep { $_ } map { $self->_create_attachment_part($_) } @{ $self->{attachments} || [] };
227
228   return Email::MIME->create(
229       header_str => $self->{headers},
230       parts      => \@parts,
231   );
232 }
233
234 sub send {
235   my ($self) = @_;
236
237   # Create driver for delivery method (sendmail/SMTP)
238   $self->{driver} = eval { $self->_create_driver };
239   if (!$self->{driver}) {
240     my $error = $@;
241     $self->_store_in_journal('failed', 'driver could not be created; check your configuration & log files');
242     $::lxdebug->message(LXDebug::WARN(), "Mailer error during 'send': $error");
243
244     return $error;
245   }
246
247   # Set defaults & headers
248   $self->{charset}        =  'UTF-8';
249   $self->{content_type} ||=  "text/plain";
250   $self->{headers}      ||=  [];
251   push @{ $self->{headers} }, (
252     Subject               => $self->{subject},
253     'Message-ID'          => '<' . $self->_create_message_id . '>',
254     'X-Mailer'            => "kivitendo " . SL::Version->get_version,
255   );
256   $self->{mail_attachments} = [];
257
258   my $error;
259   my $ok = eval {
260     # Clean up To/Cc/Bcc address fields
261     $self->_cleanup_addresses;
262     $self->_create_address_headers;
263
264     my $email = $self->_create_message;
265
266     my $from_obj = (Email::Address->parse($self->{from}))[0];
267
268     $self->{driver}->start_mail(from => $from_obj->address, to => [ $self->_all_recipients ]);
269     $self->{driver}->print($email->as_string);
270     $self->{driver}->send;
271
272     1;
273   };
274
275   $error = $@ if !$ok;
276
277   # create journal and link to record
278   $self->{journalentry} = $self->_store_in_journal;
279   $self->_create_record_link if $self->{journalentry};
280
281   return $ok ? '' : ($error || "undefined error");
282 }
283
284 sub _all_recipients {
285   my ($self) = @_;
286   $self->{addresses} ||= {};
287   return map { @{ $self->{addresses}->{$_} || [] } } qw(to cc bcc);
288 }
289
290 sub _store_in_journal {
291   my ($self, $status, $extended_status) = @_;
292
293   my $journal_enable = $::instance_conf->get_email_journal;
294
295   return if $journal_enable == 0;
296
297   $status          //= $self->{driver}->status if $self->{driver};
298   $status          //= 'failed';
299   $extended_status //= $self->{driver}->extended_status if $self->{driver};
300   $extended_status //= 'unknown error';
301
302   my $headers = join "\r\n", (bundle_by { join(': ', @_) } 2, @{ $self->{headers} || [] });
303
304   my $jentry = SL::DB::EmailJournal->new(
305     sender          => SL::DB::Manager::Employee->current,
306     from            => $self->{from}    // '',
307     recipients      => join(', ', $self->_all_recipients),
308     subject         => $self->{subject} // '',
309     headers         => $headers,
310     body            => $self->{message} // '',
311     sent_on         => DateTime->now_local,
312     attachments     => \@{ $self->{mail_attachments} },
313     status          => $status,
314     extended_status => $extended_status,
315   )->save;
316   return $jentry->id;
317 }
318
319
320 sub _create_record_link {
321   my ($self) = @_;
322
323   # check for custom/overloaded types and ids (form != controller)
324   my $record_type = $self->{record_type} || $::form->{type};
325   my $record_id   = $self->{record_id}   || $::form->{id};
326
327   # you may send mails for unsaved objects (no record_id => unlinkable case)
328   if ($self->{journalentry} && $record_id && exists($type_to_table{$record_type})) {
329     RecordLinks->create_links(
330       mode       => 'ids',
331       from_table => $type_to_table{$record_type},
332       from_ids   => $record_id,
333       to_table   => 'email_journal',
334       to_id      => $self->{journalentry},
335     );
336   }
337 }
338
339 1;
340
341
342 __END__
343
344 =pod
345
346 =encoding utf8
347
348 =head1 NAME
349
350 SL::Mailer - Base class for sending mails from kivitendo
351
352 =head1 SYNOPSIS
353
354   package SL::BackgroundJob::CreatePeriodicInvoices;
355
356   use SL::Mailer;
357
358   my $mail              = Mailer->new;
359   $mail->{from}         = $config{periodic_invoices}->{email_from};
360   $mail->{to}           = $email;
361   $mail->{subject}      = $config{periodic_invoices}->{email_subject};
362   $mail->{content_type} = $filename =~ m/.html$/ ? 'text/html' : 'text/plain';
363   $mail->{message}      = $output;
364
365   $mail->send;
366
367 =head1 OVERVIEW
368
369 Mail can be sent from kivitendo via the sendmail command or the smtp protocol.
370
371
372 =head1 INTERNAL DATA TYPES
373
374
375 =over 2
376
377 =item C<%mail_delivery_modules>
378
379   Currently two modules are supported: smtp or sendmail.
380
381 =item C<%type_to_table>
382
383   Due to the lack of a single global mapping for $form->{type},
384   type is mapped to the corresponding database table. All types which
385   implement a mail action are currently mapped and should be mapped.
386   Type is either the value of the old form or the newer controller
387   based object type.
388
389 =back
390
391 =head1 FUNCTIONS
392
393 =over 4
394
395 =item C<new>
396
397 =item C<_create_driver>
398
399 =item C<_cleanup_addresses>
400
401 =item C<_create_address_headers>
402
403 =item C<_create_message_id>
404
405 =item C<_create_attachment_part>
406
407 =item C<_create_message>
408
409 =item C<send>
410
411   If a mail was sent successfully the internal function _store_in_journal
412   is called if email journaling is enabled. If _store_in_journal was executed
413   successfully and the calling form is already persistent (database id) a
414   record_link will be created.
415
416 =item C<_all_recipients>
417
418 =item C<_store_in_journal>
419
420 =item C<_create_record_link $self->{journalentry}, $::form->{id}, $self->{record_id}>
421
422
423   If $self->{journalentry} and either $self->{record_id} or $::form->{id} (checked in
424   this order) exist a record link from record to email journal is created.
425   It is possible to provide an array reference with more than one id in
426   $self->{record_id} or $::form->{id}. In this case all records are linked to
427   the mail.
428   Will fail silently if record_link creation wasn't successful (same behaviour as
429   _store_in_journal).
430
431 =item C<validate>
432
433 =back
434
435 =head1 BUGS
436
437 Nothing here yet.
438
439 =head1 AUTHOR
440
441 =cut