rearrange isolated mails to under $isolated_queue_dir/YYYY/MM/DD dir.

3 files changed, 237 insertions, 3 deletions

diff --git a/fml/lib/FML/Isolate.pm b/fml/lib/FML/Isolate.pm
new file mode 100644
index 00000000..57f4c738
--- /dev/null
+++ b/fml/lib/FML/Isolate.pm
@@ -0,0 +1,211 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2008 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$
+#
+
+package FML::Isolate;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD $count_ok);
+use Carp;
+
+=head1 NAME
+
+FML::Isolate - manipulate isolated invalid(spam) mails.
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 new()
+
+constructor.
+
+=cut
+
+
+# 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 };
+    return bless $me, $type;
+}
+
+
+=head2 rearrange()
+
+rearrange isolated mails to a date based sub directory under
+$isolated_queue_dir.
+
+=cut
+
+
+# Descriptions: rearrange isolated mails to a date based sub directory
+#               under $isolated_queue_dir.
+#    Arguments: OBJ($self)
+# Side Effects:
+# Return Value: none
+sub rearrange
+{
+    my ($self)    = @_;
+    my ($curproc) = $self->{ _curproc };
+    my ($config)  = $curproc->config();
+    my $queue_dir = $config->{ mail_queue_dir };
+
+    # 1. open the isolated queue.
+    use Mail::Delivery::Queue;
+    my $queue = new Mail::Delivery::Queue {
+	directory => $queue_dir,
+    };
+
+    # 2. list up isolated queue messages.
+    my $q_class = "isolated";
+    my $src_dir = $queue->local_dir_path($q_class);
+    my $qlist   = $queue->list($q_class);
+    for my $qid (@$qlist) {
+	my $mtime   = $queue->last_modified_time($qid);
+	my $dst_dir = $self->_rearranged_dir_name($mtime);
+	my $dst_key = $self->_rearranged_dir_key($mtime);
+	$self->_move_queue_file($qid, $src_dir, $dst_dir, $dst_key);
+    }
+
+    # 3. log.
+    for my $name (keys %$count_ok) {
+	my $c = $count_ok->{ $name };
+	$curproc->logdebug("isolate: $c messages moved to $name");
+    }
+}
+
+
+# Descriptions: return ARRAY_REF(YEAR, MON, DAY) on mtime.
+#    Arguments: OBJ($self) NUM($mtime)
+# Side Effects: none
+# Return Value: ARRAY_REF
+sub _get_mtime_info
+{
+    my ($self, $mtime) = @_;
+
+    # get YYYY/MM/DD information from $mtime.
+    my ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
+    my $r_year = sprintf("%04d", 1900 + $year);
+    my $r_mon  = sprintf("%02d", $mon + 1);
+    my $r_day  = sprintf("%02d", $mday);
+
+    # determine the directory path "$isolated_queue_dir/YYYY/MM/DD".
+    my (@data) = ($r_year, $r_mon, $r_day);
+    return \@data;
+}
+
+
+# Descriptions: return full-path dir name based on mtime.
+#    Arguments: OBJ($self) NUM($mtime)
+# Side Effects: none
+# Return Value: STR
+sub _rearranged_dir_name
+{
+    my ($self, $mtime) = @_;
+    my ($curproc) = $self->{ _curproc };
+    my ($config)  = $curproc->config();
+    my $queue_dir = $config->{ isolated_queue_dir };
+
+    my ($mdata) = $self->_get_mtime_info($mtime);
+    my ($year, $mon, $day) = @$mdata;
+
+    # determine the directory path "$isolated_queue_dir/YYYY/MM/DD".
+    use File::Spec;
+    my $dir = File::Spec->catfile($queue_dir, $year, $mon, $day);
+    return $dir;
+}
+
+
+# Descriptions: return YYYY/MM/DD based on mtime.
+#    Arguments: OBJ($self) NUM($mtime)
+# Side Effects: none
+# Return Value: STR
+sub _rearranged_dir_key
+{
+    my ($self, $mtime) = @_;
+
+    my ($mdata) = $self->_get_mtime_info($mtime);
+    my ($year, $mon, $day) = @$mdata;
+    return sprintf("%04d/%02d/%02d", $year, $mon, $day);
+}
+
+
+# Descriptions: $qid is moved from $src_dir to $dst_dir.
+#    Arguments: OBJ($self) NUM($mtime)
+# Side Effects: $dst_dir created if not exists.
+#               $qid is moved from $src_dir to $dst_dir.
+# Return Value: none
+sub _move_queue_file
+{
+    my ($self, $qid, $src_dir, $dst_dir, $dst_key) = @_;
+    my ($curproc) = $self->{ _curproc };
+
+    unless (-d $dst_dir) {
+	$curproc->mkdir($dst_dir);
+    }
+
+    use File::Spec;
+    my $src_q = File::Spec->catfile($src_dir, $qid);
+    my $dst_q = File::Spec->catfile($dst_dir, $qid);
+
+    # ASSERT
+    unless (-f $src_q) {
+	$curproc->logerror("isolate: no such queue: $qid");
+	return undef;	
+    }
+    if (-f $dst_q) {
+	$curproc->logerror("isolate: already exists: $qid");
+	return undef;	
+    }
+
+    # ok. go move !
+    if (-f $src_q && (! -f $dst_q)) {
+	if (rename($src_q, $dst_q)) {
+	    $count_ok->{ $dst_key }++;
+	}
+	else {
+	    $curproc->logerror("isolate: cannot move queue: $qid");
+	}
+    }
+    else {
+	$curproc->logerror("isolate: invalid condition: $qid");
+    }
+}
+
+
+=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) 2008 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::Isolate 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/Flow.pm b/fml/lib/FML/Process/Flow.pm
index ad3df087..15b2acef 100644
--- a/fml/lib/FML/Process/Flow.pm
+++ b/fml/lib/FML/Process/Flow.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: Flow.pm,v 1.32 2006/04/22 13:06:19 fukachan Exp $
+# $FML: Flow.pm,v 1.33 2006/04/28 14:02:05 fukachan Exp $
 #
 
 package FML::Process::Flow;
