The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl
# vim: ts=8 sts=4 et sw=4 sr sta
use strict;
use warnings;

BEGIN {
    # use the lib directory relative to ourself
    use FindBin;
    use lib "$FindBin::Bin/../lib";

    # for building email(s)
    use MIME::Lite;

    # since we're going to be a daemon ...
    use Proc::Daemon;
    use Proc::PID::File;

    # somewhere to send stuff
    use Sys::Syslog qw( :DEFAULT :standard :macros );

    # our in to the database ...
    use Parley::Schema;
}

use version; our $VERSION = qv('0.0.1');

# whether we should be exiting
our $exit = 0;

# prepare syslog for use
openlog(
    q{parley_email_engine},
    q{ndelay,pid},
    LOG_USER
)
    or die $!;
syslog( LOG_INFO, q{script started} )
    or die $!;

# have we been asked to stop running?
if (@ARGV && $ARGV[0] eq q{stop}) {
    # we need to quit!

    # get the pid file ...
    my $pid = Proc::PID::File->running(
        debug   => 0,
        name    => q{parley_email_engine},
        dir     => q{/tmp},
    );
    if (not $pid) {
        syslog( LOG_INFO, qq{daemon not running!} );
        exit;
    }

    # send a kill signal
    kill( 2, $pid );
    syslog( LOG_INFO, qq{STOP signal sent!\n} );
    exit;
}

# connect to the schema
my $schema = schema_connect();

# daemon
my $pid;
if ($pid = Proc::Daemon::Fork) { # parent
    # nothing here
}
else { # child
    Proc::Daemon::Init;

    openlog(
        q{parley_email_engine},
        q{ndelay,pid},
        LOG_USER
    )
        or die $!;
    syslog( LOG_INFO, q{child process created} );

    # how to deal with given signals
    $SIG{TERM}  = sub { $exit = 1 };
    $SIG{INT}   = sub { $exit = 1 };
    $SIG{CHLD}  = q{IGNORE};
    $SIG{HUP}   = q{IGNORE};

    my $status_ok;
    $status_ok = open(STDOUT, '>>', '/tmp/parley_email_engine.log');
    if (not $status_ok) {
        syslog( LOG_ERR, "failed to reopen STDOUT: $!" );
        exit;
    }
    $status_ok = open(STDERR, '>&STDOUT');
    if (not $status_ok) {
        syslog( LOG_ERR, "failed to re-open STDERR to STDOUT: $!" );
        exit;
    }

    # make sure we aren't already running
    if (Proc::PID::File->running(
            debug   => 0,
            name    => q{parley_email_engine},
            dir     => q{/tmp},
        )
    ) {
        syslog( LOG_INFO, qq{Already Running!} );
        exit;
    }

    while (1) {
        child_process($schema);
        sleep(5);
    }
}

sub child_process {
    my $schema = shift;

    # get the oldest unsent email in the queue
    my $rs = $schema->resultset('EmailQueue')->search(
        {
            attempted_delivery => 0,
        },
        {
            # oldest first
            order_by    => 'queued ASC',
            # one result
            rows        => 1,

            # some prefetching to make things a little easier on the database
            prefetch => [
                'recipient',
                'cc',
                'bcc'
            ],
        }
    );

    # if we have anything waiting to be sent ...
    if ($rs->count()) {
        my $queue_item = $rs->first();
        send_email( $queue_item );
    }

    # have we been asked to stop?
    if ($exit) {
        syslog(
            LOG_INFO,
            q{STOP signal recieved}
        );
        exit;
    }
}

sub schema_connect {
    my $schema;
    eval {
        $schema = Parley::Schema->connect(
            q{dbi:Pg:dbname=parley},
            q{parley},
            undef,
            { RaiseError => 0, PrintError => 0 },
        );
    };
    if ($@) {
        syslog( LOG_INFO, $@ );
        exit;
    }
    if (not defined $schema) {
        syslog( LOG_INFO, $! );
        exit;
    }

    return $schema;
}

sub send_email {
    my $queue_item = shift;
    my ($email);

    # are we text/plain or multipart/alternative?
    if (defined $queue_item->html_content()) {
        $email = build_multipart_email( $queue_item );
    }
    else {
        $email = build_text_email( $queue_item );
    }

    # print the email out for now, no need to send anything
    $email->send();
    syslog( LOG_INFO, $email->as_string() );
    # update the table to say we've attempted delivery
    $queue_item->attempted_delivery(1);
    $queue_item->update();

    return;
}

sub _common_mail_options {
    my $queue_item = shift;

    my %options = (
        From            => $queue_item->sender(),
        To              => nice_to_header( $queue_item->recipient() ),
        Subject         => $queue_item->subject(),
        'X-Application' => qq{parley_email_engine ($VERSION)},
    );

    return \%options;
}


sub build_text_email {
    my $queue_item = shift;
    my ($msg);

    # create a straight-forward text email
    $msg = MIME::Lite->new(
        %{ _common_mail_options($queue_item) },

        Type        => 'TEXT',
        Data        => $queue_item->text_content(),
        Encoding    => 'quoted-printable',
    )
        or die $!;

    return $msg;
}

sub build_multipart_email {
    my $queue_item = shift;
    my ($msg);

    # create the multipart container
    $msg = MIME::Lite->new(
        %{ _common_mail_options($queue_item) },

        Type    => 'multipart/alternative',
    )
        or die $!;

    # add the text part
    $msg->attach(
        Type    => 'text/plain',
        Data    => $queue_item->text_content(),
    );
    # add the html part
    $msg->attach(
        Type    => 'text/html',
        Data    => $queue_item->html_content(),
    );

    return $msg;
}



sub nice_to_header {
    my $recipient = shift;

    my $string =
          $recipient->first_name()
        . q{ }
        . $recipient->last_name()
        . q{ <}
        . $recipient->email()
        . q{>}
    ;

    return $string;
}