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