@@ -107,8 +107,9 @@ sub ProcessStart
     # log file rotation et.al.
     $process->log_file_cleanup();
 
-    # clean up temporary files
+    # clean up temporary files.
     $process->tmp_file_cleanup();
+    $process->isolated_message_cleanup_queue();
     $process->incoming_message_cleanup_queue();
 
     # debug
diff --git a/fml/lib/FML/Process/Kernel.pm b/fml/lib/FML/Process/Kernel.pm
index caefca3b..eb53a7de 100644
--- a/fml/lib/FML/Process/Kernel.pm
+++ b/fml/lib/FML/Process/Kernel.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: Kernel.pm,v 1.284 2006/05/13 11:45:40 fukachan Exp $
+# $FML: Kernel.pm,v 1.285 2006/07/09 12:11:13 fukachan Exp $
 #
 
 package FML::Process::Kernel;
@@ -3125,6 +3125,28 @@ sub _delete_too_old_files_in_dir
 }
 
 
+# Descriptions: manipulate isolated messages.
+#    Arguments: OBJ($curproc)
+# Side Effects: remove incoming queue.
+# Return Value: none
+sub isolated_message_cleanup_queue
+{
+    my ($curproc) = @_;
+    my $config    = $curproc->config();
+    my $channel   = 'mail_isolated_queue_cleanup';
+
+    # XXX ONLY WHEN VALID $ml_home_dir EXISTS.
+    if ($curproc->_is_valid_ml_home_dir()) {
+	if ($curproc->is_event_timeout($channel)) {
+	    use FML::Isolate;
+	    my $isolate = new FML::Isolate $curproc;
+	    $isolate->rearrange();
+	    $curproc->event_set_timeout($channel, time + 3600);
+	}
+    }
+}
+
+
 # Descriptions: add some information into header.
 #    Arguments: OBJ($config) OBJ($msg)
 # Side Effects: none