Commit | Line | Data |
8581da38 |
1 | package Email::Archive::Storage::DBI; |
8a5453ad |
2 | use Moo; |
c5f5125c |
3 | use Carp; |
8581da38 |
4 | use DBI; |
5 | use File::ShareDir 'module_file'; |
6 | use File::Slurp 'read_file'; |
5e15a8a0 |
7 | use Email::MIME; |
8581da38 |
8 | use Email::Abstract; |
9 | use SQL::Abstract; |
8a5453ad |
10 | use Scalar::Util qw(looks_like_number); |
8581da38 |
11 | use autodie; |
12 | with q/Email::Archive::Storage/; |
13 | |
8581da38 |
14 | has sqla => ( |
15 | is => 'ro', |
8a5453ad |
16 | isa => sub { |
17 | ref $_[0] eq 'SQL::Abstract' or die "sqla must be a SQL::Abstract object" |
18 | }, |
8581da38 |
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', |
8a5453ad |
29 | isa => sub { |
30 | ref $_[0] eq 'DBI::db' or die "dbh must be a DBI handle", |
31 | }, |
8581da38 |
32 | handles => [qw/ |
33 | prepare |
34 | do |
35 | /], |
36 | ); |
37 | |
38 | has deployed_schema_version => ( |
39 | is => 'rw', |
8a5453ad |
40 | isa => sub { |
41 | looks_like_number($_[0]) or die "deployed_schema_version must be integer" |
42 | }, |
8581da38 |
43 | default => 0, |
44 | ); |
45 | |
c5f5125c |
46 | |
47 | my $SCHEMA_VERSION = 1; |
8581da38 |
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; |
5e15a8a0 |
72 | return Email::MIME->create( |
8581da38 |
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 | |
c5f5125c |
94 | sub _deployed { |
8581da38 |
95 | my ($self) = @_; |
c5f5125c |
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 | |
58854002 |
103 | sub storage_connect { |
c5f5125c |
104 | my ($self, $dsn) = @_; |
105 | $self->dbh(DBI->connect($dsn)); |
8581da38 |
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 | |
8581da38 |
116 | 1; |