File Coverage

blib/lib/Mail/Address/Tagged.pm

Criterion	Covered	Total	%
statement	128	131	97.7
branch	42	68	61.7
condition	11	23	47.8
subroutine	32	32	100.0
pod	23	23	100.0
total	236	277	85.2

package Mail::Address::Tagged;

#------------------------------------------------------------------------------
#
# Copyright  (c) Andrew Wilson 2001
#
#------------------------------------------------------------------------------
#
# Modification History
#
# Auth    Date       AECN        Description
# ------  ---------  ----------  ----------------------------------------------
# andrew  16 Sep 01  1.0.1001    Expanded the documentation
# andrew  12 Sep 01  1.0.1000    Wrote this.
#------------------------------------------------------------------------------

$Mail::Address::Tagged::VERSION = '0.01';

=head1 NAME

Mail::Address::Tagged - construct and validate email addresses with HMAC verification

=head1 SYNOPSIS

 #---------------------------------------------------------------------------
 # methods to use when constructing an address
 #---------------------------------------------------------------------------

 my $tag = Mail::Address::Tagged->new(key   => $key,
                                      email => '[e-mail]');

 my $seconds = $tag->set_valid_for($period);
 my $keyword = $tag->set_keyword('wibble');

 my $tag = Mail::Address::Tagged->new(key       => $key,
                                      user      => 'foo',
                                      host      => 'bar.com',
                                      valid_for => '10d',
                                      keyword   => 'wibble');

 $my $address = $tag->make_confirm(time    => $unix_time,
                                   pid     => $pid,
                                   keyword => $keyword);

 $my $address = $tag->make_confirm({time    => $unix_time,
                                    pid     => $pid,});

 $my $address = $tag->make_dated;
 $my $address = $tag->make_sender($address_to_receive_from);


 #---------------------------------------------------------------------------
 # methods to use when validating an address
 #---------------------------------------------------------------------------

 my $tag = Mail::Address::Tagged->for_received(key      => $key,
                                               received => $address,
                                               sender   => $sender,);

 if ($tag->valid) {
   ...
 }

 my $still_valid = ! $tag->expired;


 #---------------------------------------------------------------------------
 # Methods for accessing the objects internals (these will probably
 # be mainly used internally)
 #---------------------------------------------------------------------------

 my $email   = $tag->key;
 my $address = $tag->email;
 my $user    = $tag->user;
 my $host    = $tag->host;
 my $seconds = $tag->valid_for;
 my $keyword = $tag->keyword
 my $address = $tag->wrap('text_to_wrap');

 my $hmac = $tag->conf_mac(time => $time,
                           pid  => $pid);

 my $hmac = $tag->conf_mac(time    => $time,
                           pid     => $pid,
                           keyword => $value);

 my $hmac = $tag->single_value_mac($date);
 my $hmac = $tag->single_value_mac($sender);


 # only set by for_received

 my $received_time = $tag->candidate_time
 my $received_pid  = $tag->candidate_pid
 my $received_HMAC = $tag->candidate_mac
 my $address_type  = $tag->type
 my $correspondent = $tag->sender

=head1 DESCRIPTION

This module implements an object that can generate and validate tagged
email addresses.  These are designed to be used primarily in anti-spam
applications.

The addresses generated all carry extra information, such as the date
when they expire, who may use them to send you mail etc.  A
cryptocraphic hash of this extra information is also included in in
the address.  This Hashed Message Authenticaion Code (HMAC RFC 2104)
is your guarantee that the information contained in the address has
not been tampered with.

This module can generate and validate three different types of tagged
address.  They are all extensions of a users normal email address and
are constructed in a similar manner.  Where the normal address is
[e-mail], the tagged address takes the form
[e-mail].

The three supported address types are confirm, dated and sender.

Confirm addresses must contain a time (in unixtime) and the process id
of the process that generated them, they may also optionally contain a
keyword.  They include the time and process id so that the system can
deal with more than one message a second.  Addresses of this type are
used to request verification that a message should be delivered.  The
point being that automated mailers are unlikely to be able to respond
in this way so spam will not get through.  If a persistant spammer
does reach your mailbox, then you can always black list the address.
The keyword when it is supplied is the type of confirmation being
asked for.  All three bits of information are combined and a
cryptographic hash is taken of the result, these bits of info are then
combined like this.

  [e-mail]

