qpsmtpd/lib/Qpsmtpd.pm

package Qpsmtpd;
use strict;

#use warnings;

our $VERSION = "0.95";
use vars qw($TraceLevel $Spool_dir $Size_threshold);

use lib 'lib';
use base 'Qpsmtpd::Base';
use Qpsmtpd::Address;
use Qpsmtpd::Config;
use Qpsmtpd::Constants;

my $git;

if (-e ".git") {
    local $ENV{PATH} = "/usr/bin:/usr/local/bin:/opt/local/bin/";
    $git = `git describe`;
    $git && chomp $git;
}

our $hooks = {};

our $LOGGING_LOADED = 0;

sub _restart {
    my $self = shift;
    my %args = @_;
    if ($args{restart}) {

        # reset all global vars to defaults
        $self->conf->clear_cache();
        $hooks          = {};
        $LOGGING_LOADED = 0;
        $TraceLevel     = LOGWARN;
        $Spool_dir      = undef;
        $Size_threshold = undef;
    }
}

sub version { $VERSION . ($git ? "/$git" : "") }

sub TRACE_LEVEL { $TraceLevel };    # leave for plugin compatibility

sub hooks { $hooks; }

sub load_logging {
    my $self = shift;

    # avoid triggering log activity
    return if ($LOGGING_LOADED || $hooks->{'logging'});

    my $configdir  = $self->config_dir("logging");
    my $configfile = "$configdir/logging";
    my @loggers    = $self->conf->from_file($configfile, 'logging');

    $configdir  = $self->config_dir('plugin_dirs');
    $configfile = "$configdir/plugin_dirs";
    my @plugin_dirs = $self->conf->from_file($configfile, 'plugin_dirs');
    unless (@plugin_dirs) {
        my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
        @plugin_dirs = ("$name/plugins");
    }

    my @loaded;
    for my $logger (@loggers) {
        push @loaded, $self->_load_plugin($logger, @plugin_dirs);
    }

    foreach my $logger (@loaded) {
        $self->log(LOGINFO, "Loaded $logger");
    }

    $configdir  = $self->config_dir("loglevel");
    $configfile = "$configdir/loglevel";
    $TraceLevel = $self->conf->from_file($configfile, 'loglevel');

    unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
        $TraceLevel = LOGWARN;    # Default if no loglevel file found.
    }

    $LOGGING_LOADED = 1;

    return @loggers;
}

sub trace_level { return $TraceLevel; }

sub init_logger {                 # needed for compatibility
    shift->trace_level();
}

sub log {
    my ($self, $trace, @log) = @_;
    $self->varlog($trace, join(" ", @log));
}

