very simple, very stupid proof of concept

This was written in one hacking session at a coffeeshop. It's not the
best code, for sure, but it's a starting point. The files in lib/auto
are there for now so you can do perl -Mlib=lib -MEmail::Archive .... and
also so you can run test_run, which is the only bit of tests this code
has presently.

All that said, the hard part is done: there's no longer a blank slate
for this project in my mind.

diff --git a/lib/Email/Archive.pm b/lib/Email/Archive.pm
new file mode 100644 (file)
index 0000000..83d86d1
--- /dev/null
+++ b/lib/Email/Archive.pm
@@ -0,0 +1,35 @@
+package Email::Archive;
+use Moose;
+use Module::Load;
+
+has storage => (
+  is    => 'rw',
+  does  => 'Email::Archive::Storage',
+  handles     => [qw/
+    store
+    retrieve
+    search
+  /],
+  lazy_build  => 1,
+);
+
+has dsn => (
+  is  => 'ro',
+  isa => 'Str',
+  required => 1,
+);
+
+has storage_class => (
+  is  => 'ro',
+  isa => 'Str',
+  required => 1,
+  default  => 'Email::Archive::Storage::DBI',
+);
+
+sub _build_storage {
+  my ($self) = @_;
+  load $self->storage_class;
+  my $storage = $self->storage_class->new(dsn => $self->dsn);
+}
+
+1;

diff --git a/lib/Email/Archive/Storage.pm b/lib/Email/Archive/Storage.pm
new file mode 100644 (file)
index 0000000..3c9a6ff
--- /dev/null
+++ b/lib/Email/Archive/Storage.pm
@@ -0,0 +1,5 @@
+package Email::Archive::Storage;
+use Moose::Role;
+
+requires qw/store retrieve search/;
+1;

diff --git a/lib/Email/Archive/Storage/DBI.pm b/lib/Email/Archive/Storage/DBI.pm
new file mode 100644 (file)
index 0000000..2017b10
--- /dev/null
+++ b/lib/Email/Archive/Storage/DBI.pm
@@ -0,0 +1,113 @@
+package Email::Archive::Storage::DBI;
+use Moose;
+use DBI;
+use File::ShareDir 'module_file';
+use File::Slurp 'read_file';
+use Email::Simple::Creator;
+use Email::Abstract;
+use SQL::Abstract;
+use autodie;
+with q/Email::Archive::Storage/;
+
+has dsn => (
+  is  => 'ro',
+  isa => 'Str',
+  required => 1,
+);
+
+has sqla => (
+  is   => 'ro',
+  isa  => 'SQL::Abstract',
+  lazy => 1,
+  default => sub { SQL::Abstract->new },
+  handles => [qw/
+    select
+    insert
+  /],
+);
+
+has dbh => (
+  is   => 'rw',
+  isa  => 'DBI::db',
+  handles => [qw/
+    prepare
+    do
+  /],
+);
+
+has deployed_schema_version => (
+  is  => 'rw',
+  isa => 'Int',
+  default => 0,
+);
+
+my $SCHEMA_VERSION = 0;
+
+sub store {
+  my ($self, $email) = @_;
+  # passing an E::A to E::A->new is perfectly valid
+  $email = Email::Abstract->new($email);
+  my $fields = {
+    from_addr   => $email->get_header('From'),
+    to_addr     => $email->get_header('To'),
+    date        => $email->get_header('Date'),
+    subject     => $email->get_header('Subject'),
+    message_id  => $email->get_header('Message-ID'),
+    body        => $email->get_body,
+  };
+  my ($sql, @bind) = $self->insert('messages', $fields);
+  my $sth = $self->prepare($sql);
+  $sth->execute(@bind);
+}
+
+sub search {
+  my ($self, $attribs) = shift;
+  my ($sql, @bind) = $self->select('messages', [qw/message_id from_addr to_addr date subject body/], $attribs);
+  my $sth = $self->prepare($sql);
+  $sth->execute(@bind);
+  my ($message) = $sth->fetchrow_hashref;
+  return Email::Simple->create(
+    header => [
+      From    => $message->{from_addr},
+      To      => $message->{to_addr},
+      Subject => $message->{subject},
+    ],
+    body => $message->{body},
+  );
+}
+
+sub retrieve {
+  my ($self, $message_id) = shift;
+  $self->search({message_id => $message_id});
+}
+
+sub _deploy {
+  my ($self) = @_;
+  my $schema = module_file('Email::Archive::Storage::DBI', 'latest_schema.txt');
+  my $sql = read_file($schema);
+  $self->do($sql);
+}
+
+sub BUILD {
+  my ($self) = @_;
+  $self->dbh(DBI->connect($self->dsn));
+  if(!$self->_deployed) {
+    $self->_deploy;
+  }
+  elsif(!$self->_is_latest_schema) {
+    croak sprintf "Schema version %d not supported; we support version " .
+                  "$SCHEMA_VERSION. Please upgrade your schema before "  .
+                  "continuing.", $self->_deployed_schema_version;
+  }
+}
+
+sub _deployed {
+  my ($self) = @_;
+  my $schema_version = eval { $self->selectcol_array('SELECT schema_version FROM metadata') };
+  if(defined $schema_version and $schema_version =~ /^\d+$/) {
+    $self->deployed_schema_version($schema_version);
+    return $schema_version =~ /^\d+$/;
+  }
+}
+
+1;

