webgui_newsletter/lib/WebGUI/Mailing/Email.pm

package WebGUI::Mailing::Email;

use strict;
use warnings;

use HTML::TreeBuilder;
use WebGUI::HTML;
use WebGUI::Mailing::Bounce;

use base 'WebGUI::Crud';

#----------------------------------------------------------------------------
sub crud_definition {
    my $class   = shift;
    my $session = shift;

    my $definition = $class->SUPER::crud_definition( $session );

    $definition->{ tableName    } = 'Mailing_email';
    $definition->{ tableKey     } = 'mailId';
    $definition->{ sequenceKey  } = 'mailingId';

    my %properties = (
        mailingId       => {
            fieldType       => 'guid',
        },
        userId          => {
            fieldType       => 'guid',
        },
        recipientEmail  => {
            fieldType       => 'email',
            defaultValue    => undef,
        },
        status          => {
            fieldType       => 'text',
            defaultValue    => 'queued',    # Allowed are: 'queued', 'sent', 'error', 'bounced'
        },
        errorMessage    => {
            fieldType       => 'text',
            defaultValue    => undef,
        },
        isTest          => {
            fieldType       => 'yesNo',
            defaultValue    => 1,           # For safety: explicitly turn this off to send real emails
        },
        sendDate        => {
            fieldType       => 'dateTime',
        },
        sentTo          => {
            fieldType       => 'text',
        },
        bounceReason    => {
            fieldType       => 'text',
        },
    );

    $definition->{ properties } = { 
        %{ $definition->{ properties } || {} },
        %properties,
    };

    return $definition;
}

#----------------------------------------------------------------------------
sub getMailing {
    my $self = shift;
    my $session = $self->session;

    require WebGUI::Mailing;
    my $mailing = WebGUI::Mailing->new( $session, $self->get('mailingId') );
    #### TODO: error checking;
    return $mailing;
}

#----------------------------------------------------------------------------
sub getQueuedTestEmails {
    my $class   = shift;
    my $session = shift;

    my $it = $class->getAllIterator( $session, {
        constraints => [
            { 'isTest=?'    => [ 1 ]        },
            { 'status=?'    => [ 'queued' ] },
        ],
    } );

    return $it;
}

#----------------------------------------------------------------------------
sub getQueued {
    my $class       = shift;
    my $session     = shift;
    my $mailingId   = shift;

    my $it = $class->getAllIterator( $session, {
        constraints => [
            { 'mailingId=?'     => [ $mailingId  ] },
            { 'isTest=?'        => [ 0           ] },
            { 'status=?'        => [ 'queued'    ] },
        ],
    } );

    return $it;
}

#----------------------------------------------------------------------------
sub error {
    my $self    = shift;
    my $message = shift;

    $self->update( {
        status          => 'error',
        errorMessage    => $message || 'No error message available',
    } );

    return;
}

#----------------------------------------------------------------------------
sub absolutifyURIs {
    my $self    = shift;
    my $content = shift;
    my $pageUrl = shift;
    my $siteUrl = $self->session->url->getSiteURL;

    my $tb      = HTML::TreeBuilder->new;
    my $root    = $tb->parse( $content );

    foreach my $link ( @{ $root->extract_links } ) { 
        my ($uri, $element, $attr, $tag) = @{ $link };
        
        if ( $uri !~ m{ ^ [a-z]+:// }xmsi ) {
            my $new = 
                    ( $uri =~ m{ ^ / }xmsi )        # Is url absolute?
                    ? $siteUrl . $uri
                    : $siteUrl . $pageUrl . '/' . $uri
                    ;
            
            # replace attribute
            $element->attr( $attr, $new );
        }
    } 

    return $tb->as_HTML;
}

sub transformToText {
    my $self    = shift;
    my $html    = shift;

    my $text = $html;
    #HTML::Entities::decode($text);
    $text =~ s/<a.*?href=["'](.*?)['"].*?>(.+?)<\/a>/$2 ($1)/g;
    $text = WebGUI::HTML::html2text($text);

    return $text;
}

#----------------------------------------------------------------------------
sub send {
    my $self    = shift;
    my $session = $self->session;
    my $id      = $session->id;

    #### TODO: Error checking
    my $mailing = $self->getMailing;
    unless ( $mailing ) {
        $session->log->error( 'Cannot send because getMailing doesn\'t return one.' ); 
        return;
    }

    my $configuration = $mailing->get('configuration') || {};
    my $asset   = $mailing->getAsset;
    my $content = $asset->processContentAsUser( $mailing->get('issueId'), $self->get('userId'), $configuration );
    my $body    = $self->absolutifyURIs( $content, $asset->getUrl );
    my $text    = $self->transformToText( $body );

    # Mail is a test mail but there is noone to send the result to
    if ( $self->get( 'isTest' ) && !$self->get('recipientEmail') ) {
        $self->error( 'Cannot send test mails without an override recipient address' );
        return;
    }

    # Determine recipients email address and bail out if we can't find one.
    my $to  = $self->get('recipientEmail') || $self->user->get('email');
    if ( !$to ) {
        $self->error( 'Cannot find an email address for this user' );
        return;
    }

    # Check bounce score
    my $bounceScoreOk = WebGUI::Mailing::Bounce->new( $session )->bounceScoreOk( $to );
    if ( !$self->get( 'isTest' ) && !$bounceScoreOk ) {
        $self->update( { 
            status          => 'skipped',
            sendDate        => time,
            errorMessage    => "Bounce score for $to too high",
        } );

        return;
    }

    # Fetch subject
    my $subject   = $asset->getSubject( $configuration );

    my $messageId = $id->toHex( $self->getId );
    my $domain    = $session->setting->get( 'newsletterReturnDomain' );

    # Setup email
    my $mail = WebGUI::Mail::Send->create( $session, {
#        from        => 'martin@geefmegeld.nl',
        to          => $to,
        subject     => $subject,
        messageId   => "$messageId\@$domain",
        returnPath  => "$messageId-bounce\@$domain",
        contentType => 'multipart/alternative',
    } );
    $mail->addText( $text );
    $mail->addHtml( $body );

    if ( $asset->can( 'getListHeaders' ) ) {
        my $listHeaders = $asset->getListHeaders( $self->user->get('email') );

        while ( my ($header, $value) = each %{ $listHeaders } ) {
            $mail->addHeaderField( $header, $value );
        }
    }

    # And send it.  
    my $success = $mail->send;

    if ( $success ne '1' ) {
        $self->error( "Mail couldn't be sent by WebGUI::Mail::Send" );
    }
    else {
        $self->update( { 
            status      => 'sent',
            sendDate    => time,
            sentTo      => $to,
        } );
    }

    return;
}

#----------------------------------------------------------------------------
sub user {
    my $self    = shift;
    my $session = $self->session;

    my $user = WebGUI::User->new( $session, $self->get('userId') );
    return $user;
}

#----------------------------------------------------------------------------
sub registerBounced {
    my $self    = shift;
    my $reason  = shift;
    my $message = shift;

    $self->update( {
        status          => 'bounced',
        errorMessage    => $message,
        bounceReason    => $reason,
    } );

    #### TODO: Write to bounce log <= is this necessary? We're writing to the mail log already with most relevant info...

    return;
}

1;