package FS::msg_template::email; use base qw( FS::msg_template ); use strict; use vars qw( $DEBUG $conf ); # stuff needed for template generation use Date::Format qw( time2str ); use File::Temp; use IPC::Run qw(run); use Text::Template; use HTML::Entities qw( decode_entities encode_entities ) ; use HTML::FormatText; use HTML::TreeBuilder; use Encode; # needed to send email use FS::Misc qw( generate_email _sendmail ); use FS::Conf; use FS::Record qw( qsearch qsearchs ); # needed to manage template_content objects use FS::template_content; use FS::UID qw( dbh ); # needed to manage prepared messages use FS::cust_msg; FS::UID->install_callback( sub { $conf = new FS::Conf; } ); our $DEBUG = 0; our $me = '[FS::msg_template::email]'; =head1 NAME FS::msg_template::email - Construct email notices with Text::Template. =head1 DESCRIPTION FS::msg_template::email is a message processor in which the template contains L strings for the message subject line and body, and the message is delivered by email. Currently the C and C fields used by this processor are in the main msg_template table. =head1 METHODS =over 4 =item insert [ CONTENT ] Adds this record to the database. If there is an error, returns the error, otherwise returns false. A default (no locale) L object will be created. CONTENT is an optional hash containing 'subject' and 'body' for this object. =cut sub insert { my $self = shift; my %content = @_; my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; my $error = $self->SUPER::insert; if ( !$error ) { $content{'msgnum'} = $self->msgnum; $content{'subject'} ||= ''; $content{'body'} ||= ''; my $template_content = new FS::template_content (\%content); $error = $template_content->insert; } if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } $dbh->commit if $oldAutoCommit; return; } =item replace [ OLD_RECORD ] [ CONTENT ] Replaces the OLD_RECORD with this one in the database. If there is an error, returns the error, otherwise returns false. CONTENT is an optional hash containing 'subject', 'body', and 'locale'. If supplied, an L object will be created (or modified, if one already exists for this locale). =cut sub replace { my $self = shift; my $old = ( ref($_[0]) and $_[0]->isa('FS::Record') ) ? shift : $self->replace_old; my %content = @_; my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; my $error = $self->SUPER::replace($old); if ( !$error and %content ) { $content{'locale'} ||= ''; my $new_content = qsearchs('template_content', { 'msgnum' => $self->msgnum, 'locale' => $content{'locale'}, } ); if ( $new_content ) { $new_content->subject($content{'subject'}); $new_content->body($content{'body'}); $error = $new_content->replace; } else { $content{'msgnum'} = $self->msgnum; $new_content = new FS::template_content \%content; $error = $new_content->insert; } } if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } warn "committing FS::msg_template->replace\n" if $DEBUG and $oldAutoCommit; $dbh->commit if $oldAutoCommit; return; } =item content_locales Returns a hashref of the L objects attached to this template, with the locale as key. =cut sub content_locales { my $self = shift; return $self->{'_content_locales'} ||= +{ map { $_->locale , $_ } qsearch('template_content', { 'msgnum' => $self->msgnum }) }; } =item prepare OPTION => VALUE Fills in the template and returns an L object. Options are passed as a list of name/value pairs: =over 4 =item cust_main Customer object =item object Additional context object (currently, can be a cust_main, cust_pkg, cust_bill, cust_pay, cust_pay_pending, or svc_(acct, phone, broadband, domain) ). If the object is a svc_*, its cust_pkg will be fetched and used for substitution. As a special case, this may be an arrayref of two objects. Both objects will be available for substitution, with their field names prefixed with 'new_' and 'old_' respectively. This is used in the rt_ticket export when exporting "replace" events. =item from_config Configuration option to use as the source address, based on the customer's agentnum. If unspecified (or the named option is empty), 'invoice_from' will be used. The I field in the template takes precedence over this. =item to Destination address. The default is to use the customer's invoicing_list addresses. Multiple addresses may be comma-separated. =item substitutions A hash reference of additional substitutions =item msgtype A string identifying the kind of message this is. Currently can be "invoice", "receipt", "admin", or null. Expand this list as necessary. =item override_content A string to use as the HTML body; if specified, replaces the entire body of the message. This should be used ONLY by L and may go away in the future. =item attach A L (or arrayref of them) to attach to the message. =item to_contact_classnum Set a string containing a comma-separated list. This list may contain: - the text "invoice" indicating contacts with invoice_dest flag should be included - the text "message" indicating contacts with message_dest flag should be included - numbers representing classnum id values for email contact classes. If any classnum are present, emails should only be sent to contact_email addresses where contact_email.classnum contains one of these classes. The classnum 0 also includes where contact_email.classnum IS NULL If neither 'invoice' nor 'message' has been specified, this method will behave as if 'invoice' had been selected =cut =back =cut sub prepare { my( $self, %opt ) = @_; my $cust_main = $opt{'cust_main'}; # or die 'cust_main required'; my $object = $opt{'object'}; # or die 'object required'; my $hashref = $self->prepare_substitutions(%opt); # localization my $locale = $cust_main && $cust_main->locale || ''; warn "no locale for cust#".$cust_main->custnum."; using default content\n" if $DEBUG and $cust_main && !$locale; my $content = $self->content($locale); warn "preparing template '".$self->msgname."\n" if $DEBUG; $_ = encode_entities($_ || '') foreach values(%$hashref); ### # clean up template ### my $subject_tmpl = new Text::Template ( TYPE => 'STRING', SOURCE => $content->subject, ); warn "$me filling in subject template\n" if $DEBUG; my $subject = $subject_tmpl->fill_in( HASH => $hashref ); my $body = $content->body; my ($skin, $guts) = eviscerate($body); @$guts = map { $_ = decode_entities($_); # turn all punctuation back into itself s/\r//gs; # remove \r's s/]*>/\n/gsi; # and
tags s/

