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