diff --git a/lib/auto/Email/Archive/Storage/DBI/insert_sql.txt b/lib/auto/Email/Archive/Storage/DBI/insert_sql.txt
new file mode 100644 (file)
index 0000000..5432eb3
--- /dev/null
+++ b/lib/auto/Email/Archive/Storage/DBI/insert_sql.txt
@@ -0,0 +1,8 @@
+INSERT INTO messages (
+  message_id,
+  from_addr,
+  to_addr,
+  cc,
+  subject,
+  body
+) VALUES (?, ?, ?, ?, ?, ?);

diff --git a/lib/auto/Email/Archive/Storage/DBI/latest_schema.txt b/lib/auto/Email/Archive/Storage/DBI/latest_schema.txt
new file mode 100644 (file)
index 0000000..8e41d3d
--- /dev/null
+++ b/lib/auto/Email/Archive/Storage/DBI/latest_schema.txt
@@ -0,0 +1,13 @@
+CREATE TABLE messages (
+  message_id  VARCHAR(50) PRIMARY KEY,
+  from_addr   VARCHAR(255) NOT NULL DEFAULT '',
+  to_addr     VARCHAR(255) NOT NULL DEFAULT '',
+  cc          VARCHAR(255) NOT NULL DEFAULT '',
+  subject     VARCHAR(255) NOT NULL DEFAULT '',
+  date        VARCHAR(255) NOT NULL DEFAULT '',
+  body        TEXT NOT NULL  DEFAULT ''
+);
+
+CREATE TABLE metadata (
+  schema_version INT PRIMARY KEY DEFAULT 0
+);

diff --git a/test_run b/test_run
new file mode 100644 (file)
index 0000000..0174bf4
--- /dev/null
+++ b/test_run
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Email::Simple;
+use Email::Simple::Creator;
+
+use lib 'lib';
+use Email::Archive;
+
+my $email = Email::Simple->create(
+    header => [
+      From    => 'casey@geeknest.com',
+      To      => 'drain@example.com',
+      Subject => 'Message in a bottle',
+      'Message-ID' => 'helloworld',
+    ],
+    body => 'hello there!'
+);
+
+my $e = Email::Archive->new({dsn => 'dbi:SQLite:dbname=test.db'});
+print "sending @{[$email->as_string]}\n";
+$e->store($email);
+
+my $found = $e->retrieve('helloworld');
+print $found->as_string;