Source of adaddr
#!/usr/bin/perl
########################################################################
# adaddr 1.0 - autodestructing email adresses
########################################################################
#
# This script is to be used in conjunction with the MTA of your choice
# to create email-adresses that are valid for a defined timestamp
# and/or a count of mails delivered to it.
#
# The program knows three modes which are passed when calling it
# from the command-line:
#
# Encode (enc): Creates an adress with the specified parameters.
# Syntax: adaddr enc <valid_seconds> <valid_count> [timestamp]
# where :
# valid_seconds: Seconds after [timestamp] this address
# should be valid. Set this to 0 for
# timely unlimited validity
# valid_count : Number of mails to be delivered to this
# address before it gets invalid. Set to
# 0 for unlimited validity
# timestamp : Adress is valid between timestamp and
# timestamp + valid_seconds. Not before.
# If left out, the current time is taken.
# Value must be a valid UNIX-Timestamp
#
# In encode-Mode, adaddr will create an address in the form
# prefix-<encoded information>@yourdomain.com
# which can be used wherever an email address can be put.
#
# Decode (dec): Decode an adress back to human readable format
# Syntax: adaddr dec <encoded adress>
# where :
# <encoded adress> is an adress in the form above to be
# decoded.
#
# This can be used for debugging purposes in case you suspect
# something to be wrong with an adress.
#
# check (check): Checks wheter an adress is valid
# Syntax: adaddr check <encoded adress>
# where:
# <encoded adress> is an adress in the form that is
# generated by encode-mode.
#
# This mode must be used when integrating in your MTA. It does
# not return any human readable information but fully relies on
# exitcodes as defined below:
#
# 0 : ok
# 1 : Adress failed time-test
# 2 : Address exceeded callcount
# 3 : Syntax-Error in Address
# 4 : Invalid struct version
# 75 : Error while opening DBM-File. Use Error-Code of
# 75 for mailer to notice temporary error.
#
# 3 and 4 mainly indicate that there is something wrong with the
# adress that has been checked. As there are future versions of
# this script, it is likely that there will be more and more
# features to be added into the encoded form. For this, a version
# number is encoded within the adress. Currently just version 1
# exists and everything else will yield exit code 4.
#
# check relies on a dbm-file which is stored somewhere you can
# define with the constant
#
use constant DBMFILE => '/tmp/mc.dat';
#
# here. I recommend against using the /tmp-directory as this
# can get wiped out here and then which would lead to adresses
# being accepted that should not be.
#
# Garbage collection (gc): Remove old coundown-values from dbm-file
# Syntax: adaddr gc
#
# If you use adresses with a calling-count bigger than 0, the address
# will be stored in a DBM-File together with a TTL-Value that gets
# decremented everytime "check" is used on the adress sometime this
# counter reaches 0.
#
# gc will remove adresses from the DMB-file whose counter reached
# 0 but that are too old to be valid too. Use this as a space-safer
# if you use many messages with a call-count-restriction.
#
# Please note that adresses with an unlimited time-validity cannot
# be removed from the dbm-file. If you create millions of adresses
# with just a countdown-validity but unlimited time validity, your
# DBM-file will grow quite big.
#
#
# Author:
# this script has been written by pilif <pilif@sen.ch> (not self
# destructing as I have not yet created a webpage where you can
# easily create new adresses).
#
# Licence:
# this script comes withouth any warranty of any kind (as usual
# with software, but: have you ever thought about this? If you
# buy a toaster that does not work, you can bring it back to the
# store. If you buy software, you are on your own). You may
# modify it or use it even in commercional environments without
# any restrictions as I don't think this is really useful for the
# average non-geek out there.
#
# Bugs:
# there is currently one known bug:
#
# *) this is calculation intensive and should not be used
# in high-volumen environments. Create special domains
# for self destructing adresses and to not run this script
# for non-special ones.
use warnings;
use strict;
use POSIX;
use Class::Date qw(date);
use Digest::MD5 qw(md5_hex);
use Tie::DB_FileLock;
use constant STRUCTVER => 1;
$ARGV[0] = "check" unless $ARGV[0]; # prevent warning
my %funcs = (
"enc" => \&encode,
"dec" => \&decode,
"check" => \&adcheck,
"gc" => \&garbage_connection
);
my($mode) = shift(@ARGV);
if (!$funcs{$mode}){
printf "Command '%s' is invalid. Valid commands are:\n", $mode;
foreach my $key (sort(keys %funcs)){
print "\t$key\n";
}
printf "Enter '$0 <command> help' to get more information\n";
exit 0;
}
$funcs{$mode}();
sub encode(){
my ($valsec, $valcount, $startdate) = @ARGV;
my $i;
my $result = '';
$valsec = 86400 unless $valsec;
$valcount = 1 unless $valcount;
$startdate = time unless $startdate;
printf("Encoding address with [ver=%d, sd=%d, valids=%d, validt=%d]\n",
STRUCTVER,
$startdate,
$valsec,
$valcount);
my($es) = pack("SllS", (STRUCTVER, $startdate, $valsec, $valcount));
foreach $i ($es =~ m/./gs){
$result .= sprintf("%02X",ord($i));
}
print "Encoded address: [prefix]-$result\@yourdomain.com\n";
}
sub decode(){
my $adstr = shift(@ARGV);
my($prefix, $str) = split('-', $adstr);
($str) = split('@', $str); # remove @-sign. $str contains only HEX-part
printf("Decoding: %s\n", $str);
my($v, $start, $valsec, $valcount) = get_values($adstr);
die(sprintf("Cannot decode: Address-Version is %d and required is %d", $v,
STRUCTVER)) if ($v != STRUCTVER);
my($date) = date($start);
printf("Address decoded:\n\tver: %d\n\tsdate: %d (%s)\n\tvalsec: %d\n\tvalcount: %d\n",
$v,
$start,
$date->string,
$valsec,
$valcount
);
}
sub adcheck(){
my($adstr) = shift(@ARGV);
my($v, $start, $valsec, $valcount, $struct) = get_values($adstr);
my $retval;
my %maildb;
exit(4) if ($v != STRUCTVER);
exit(3) if ($start < 0 || $valsec < 0 || $valcount < 0);
if ($valsec == 0){
exit 0 if ($valcount == 0); # pass if no send-count and time ok.
}else{
exit 1 if ( (time() > ($start + $valsec)) || (time() < $start) );
}
# there is a receiption count limit. Now things get complicated
# as I will have to query the database.
my ($dbkey) = md5_hex($adstr).'|'.($start+$valsec); # adstr *is* unique!
tie %maildb, 'Tie::DB_FileLock', DBMFILE, O_CREAT|O_RDWR, 0644 or exit 75;
$maildb{$dbkey} = $valcount unless defined $maildb{$dbkey};
$maildb{$dbkey}-- unless ($maildb{$dbkey} == 0);
if ($maildb{$dbkey} <= 0){
$retval = 2;
}else{
$retval = 0;
}
untie %maildb;
exit $retval;
}
sub garbage_connection(){
my %maildb;
print "Collecting old entries. This is a time-consuming procedure...\n";
tie %maildb, 'Tie::DB_FileLock', DBMFILE, O_CREAT|O_RDWR, 0644 or
die "Cannot open DMB-File\n";
foreach my $d (keys(%maildb)){
my($h, $ts) = split('\|', $d);
if ( time() > $ts){
print("Found old entry with hash: $h\n");
delete($maildb{$d});
}
}
untie %maildb;
}
sub get_values(){
my($adstr) = @_;
my($prefix, $str) = split('-', $adstr);
($str) = split('@', $str); # remove @-sign. $str contains only HEX-part
$str =~ s/([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
return (unpack('SllS', $str), $str);
}
Layout will follow as soon as I have time to create it...