FS/FS/msg_template/email.pm

   1 package FS::msg_template::email;
   2 use base qw( FS::msg_template );
   3
   4 use strict;
   5 use vars qw( $DEBUG $conf );
   6
   7 # stuff needed for template generation
   8 use Date::Format qw( time2str );
   9 use File::Temp;
  10 use IPC::Run qw(run);
  11 use Text::Template;
  12
  13 use HTML::Entities qw( decode_entities encode_entities ) ;
  14 use HTML::FormatText;
  15 use HTML::TreeBuilder;
  16 use Encode;
  17
  18 # needed to send email
  19 use FS::Misc qw( generate_email );
  20 use FS::Conf;
  21 use Email::Sender::Simple qw( sendmail );
  22
  23 use FS::Record qw( qsearch qsearchs );
  24
  25 # needed to manage template_content objects
  26 use FS::template_content;
  27 use FS::UID qw( dbh );
  28
  29 # needed to manage prepared messages
  30 use FS::cust_msg;
  31
  32 FS::UID->install_callback( sub { $conf = new FS::Conf; } );
  33
  34 our $DEBUG = 0;
  35 our $me = '[FS::msg_template::email]';
  36
  37 =head1 NAME
  38
  39 FS::msg_template::email - Construct email notices with Text::Template.
  40
  41 =head1 DESCRIPTION
  42
  43 FS::msg_template::email is a message processor in which the template contains
  44 L<Text::Template> strings for the message subject line and body, and the
  45 message is delivered by email.
  46
  47 Currently the C<from_addr> and C<bcc_addr> fields used by this processor are
  48 in the main msg_template table.
  49
  50 =head1 METHODS
  51
  52 =over 4
  53
  54 =item insert [ CONTENT ]
  55
  56 Adds this record to the database.  If there is an error, returns the error,
  57 otherwise returns false.
  58
  59 A default (no locale) L<FS::template_content> object will be created.  CONTENT
  60 is an optional hash containing 'subject' and 'body' for this object.
  61
  62 =cut
  63
  64 sub insert {
  65   my $self = shift;
  66   my %content = @_;
  67
  68   my $oldAutoCommit = $FS::UID::AutoCommit;
  69   local $FS::UID::AutoCommit = 0;
  70   my $dbh = dbh;
  71
  72   my $error = $self->SUPER::insert;
  73   if ( !$error ) {
  74     $content{'msgnum'} = $self->msgnum;
  75     $content{'subject'} ||= '';
  76     $content{'body'} ||= '';
  77     my $template_content = new FS::template_content (\%content);
  78     $error = $template_content->insert;
  79   }
  80
  81   if ( $error ) {
  82     $dbh->rollback if $oldAutoCommit;
  83     return $error;
  84   }
  85
  86   $dbh->commit if $oldAutoCommit;
  87   return;
  88 }
  89
  90 =item replace [ OLD_RECORD ] [ CONTENT ]
  91
  92 Replaces the OLD_RECORD with this one in the database.  If there is an error,
  93 returns the error, otherwise returns false.
  94
  95 CONTENT is an optional hash containing 'subject', 'body', and 'locale'.  If
  96 supplied, an L<FS::template_content> object will be created (or modified, if
  97 one already exists for this locale).
  98
  99 =cut
 100
 101 sub replace {
 102   my $self = shift;
 103   my $old = ( ref($_[0]) and $_[0]->isa('FS::Record') )
 104               ? shift
 105               : $self->replace_old;
 106   my %content = @_;
 107
 108   my $oldAutoCommit = $FS::UID::AutoCommit;
 109   local $FS::UID::AutoCommit = 0;
 110   my $dbh = dbh;
 111
 112   my $error = $self->SUPER::replace($old);
 113
 114   if ( !$error and %content ) {
 115     $content{'locale'} ||= '';
 116     my $new_content = qsearchs('template_content', {
 117                         'msgnum' => $self->msgnum,
 118                         'locale' => $content{'locale'},
 119                       } );
 120     if ( $new_content ) {
 121       $new_content->subject($content{'subject'});
 122       $new_content->body($content{'body'});
 123       $error = $new_content->replace;
 124     }
 125     else {
 126       $content{'msgnum'} = $self->msgnum;
 127       $new_content = new FS::template_content \%content;
 128       $error = $new_content->insert;
 129     }
 130   }
 131
 132   if ( $error ) {
 133     $dbh->rollback if $oldAutoCommit;
 134     return $error;
 135   }
 136
 137   warn "committing FS::msg_template->replace\n" if $DEBUG and $oldAutoCommit;
 138   $dbh->commit if $oldAutoCommit;
 139   return;
 140 }
 141
 142 =item content_locales
 143
 144 Returns a hashref of the L<FS::template_content> objects attached to
 145 this template, with the locale as key.
 146
 147 =cut
 148
 149 sub content_locales {
 150   my $self = shift;
 151   return $self->{'_content_locales'} ||= +{
 152     map { $_->locale , $_ }
 153     qsearch('template_content', { 'msgnum' => $self->msgnum })
 154   };
 155 }
 156
 157 =item prepare OPTION => VALUE
 158
 159 Fills in the template and returns an L<FS::cust_msg> object.
 160
 161 Options are passed as a list of name/value pairs:
 162
 163 =over 4
 164
 165 =item cust_main
 166
 167 Customer object
 168
 169 =item object
 170
 171 Additional context object (currently, can be a cust_main, cust_pkg,
 172 cust_bill, cust_pay, cust_pay_pending, or svc_(acct, phone, broadband,
 173 domain) ).  If the object is a svc_*, its cust_pkg will be fetched and
 174 used for substitution.
 175
 176 As a special case, this may be an arrayref of two objects.  Both
 177 objects will be available for substitution, with their field names
 178 prefixed with 'new_' and 'old_' respectively.  This is used in the
 179 rt_ticket export when exporting "replace" events.
 180
 181 =item from_config
 182
 183 Configuration option to use as the source address, based on the customer's
 184 agentnum.  If unspecified (or the named option is empty), 'invoice_from'
 185 will be used.
 186
 187 The I<from_addr> field in the template takes precedence over this.
 188
 189 =item to
 190
 191 Destination address.  The default is to use the customer's
 192 invoicing_list addresses.  Multiple addresses may be comma-separated.
 193
 194 =item substitutions
 195
 196 A hash reference of additional substitutions
 197
 198 =item msgtype
 199
 200 A string identifying the kind of message this is. Currently can be "invoice",
 201 "receipt", "admin", or null. Expand this list as necessary.
 202
 203 =item override_content
 204
 205 A string to use as the HTML body; if specified, replaces the entire
 206 body of the message. This should be used ONLY by L<FS::report_batch> and may
 207 go away in the future.
 208
 209 =item attach
 210
 211 A L<MIME::Entity> (or arrayref of them) to attach to the message.
 212
 213 =cut
 214
 215 =back
 216
 217 =cut
 218
 219 sub prepare {
 220
 221   my( $self, %opt ) = @_;
 222
 223   my $cust_main = $opt{'cust_main'}; # or die 'cust_main required';
 224   my $object = $opt{'object'}; # or die 'object required';
 225
 226   my $hashref = $self->prepare_substitutions(%opt);
 227
 228   # localization
 229   my $locale = $cust_main && $cust_main->locale || '';
 230   warn "no locale for cust#".$cust_main->custnum."; using default content\n"
 231     if $DEBUG and $cust_main && !$locale;
 232   my $content = $self->content($locale);
 233
 234   warn "preparing template '".$self->msgname."\n"
 235     if $DEBUG;
 236
 237   $_ = encode_entities($_ || '') foreach values(%$hashref);
 238
 239   ###
 240   # clean up template
 241   ###
 242   my $subject_tmpl = new Text::Template (
 243     TYPE   => 'STRING',
 244     SOURCE => $content->subject,
 245   );
 246
 247   warn "$me filling in subject template\n" if $DEBUG;
 248   my $subject = $subject_tmpl->fill_in( HASH => $hashref );
 249
 250   my $body = $content->body;
 251   my ($skin, $guts) = eviscerate($body);
 252   @$guts = map {
 253     $_ = decode_entities($_); # turn all punctuation back into itself
 254     s/\r//gs;           # remove \r's
 255     s/<br[^>]*>/\n/gsi; # and <br /> tags
 256     s/<p>/\n/gsi;       # and <p>
 257     s/<\/p>//gsi;       # and </p>
 258     s/\240/ /gs;        # and &nbsp;
 259     $_
 260   } @$guts;
 261
 262   $body = '{ use Date::Format qw(time2str); "" }';
 263   while(@$skin || @$guts) {
 264     $body .= shift(@$skin) || '';
 265     $body .= shift(@$guts) || '';
 266   }
 267
 268   ###
 269   # fill-in
 270   ###
 271
 272   my $body_tmpl = new Text::Template (
 273     TYPE          => 'STRING',
 274     SOURCE        => $body,
 275   );
 276
 277   warn "$me filling in body template\n" if $DEBUG;
 278   $body = $body_tmpl->fill_in( HASH => $hashref );
 279
 280   # override $body if requested
 281   if ( $opt{'override_content'} ) {
 282     warn "$me overriding template body with requested content" if $DEBUG;
 283     $body = $opt{'override_content'};
 284   }
 285
 286   ###
 287   # and email
 288   ###
 289
 290   my @to;
 291   if ( exists($opt{'to'}) ) {
 292
 293     @to = split(/\s*,\s*/, $opt{'to'});
 294
 295   } elsif ( $cust_main ) {
 296
 297     if ( $opt{'to_contact_classnum'} ) {
 298
 299       my $classnum = $opt{'to_contact_classnum'};
 300       my @classes = ref($classnum) ? @$classnum : split(',', $classnum);
 301       if ( !@classes ) {
 302         # traditional behavior: send to invoice email destinations (only)
 303         @classes = ( 'invoice' );
 304       }
 305       @to = $cust_main->contact_list_email(@classes);
 306       # not guaranteed to produce contacts, but then customers aren't
 307       # guaranteed to have email addresses on file. in that case, env_to
 308       # will be null and sending this message will fail.
 309     }
 310
 311   } else {
 312     die 'no To: address or cust_main object specified';
 313   }
 314
 315   my $from_addr = $self->from_addr;
 316
 317   if ( !$from_addr ) {
 318
 319     my $agentnum = $cust_main ? $cust_main->agentnum : '';
 320
 321     if ( $opt{'from_config'} ) {
 322       $from_addr = $conf->config($opt{'from_config'}, $agentnum);
 323     }
 324     $from_addr ||= $conf->invoice_from_full($agentnum);
 325   }
 326
 327   my $text_body = encode('UTF-8',
 328                   HTML::FormatText->new(leftmargin => 0, rightmargin => 70)
 329                       ->format( HTML::TreeBuilder->new_from_content($body) )
 330                   );
 331
 332   warn "$me constructing MIME entities\n" if $DEBUG;
 333   my %email = generate_email(
 334     'from'      => $from_addr,
 335     'to'        => \@to,
 336     'bcc'       => $self->bcc_addr || undef,
 337     'subject'   => $subject,
 338     'html_body' => $body,
 339     'text_body' => $text_body,
 340   );
 341
 342   warn "$me creating message headers\n" if $DEBUG;
 343   # strip display-name from envelope addresses
 344   # (use Email::Address for this? it chokes on non-ASCII characters in
 345   # the display-name, which is not great for us)
 346   my $env_from = $from_addr;
 347   foreach ($env_from, @to) {
 348     s/^\s*//;
 349     s/\s*$//;
 350     s/^(.*)\s*<(.*@.*)>$/$2/;
 351   }
 352
 353   my $domain;
 354   if ( $env_from =~ /\@([\w\.\-]+)/ ) {
 355     $domain = $1;
 356   } else {
 357     warn 'no domain found in invoice from address '. $env_from .
 358          '; constructing Message-ID (and saying HELO) @example.com';
 359     $domain = 'example.com';
 360   }
 361   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 362
 363   my $time = time;
 364   my $message = MIME::Entity->build(
 365     'From'        => $from_addr,
 366     'To'          => join(', ', @to),
 367     'Sender'      => $from_addr,
 368     'Reply-To'    => $from_addr,
 369     'Date'        => time2str("%a, %d %b %Y %X %z", $time),
 370     'Subject'     => Encode::encode('MIME-Header', $subject),
 371     'Message-ID'  => "<$message_id>",
 372     'Encoding'    => '7bit',
 373     'Type'        => 'multipart/related',
 374   );
 375
 376   if ( $opt{'attach'} ) {
 377     my @attach;
 378     if (ref $opt{'attach'} eq 'ARRAY') {
 379       @attach = @{ $opt{'attach'} };
 380     } else {
 381       @attach = $opt{'attach'};
 382     }
 383     foreach (@attach) {
 384       $message->add_part($_);
 385     }
 386   }
 387
 388   #$message->head->replace('Content-type',
 389   #  'multipart/related; '.
 390   #  'boundary="' . $message->head->multipart_boundary . '"; ' .
 391   #  'type=multipart/alternative'
 392   #);
 393
 394   foreach my $part (@{ $email{mimeparts} }) {
 395     warn "$me appending part ".$part->mime_type."\n" if $DEBUG;
 396     $message->add_part( $part );
 397   }
 398
 399   # effective To: address (not in headers)
 400   push @to, $self->bcc_addr if $self->bcc_addr;
 401   my $env_to = join(', ', @to);
 402
 403   my $cust_msg = FS::cust_msg->new({
 404       'custnum'   => $cust_main ? $cust_main->custnum : '',
 405       'msgnum'    => $self->msgnum,
 406       '_date'     => $time,
 407       'env_from'  => $env_from,
 408       'env_to'    => $env_to,
 409       'header'    => $message->header_as_string,
 410       'body'      => $message->body_as_string,
 411       'error'     => '',
 412       'status'    => 'prepared',
 413       'msgtype'   => ($opt{'msgtype'} || ''),
 414       'preview'   => $body, # html content only
 415   });
 416
 417   return $cust_msg;
 418 }
 419
 420 =item render OPTION => VALUE ...
 421
 422 Fills in the template and renders it to a PDF document.  Returns the
 423 name of the PDF file.
 424
 425 Options are as for 'prepare', but 'from' and 'to' are meaningless.
 426
 427 =cut
 428
 429 # will also have options to set paper size, margins, etc.
 430
 431 sub render {
 432   my $self = shift;
 433   eval "use PDF::WebKit";
 434   die $@ if $@;
 435   my %opt = @_;
 436   my %hash = $self->prepare(%opt);
 437   my $html = $hash{'html_body'};
 438
 439   # Graphics/stylesheets should probably go in /var/www on the Freeside
 440   # machine.
 441   my $script_path = `/usr/bin/which freeside-wkhtmltopdf`;
 442   chomp $script_path;
 443   my $kit = PDF::WebKit->new(\$html); #%options
 444   # hack to use our wrapper script
 445   $kit->configure(sub { shift->wkhtmltopdf($script_path) });
 446
 447   $kit->to_pdf;
 448 }
 449
 450 =item print OPTIONS
 451
 452 Render a PDF and send it to the printer.  OPTIONS are as for 'render'.
 453
 454 =cut
 455
 456 sub print {
 457   my( $self, %opt ) = @_;
 458   do_print( [ $self->render(%opt) ], agentnum=>$opt{cust_main}->agentnum );
 459 }
 460
 461 # helper sub for package dates
 462 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
 463
 464 # helper sub for money amounts
 465 my $money = sub { ($conf->money_char || '$') . sprintf('%.2f', $_[0] || 0) };
 466
 467 # helper sub for usage-related messages
 468 my $usage_warning = sub {
 469   my $svc = shift;
 470   foreach my $col (qw(seconds upbytes downbytes totalbytes)) {
 471     my $amount = $svc->$col; next if $amount eq '';
 472     my $method = $col.'_threshold';
 473     my $threshold = $svc->$method; next if $threshold eq '';
 474     return [$col, $amount, $threshold] if $amount <= $threshold;
 475     # this only returns the first one that's below threshold, if there are
 476     # several.
 477   }
 478   return ['', '', ''];
 479 };
 480
 481 =item content LOCALE
 482
 483 Returns the L<FS::template_content> object appropriate to LOCALE, if there
 484 is one.  If not, returns the one with a NULL locale.
 485
 486 =cut
 487
 488 sub content {
 489   my $self = shift;
 490   my $locale = shift;
 491   qsearchs('template_content',
 492             { 'msgnum' => $self->msgnum, 'locale' => $locale }) ||
 493   qsearchs('template_content',
 494             { 'msgnum' => $self->msgnum, 'locale' => '' });
 495 }
 496
 497 =cut
 498
 499 =item send_prepared CUST_MSG
 500
 501 Takes the CUST_MSG object and sends it to its recipient. The "smtpmachine"
 502 configuration option will be used to find the outgoing mail server.
 503
 504 =cut
 505
 506 sub send_prepared {
 507   my $self = shift;
 508   my $cust_msg = shift or die "cust_msg required";
 509
 510   my $domain = 'example.com';
 511   if ( $cust_msg->env_from =~ /\@([\w\.\-]+)/ ) {
 512     $domain = $1;
 513   }
 514
 515   my @to = split(/\s*,\s*/, $cust_msg->env_to);
 516
 517   my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
 518                    'helo' => $domain );
 519
 520   my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
 521   $smtp_opt{'port'} = $port;
 522
 523   my $transport;
 524   if ( defined($enc) && $enc eq 'starttls' ) {
 525     $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
 526     $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
 527   } else {
 528     if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
 529       $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
 530     }
 531     $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
 532     $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
 533   }
 534
 535   warn "$me sending message\n" if $DEBUG;
 536   my $message = join("\n", $cust_msg->header, $cust_msg->body);
 537   local $@;
 538   eval {
 539     sendmail( $message, { transport => $transport,
 540                           from      => $cust_msg->env_from,
 541                           to        => \@to })
 542   };
 543   my $error = '';
 544   if(ref($@) and $@->isa('Email::Sender::Failure')) {
 545     $error = $@->code.' ' if $@->code;
 546     $error .= $@->message;
 547   }
 548   else {
 549     $error = $@;
 550   }
 551
 552   $cust_msg->set('error', $error);
 553   $cust_msg->set('status', $error ? 'failed' : 'sent');
 554   if ( $cust_msg->custmsgnum ) {
 555     $cust_msg->replace;
 556   } else {
 557     $cust_msg->insert;
 558   }
 559
 560   $error;
 561 }
 562
 563 =back
 564
 565 =cut
 566
 567 # internal use only
 568
 569 sub eviscerate {
 570   # Every bit as pleasant as it sounds.
 571   #
 572   # We do this because Text::Template::Preprocess doesn't
 573   # actually work.  It runs the entire template through
 574   # the preprocessor, instead of the code segments.  Which
 575   # is a shame, because Text::Template already contains
 576   # the code to do this operation.
 577   my $body = shift;
 578   my (@outside, @inside);
 579   my $depth = 0;
 580   my $chunk = '';
 581   while($body || $chunk) {
 582     my ($first, $delim, $rest);
 583     # put all leading non-delimiters into $first
 584     ($first, $rest) =
 585         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
 586     $chunk .= $first;
 587     # put a leading delimiter into $delim if there is one
 588     ($delim, $rest) =
 589       ($rest =~ /^([{}]?)(.*)$/s);
 590
 591     if( $delim eq '{' ) {
 592       $chunk .= '{';
 593       if( $depth == 0 ) {
 594         push @outside, $chunk;
 595         $chunk = '';
 596       }
 597       $depth++;
 598     }
 599     elsif( $delim eq '}' ) {
 600       $depth--;
 601       if( $depth == 0 ) {
 602         push @inside, $chunk;
 603         $chunk = '';
 604       }
 605       $chunk .= '}';
 606     }
 607     else {
 608       # no more delimiters
 609       if( $depth == 0 ) {
 610         push @outside, $chunk . $rest;
 611       } # else ? something wrong
 612       last;
 613     }
 614     $body = $rest;
 615   }
 616   (\@outside, \@inside);
 617 }
 618
 619 =head1 BUGS
 620
 621 =head1 SEE ALSO
 622
 623 L<FS::Record>, schema.html from the base documentation.
 624
 625 =cut
 626
 627 1;
 628