sub varlog {
    my ($self, $trace) = (shift, shift);
    my ($hook, $plugin, @log);
    if    ($#_ == 0) { (@log) = @_; }                 # log itself
    elsif ($#_ == 1) { ($hook, @log) = @_; }          # plus the hook
    else             { ($hook, $plugin, @log) = @_; } # from a plugin

    $self->load_logging;

    my ($rc) =
      $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
      or return;

    return if $rc == DECLINED || $rc == OK;              # plugin success
    return if $trace > $TraceLevel;

    # no logging plugins registered, fall back to STDERR
    my $prefix =
        defined $plugin && defined $hook ? " ($hook) $plugin:"
      : defined $plugin ? " $plugin:"
      : defined $hook   ? " ($hook) running plugin:"
      :                   '';

    warn join(' ', $$ . $prefix, @log), "\n";
}

sub conf {
    my $self = shift;
    if (!$self->{_config}) {
        $self->{_config} = Qpsmtpd::Config->new();
    }
    return $self->{_config};
}

sub config {
    my $self = shift;
    return $self->conf->config($self, @_);
}

sub config_dir {
    my $self = shift;
    return $self->conf->config_dir(@_);
}

sub plugin_dirs {
    my $self        = shift;
    my @plugin_dirs = $self->config('plugin_dirs');

    unless (@plugin_dirs) {
        my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
        @plugin_dirs = ("$path/plugins");
    }
    return @plugin_dirs;
}

sub load_plugins {
    my $self = shift;

    my @plugins = $self->config('plugins');
    my @loaded;

    if ($hooks->{queue}) {

        #$self->log(LOGWARN, "Plugins already loaded");
        return @plugins;
    }

    for my $plugin_line (@plugins) {
        my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs);
        push @loaded, $this_plugin if $this_plugin;
    }

    return @loaded;
}

sub _load_plugin {
    my $self = shift;
    my ($plugin_line, @plugin_dirs) = @_;

    # untaint the config data before passing it to plugins
    my ($safe_line) = $plugin_line =~ /^([ -~]+)$/    # all ascii printable
      or die "unsafe characters in config line: $plugin_line\n";
    my ($plugin, @args) = split /\s+/, $safe_line;

    if ($plugin =~ m/::/) {
        return $self->_load_package_plugin($plugin, $safe_line, \@args);
    }

    # regular plugins/$plugin plugin
    my $plugin_name = $plugin;
    $plugin =~ s/:\d+$//;    # after this point, only used for filename

    # Escape everything into valid perl identifiers
    $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;

    # second pass cares for slashes and words starting with a digit
    $plugin_name =~ s{
    (/+)       # directory
    (\d?)      # package's first character
    }[
        "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
    ]egx;

    my $package = "Qpsmtpd::Plugin::$plugin_name";

    # don't reload plugins if they are already loaded
    if (!defined &{"${package}::plugin_name"}) {
        for my $dir (@plugin_dirs) {
            next if !-e "$dir/$plugin";
            Qpsmtpd::Plugin->compile($plugin_name, $package,
                                     "$dir/$plugin", $self->{_test_mode},
                                     $plugin);
            if ($safe_line !~ /logging/) {
                $self->log(LOGDEBUG, "Loading $safe_line from $dir/$plugin");
            }
            last;
        }
        if (!defined &{"${package}::plugin_name"}) {
            die "Plugin $plugin_name not found in our plugin dirs (",
              join(', ', @plugin_dirs), ")";
        }
    }

    my $plug = $package->new();
    $plug->_register($self, @args);

    return $plug;
}

sub _load_package_plugin {
    my ($self, $plugin, $plugin_line, $args) = @_;

    # "full" package plugin (My::Plugin)
    my $package = $plugin;
    $package =~ s/[^_a-z0-9:]+//gi;
    my $eval =
      qq[require $package;\n] . qq[sub ${plugin}::plugin_name { '$plugin' }];
    $eval =~ m/(.*)/s;
    $eval = $1;
    eval $eval;    ## no critic (Eval)
    die "Failed loading $package - eval $@" if $@;

    if ($plugin_line !~ /logging/) {
        $self->log(LOGDEBUG, "Loading $package ($plugin_line)");
    }

    my $plug = $package->new();
    $plug->_register($self, @$args);

    return $plug;
}

sub transaction { return {}; }    # base class implements empty transaction

sub run_hooks {
    my ($self, $hook) = (shift, shift);
    if ($hooks->{$hook}) {
        my @r;
        my @local_hooks = @{$hooks->{$hook}};
        $self->{_continuation} = [$hook, [@_], @local_hooks];
        return $self->run_continuation();
    }
    return $self->hook_responder($hook, [0, ''], [@_]);
}

sub run_hooks_no_respond {
    my ($self, $hook) = (shift, shift);
    if ($hooks->{$hook}) {
        my @r;
        for my $code (@{$hooks->{$hook}}) {
            eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
            if ($@) {
                warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@);
                next;
            }
            if ($r[0] == YIELD) {
                die "YIELD not valid from $hook hook";
            }
            last unless $r[0] == DECLINED;
        }
        $r[0] = DECLINED if not defined $r[0];
        return @r;
    }
    return (0, '');
}

sub continue_read { }    # subclassed in -async
sub pause_read { die "Continuations only work in qpsmtpd-async" }