When mail like this is received, the bits can be separated out and a
new HMAC generated, if it matches the one in the address, then this is
a valid address.

Dated addresses have an expiry time and are used to accept mail up to
a given time.  They end up in the format

  [e-mail]

and are validated in the same manner

The third type of supported address is sender, this takes the form

  [e-mail]

the address that this will be accepted from is included in the HMAC
generation.  When mail of this form comes in the sending address can
be checked against the HMAC if they don't match then appropriate
action can be taken (disposal or confirmation request etc.).

=cut

use strict;
use Digest::HMAC;
use Digest::SHA1;

=head1 FACTORY METHODS

=head2 new

  my $tag = Mail::Address::Tagged->new(key   => $key,
                                       email => '[e-mail]');

  my $tag = Mail::Address::Tagged->new(key       => $key,
                                       user      => 'foo',
                                       host      => 'bar.com',
                                       valid_for => '10d',
                                       keyword   => 'wibble');

Pass this your key and email address it will constrct an object for
making tagged addresses.  The email address may be complete
e.g. [e-mail] or supplied as user and host.

There are also various optional parametes that may be supplied to new.

You may pass the valid_for attribute to control how long dated address
will be active for, if not supplied it defaults to 5 days (see
set_valid_for documentation)

The keyword parameter is used when generating dated addresses.  It is
included in the string and allows for the generation of addresses like
this:

[e-mail]

If not supplied it defaults to the empty string.

=cut

sub new {
  my $class = shift;

  my %arg = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;
  exists $arg{key} or return undef;
  exists $arg{email} or (exists $arg{user} and exists $arg{host}) or return undef;

  my $self = bless {}, $class;
  $self->_init(%arg) or return undef;

  return $self;
}

sub _init {
  my $self = shift;

  %{$self} = (@_);

  if (exists $self->{email}) {
    @{$self}{'user', 'host'} = split "@", $self->{email};
  } else {
    $self->{email} = $self->{user} . '@' . $self->{host};
  }

  $self->{keyword} ||= "";
  $self->set_valid_for($self->{valid_for});
}

=head2 for_received

  my $tag = Mail::Address::Tagged->for_received(key      => $key,
                                                received => $address,
                                                sender   => $sender,);

This constructs an object based on the received address.  It will
break it down into it's component parts, these may then be queried and
checked for validity.

=cut

sub for_received {
  my $class = shift;

  my %arg = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;
  exists $arg{key} and
  exists $arg{address} and
  exists $arg{sender} or return undef;

  my ($user_part, $host)   = split "@", $arg{address};
  my ($user, $type, $data) = split "-", $user_part;

  # if we don't know what type of address this is then there's no
  # point continuing
  defined $type and $type =~ /^(confirm|dated|sender)$/ or return undef;

  # need to have an HMAC
  defined $data or return undef;

  # now set up the object
  my $self = $class->new(key  => $arg{key},
                         user => $user,
                         host => $host,);
  defined $self or return undef;

  $self->_set_type($type);
  $self->_set_sender($arg{sender});

  if ($type eq 'confirm') {

    my ($keyword, $date, $pid, $mac) = split m#\.#, $data;
    $self->set_keyword($keyword);
    $self->_set_candidate_time($date);
    $self->_set_candidate_pid($pid);
    $self->_set_candidate_mac($mac);

  } elsif ($type eq 'dated') {

    my ($date, $mac) = split m#\.#, $data;
    $self->_set_candidate_time($date);
    $self->_set_candidate_mac($mac);

  } else {
    $self->_set_candidate_mac($data);
  }

  return $self;
}

=head1 INSTANCE METHODS - Construction

=head2 set_valid_for

  my $seconds = $tag->set_valid_for($period);

This allows one to set the time period that dated addresses will be
valid for.  Times periods are specified as a string which consists of
a positive integer folowed by a period modifier.  Valid modifiers are:

=over 4

=item Y year

=item M month

=item w week

=item d day

=item h hours

=item s seconds

=back

=cut

