implement size limit filter for both article and command mail.

3 files changed, 425 insertions, 5 deletions

diff --git a/fml/lib/FML/Filter.pm b/fml/lib/FML/Filter.pm
index 57ef3dd7..18137f03 100644
--- a/fml/lib/FML/Filter.pm
+++ b/fml/lib/FML/Filter.pm
@@ -4,7 +4,7 @@
 #   All rights reserved. This program is free software; you can
 #   redistribute it and/or modify it under the same terms as Perl itself.
 #
-# $FML: Filter.pm,v 1.27 2003/05/13 03:49:55 fukachan Exp $
+# $FML: Filter.pm,v 1.28 2003/05/13 04:26:47 fukachan Exp $
 #
 
 package FML::Filter;
@@ -91,6 +91,44 @@ sub article_filter
 }
 
 
+# Descriptions: size based filtering
+#    Arguments: OBJ($self) OBJ($curproc) HASH_REF($args) OBJ($mesg)
+# Side Effects: none
+# Return Value: STR(reason) or 0 (not trapped, ok)
+sub _apply_article_size_filter
+{
+    my ($self, $curproc, $args, $mesg) = @_;
+    my $config = $curproc->config();
+
+    use FML::Filter::Size;
+    my $obj = new FML::Filter::Size $curproc;
+
+    if (defined $obj) {
+	$obj->set_class('incoming_article');
+
+	# overwrite filter rules based on FML::Config
+	my $rules = $config->get_as_array_ref('article_size_filter_rules');
+
+	# overwrite rules
+	if (defined $rules) {
+	    $obj->rules( $rules );
+	}
+
+	# go check
+	$obj->size_check($mesg);
+	if ($obj->error()) {
+	    my $x = $obj->error();
+	    $x =~ s/\s*at .*$//;
+	    $x =~ s/[\n\s]*$//m;
+	    $self->error_set($x);
+	    return $x;
+	}
+    }
+
+    return 0;
+}
+
+
 # Descriptions: header based filter
 #    Arguments: OBJ($self) OBJ($curproc) HASH_REF($args) OBJ($mesg)
 # Side Effects: none
@@ -244,16 +282,39 @@ send back message on rejection, with reason if could.
 sub article_filter_reject_notice
 {
     my ($self, $curproc, $msg_args) = @_;
+    $self->_filter_reject_notice($curproc, $msg_args, "article");
+}
+
+
+# Descriptions: send back message on rejection, with reason if could.
+#    Arguments: OBJ($self) OBJ($curproc) HASH_REF($msg_args)
+# Side Effects: update reply message queue
+# Return Value: none
+sub command_mail_filter_reject_notice
+{
+    my ($self, $curproc, $msg_args) = @_;
+    $self->_filter_reject_notice($curproc, $msg_args, "command_mail");
+}
+
+
+# Descriptions: send back message on rejection, with reason if could.
+#    Arguments: OBJ($self) OBJ($curproc) HASH_REF($msg_args) STR($class)
+# Side Effects: update reply message queue
+# Return Value: none
+sub _filter_reject_notice
+{
+    my ($self, $curproc, $msg_args, $class) = @_;
     my $cred   = $curproc->{ credential };
     my $config = $curproc->config();
     my $msg    = $curproc->incoming_message();
     my $r      = $msg_args->{ _arg_reason } || 'unknown';
-    my $type   = $config->{article_filter_reject_notice_data_type} || 'string';
+    my $type   = $config->{ "${class}_filter_reject_notice_data_type" } || 
+	'string';
     my $size   = 2048;
 
     # recipients
     my $list  =
-	$config->get_as_array_ref('article_filter_reject_notice_recipients');
+	$config->get_as_array_ref("${class}_filter_reject_notice_recipients");
     my $rcpts = $curproc->convert_to_mail_address($list);
     $msg_args->{ recipient }    = $rcpts;
     $msg_args->{ _arg_address } = $cred->sender();
@@ -284,8 +345,87 @@ sub article_filter_reject_notice
 	$curproc->reply_message(sprintf("\n\n%s", $s), $msg_args);
     }
     else {
-	LogError("unknown article_filter_reject_notice_data_type: $type");
+	LogError("unknown ${class}_filter_reject_notice_data_type: $type");
+    }
+}
+
+
+=head1 COMMAND MAIL
+
+=cut
+
+# Descriptions: entry point for FML::Filter::* modules
+#    Arguments: OBJ($self) OBJ($curproc) HASH_REF($args)
+# Side Effects: none
+# Return Value: STR or UNDEF, error reason (string). return undef if ok.
+sub command_mail_filter
+{
+    my ($self, $curproc, $args) = @_;
+    my $message = $curproc->incoming_message();
+    my $config  = $curproc->config();
+
+    if (defined $message) {
+	my $functions = 
+	    $config->get_as_array_ref('command_mail_filter_functions');
+	my $status    = 0;
+
+      FUNCTION:
+	for my $function (@$functions) {
+	    if ($config->yes( "use_${function}" )) {
+		Log("filter(debug): check by $function");
+		my $fp = "_apply_$function";
+		$status = $self->$fp($curproc, $args, $message);
+	    }
+	    else {
+		Log("filter(debug): not check by $function");
+	    }
+
+	    last FUNCTION if $status;
+	}
+
+	return $status if $status;
     }
+
+    return undef;
+}
+
+
+# Descriptions: size based filtering
+#    Arguments: OBJ($self) OBJ($curproc) HASH_REF($args) OBJ($mesg)
+# Side Effects: none
+# Return Value: STR(reason) or 0 (not trapped, ok)
+sub _apply_command_mail_size_filter
+{
+    my ($self, $curproc, $args, $mesg) = @_;
+    my $config = $curproc->config();
+
+    use FML::Filter::Size;
+    my $obj = new FML::Filter::Size $curproc;
+
+    if (defined $obj) {
+	$obj->set_class('incoming_command_mail');
+
+	# overwrite filter rules based on FML::Config
+	my $rules = 
+	    $config->get_as_array_ref('command_mail_size_filter_rules');
+
+	# overwrite rules
+	if (defined $rules) {
+	    $obj->rules( $rules );
+	}
+
+	# go check
+	$obj->size_check($mesg);
+	if ($obj->error()) {
+	    my $x = $obj->error();
+	    $x =~ s/\s*at .*$//;
+	    $x =~ s/[\n\s]*$//m;
+	    $self->error_set($x);
+	    return $x;
+	}
+    }
+
+    return 0;
 }
 
 