sub run_continuation {
    my $self = shift;

    die "No continuation in progress" unless $self->{_continuation};
    $self->continue_read();
    my $todo = $self->{_continuation};
    $self->{_continuation} = undef;
    my $hook = shift @$todo || die "No hook in the continuation";
    my $args = shift @$todo || die "No hook args in the continuation";
    my @r;

    while (@$todo) {
        my $code = shift @$todo;

        $self->varlog(LOGDEBUG, $hook, $code->{name});
        my $tran = $self->transaction;
        eval { (@r) = $code->{code}->($self, $tran, @$args); };
        if ($@) {
            $self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ",
                       $@);
            next;
        }

        !defined $r[0]
          and $self->log(LOGERROR,
                             "plugin "
                           . $code->{name}
                           . " running the $hook hook returned undef!"
                        )
          and next;

        # note this is wrong as $tran is always true in the
        # current code...
        if ($tran) {
            my $tnotes = $tran->notes($code->{name});
            $tnotes->{"hook_$hook"}->{'return'} = $r[0]
              if (!defined $tnotes || ref $tnotes eq "HASH");
        }
        else {
            my $cnotes = $self->connection->notes($code->{name});
            $cnotes->{"hook_$hook"}->{'return'} = $r[0]
              if (!defined $cnotes || ref $cnotes eq "HASH");
        }

        if ($r[0] == YIELD) {
            $self->pause_read();
            $self->{_continuation} = [$hook, $args, @$todo];
            return @r;
        }
        elsif (   $r[0] == DENY
               or $r[0] == DENYSOFT
               or $r[0] == DENY_DISCONNECT
               or $r[0] == DENYSOFT_DISCONNECT)
        {
            $r[1] = "" if not defined $r[1];
            $self->log(LOGDEBUG,
                           "Plugin "
                         . $code->{name}
                         . ", hook $hook returned "
                         . return_code($r[0])
                         . ", $r[1]"
                      );
            $self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1])
              unless ($hook eq "deny");
        }
        else {
            $r[1] = "" if not defined $r[1];
            $self->log(LOGDEBUG,
                           "Plugin "
                         . $code->{name}
                         . ", hook $hook returned "
                         . return_code($r[0])
                         . ", $r[1]"
                      );
            $self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1])
              unless ($hook eq "ok");
        }

        last unless $r[0] == DECLINED;
    }
    $r[0] = DECLINED if not defined $r[0];

    # hook_*_parse() may return a CODE ref..
    # ... which breaks when splitting as string:
    @r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE");
    return $self->hook_responder($hook, \@r, $args);
}

sub hook_responder {
    my ($self, $hook, $msg, $args) = @_;

    my $code = shift @$msg;

    my $responder = $hook . '_respond';
    if (my $meth = $self->can($responder)) {
        return $meth->($self, $code, $msg, $args);
    }
    return $code, @$msg;
}

sub _register_hook {
    my ($self, $hook, $code, $unshift) = @_;

    if ($unshift) {
        unshift @{$hooks->{$hook}}, $code;
        return;
    }

    push @{$hooks->{$hook}}, $code;
}

sub spool_dir {
    my $self = shift;

    return $Spool_dir if $Spool_dir;    # already set

    $self->log(LOGDEBUG, "Initializing spool_dir");
    $Spool_dir = $self->config('spool_dir') || $self->tildeexp('~/tmp/');

    $Spool_dir .= "/" if $Spool_dir !~ m!/$!;

    $Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly";
    $Spool_dir = $1;                    # cleanse the taint

    my $Spool_perms = $self->config('spool_perms') || '0700';

    if (!-d $Spool_dir) {               # create if it doesn't exist
        mkdir($Spool_dir, oct($Spool_perms))
          or die "Could not create spool_dir $Spool_dir: $!";
    }

    # Make sure the spool dir has appropriate rights
    if (((stat $Spool_dir)[2] & oct('07777')) != oct($Spool_perms)) {
        $self->log(LOGWARN,
                   "Permissions on spool_dir $Spool_dir are not $Spool_perms");
    }

    return $Spool_dir;
}

# For unique filenames. We write to a local tmp dir so we don't need
# to make them unpredictable.
my $transaction_counter = 0;

sub temp_file {
    my $self = shift;
    my $filename =
      $self->spool_dir() . join(":", time, $$, $transaction_counter++);
    return $filename;
}

sub temp_dir {
    my ($self, $mask) = @_;
    $mask ||= '0700';
    my $dirname = $self->temp_file();
    if (!-d $dirname) {
        mkdir($dirname, $mask)
            or die "Could not create temporary directory $dirname: $!";
    }
    return $dirname;
}

sub size_threshold {
    my $self = shift;
    return $Size_threshold if defined $Size_threshold;

    $Size_threshold = $self->config('size_threshold') || 0;
    $self->log(LOGDEBUG, "size_threshold set to $Size_threshold");
    return $Size_threshold;
}

sub authenticated {
    my $self = shift;
    return (defined $self->{_auth} ? $self->{_auth} : "");
}

sub auth_user {
    my $self = shift;
    return (defined $self->{_auth_user} ? $self->{_auth_user} : "");
}

sub auth_mechanism {
    my $self = shift;
    return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "");
}

sub address {
    my $self = shift;
    my $addr = Qpsmtpd::Address->new(@_);
    $addr->qp($self);
    return $addr;
}

1;

__END__

=head1 NAME

Qpsmtpd - base class for the qpsmtpd mail server

=head1 DESCRIPTION

This is the base class for the qpsmtpd mail server.  See
L<http://smtpd.develooper.com/> and the I<README> file for more information.

=encoding UTF8

=head1 COPYRIGHT

Copyright 2001-2012 Ask Bjørn Hansen, Develooper LLC.  See the
LICENSE file for more information.

=cut