lib/Email/Archive/Storage/DBI.pm

   1 package Email::Archive::Storage::DBI;
   2 use Moo;
   3 use Carp;
   4 use DBI;
   5 use File::ShareDir 'module_file';
   6 use File::Slurp 'read_file';
   7 use Email::MIME;
   8 use Email::Abstract;
   9 use SQL::Abstract;
  10 use Scalar::Util qw(looks_like_number);
  11 use autodie;
  12 with q/Email::Archive::Storage/;
  13
  14 has sqla => (
  15   is   => 'ro',
  16   isa  => sub {
  17     ref $_[0] eq 'SQL::Abstract' or die "sqla must be a SQL::Abstract object"
  18   },
  19   lazy => 1,
  20   default => sub { SQL::Abstract->new },
  21   handles => [qw/
  22     select
  23     insert
  24   /],
  25 );
  26
  27 has dbh => (
  28   is   => 'rw',
  29   isa  => sub {
  30     ref $_[0] eq 'DBI::db' or die "dbh must be a DBI handle",
  31   },
  32   handles => [qw/
  33     prepare
  34     do
  35   /],
  36 );
  37
  38 has deployed_schema_version => (
  39   is  => 'rw',
  40   isa => sub {
  41     looks_like_number($_[0]) or die "deployed_schema_version must be integer"
  42   },
  43   default => 0,
  44 );
  45
  46
  47 my $SCHEMA_VERSION = 1;
  48
  49 sub store {
  50   my ($self, $email) = @_;
  51   # passing an E::A to E::A->new is perfectly valid
  52   $email = Email::Abstract->new($email);
  53   my $fields = {
  54     from_addr   => $email->get_header('From'),
  55     to_addr     => $email->get_header('To'),
  56     date        => $email->get_header('Date'),
  57     subject     => $email->get_header('Subject'),
  58     message_id  => $email->get_header('Message-ID'),
  59     body        => $email->get_body,
  60   };
  61   my ($sql, @bind) = $self->insert('messages', $fields);
  62   my $sth = $self->prepare($sql);
  63   $sth->execute(@bind);
  64 }
  65
  66 sub search {
  67   my ($self, $attribs) = shift;
  68   my ($sql, @bind) = $self->select('messages', [qw/message_id from_addr to_addr date subject body/], $attribs);
  69   my $sth = $self->prepare($sql);
  70   $sth->execute(@bind);
  71   my ($message) = $sth->fetchrow_hashref;
  72   return Email::MIME->create(
  73     header => [
  74       From    => $message->{from_addr},
  75       To      => $message->{to_addr},
  76       Subject => $message->{subject},
  77     ],
  78     body => $message->{body},
  79   );
  80 }
  81
  82 sub retrieve {
  83   my ($self, $message_id) = shift;
  84   $self->search({message_id => $message_id});
  85 }
  86
  87 sub _deploy {
  88   my ($self) = @_;
  89   my $schema = module_file('Email::Archive::Storage::DBI', 'latest_schema.txt');
  90   my $sql = read_file($schema);
  91   $self->do($sql);
  92 }
  93
  94 sub _deployed {
  95   my ($self) = @_;
  96   my $schema_version = eval { $self->selectcol_array('SELECT schema_version FROM metadata') };
  97   if(defined $schema_version and $schema_version =~ /^\d+$/) {
  98     $self->deployed_schema_version($schema_version);
  99     return $schema_version =~ /^\d+$/;
 100   }
 101 }
 102
 103 sub storage_connect {
 104   my ($self, $dsn) = @_;
 105   $self->dbh(DBI->connect($dsn));
 106   if(!$self->_deployed) {
 107     $self->_deploy;
 108   }
 109   elsif(!$self->_is_latest_schema) {
 110     croak sprintf "Schema version %d not supported; we support version " .
 111                   "$SCHEMA_VERSION. Please upgrade your schema before "  .
 112                   "continuing.", $self->_deployed_schema_version;
 113   }
 114 }
 115
 116 1;