my %Conv = ('Y' => 60 * 60 * 24 * 365,
            'M' => 60 * 60 * 24 * 30,
            'w' => 60 * 60 * 24 * 7,
            'd' => 60 * 60 * 24,
            'h' => 60 * 60,
            'm' => 60,
            's' => 1,);

sub set_valid_for {
  my $self = shift;

  my $period  = shift;
  if (defined $period and $period =~  /^(\d+)([YMwdhms])/) {
    my $num = $1;
    my $unit = $2;

    $self->{valid_for} = $Conv{$unit} * $num;
  } else {
    $self->{valid_for} = $Conv{d} * 5;
  }
  return $self->{valid_for};
}

=head2 set_keyword

  my $keyword = $tag->set_keyword('wibble');

Set the keyword of this object.  Returns the new keyword.

=cut

sub set_keyword {
  my $self = shift;

  my $new = shift;
  defined $new or return $self->keyword;
  $self->{keyword} = $new;
}

=head2 make_confirm

  $my $address = $tag->make_confirm(time    => $unix_time,
                                    pid     => $pid,
                                    keyword => $keyword);

  $my $address = $tag->make_confirm({time    => $unix_time,
                                     pid     => $pid,});

Return an address that will be used to confirm an email from an
untrusted source.  You must pass time and processid, you may also
optionally pass a keyword.

=cut

sub make_confirm {
  my $self = shift;

  my %arg = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;

  exists $arg{time} or carp('no time passed to make_confirm');
  exists $arg{pid}  or carp('no pid passed to make_confirm');

  $self->set_keyword($arg{keyword}) if exists $arg{keyword};
  my $keyword = $self->keyword;

  # generate the HMAC
  my $details;
  @{$details}{'time', 'pid'} = @arg{'time', 'pid'};
  my $mac = $self->conf_mac($details);

  return $self->wrap("-confirm-$keyword.$arg{time}.$arg{pid}." . $mac);
}

=head2 make_dated

  $my $address = $tag->make_dated;

Return an address that will be allowed to send us mail for the default
period of time from now.

=cut

sub make_dated {
  my $self = shift;

  my $date = shift;
  defined $date or $date = time();
  $date += $self->valid_for;

  my $mac  = $self->single_value_mac($date);

  return $self->wrap("-dated-". $date . '.' . $mac);
}

=head2 make_sender

  $my $address = $tag->make_sender($address_to_receive_from);

Return an address that will only accept mail if it is sent from one
particular sender address.

=cut

sub make_sender {
  my $self = shift;

  my $sender = lc(shift);
  my $mac    = $self->single_value_mac($sender);

  return $self->wrap("-sender-" . $mac);
}

=head1 INSTANCE METHODS - querying

These methods are only useful on objects constructed with the
for_received method.  They will tell you whether the address is
genuine and whether it has expired (for dated addresses).

=head2 valid

  if ($tag->valid) {
   ...
  }

This will tell you whether the HMAC matches the details of the address.

=cut

sub valid {
  my $self = shift;

  return undef unless $self->type;

  if ($self->type eq "confirm") {

    my $mac = $self->conf_mac({time => $self->candidate_time,
                               pid  => $self->candidate_pid});
    return $mac eq $self->candidate_mac;

  } elsif ($self->type eq "dated") {

    my $mac = $self->single_value_mac($self->candidate_time);
    return $mac eq $self->candidate_mac;

  } elsif ($self->type eq "sender") {

    my $mac = $self->single_value_mac($self->sender);
    return $mac eq $self->candidate_mac;

  }

  return 0;
}

=head2 expired

  my $still_valid = ! $tag->expired;

This will tell you whether dated addresses have expired.

=cut

sub expired {
  my $self = shift;

  return undef unless $self->candidate_time and $self->valid;
  return $self->candidate_time > time();
}

=head1 VALIDATION METHODS (mostly only for internal use)

=head2 conf_mac

  my $hmac = $tag->conf_mac(time => $time,
                            pid  => $pid);

  my $hmac = $tag->conf_mac(time    => $time,
                            pid     => $pid,
                            keyword => $value);