/\n/gsi; # and

s/<\/p>//gsi; # and

s/\240/ /gs; # and   $_ } @$guts; $body = '{ use Date::Format qw(time2str); "" }'; while(@$skin || @$guts) { $body .= shift(@$skin) || ''; $body .= shift(@$guts) || ''; } ### # fill-in ### my $body_tmpl = new Text::Template ( TYPE => 'STRING', SOURCE => $body, ); warn "$me filling in body template\n" if $DEBUG; $body = $body_tmpl->fill_in( HASH => $hashref ); # override $body if requested if ( $opt{'override_content'} ) { warn "$me overriding template body with requested content" if $DEBUG; $body = $opt{'override_content'}; } ### # and email ### my @to; if ( exists($opt{'to'}) ) { @to = map { $_->format } Email::Address->parse($opt{'to'}); } elsif ( $cust_main ) { my $classnum = $opt{'to_contact_classnum'} || ''; my @classes = ref($classnum) ? @$classnum : split(',', $classnum); # There are two e-mail opt-in flags per contact_email address. # If neither 'invoice' nor 'message' has been specified, default # to 'invoice'. # # This default supports the legacy behavior of # send to all invoice recipients push @classes,'invoice' unless grep {$_ eq 'invoice' || $_ eq 'message'} @classes; @to = $cust_main->contact_list_email(@classes); # not guaranteed to produce contacts, but then customers aren't # guaranteed to have email addresses on file. in that case, env_to # will be null and sending this message will fail. } else { die 'no To: address or cust_main object specified'; } my $from_addr = $self->from_addr; if ( !$from_addr ) { my $agentnum = $cust_main ? $cust_main->agentnum : ''; if ( $opt{'from_config'} ) { $from_addr = $conf->config($opt{'from_config'}, $agentnum); } $from_addr ||= $conf->invoice_from_full($agentnum); } my $text_body = encode('UTF-8', HTML::FormatText->new(leftmargin => 0, rightmargin => 70) ->format( HTML::TreeBuilder->new_from_content($body) ) ); warn "$me constructing MIME entities\n" if $DEBUG; my %email = generate_email( 'from' => $from_addr, 'to' => \@to, 'bcc' => $self->bcc_addr || undef, 'subject' => $subject, 'html_body' => $body, 'text_body' => $text_body, ); warn "$me creating message headers\n" if $DEBUG; # strip display-name from envelope addresses # (use Email::Address for this? it chokes on non-ASCII characters in # the display-name, which is not great for us) my $env_from = $from_addr; foreach ($env_from, @to) { s/^\s*//; s/\s*$//; s/^(.*)\s*<(.*@.*)>$/$2/; } my $domain; if ( $env_from =~ /\@([\w\.\-]+)/ ) { $domain = $1; } else { warn 'no domain found in invoice from address '. $env_from . '; constructing Message-ID (and saying HELO) @example.com'; $domain = 'example.com'; } my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain"; my $time = time; my $message = MIME::Entity->build( 'From' => $from_addr, 'To' => join(', ', @to), 'Sender' => $from_addr, 'Reply-To' => $from_addr, 'Date' => time2str("%a, %d %b %Y %X %z", $time), 'Subject' => Encode::encode('MIME-Header', $subject), 'Message-ID' => "<$message_id>", 'Encoding' => '7bit', 'Type' => 'multipart/related', ); if ( $opt{'attach'} ) { my @attach; if (ref $opt{'attach'} eq 'ARRAY') { @attach = @{ $opt{'attach'} }; } else { @attach = $opt{'attach'}; } foreach (@attach) { $message->add_part($_); } } #$message->head->replace('Content-type', # 'multipart/related; '. # 'boundary="' . $message->head->multipart_boundary . '"; ' . # 'type=multipart/alternative' #); foreach my $part (@{ $email{mimeparts} }) { warn "$me appending part ".$part->mime_type."\n" if $DEBUG; $message->add_part( $part ); } # effective To: address (not in headers) push @to, $self->bcc_addr if $self->bcc_addr; my @env_to; foreach my $dest (@to) { push @env_to, map { $_->address } Email::Address->parse($dest); } my $cust_msg = FS::cust_msg->new({ 'custnum' => $cust_main ? $cust_main->custnum : '', 'msgnum' => $self->msgnum, '_date' => $time, 'env_from' => $env_from, 'env_to' => join(',', @env_to), 'header' => $message->header_as_string, 'body' => $message->body_as_string, 'error' => '', 'status' => 'prepared', 'msgtype' => ($opt{'msgtype'} || ''), 'preview' => $body, # html content only }); return $cust_msg; } =item render OPTION => VALUE ... Fills in the template and renders it to a PDF document. Returns the name of the PDF file. Options are as for 'prepare', but 'from' and 'to' are meaningless. =cut # will also have options to set paper size, margins, etc. sub render { my $self = shift; eval "use PDF::WebKit"; die $@ if $@; my %opt = @_; my %hash = $self->prepare(%opt); my $html = $hash{'html_body'}; # Graphics/stylesheets should probably go in /var/www on the Freeside # machine. my $script_path = `/usr/bin/which freeside-wkhtmltopdf`; chomp $script_path; my $kit = PDF::WebKit->new(\$html); #%options # hack to use our wrapper script $kit->configure(sub { shift->wkhtmltopdf($script_path) }); $kit->to_pdf; } =item print OPTIONS Render a PDF and send it to the printer. OPTIONS are as for 'render'. =cut sub print { my( $self, %opt ) = @_; do_print( [ $self->render(%opt) ], agentnum=>$opt{cust_main}->agentnum ); } # helper sub for package dates my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' }; # helper sub for money amounts my $money = sub { ($conf->money_char || '$') . sprintf('%.2f', $_[0] || 0) }; # helper sub for usage-related messages my $usage_warning = sub { my $svc = shift; foreach my $col (qw(seconds upbytes downbytes totalbytes)) { my $amount = $svc->$col; next if $amount eq ''; my $method = $col.'_threshold'; my $threshold = $svc->$method; next if $threshold eq ''; return [$col, $amount, $threshold] if $amount <= $threshold; # this only returns the first one that's below threshold, if there are # several. } return ['', '', '']; }; =item content LOCALE Returns the L object appropriate to LOCALE, if there is one. If not, returns the one with a NULL locale. =cut sub content { my $self = shift; my $locale = shift; qsearchs('template_content', { 'msgnum' => $self->msgnum, 'locale' => $locale }) || qsearchs('template_content', { 'msgnum' => $self->msgnum, 'locale' => '' }); } =cut =item send_prepared CUST_MSG Takes the CUST_MSG object and sends it to its recipient. The "smtpmachine" configuration option will be used to find the outgoing mail server. =cut sub send_prepared { my $self = shift; my $cust_msg = shift or die "cust_msg required"; if ( $FS::Misc::DISABLE_ALL_NOTICES ) { warn 'send_prepared() disabled by $FS::Misc::DISABLE_ALL_NOTICES' if $DEBUG; return; } my $domain = 'example.com'; if ( $cust_msg->env_from =~ /\@([\w\.\-]+)/ ) { $domain = $1; } # in principle should already be a list of bare addresses, but run it # through Email::Address to make sure my @env_to = map { $_->address } Email::Address->parse($cust_msg->env_to); my $message = join("\n", $cust_msg->header, $cust_msg->body); my $error = _sendmail( $message, { 'from' => $cust_msg->env_from, 'to' => \@env_to, 'domain' => $domain, } ); $cust_msg->set('error', $error); $cust_msg->set('status', $error ? 'failed' : 'sent'); if ( $cust_msg->custmsgnum ) { $cust_msg->replace; } else { $cust_msg->insert; } $error; } =back =cut # internal use only sub eviscerate { # Every bit as pleasant as it sounds. # # We do this because Text::Template::Preprocess doesn't # actually work. It runs the entire template through # the preprocessor, instead of the code segments. Which # is a shame, because Text::Template already contains # the code to do this operation. my $body = shift; my (@outside, @inside); my $depth = 0; my $chunk = ''; while($body || $chunk) { my ($first, $delim, $rest); # put all leading non-delimiters into $first ($first, $rest) = ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s); $chunk .= $first; # put a leading delimiter into $delim if there is one ($delim, $rest) = ($rest =~ /^([{}]?)(.*)$/s); if( $delim eq '{' ) { $chunk .= '{'; if( $depth == 0 ) { push @outside, $chunk; $chunk = ''; } $depth++; } elsif( $delim eq '}' ) { $depth--; if( $depth == 0 ) { push @inside, $chunk; $chunk = ''; } $chunk .= '}'; } else { # no more delimiters if( $depth == 0 ) { push @outside, $chunk . $rest; } # else ? something wrong last; } $body = $rest; } (\@outside, \@inside); } =head1 BUGS =head1 SEE ALSO L, schema.html from the base documentation. =cut 1;