diff --git a/fml/lib/FML/Filter/Size.pm b/fml/lib/FML/Filter/Size.pm
new file mode 100644
index 00000000..b7f479b1
--- /dev/null
+++ b/fml/lib/FML/Filter/Size.pm
@@ -0,0 +1,239 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2003 Ken'ichi Fukamachi
+#   All rights reserved. This program is free software; you can
+#   redistribute it and/or modify it under the same terms as Perl itself.
+#
+# $FML: Size.pm,v 1.2 2002/12/20 03:41:28 fukachan Exp $
+#
+
+package FML::Filter::Size;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+use ErrorStatus qw(error_set error error_clear);
+
+
+=head1 NAME
+
+FML::Filter::Size - filter based on mail size
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+C<FML::Filter::Size> is the collectoin of filter rules based on mail
+size.
+
+=head1 METHODS
+
+=head2 C<new()>
+
+constructor.
+
+=cut
+
+
+my $debug = 0;
+
+
+# XXX-TODO: need this default rules here ? (principle of least surprise?)
+my (@default_rules) = qw(check_header_size check_body_size);
+
+
+# Descriptions: constructor.
+#    Arguments: OBJ($self) OBJ($curproc)
+# Side Effects: none
+# Return Value: OBJ
+sub new
+{
+    my ($self, $curproc) = @_;
+    my ($type) = ref($self) || $self;
+    my $me     = { _curproc => $curproc };
+
+    # apply default rules
+    $me->{ _rules } = \@default_rules;
+
+    # class (direction)
+    $me->{ _class } = 'incoming_article';
+
+    return bless $me, $type;
+}
+
+
+
+=head2 C<rules( $rules )>
+
+overwrite rules by specified C<@$rules> ($rules is ARRAY_REF).
+
+=cut
+
+
+# Descriptions: access method to overwrite rule
+#    Arguments: OBJ($self) ARRAY_REF($rarray)
+# Side Effects: overwrite info in object
+# Return Value: ARRAY_REF
+sub rules
+{
+    my ($self, $rarray) = @_;
+    $self->{ _rules } = $rarray;
+}
+
+
+=head2 set_class( $class )
+
+set class e.g. incoming_article, outgoing_article, ...
+
+=cut
+
+
+# Descriptions: set class. 
+#    Arguments: OBJ($self) STR($class)
+# Side Effects: update $self->{ _class }
+# Return Value: STR
+sub set_class
+{
+    my ($self, $class) = @_;
+    $self->{ _class } = $class;
+}
+
+
+=head2 C<size_check($msg, $args)>
+
+C<$msg> is C<Mail::Message> object.
+
+C<Usage>:
+
+    use FML::Filter::Size;
+    my $obj  = new FML::Filter::Size;
+    my $msg  = $curproc->{'incoming_message'};
+
+    $obj->Size_check($msg, $args);
+    if ($obj->error()) {
+       # do something for wrong formated message ...
+    }
+
+=cut
+
+
+# Descriptions: top level dispatcher
+#    Arguments: OBJ($self) OBJ($msg) HASH_REF($args)
+# Side Effects: none
+# Return Value: none
+sub size_check
+{
+    my ($self, $msg, $args) = @_;
+    my $rules = $self->{ _rules };
+
+  RULE:
+    for my $rule (@$rules) {
+	if ($rule eq 'permit') {
+	    last RULE;
+	}
+
+	eval q{
+	    $self->$rule($msg, $args);
+	};
+
+	if ($@) {
+	    $self->error_set($@);
+	}
+    }
+}
+
+
+=head1 FILTER RULES
+
+=head2 check_header_size($msg, $args)
+
+check the size of mail header.
+throw reason via croak() if the size exceeds the limit.
+
+=head2 check_body_size($msg, $args)
+
+check the size of mail body.
+throw reason via croak() if the size exceeds the limit.
+
+=cut
+
+
+# Descriptions: check the size of mail header.
+#    Arguments: OBJ($self) OBJ($msg) HASH_REF($args)
+# Side Effects: none
+# Return Value: none
+sub check_header_size
+{
+    my ($self, $msg, $args) = @_;
+    $self->_check_mail_size($msg, "header");
+}
+
+
+# Descriptions: check the size of mail body.
+#    Arguments: OBJ($self) OBJ($msg) HASH_REF($args)
+# Side Effects: none
+# Return Value: none
+sub check_body_size
+{
+    my ($self, $msg, $args) = @_;
+    $self->_check_mail_size($msg, "body");
+}
+
+
+# Descriptions: check the size of mail header and body.
+#    Arguments: OBJ($self) OBJ($msg) STR($type)
+# Side Effects: croak() if matched.
+# Return Value: none
+sub _check_mail_size
+{
+    my ($self, $msg, $type) = @_;
+    my $curproc    = $self->{ _curproc };
+    my $config     = $curproc->config();
+    my $hdr_size   = $msg->whole_message_header_size();
+    my $body_size  = $msg->whole_message_body_size();
+    my $class      = $self->{ _class };
+    my $limit      = $config->{ "${class}_${type}_size_limit" };
+    my $reason     = '';
+    my $errmsg_key = '';
+
+    if ($type eq 'header') {
+	if ($hdr_size > $limit) {
+	    $reason = "header size exceeds the limit: $hdr_size > $limit";
+	    $errmsg_key = 'error.header_size_limit';
+	}
+    }
+    elsif ($type eq 'body') {
+	if ($body_size > $limit) {
+	    $reason = "body size exceeds the limit: $body_size > $limit";
+	    $errmsg_key = 'error.body_size_limit';
+	}
+    }
+
+    $self->error_set($reason) if $reason;
+    croak($reason);
+}
+
+
+=head1 CODING STYLE
+
+See C<http://www.fml.org/software/FNF/> on fml coding style guide.
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2003 Ken'ichi Fukamachi
+
+All rights reserved. This program is free software; you can
+redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 HISTORY
+
+FML::Filter::Size first appeared in fml8 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;
diff --git a/fml/lib/FML/Process/Command.pm b/fml/lib/FML/Process/Command.pm
index a378d2e8..6f9e9385 100644
--- a/fml/lib/FML/Process/Command.pm
+++ b/fml/lib/FML/Process/Command.pm
@@ -3,7 +3,7 @@
 # Copyright (C) 2000,2001,2002,2003 Ken'ichi Fukamachi
 #          All rights reserved.
 #
