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