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