1package Qpsmtpd;
2use strict;
3use vars qw($VERSION $TraceLevel $Spool_dir $Size_threshold);
4
5use Sys::Hostname;
6use Qpsmtpd::Constants;
7
8#use DashProfiler;
9
10$VERSION = "0.93";
11
12my $git;
13
14if (-e ".git") {
15    local $ENV{PATH} = "/usr/bin:/usr/local/bin:/opt/local/bin/";
16    $git = `git describe`;
17    $git && chomp $git;
18}
19
20my $hooks = {};
21my %defaults = (
22                me      => hostname,
23                timeout => 1200,
24               );
25my $_config_cache = {};
26my %config_dir_memo;
27
28#DashProfiler->add_profile("qpsmtpd");
29#my $SAMPLER = DashProfiler->prepare("qpsmtpd");
30my $LOGGING_LOADED = 0;
31
32sub _restart {
33    my $self = shift;
34    my %args = @_;
35    if ($args{restart}) {
36
37        # reset all global vars to defaults
38        $self->clear_config_cache;
39        $hooks           = {};
40        $LOGGING_LOADED  = 0;
41        %config_dir_memo = ();
42        $TraceLevel      = LOGWARN;
43        $Spool_dir       = undef;
44        $Size_threshold  = undef;
45    }
46}
47
48sub DESTROY {
49
50    #warn $_ for DashProfiler->profile_as_text("qpsmtpd");
51}
52
53sub version { $VERSION . ($git ? "/$git" : "") }
54
55sub TRACE_LEVEL { $TraceLevel };    # leave for plugin compatibility
56
57sub hooks { $hooks; }
58
59sub load_logging {
60
61    # need to do this differently than other plugins so as to
62    # not trigger logging activity
63    return if $LOGGING_LOADED;
64    my $self = shift;
65    return if $hooks->{"logging"};
66    my $configdir  = $self->config_dir("logging");
67    my $configfile = "$configdir/logging";
68    my @loggers    = $self->_config_from_file($configfile, 'logging');
69
70    $configdir  = $self->config_dir('plugin_dirs');
71    $configfile = "$configdir/plugin_dirs";
72    my @plugin_dirs = $self->_config_from_file($configfile, 'plugin_dirs');
73    unless (@plugin_dirs) {
74        my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
75        @plugin_dirs = ("$name/plugins");
76    }
77
78    my @loaded;
79    for my $logger (@loggers) {
80        push @loaded, $self->_load_plugin($logger, @plugin_dirs);
81    }
82
83    foreach my $logger (@loaded) {
84        $self->log(LOGINFO, "Loaded $logger");
85    }
86
87    $configdir  = $self->config_dir("loglevel");
88    $configfile = "$configdir/loglevel";
89    $TraceLevel = $self->_config_from_file($configfile, 'loglevel');
90
91    unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
92        $TraceLevel = LOGWARN;    # Default if no loglevel file found.
93    }
94
95    $LOGGING_LOADED = 1;
96
97    return @loggers;
98}
99
100sub trace_level {
101    my $self = shift;
102    return $TraceLevel;
103}
104
105sub init_logger {    # needed for compatibility purposes
106    shift->trace_level();
107}
108
109sub log {
110    my ($self, $trace, @log) = @_;
111    $self->varlog($trace, join(" ", @log));
112}
113
114sub varlog {
115    my ($self, $trace) = (shift, shift);
116    my ($hook, $plugin, @log);
117    if ($#_ == 0) {    # log itself
118        (@log) = @_;
119    }
120    elsif ($#_ == 1) {    # plus the hook
121        ($hook, @log) = @_;
122    }
123    else {                # called from plugin
124        ($hook, $plugin, @log) = @_;
125    }
126
127    $self->load_logging;    # in case we don't have this loaded yet
128
129    my ($rc) =
130      $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
131      or return;
132
133    return if $rc == DECLINED || $rc == OK;    # plugin success
134    return if $trace > $TraceLevel;
135
136    # no logging plugins registered, fall back to STDERR
137    my $prefix =
138        defined $plugin && defined $hook ? " ($hook) $plugin:"
139      : defined $plugin ? " $plugin:"
140      : defined $hook   ? " ($hook) running plugin:"
141      :                   '';
142
143    warn join(' ', $$ . $prefix, @log), "\n";
144}
145
146sub clear_config_cache {
147    $_config_cache = {};
148}
149
150#
151# method to get the configuration.  It just calls get_qmail_config by
152# default, but it could be overwritten to look configuration up in a
153# database or whatever.
154#
155sub config {
156    my ($self, $c, $type) = @_;
157
158    $self->log(LOGDEBUG, "in config($c)");
159
160    # first try the cache
161    # XXX - is this always the right thing to do? what if a config hook
162    # can return different values on subsequent calls?
163    if ($_config_cache->{$c}) {
164        $self->log(LOGDEBUG,
165                   "config($c) returning (@{$_config_cache->{$c}}) from cache");
166        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
167    }
168
169    # then run the hooks
170    my ($rc, @config) = $self->run_hooks_no_respond("config", $c);
171    $self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) ");
172    if ($rc == OK) {
173        $self->log(LOGDEBUG,
174"setting _config_cache for $c to [@config] from hooks and returning it"
175        );
176        $_config_cache->{$c} = \@config;
177        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
178    }
179
180    # and then get_qmail_config
181    @config = $self->get_qmail_config($c, $type);
182    if (@config) {
183        $self->log(LOGDEBUG,
184"setting _config_cache for $c to [@config] from get_qmail_config and returning it"
185        );
186        $_config_cache->{$c} = \@config;
187        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
188    }
189
190    # finally we use the default if there is any:
191    if (exists($defaults{$c})) {
192        $self->log(LOGDEBUG,
193"setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it"
194        );
195        $_config_cache->{$c} = [$defaults{$c}];
196        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
197    }
198    return;
199}
200
201sub config_dir {
202    my ($self, $config) = @_;
203    if (exists $config_dir_memo{$config}) {
204        return $config_dir_memo{$config};
205    }
206    my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
207    my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
208    $configdir = "$path/config" if (-e "$path/config/$config");
209    if (exists $ENV{QPSMTPD_CONFIG}) {
210        $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/;    # detaint
211        $configdir = $1 if -e "$1/$config";
212    }
213    return $config_dir_memo{$config} = $configdir;
214}
215
216sub plugin_dirs {
217    my $self        = shift;
218    my @plugin_dirs = $self->config('plugin_dirs');
219
220    unless (@plugin_dirs) {
221        my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
222        @plugin_dirs = ("$path/plugins");
223    }
224    return @plugin_dirs;
225}
226
227sub get_qmail_config {
228    my ($self, $config, $type) = @_;
229    $self->log(LOGDEBUG, "trying to get config for $config");
230    my $configdir = $self->config_dir($config);
231
232    my $configfile = "$configdir/$config";
233
234    # CDB config support really should be moved to a plugin
235    if ($type and $type eq "map") {
236        unless (-e $configfile . ".cdb") {
237            $_config_cache->{$config} ||= [];
238            return +{};
239        }
240        eval { require CDB_File };
241
242        if ($@) {
243            $self->log(LOGERROR,
244"No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@"
245            );
246            return +{};
247        }
248
249        my %h;
250        unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
251            $self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
252            return +{};
253        }
254
255        # We explicitly don't cache cdb entries. The assumption is that
256        # the data is in a CDB file in the first place because there's
257        # lots of data and the cache hit ratio would be low.
258        return \%h;
259    }
260
261    return $self->_config_from_file($configfile, $config);
262}
263
264sub _config_from_file {
265    my ($self, $configfile, $config, $visited) = @_;
266    unless (-e $configfile) {
267        $_config_cache->{$config} ||= [];
268        return;
269    }
270
271    $visited ||= [];
272    push @{$visited}, $configfile;
273
274    open CF, "<$configfile"
275      or warn "$$ could not open configfile $configfile: $!" and return;
276    my @config = <CF>;
277    chomp @config;
278    @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/ }
279      map { s/^\s+//; s/\s+$//; $_; }    # trim leading/trailing whitespace
280      @config;
281    close CF;
282
283    my $pos = 0;
284    while ($pos < @config) {
285
286       # recursively pursue an $include reference, if found.  An inclusion which
287       # begins with a leading slash is interpreted as a path to a file and will
288       # supercede the usual config path resolution.  Otherwise, the normal
289       # config_dir() lookup is employed (the location in which the inclusion
290       # appeared receives no special precedence; possibly it should, but it'd
291       # be complicated beyond justifiability for so simple a config system.
292        if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) {
293            my ($includedir, $inclusion) = ('', $1);
294
295            splice @config, $pos, 1;    # remove the $include line
296            if ($inclusion !~ /^\//) {
297                $includedir = $self->config_dir($inclusion);
298                $inclusion  = "$includedir/$inclusion";
299            }
300
301            if (grep($_ eq $inclusion, @{$visited})) {
302                $self->log(LOGERROR,
303                           "Circular \$include reference in config $config:");
304                $self->log(LOGERROR, "From $visited->[0]:");
305                $self->log(LOGERROR, "  includes $_")
306                  for (@{$visited}[1 .. $#{$visited}], $inclusion);
307                return wantarray ? () : undef;
308            }
309            push @{$visited}, $inclusion;
310
311            for my $inc ($self->expand_inclusion_($inclusion, $configfile)) {
312                my @insertion =
313                  $self->_config_from_file($inc, $config, $visited);
314                splice @config, $pos, 0, @insertion;    # insert the inclusion
315                $pos += @insertion;
316            }
317        }
318        else {
319            $pos++;
320        }
321    }
322
323    $_config_cache->{$config} = \@config;
324
325    return wantarray ? @config : $config[0];
326}
327
328sub expand_inclusion_ {
329    my $self      = shift;
330    my $inclusion = shift;
331    my $context   = shift;
332    my @includes;
333
334    if (-d $inclusion) {
335        $self->log(LOGDEBUG, "inclusion of directory $inclusion from $context");
336
337        if (opendir(INCD, $inclusion)) {
338            @includes = map { "$inclusion/$_" }
339              (grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD);
340            closedir INCD;
341        }
342        else {
343            $self->log(LOGERROR,
344                           "Couldn't open directory $inclusion,"
345                         . " referenced from $context ($!)"
346                      );
347        }
348    }
349    else {
350        $self->log(LOGDEBUG, "inclusion of file $inclusion from $context");
351        @includes = ($inclusion);
352    }
353    return @includes;
354}
355
356sub load_plugins {
357    my $self = shift;
358
359    my @plugins = $self->config('plugins');
360    my @loaded;
361
362    if ($hooks->{queue}) {
363
364        #$self->log(LOGWARN, "Plugins already loaded");
365        return @plugins;
366    }
367
368    for my $plugin_line (@plugins) {
369        my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs);
370        push @loaded, $this_plugin if $this_plugin;
371    }
372
373    return @loaded;
374}
375
376sub _load_plugin {
377    my $self = shift;
378    my ($plugin_line, @plugin_dirs) = @_;
379
380    # untaint the config data before passing it to plugins
381    my ($safe_line) = $plugin_line =~ /^([ -~]+)$/  # all ascii printable
382        or die "unsafe characters in config line: $plugin_line\n";
383    my ($plugin, @args) = split /\s+/, $safe_line;
384
385    if ($plugin =~ m/::/) {
386        return $self->_load_package_plugin($plugin, $safe_line, \@args);
387    };
388
389    # regular plugins/$plugin plugin
390    my $plugin_name = $plugin;
391    $plugin =~ s/:\d+$//;    # after this point, only used for filename
392
393    # Escape everything into valid perl identifiers
394    $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
395
396    # second pass cares for slashes and words starting with a digit
397    $plugin_name =~ s{
398    (/+)       # directory
399    (\d?)      # package's first character
400    }[
401        "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
402    ]egx;
403
404    my $package = "Qpsmtpd::Plugin::$plugin_name";
405
406    # don't reload plugins if they are already loaded
407    unless (defined &{"${package}::plugin_name"}) {
408        PLUGIN_DIR: for my $dir (@plugin_dirs) {
409            if (-e "$dir/$plugin") {
410                Qpsmtpd::Plugin->compile($plugin_name, $package,
411                                "$dir/$plugin", $self->{_test_mode}, $plugin);
412                $self->log(LOGDEBUG, "Loading $safe_line from $dir/$plugin")
413                    unless $safe_line =~ /logging/;
414                last PLUGIN_DIR;
415            }
416        }
417        die "Plugin $plugin_name not found in our plugin dirs (",
418            join(", ", @plugin_dirs), ")"
419            unless defined &{"${package}::plugin_name"};
420    }
421
422    my $plug = $package->new();
423    $plug->_register($self, @args);
424
425    return $plug;
426}
427
428sub _load_package_plugin {
429    my ($self, $plugin, $plugin_line, $args) = @_;
430    # "full" package plugin (My::Plugin)
431    my $package = $plugin;
432    $package =~ s/[^_a-z0-9:]+//gi;
433    my $eval = qq[require $package;\n]
434        . qq[sub ${plugin}::plugin_name { '$plugin' }];
435    $eval =~ m/(.*)/s;
436    $eval = $1;
437    eval $eval;
438    die "Failed loading $package - eval $@" if $@;
439    $self->log(LOGDEBUG, "Loading $package ($plugin_line)")
440        unless $plugin_line =~ /logging/;
441
442    my $plug = $package->new();
443    $plug->_register($self, @$args);
444
445    return $plug;
446};
447
448sub transaction { return {}; }    # base class implements empty transaction
449
450sub run_hooks {
451    my ($self, $hook) = (shift, shift);
452    if ($hooks->{$hook}) {
453        my @r;
454        my @local_hooks = @{$hooks->{$hook}};
455        $self->{_continuation} = [$hook, [@_], @local_hooks];
456        return $self->run_continuation();
457    }
458    return $self->hook_responder($hook, [0, ''], [@_]);
459}
460
461sub run_hooks_no_respond {
462    my ($self, $hook) = (shift, shift);
463    if ($hooks->{$hook}) {
464        my @r;
465        for my $code (@{$hooks->{$hook}}) {
466            eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
467            $@
468              and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@)
469              and next;
470            if ($r[0] == YIELD) {
471                die "YIELD not valid from $hook hook";
472            }
473            last unless $r[0] == DECLINED;
474        }
475        $r[0] = DECLINED if not defined $r[0];
476        return @r;
477    }
478    return (0, '');
479}
480
481sub continue_read { }    # subclassed in -async
482sub pause_read { die "Continuations only work in qpsmtpd-async" }
483
484sub run_continuation {
485    my $self = shift;
486
487    #my $t1 = $SAMPLER->("run_hooks", undef, 1);
488    die "No continuation in progress" unless $self->{_continuation};
489    $self->continue_read();
490    my $todo = $self->{_continuation};
491    $self->{_continuation} = undef;
492    my $hook = shift @$todo || die "No hook in the continuation";
493    my $args = shift @$todo || die "No hook args in the continuation";
494    my @r;
495
496    while (@$todo) {
497        my $code = shift @$todo;
498
499        #my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1);
500        #warn("Got sampler called: ${hook}_$code->{name}\n");
501        $self->varlog(LOGDEBUG, $hook, $code->{name});
502        my $tran = $self->transaction;
503        eval { (@r) = $code->{code}->($self, $tran, @$args); };
504        $@
505          and
506          $self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ",
507                     $@)
508          and next;
509
510        !defined $r[0]
511          and $self->log(LOGERROR,
512                             "plugin "
513                           . $code->{name}
514                           . " running the $hook hook returned undef!"
515                        )
516          and next;
517
518        # note this is wrong as $tran is always true in the
519        # current code...
520        if ($tran) {
521            my $tnotes = $tran->notes($code->{name});
522            $tnotes->{"hook_$hook"}->{'return'} = $r[0]
523              if (!defined $tnotes || ref $tnotes eq "HASH");
524        }
525        else {
526            my $cnotes = $self->connection->notes($code->{name});
527            $cnotes->{"hook_$hook"}->{'return'} = $r[0]
528              if (!defined $cnotes || ref $cnotes eq "HASH");
529        }
530
531        if ($r[0] == YIELD) {
532            $self->pause_read();
533            $self->{_continuation} = [$hook, $args, @$todo];
534            return @r;
535        }
536        elsif (   $r[0] == DENY
537               or $r[0] == DENYSOFT
538               or $r[0] == DENY_DISCONNECT
539               or $r[0] == DENYSOFT_DISCONNECT)
540        {
541            $r[1] = "" if not defined $r[1];
542            $self->log(LOGDEBUG,
543                           "Plugin "
544                         . $code->{name}
545                         . ", hook $hook returned "
546                         . return_code($r[0])
547                         . ", $r[1]"
548                      );
549            $self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1])
550              unless ($hook eq "deny");
551        }
552        else {
553            $r[1] = "" if not defined $r[1];
554            $self->log(LOGDEBUG,
555                           "Plugin "
556                         . $code->{name}
557                         . ", hook $hook returned "
558                         . return_code($r[0])
559                         . ", $r[1]"
560                      );
561            $self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1])
562              unless ($hook eq "ok");
563        }
564
565        last unless $r[0] == DECLINED;
566    }
567    $r[0] = DECLINED if not defined $r[0];
568
569    # hook_*_parse() may return a CODE ref..
570    # ... which breaks when splitting as string:
571    @r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE");
572    return $self->hook_responder($hook, \@r, $args);
573}
574
575sub hook_responder {
576    my ($self, $hook, $msg, $args) = @_;
577
578    #my $t1 = $SAMPLER->("hook_responder", undef, 1);
579    my $code = shift @$msg;
580
581    my $responder = $hook . '_respond';
582    if (my $meth = $self->can($responder)) {
583        return $meth->($self, $code, $msg, $args);
584    }
585    return $code, @$msg;
586}
587
588sub _register_hook {
589    my $self = shift;
590    my ($hook, $code, $unshift) = @_;
591
592    if ($unshift) {
593        unshift @{$hooks->{$hook}}, $code;
594    }
595    else {
596        push @{$hooks->{$hook}}, $code;
597    }
598}
599
600sub spool_dir {
601    my $self = shift;
602
603    unless ($Spool_dir) {    # first time through
604        $self->log(LOGDEBUG, "Initializing spool_dir");
605        $Spool_dir = $self->config('spool_dir')
606          || Qpsmtpd::Utils::tildeexp('~/tmp/');
607
608        $Spool_dir .= "/" unless ($Spool_dir =~ m!/$!);
609
610        $Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly";
611        $Spool_dir = $1;     # cleanse the taint
612        my $Spool_perms = $self->config('spool_perms') || '0700';
613
614        if (!-d $Spool_dir) {    # create it if it doesn't exist
615            mkdir($Spool_dir, oct($Spool_perms))
616              or die "Could not create spool_dir $Spool_dir: $!";
617        }
618
619        # Make sure the spool dir has appropriate rights
620        $self->log(LOGWARN,
621                   "Permissions on spool_dir $Spool_dir are not $Spool_perms")
622          unless ((stat $Spool_dir)[2] & 07777) == oct($Spool_perms);
623    }
624
625    return $Spool_dir;
626}
627
628# For unique filenames. We write to a local tmp dir so we don't need
629# to make them unpredictable.
630my $transaction_counter = 0;
631
632sub temp_file {
633    my $self = shift;
634    my $filename =
635      $self->spool_dir() . join(":", time, $$, $transaction_counter++);
636    return $filename;
637}
638
639sub temp_dir {
640    my $self    = shift;
641    my $mask    = shift || 0700;
642    my $dirname = $self->temp_file();
643    -d $dirname
644      or mkdir($dirname, $mask)
645      or die "Could not create temporary directory $dirname: $!";
646    return $dirname;
647}
648
649sub size_threshold {
650    my $self = shift;
651    unless (defined $Size_threshold) {
652        $Size_threshold = $self->config('size_threshold') || 0;
653        $self->log(LOGDEBUG, "size_threshold set to $Size_threshold");
654    }
655    return $Size_threshold;
656}
657
658sub authenticated {
659    my $self = shift;
660    return (defined $self->{_auth} ? $self->{_auth} : "");
661}
662
663sub auth_user {
664    my $self = shift;
665    return (defined $self->{_auth_user} ? $self->{_auth_user} : "");
666}
667
668sub auth_mechanism {
669    my $self = shift;
670    return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "");
671}
672
6731;
674
675__END__
676
677=head1 NAME
678
679Qpsmtpd - base class for the qpsmtpd mail server
680
681=head1 DESCRIPTION
682
683This is the base class for the qpsmtpd mail server.  See
684L<http://smtpd.develooper.com/> and the I<README> file for more information.
685
686=head1 COPYRIGHT
687
688Copyright 2001-2012 Ask Bjørn Hansen, Develooper LLC.  See the
689LICENSE file for more information.
690
691=cut
692
693