Return the HMAC for the time and pid passed in.  The method may also
take an optional keyword -> value pairing and if provided this will
also be included in the HMAC generation.

=cut

sub conf_mac {
  my $self = shift;

  my %arg = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;
  exists $arg{time} or carp('no time passed to conf_mac');
  exists $arg{pid}  or carp('no pid passed to conf_mac');

  my $digest = Digest::HMAC->new($self->key, "Digest::SHA1");
  $digest->add($arg{time});
  $digest->add($arg{pid});
  $digest->add($self->keyword) if $self->keyword;
  # we only want the first 6 hex digits of the HMAC (there are 40)
  return substr($digest->hexdigest, 0, 6);
}

=head2 single_value_mac

  my $hmac = $tag->single_value_mac($date);

  my $hmac = $tag->single_value_mac($sender);

Return the HMAC for the value passed in.

=cut

sub single_value_mac {
  my $self = shift;

  my $value = shift;
  defined $value or carp('no value passed to single_value_mac');

  my $digest = Digest::HMAC->new($self->key, "Digest::SHA1");
  $digest->add($value);
  # we only want the first 6 hex digits of the HMAC (there are 40)
  return substr($digest->hexdigest, 0, 6);
}


=head2 key

  my $email = $tag->key;

Return the cryptographic key that this address is using.

=head2 email

  my $address = $tag->email;

This returns the unaltered email address that this object is
manipulating.

=head2 user

  my $user = $tag->user;

This returns the user portion of the email address that this object is
manipulating.

=head2 host

  my $host = $tag->host;

This returns the host portion of the email address that this object is
manipulating.

=cut

sub email     { $_[0]->{email} }
sub host      { $_[0]->{host} }
sub key       { $_[0]->{key} };
sub user      { $_[0]->{user} }

=head2 valid_for

  my $seconds = $tag->valid_for;

The number of seconds that a dated email address will be valid for.

=cut

sub valid_for { $_[0]->{valid_for} }

=head2 keyword

  my $keyword = $tag->keyword

If a keyword was supplied to the constructor, this method returns its
value.

=cut

sub keyword { $_[0]->{keyword} }

=head2 wrap

  my $address = $hmac->wrap('text_to_wrap');

When you call this method it constructs an email address of the form

  nametext_to_wrap@host

that is it wraps its argument in the user and host

=cut

sub wrap {
  my $self = shift;

  my $text = shift;
  return $self->user . $text . '@' . $self->host;
}

# these methods will not form part of the public interface of the module
sub _set_candidate_time {
  $_[0]->{candidate_time} = $_[1] if (defined $_[1])
};

sub _set_candidate_pid {
  $_[0]->{candidate_pid} = $_[1] if (defined $_[1])
};

sub _set_candidate_mac {
  $_[0]->{candidate_mac} = $_[1] if (defined $_[1])
};

sub _set_type {
  $_[0]->{type} = $_[1] if (defined $_[1])
};

sub _set_sender {
  $_[0]->{sender} = $_[1] if (defined $_[1])
};

=head2 candidate_time

  my $time = $tag->candidate_time

The time in the address.  This is only valid when an address of type
confirm or dated is being validated.  In all other cases it will
return undef.

=head2 candidate_pid

  my $received_pid = $tag->candidate_pid

the pid in the address.  this is only valid when a confirmation
address is bing validated.  it will return undef at all other times.

=head2 candidate_mac

  my $tag->candidate_mac

The HMAC of the address used to construct this object, this will only
being valid for objects that have been instantiated to validate an
address, it returns undef at all other times.

=head2 type

  $tag->type

The type of mail address used to create this object, it is only valid
when this object is being used for validation, it will return undef at
all other times.

=head2 sender

  $tag->sender

The sender argument passed to for_address when constructing an object
to validate an address.  If the object was not constructed to validate
an addrss it will return undef.

=cut

sub candidate_time { $_[0]->{candidate_time} };
sub candidate_pid  { $_[0]->{candidate_pid}  };
sub candidate_mac  { $_[0]->{candidate_mac}  };
sub type   {  $_[0]->{type}   };
sub sender {  $_[0]->{sender} };

=head1 BUGS

Nothing Known

=head1 TODO

Nothing Known

=cut

1;