Initial commit.

2 files changed, 211 insertions, 0 deletions

diff --git a/lib/SpamCat.pm b/lib/SpamCat.pm
new file mode 100644
index 0000000..5c6db51
--- /dev/null
+++ b/lib/SpamCat.pm
@@ -0,0 +1,166 @@
+package SpamCat;
+
+use Carp;
+use Data::Dumper;
+use DBI;
+use Email::Simple;
+use IO::File;
+
+use strict;
+use warnings;
+
+our $VERSION = '0';
+
+my $log = sub {
+  print STDERR "DEBUG: " . join(', ', @_) . "\n";
+};
+
+sub new {
+  my($class, %conf) = @_;
+
+  my $dbh = DBI->connect("dbi:SQLite:dbname=$conf{dbpath}", '', '');
+  $conf{dbh} = $dbh;
+  bless \%conf, $class;
+}
+
+sub deliver {
+  my ($self) = @_;
+
+  local $/;
+  my $email = Email::Simple->new(<>);
+  my $email_to = $email->header('To');
+  my @to_addrs = $self->parse_to(split /,\s*/, $email_to);
+
+  my $count;
+  foreach my $to_addr (@to_addrs) {
+    foreach my $domain (@{$self->{domains}}) {
+      if ($to_addr =~ /(.*)\@$domain/) {
+	my $sender = $1;
+	my $c = $self->decrement_count($sender);
+	if (!defined $count || $c > $count) {
+	  $count = $c;
+	}
+      }
+    }
+  }
+
+  if (defined $count) {
+    return if $count == 0;
+
+    my $count_str = '[' . $count . '/' . $self->{default_count} . ']';
+    my $new_subject = $email->header('Subject');
+    if ($new_subject) {
+      $new_subject .= ' - ' . $count_str;
+    } else {
+      $new_subject = $count_str;
+    }
+    $email->header_set('Subject' => $new_subject);
+  }
+
+  my $deliverfh = IO::File->new("| " . $self->{deliver}) ||
+    die "Couldn't open pipe to " . $self->{deliver} . ": $!\n";
+  print $deliverfh $email->as_string;
+  $deliverfh->close;
+}
+
+sub parse_to {
+  my ($self, @tovals) = @_;
+
+  map {
+    if ($_ =~ /<(.*)>/) {
+      $1;
+    } else {
+      $_;
+    }
+  } @tovals;
+}
+
+sub get_count {
+  my ($self, $sender) = @_;
+
+  $self->in_transaction(sub { $self->get_count_t($sender) });
+}
+
+sub set_count {
+  my ($self, $sender, $count) = @_;
+
+  $self->in_transaction(sub { $self->set_count_t($sender, $count); });
+}
+
+sub decrement_count {
+  my ($self, $sender) = @_;
+
+  $self->in_transaction(sub { $self->decrement_count_t($sender); });
+}
+
+#
+# The _t functions are meant to be run inside transacitons.
+#
+
+sub get_count_t {
+  my ($self, $sender) = @_;
+
+  my $q = 'SELECT count FROM emails WHERE sender=?';
+  my $sth = $self->{dbh}->prepare($q);
+  $sth->execute($sender);
+  my @row = $sth->fetchrow_array;
+  $sth->finish;
+
+  $row[0];
+}
+
+sub set_count_t {
+  my ($self, $sender, $count) = @_;
+
+  my $q;
+  if (!defined $self->get_count_t($sender)) {
+    # Insert when there's no count.
+    $q = 'INSERT INTO emails (count, sender) VALUES (?, ?)';
+  } else {
+    # Otherwise update the record with the new count.
+    $q = 'UPDATE emails SET count = ? modified = CURRENT_TIMESTAMP WHERE sender = ?'
+  }
+  my $sth = $self->{dbh}->prepare($q);
+  $sth->execute($count, $sender);
+  $sth->finish;
+
+  $count;
+}
+
+sub decrement_count_t {
+  my ($self, $sender) = @_;
+
+  my $q;
+  my $count = $self->get_count_t($sender);
+  if (!defined $count) {
+    $count = $self->{default_count};
+    $q = 'INSERT INTO emails (count, sender) VALUES (?, ?)';
+  } else {
+    $count = $count <= 0 ? '0' : $count - 1;
+    $q = "UPDATE emails SET count = ?, modified = CURRENT_TIMESTAMP WHERE sender = ?";
+  }
+
+  my $sth = $self->{dbh}->prepare($q);
+  $sth->execute($count, $sender);
+  $sth->finish;
+
+  $count;
+}
+
+sub in_transaction {
+  my ($self, $sub) = @_;
+
+  $self->{dbh}->begin_work;
+  my $rc = eval { &$sub($self); };
+  if ($@) {
+    $self->{dbh}->rollback;
+    warn "ERROR: Transaction failed: $@\n";
+    exit 1;
+  } else {
+    $self->{dbh}->commit;
+  }
+
+  $rc;
+}
+
+1;
diff --git a/lib/SpamCat/Conf.pm b/lib/SpamCat/Conf.pm
new file mode 100644
index 0000000..ab6a3ff
--- /dev/null
+++ b/lib/SpamCat/Conf.pm
@@ -0,0 +1,45 @@
+package SpamCat::Conf;
+
+use IO::File;
+
+use strict;
+use warnings;
+
+sub read {
+  my ($filen) = @_;
+  my %rc;
+
+  my $fh = IO::File->new($filen) ||
+    die "Couldn't open $filen for reading: $!\n";
+  while (<$fh>) {
+    my ($key, $val) = parse_line($_);
+    if (defined $key && defined $val) {
+      $rc{$key} = $val;
+    }
+  }
+  $fh->close;
+
+  %rc;
+}
+
+sub parse_line {
+  my ($line) = @_;
+
+  chomp $line;
+  $line =~ s/(.*)#.*/$1/;
+  $line =~ s/\s+$//;
+
+  if ($line =~ /\s*([^\s]*)\s*=\s*(.*)$/) {
+    my $key = lc $1;
+    my $val = $2;
+
+    if ($key eq 'domains') {
+      $val =~ s/,/ /g;
+      my @vals = split /\s+/, $val;
+      $val = \@vals;
+    }
+    return ($key, $val);
+  }
+}
+
+1;