-# $FML: Command.pm,v 1.84 2003/03/05 15:07:31 fukachan Exp $
+# $FML: Command.pm,v 1.85 2003/03/15 09:03:52 fukachan Exp $
 #
 
 package FML::Process::Command;
@@ -119,11 +119,52 @@ sub verify_request
 
     $curproc->verify_sender_credential();
 
+    unless ($curproc->is_refused()) {
+	$curproc->_check_filter($args);
+    }
+
     $eval = $config->get_hook( 'command_verify_request_end_hook' );
     if ($eval) { eval qq{ $eval; }; LogWarn($@) if $@; }
 }
 
 
+# Descriptions: filter
+#    Arguments: OBJ($curproc) HASH_REF($args)
+# Side Effects: set flag to ignore this process if it should be filtered.
+# Return Value: none
+sub _check_filter
+{
+    my ($curproc, $args) = @_;
+    my $config = $curproc->config();
+
+    eval q{
+	use FML::Filter;
+	my $filter = new FML::Filter;
+	my $r = $filter->command_mail_filter($curproc, $args);
+
+	# filter traps this message.
+	if ($r = $filter->error()) {
+	    if ($config->yes('use_command_mail_filter_reject_notice')) {
+		my $msg_args = {
+		    _arg_reason => $r,
+		};
+
+		Log("(debug) filter: inform rejection");
+		$filter->command_mail_filter_reject_notice($curproc,$msg_args);
+	    }
+	    else {
+		Log("filter: not inform rejection");
+	    }
+
+	    # we should stop this process ASAP.
+	    $curproc->stop_this_process();
+	    Log("rejected by filter due to $r");
+	}
+    };
+    Log($@) if $@;
+}
+
+
 =head2 C<run($args)>
 
 dispatcher to run correspondig C<FML::Command::command> for