enable confirmation using FML::Confirm module.

FML::Confirm provides basic functions needed for confirmation

2 files changed, 318 insertions, 0 deletions

diff --git a/fml/lib/FML/Command/User/confirm.pm b/fml/lib/FML/Command/User/confirm.pm
new file mode 100644
index 00000000..1aa1468c
--- /dev/null
+++ b/fml/lib/FML/Command/User/confirm.pm
@@ -0,0 +1,123 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2001 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: confirm.pm,v 1.3 2001/10/10 14:50:03 fukachan Exp $
+#
+
+package FML::Command::User::confirm;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+
+use ErrorStatus;
+use FML::Command::Utils;
+use FML::Log qw(Log LogWarn LogError);
+@ISA = qw(FML::Command::Utils ErrorStatus);
+
+
+=head1 NAME
+
+FML::Command::User::confirm - allow action after confirmation
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+See C<FML::Command> for more details.
+
+=head1 METHODS
+
+=head2 C<process($curproc, $optargs)>
+
+=cut
+
+
+sub process
+{
+    my ($self, $curproc, $optargs) = @_;
+    my $config        = $curproc->{ config };
+    my $member_map    = $config->{ primary_member_map };
+    my $recipient_map = $config->{ primary_recipient_map };
+    my $cache_dir     = $config->{ db_dir };
+    my $keyword       = $config->{ confirm_keyword };
+    my $expire_limit  = $config->{ confirm_expire_limit } || 14*24*3600;
+    my $command       = $optargs->{ command };
+
+    my ($class, $id);
+
+    # get class and id from buffer, for example,  
+    # "confirm subscribe 813f42fa2aa84bbba500ed3d2781dea6"
+    if ($command =~ /$keyword\s+(\w+)\s+([\w\d]+)/) {
+	($class, $id) = ($1, $2);
+    }
+
+    use FML::Confirm;
+    my $confirm = new FML::Confirm {
+	keyword   => $keyword,
+	cache_dir => $cache_dir,
+	class     => $class,
+	buffer    => $command,
+    };
+
+    my $found = '';
+    if ($found = $confirm->find($id)) { # if request is found
+	unless ($confirm->is_expired($found, $expire_limit)) {
+	    my $address = $confirm->get_address($id);
+	    $self->_switch_command($class, $address, $curproc, $optargs);
+	}
+	else { # if req is expired
+	    croak("request is expired");
+	}
+    }
+    else {
+	croak("no such confirmation request");
+    }
+}
+
+
+sub _switch_command
+{
+    my ($self, $class, $address, $curproc, $optargs) = @_;
+
+    # lower case 
+    $class =~ tr/A-Z/a-z/;
+
+    use FML::Command;
+    my $obj = new FML::Command;
+
+    if ($class eq 'subscribe'   || 
+	$class eq 'unsubscribe' || 
+	$class eq 'chaddr') {
+	$optargs->{ address }      = $address;
+	$optargs->{ command_mode } = 'Admin';
+	$obj->$class($curproc, $optargs);
+    }
+    else {
+	croak("no such rule");
+    }
+}
+
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2001 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::Command::User::confirm appeared in fml5 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;
diff --git a/fml/lib/FML/Confirm.pm b/fml/lib/FML/Confirm.pm
new file mode 100644
index 00000000..ac8653c9
--- /dev/null
+++ b/fml/lib/FML/Confirm.pm
@@ -0,0 +1,195 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2001 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.1 2001/08/07 12:23:48 fukachan Exp $
+#
+
+package FML::Confirm;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+
+=head1 NAME
+
+FML::Confirm - assign id for e.g. confirmation 
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 C<new($args)>
+
+usual constructor.
+
+    $args = {
+	cache_dir => "/some/where",
+	class     => "subscribe",
+	address   => "mail@address",
+	buffer    => $buffer,
+    };
+
+=cut
+
+sub new
+{
+    my ($self, $args) = @_;
+    my ($type) = ref($self) || $self;
+    my $me     = {};
+
+    for my $id ('keyword', 'class', 'address', 'buffer', 'cache_dir') {
+	if (defined $args->{ $id }) {
+	    $me->{ "_$id" } = $args->{ $id };
+	}
+    }
+
+    return bless $me, $type;
+}
+
+
+sub assign_id
+{
+    my ($self) = @_;
+    my $class   = $self->{ _class };
+    my $addr    = $self->{ _address };
+    my $buffer  = $self->{ _buffer };
+    my $keyword = $self->{ _keyword };
+    my $time    = time;
+    my $pid     = $$;
+    my $string  = "$time $pid $addr $buffer";
+
+    use FML::Checksum;
+    my $cksum  = new FML::Checksum;
+    my $md5sum = $cksum->md5( \$string );
+
+    # o.k. assign id
+    my $id = "$keyword $class $md5sum";
+    $self->store_id( $md5sum );
+
+    return $id;
+}
+
+
+sub _open_db
+{
+    my ($self, $id, $comment) = @_;
+    my (%db) = ();
+
+    use File::Spec;
+    my $cache_dir = $self->{ _cache_dir };
+    my $class     = $self->{ _class };
+    my $dir       = File::Spec->catfile($cache_dir, $class);
+
+    unless (-d $dir) {
+	use File::Utils qw(mkdirhier);
+	mkdirhier($dir, 0700);
+    }
+
+    use Tie::JournaledDir;
+    tie %db, 'Tie::JournaledDir', { dir => $dir };
+
+    $self->{ _db } = \%db;
+
+    return \%db;
+}
+
+
+sub _close_db
+{
+    my ($self) = @_;
+    my $db = $self->{ _db };
+    untie %$db;
+}
+
+
+sub store_id
+{    
+    my ($self, $id, $comment) = @_;
+    my $class = $self->{ _class };
+    my $addr  = $self->{ _address };
+    my $db    = $self->_open_db();
+
+    $db->{ $id } = time .(defined $comment ? " $comment" : '');
+    $db->{ "request-$id" } = "$class $addr";
+    $db->{ "address-$id" } = $addr;
+
+    $self->_close_db();
+}
+
+
+sub find
+{
+    my ($self, $id) = @_;    
+    my $db = $self->_open_db();
+
+    my $found = $db->{ $id };
+    $self->_close_db();
+
+    $self->{ _found } = $found;
+
+    return $found;
+}
+
+
+sub get_request
+{
+    my ($self, $id) = @_;    
+    my $db = $self->_open_db();
+
+    my $found = $db->{ "request-$id" } || undef;
+    $self->_close_db();
+
+    return $found;
+}
+
+
+sub get_address
+{
+    my ($self, $id) = @_;    
+    my $db = $self->_open_db();
+
+    my $found = $db->{ "address-$id" } || undef;
+    $self->_close_db();
+
+    return $found;
+}
+
+
+sub is_expired
+{
+    my ($self, $found, $howold) = @_;
+    my ($time, $commont) = split(/\s+/, $found);
+
+    if ((time - $time) > $howold) {
+	return 1; # expired
+    }
+    else {
+	return 0;
+    }
+}
+
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2001 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::Confirm appeared in fml5 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;