enable automatic user removing (prototype)

3 files changed, 274 insertions, 95 deletions

diff --git a/fml/lib/FML/Error.pm b/fml/lib/FML/Error.pm
new file mode 100644
index 00000000..82c4a669
--- /dev/null
+++ b/fml/lib/FML/Error.pm
@@ -0,0 +1,189 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2002 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: @template.pm,v 1.5 2002/01/18 15:37:38 fukachan Exp $
+#
+
+package FML::Error;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+use FML::Log qw(Log LogWarn LogError);
+
+my $debug = 1;
+
+
+=head1 NAME
+
+FML::Error - error manipulation
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 C<new()>
+
+=cut
+
+
+# Descriptions: standard constructor
+#    Arguments: OBJ($self) HASH_REF($curproc)
+# Side Effects: none
+# Return Value: none
+sub new
+{
+    my ($self, $curproc) = @_;
+    my ($type) = ref($self) || $self;
+    my $me     = { _curproc => $curproc };
+    return bless $me, $type;
+}
+
+
+sub analyze
+{
+    my ($self) = @_;
+    my $curproc = $self->{ _curproc };
+
+    use FML::Error::Cache;
+    my $cache = new FML::Error::Cache $curproc;
+    my $rdata = $cache->get_all_values_as_hash_ref();
+    my $list  = $self->md_analyze($curproc, $rdata);
+
+    # pass address list to remove
+    $self->{ _remove_addr_list } = $list;
+}
+
+
+# *** model specific analyzer ***
+# $data = {
+#    address => [ 
+#           error_string_1,
+#           error_string_2, ... 
+#    ]
+# };
+sub md_analyze
+{
+    my ($self, $curproc, $data) = @_;
+    my ($addr, $bufarray, $count);
+    my @removelist = ();
+
+    while (($addr, $bufarray) = each %$data) {
+	$count = 0;
+	if (defined $bufarray) {
+	    for my $buf (@$bufarray) {
+		$count++;
+	    }
+	}
+
+	if ($count > 5) {
+	    push(@removelist, $addr);
+	}
+    }
+
+    return \@removelist;
+}
+
+
+sub remove_bouncers
+{
+    my ($self) = @_;
+    my $list = $self->{ _remove_addr_list };
+
+    for my $addr (@$list) {
+	Log("error.remove $addr");
+    }
+}
+
+
+# Descriptions: delete the specified address
+#    Arguments: OBJ($self) STR($address)
+# Side Effects: none
+# Return Value: none
+sub deluser
+{
+    my ($self, $address) = @_;
+    my $curproc = $self->{ _curproc };
+    my $config  = $curproc->{ config };
+    my $ml_name = $config->{ ml_name };
+
+    use FML::Restriction::Base;
+    my $safe    = new FML::Restriction::Base;
+    my $regexp  = $safe->basic_variable();
+    my $addrreg = $regexp->{ address };
+
+    # check if $address is a safe string.
+    if ($address =~ /^($addrreg)$/) {
+	Log("deluser: ok <$address>");
+    }
+    else {
+	Log("deluser: invalid address");
+	return;
+    }
+
+    # arguments to pass off to each method
+    my $method       = 'unsubscribe';
+    my $command_args = {
+        command_mode => 'admin',
+        comname      => $method,
+        command      => "$method $address",
+        ml_name      => $ml_name,
+        options      => [ $address ],
+        argv         => undef,
+        args         => undef,
+    };
+
+    # here we go
+    require FML::Command;
+    my $obj = new FML::Command;
+
+    if (defined $obj) {
+        # execute command ($comname method) under eval().
+        eval q{
+            $obj->$method($curproc, $command_args);
+        };
+        unless ($@) {
+            ; # not show anything
+        }
+        else {
+            my $r = $@;
+            LogError("command $method fail");
+            LogError($r);
+            if ($r =~ /^(.*)\s+at\s+/) {
+                my $reason = $1;
+                Log($reason); # pick up 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) 2002 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::Error appeared in fml5 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;
diff --git a/fml/lib/FML/Error/Cache.pm b/fml/lib/FML/Error/Cache.pm
index 884ff586..f6b1dc0c 100644
--- a/fml/lib/FML/Error/Cache.pm
+++ b/fml/lib/FML/Error/Cache.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: Error::Cache.pm,v 1.2 2002/08/03 13:13:19 fukachan Exp $
+# $FML: Cache.pm,v 1.1.1.1 2002/08/07 03:51:11 fukachan Exp $
 #
 
 package FML::Error::Cache;
@@ -60,9 +60,11 @@ sub new
 sub add
 {
     my ($self, $info) = @_;
-    my $io = $self->_open_cache();
 
-    if (defined $io) {
+    $self->_open_cache();
+
+    my $db = $self->{ _db };
+    if (defined $db) {
 	my ($address, $reason, $status);
 	my $unixtime = time;
 
@@ -73,7 +75,7 @@ sub add
 	if ($address) {
 	    $status =~ s/\s+/_/g;
 	    $reason =~ s/\s+/_/g;
-	    $io->set($address, "$unixtime status=$status reason=$reason");
+	    $db->{ $address } = "$unixtime status=$status reason=$reason";
 	}
 	else {
 	    LogWarn("Error::Cache: cache_on: invalid data");
@@ -87,25 +89,6 @@ sub add
 }
 
 
-# Descriptions: check cache and determine bounced or not
-#               apply deluser() for addressed looked as bounced
-#    Arguments: OBJ($self) HASH_REF($args)
-# Side Effects: delete addresses
-# Return Value: none
-sub is_bounced
-{
-    my ($self) = @_;
-
-    my $io = $self->_open_cache();
-
-    if (defined $io) {
-	$self->_close_cache();
-    }
-
-    return 0;
-}
-
-
 # Descriptions: open the cache dir for File::CacheDir
 #    Arguments: OBJ($self)
 # Side Effects: none
@@ -120,19 +103,12 @@ sub _open_cache
     my $mode    = $config->{ error_analyzer_cache_mode } || 'temporal';
     my $days    = $config->{ error_analyzer_cache_size } || 14;
 
-    if ($type eq 'File::CacheDir') {
-	if ($dir) {
-	    use File::CacheDir;
-	    my $obj = new File::CacheDir {
-		directory  => $dir,
-		cache_type => $mode,
-		expires_in => $days,
-	    };
-	    return $obj;
-	}
-    }
+    use Tie::JournaledDir;
 
-    return undef;
+    # tie style
+    my %db = ();
+    tie %db, 'Tie::JournaledDir', { dir => $dir };
+    $self->{ _db } = \%db;
 }
 
 
@@ -142,70 +118,52 @@ sub _open_cache
 # Return Value: none
 sub _close_cache
 {
-    ;
+    my ($self) = @_;
+    my $db = $self->{ _db };
+
+    if (defined $db) {
+	untie %$db;
+    }
 }
 
 
-# Descriptions: delete the specified address
-#    Arguments: OBJ($self) STR($address)
-# Side Effects: none
-# Return Value: none
-sub deluser
+sub get_addr_list
+{
+    my ($self) = @_;
+
+    $self->_open_cache();
+    my $db = $self->{ _db };
+
+    my @addr = keys %$db;
+
+    $self->_close_cache();
+
+    return \@addr;
+}
+
+
+sub _new
 {
-    my ($self, $address) = @_;
+    my ($self) = @_;
     my $curproc = $self->{ _curproc };
     my $config  = $curproc->{ config };
-    my $ml_name = $config->{ ml_name };
+    my $type    = $config->{ error_analyzer_cache_type };
+    my $dir     = $config->{ error_analyzer_cache_dir  };
+    my $mode    = $config->{ error_analyzer_cache_mode } || 'temporal';
+    my $days    = $config->{ error_analyzer_cache_size } || 14;
 
-    use FML::Restriction::Base;
-    my $safe    = new FML::Restriction::Base;
-    my $regexp  = $safe->basic_variable();
-    my $addrreg = $regexp->{ address };
+    use Tie::JournaledDir;
+    return new Tie::JournaledDir { dir => $dir };
+}
 
-    # check if $address is a safe string.
-    if ($address =~ /^($addrreg)$/) {
-	Log("deluser: ok <$address>");
-    }
-    else {
-	Log("deluser: invalid address");
-	return;
-    }
 
-    # arguments to pass off to each method
-    my $method       = 'unsubscribe';
-    my $command_args = {
-        command_mode => 'admin',
-        comname      => $method,
-        command      => "$method $address",
-        ml_name      => $ml_name,
-        options      => [ $address ],
-        argv         => undef,
-        args         => undef,
-    };
-
-    # here we go
-    require FML::Command;
-    my $obj = new FML::Command;
-
-    if (defined $obj) {
-        # execute command ($comname method) under eval().
-        eval q{
-            $obj->$method($curproc, $command_args);
-        };
-        unless ($@) {
-            ; # not show anything
-        }
-        else {
-            my $r = $@;
-            LogError("command $method fail");
-            LogError($r);
-            if ($r =~ /^(.*)\s+at\s+/) {
-                my $reason = $1;
-                Log($reason); # pick up reason
-                croak($reason);
-            }
-        }
-    }
+
+sub get_all_values_as_hash_ref
+{
+    my ($self) = @_;
+    my $obj = $self->_new();
+
+    $obj->get_all_values_as_hash_ref();
 }
 
 
diff --git a/fml/lib/FML/Process/Error.pm b/fml/lib/FML/Process/Error.pm
index 70629a3e..29b2eb7e 100644
--- a/fml/lib/FML/Process/Error.pm
+++ b/fml/lib/FML/Process/Error.pm
@@ -3,7 +3,7 @@
 # Copyright (C) 2002 Ken'ichi Fukamachi
 #          All rights reserved.
 #
-# $FML: Error.pm,v 1.14 2002/08/03 10:35:08 fukachan Exp $
+# $FML: Error.pm,v 1.15 2002/08/07 04:00:40 fukachan Exp $
 #
 
 package FML::Process::Error;
@@ -161,11 +161,13 @@ sub run
 		Log("bounced: status=$status");
 		Log("bounced: reason=\"$reason\"");
 
+		$curproc->lock('errorcache');
 		$errorcache->add({
 		    address => $address,
 		    status  => $status,
 		    reason  => $reason,
 		});
+		$curproc->unlock('errorcache');
 
 		$found++;
 	    }
@@ -173,13 +175,45 @@ sub run
     };
     LogError($@) if $@;
 
-    $pcb->set("error", "found", 1) if $found;
+    if ($found) {
+	$pcb->set("error", "found", 1);
+	$curproc->_clean_up_bouncers($args);
+    }
 
     $eval = $config->get_hook( 'error_run_end_hook' );
     if ($eval) { eval qq{ $eval; }; LogWarn($@) if $@; }
 }
 
 
+# run analyzer() if long time spent after the last analyze.
+sub _clean_up_bouncers
+{
+    my ($curproc, $args) = @_;
+    my $channel = 'erroranalyzer';
+
+    if ($curproc->is_timeout($channel)) {
+	Log("(debug) event timeout");
+
+	$curproc->lock('errorcache');
+
+	eval q{
+	    use FML::Error;
+	    my $error = new FML::Error $curproc;
+	    $error->analyze();
+	    $error->remove_bouncers();
+	};
+	LogError($@) if $@;
+
+	$curproc->unlock('errorcache');
+
+	$curproc->set_timeout($channel, time + 3600);
+    }
+    else {
+	Log("(debug) event not timeout");
+    }
+}
+
+
 =head2 help()
 
 show help.
@@ -227,9 +261,7 @@ sub finish
 
     if ($pcb->get("error", "found")) {
 	Log("error message found");
-
-	my $scheduler = $curproc->scheduler();
-
+	# inform ? 
     }
     else {
 	Log("error message not found");