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