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     @to = split(/\s*,\s*/, $opt{'to'});
 293   } elsif ( $cust_main ) {
 294     @to = $cust_main->invoicing_list_emailonly;
 295   } else {
 296     die 'no To: address or cust_main object specified';
 297   }
 298
 299   my $from_addr = $self->from_addr;
 300
 301   if ( !$from_addr ) {
 302
 303     my $agentnum = $cust_main ? $cust_main->agentnum : '';
 304
 305     if ( $opt{'from_config'} ) {
 306       $from_addr = $conf->config($opt{'from_config'}, $agentnum);
 307     }
 308     $from_addr ||= $conf->invoice_from_full($agentnum);
 309   }
 310
 311   my $text_body = encode('UTF-8',
 312                   HTML::FormatText->new(leftmargin => 0, rightmargin => 70)
 313                       ->format( HTML::TreeBuilder->new_from_content($body) )
 314                   );
 315
 316   warn "$me constructing MIME entities\n" if $DEBUG;
 317   my %email = generate_email(
 318     'from'      => $from_addr,
 319     'to'        => \@to,
 320     'bcc'       => $self->bcc_addr || undef,
 321     'subject'   => $subject,
 322     'html_body' => $body,
 323     'text_body' => $text_body,
 324   );
 325
 326   warn "$me creating message headers\n" if $DEBUG;
 327   my $env_from = $from_addr;
 328   $env_from =~ s/^\s*//; $env_from =~ s/\s*$//;
 329   if ( $env_from =~ /^(.*)\s*<(.*@.*)>$/ ) {
 330     # a common idiom
 331     $env_from = $2;
 332   }
 333
 334   my $domain;
 335   if ( $env_from =~ /\@([\w\.\-]+)/ ) {
 336     $domain = $1;
 337   } else {
 338     warn 'no domain found in invoice from address '. $env_from .
 339          '; constructing Message-ID (and saying HELO) @example.com';
 340     $domain = 'example.com';
 341   }
 342   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 343
 344   my $time = time;
 345   my $message = MIME::Entity->build(
 346     'From'        => $from_addr,
 347     'To'          => join(', ', @to),
 348     'Sender'      => $from_addr,
 349     'Reply-To'    => $from_addr,
 350     'Date'        => time2str("%a, %d %b %Y %X %z", $time),
 351     'Subject'     => Encode::encode('MIME-Header', $subject),
 352     'Message-ID'  => "<$message_id>",
 353     'Encoding'    => '7bit',
 354     'Type'        => 'multipart/related',
 355   );
 356
 357   if ( $opt{'attach'} ) {
 358     my @attach;
 359     if (ref $opt{'attach'} eq 'ARRAY') {
 360       @attach = @{ $opt{'attach'} };
 361     } else {
 362       @attach = $opt{'attach'};
 363     }
 364     foreach (@attach) {
 365       $message->add_part($_);
 366     }
 367   }
 368
 369   #$message->head->replace('Content-type',
 370   #  'multipart/related; '.
 371   #  'boundary="' . $message->head->multipart_boundary . '"; ' .
 372   #  'type=multipart/alternative'
 373   #);
 374
 375   foreach my $part (@{ $email{mimeparts} }) {
 376     warn "$me appending part ".$part->mime_type."\n" if $DEBUG;
 377     $message->add_part( $part );
 378   }
 379
 380   # effective To: address (not in headers)
 381   push @to, $self->bcc_addr if $self->bcc_addr;
 382   my $env_to = join(', ', @to);
 383
 384   my $cust_msg = FS::cust_msg->new({
 385       'custnum'   => $cust_main ? $cust_main->custnum : '',
 386       'msgnum'    => $self->msgnum,
 387       '_date'     => $time,
 388       'env_from'  => $env_from,
 389       'env_to'    => $env_to,
 390       'header'    => $message->header_as_string,
 391       'body'      => $message->body_as_string,
 392       'error'     => '',
 393       'status'    => 'prepared',
 394       'msgtype'   => ($opt{'msgtype'} || ''),
 395       'preview'   => $body, # html content only
 396   });
 397
 398   return $cust_msg;
 399 }
 400
 401 =item render OPTION => VALUE ...
 402
 403 Fills in the template and renders it to a PDF document.  Returns the
 404 name of the PDF file.
 405
 406 Options are as for 'prepare', but 'from' and 'to' are meaningless.
 407
 408 =cut
 409
 410 # will also have options to set paper size, margins, etc.
 411
 412 sub render {
 413   my $self = shift;
 414   eval "use PDF::WebKit";
 415   die $@ if $@;
 416   my %opt = @_;
 417   my %hash = $self->prepare(%opt);
 418   my $html = $hash{'html_body'};
 419
 420   # Graphics/stylesheets should probably go in /var/www on the Freeside
 421   # machine.
 422   my $script_path = `/usr/bin/which freeside-wkhtmltopdf`;
 423   chomp $script_path;
 424   my $kit = PDF::WebKit->new(\$html); #%options
 425   # hack to use our wrapper script
 426   $kit->configure(sub { shift->wkhtmltopdf($script_path) });
 427
 428   $kit->to_pdf;
 429 }
 430
 431 =item print OPTIONS
 432
 433 Render a PDF and send it to the printer.  OPTIONS are as for 'render'.
 434
 435 =cut
 436
 437 sub print {
 438   my( $self, %opt ) = @_;
 439   do_print( [ $self->render(%opt) ], agentnum=>$opt{cust_main}->agentnum );
 440 }
 441
 442 # helper sub for package dates
 443 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
 444
 445 # helper sub for money amounts
 446 my $money = sub { ($conf->money_char || '$') . sprintf('%.2f', $_[0] || 0) };
 447
 448 # helper sub for usage-related messages
 449 my $usage_warning = sub {
 450   my $svc = shift;
 451   foreach my $col (qw(seconds upbytes downbytes totalbytes)) {
 452     my $amount = $svc->$col; next if $amount eq '';
 453     my $method = $col.'_threshold';
 454     my $threshold = $svc->$method; next if $threshold eq '';
 455     return [$col, $amount, $threshold] if $amount <= $threshold;
 456     # this only returns the first one that's below threshold, if there are
 457     # several.
 458   }
 459   return ['', '', ''];
 460 };
 461
 462 =item content LOCALE
 463
 464 Returns the L<FS::template_content> object appropriate to LOCALE, if there
 465 is one.  If not, returns the one with a NULL locale.
 466
 467 =cut
 468
 469 sub content {
 470   my $self = shift;
 471   my $locale = shift;
 472   qsearchs('template_content',
 473             { 'msgnum' => $self->msgnum, 'locale' => $locale }) ||
 474   qsearchs('template_content',
 475             { 'msgnum' => $self->msgnum, 'locale' => '' });
 476 }
 477
 478 =cut
 479
 480 =item send_prepared CUST_MSG
 481
 482 Takes the CUST_MSG object and sends it to its recipient. The "smtpmachine"
 483 configuration option will be used to find the outgoing mail server.
 484
 485 =cut
 486
 487 sub send_prepared {
 488   my $self = shift;
 489   my $cust_msg = shift or die "cust_msg required";
 490
 491   my $domain = 'example.com';
 492   if ( $cust_msg->env_from =~ /\@([\w\.\-]+)/ ) {
 493     $domain = $1;
 494   }
 495
 496   my @to = split(/\s*,\s*/, $cust_msg->env_to);
 497
 498   my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
 499                    'helo' => $domain );
 500
 501   my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
 502   $smtp_opt{'port'} = $port;
 503
 504   my $transport;
 505   if ( defined($enc) && $enc eq 'starttls' ) {
 506     $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
 507     $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
 508   } else {
 509     if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
 510       $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
 511     }
 512     $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
 513     $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
 514   }
 515
 516   warn "$me sending message\n" if $DEBUG;
 517   my $message = join("\n", $cust_msg->header, $cust_msg->body);
 518   local $@;
 519   eval {
 520     sendmail( $message, { transport => $transport,
 521                           from      => $cust_msg->env_from,
 522                           to        => \@to })
 523   };
 524   my $error = '';
 525   if(ref($@) and $@->isa('Email::Sender::Failure')) {
 526     $error = $@->code.' ' if $@->code;
 527     $error .= $@->message;
 528   }
 529   else {
 530     $error = $@;
 531   }
 532
 533   $cust_msg->set('error', $error);
 534   $cust_msg->set('status', $error ? 'failed' : 'sent');
 535   if ( $cust_msg->custmsgnum ) {
 536     $cust_msg->replace;
 537   } else {
 538     $cust_msg->insert;
 539   }
 540
 541   $error;
 542 }
 543
 544 =back
 545
 546 =cut
 547
 548 # internal use only
 549
 550 sub eviscerate {
 551   # Every bit as pleasant as it sounds.
 552   #
 553   # We do this because Text::Template::Preprocess doesn't
 554   # actually work.  It runs the entire template through
 555   # the preprocessor, instead of the code segments.  Which
 556   # is a shame, because Text::Template already contains
 557   # the code to do this operation.
 558   my $body = shift;
 559   my (@outside, @inside);
 560   my $depth = 0;
 561   my $chunk = '';
 562   while($body || $chunk) {
 563     my ($first, $delim, $rest);
 564     # put all leading non-delimiters into $first
 565     ($first, $rest) =
 566         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
 567     $chunk .= $first;
 568     # put a leading delimiter into $delim if there is one
 569     ($delim, $rest) =
 570       ($rest =~ /^([{}]?)(.*)$/s);
 571
 572     if( $delim eq '{' ) {
 573       $chunk .= '{';
 574       if( $depth == 0 ) {
 575         push @outside, $chunk;
 576         $chunk = '';
 577       }
 578       $depth++;
 579     }
 580     elsif( $delim eq '}' ) {
 581       $depth--;
 582       if( $depth == 0 ) {
 583         push @inside, $chunk;
 584         $chunk = '';
 585       }
 586       $chunk .= '}';
 587     }
 588     else {
 589       # no more delimiters
 590       if( $depth == 0 ) {
 591         push @outside, $chunk . $rest;
 592       } # else ? something wrong
 593       last;
 594     }
 595     $body = $rest;
 596   }
 597   (\@outside, \@inside);
 598 }
 599
 600 =head1 BUGS
 601
 602 =head1 SEE ALSO
 603
 604 L<FS::Record>, schema.html from the base documentation.
 605
 606 =cut
 607
 608 1;
 609