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