Merge branch 'master' of git.freeside.biz:/home/git/freeside
[freeside.git] / FS / FS / part_export / sqlmail.pm
1 package FS::part_export::sqlmail;
2
3 use vars qw(@ISA %info);
4 use Tie::IxHash;
5 use Digest::MD5 qw(md5_hex);
6 use FS::Record qw(qsearchs);
7 use FS::part_export;
8 use FS::svc_domain;
9
10 @ISA = qw(FS::part_export);
11
12 tie my %options, 'Tie::IxHash',
13   'datasrc'            => { label => 'DBI data source' },
14   'username'           => { label => 'Database username' },
15   'password'           => { label => 'Database password' },
16   'server_type'        => {
17     label   => 'Server type',
18     type    => 'select',
19     options => [qw(dovecot_plain dovecot_crypt dovecot_digest_md5 courier_plain
20                    courier_crypt)],
21     default => ['dovecot_plain'], },
22   'svc_acct_table'     => { label => 'User Table', default => 'user_acct' },
23   'svc_forward_table'  => { label => 'Forward Table', default => 'forward' },
24   'svc_domain_table'   => { label => 'Domain Table', default => 'domain' },
25   'svc_acct_fields'    => { label => 'svc_acct Export Fields',
26                             default => 'username _password domsvc svcnum' },
27   'svc_forward_fields' => { label => 'svc_forward Export Fields',
28                             default => 'srcsvc dstsvc dst' },
29   'svc_domain_fields'  => { label => 'svc_domain Export Fields',
30                             default => 'domain svcnum catchall' },
31   'resolve_dstsvc'     => { label => q{Resolve svc_forward.dstsvc to an email address and store it in dst. (Doesn't require that you also export dstsvc.)},
32                             type => 'checkbox' },
33 ;
34
35 %info = (
36   'svc'      => [qw( svc_acct svc_domain svc_forward )],
37   'desc'     => 'Real-time export to SQL-backed mail server',
38   'options'  => \%options,
39   'nodomain' => '',
40   'default_svc_class' => 'Email',
41   'notes'    => <<'END'
42 Database schema can be made to work with Courier IMAP, Exim and Dovecot.
43 Others could work but are untested.  (more detailed description from
44 Kristian / fire2wire? )
45 END
46 );
47
48 sub rebless { shift; }
49
50 sub _export_insert {
51   my($self, $svc) = (shift, shift);
52   # this is a svc_something.
53
54   my $svcdb = $svc->cust_svc->part_svc->svcdb;
55   my $export_table = $self->option($svcdb . '_table')
56     or die('Export table not defined for svcdb: ' . $svcdb);
57   my @export_fields = split(/\s+/, $self->option($svcdb . '_fields'));
58   my $svchash = update_values($self, $svc, $svcdb);
59
60   foreach my $key (keys(%$svchash)) {
61     unless (grep { $key eq $_ } @export_fields) {
62       delete $svchash->{$key};
63     }
64   }
65
66   my $error = $self->sqlmail_queue( $svc->svcnum, 'insert',
67     $self->option('server_type'), $export_table,
68     (map { ($_, $svchash->{$_}); } keys(%$svchash)));
69   return $error if $error;
70   '';
71
72 }
73
74 sub _export_replace {
75   my( $self, $new, $old ) = (shift, shift, shift);
76
77   my $svcdb = $new->cust_svc->part_svc->svcdb;
78   my $export_table = $self->option($svcdb . '_table')
79     or die('Export table not defined for svcdb: ' . $svcdb);
80   my @export_fields = split(/\s+/, $self->option($svcdb . '_fields'));
81   my $svchash = update_values($self, $new, $svcdb);
82
83   foreach my $key (keys(%$svchash)) {
84     unless (grep { $key eq $_ } @export_fields) {
85       delete $svchash->{$key};
86     }
87   }
88
89   my $error = $self->sqlmail_queue( $new->svcnum, 'replace',
90     $old->svcnum, $self->option('server_type'), $export_table,
91     (map { ($_, $svchash->{$_}); } keys(%$svchash)));
92   return $error if $error;
93   '';
94
95 }
96
97 sub _export_delete {
98   my( $self, $svc ) = (shift, shift);
99
100   my $svcdb = $svc->cust_svc->part_svc->svcdb;
101   my $table = $self->option($svcdb . '_table')
102     or die('Export table not defined for svcdb: ' . $svcdb);
103
104   $self->sqlmail_queue( $svc->svcnum, 'delete', $table,
105     $svc->svcnum );
106 }
107
108 sub sqlmail_queue {
109   my( $self, $svcnum, $method ) = (shift, shift, shift);
110   my $queue = new FS::queue {
111     'svcnum' => $svcnum,
112     'job'    => "FS::part_export::sqlmail::sqlmail_$method",
113   };
114   $queue->insert(
115     $self->option('datasrc'),
116     $self->option('username'),
117     $self->option('password'),
118     @_,
119   );
120 }
121
122 sub sqlmail_insert { #subroutine, not method
123   my $dbh = sqlmail_connect(shift, shift, shift);
124   my( $server_type, $table ) = (shift, shift);
125
126   my %attrs = @_;
127
128   map { $attrs{$_} = $attrs{$_} ? qq!'$attrs{$_}'! : 'NULL'; } keys(%attrs);
129   my $query = sprintf("INSERT INTO %s (%s) values (%s)",
130                       $table, join(",", keys(%attrs)),
131                       join(',', values(%attrs)));
132
133   $dbh->do($query) or die $dbh->errstr;
134   $dbh->disconnect;
135
136   '';
137 }
138
139 sub sqlmail_delete { #subroutine, not method
140   my $dbh = sqlmail_connect(shift, shift, shift);
141   my( $table, $svcnum ) = @_;
142
143   $dbh->do("DELETE FROM $table WHERE svcnum = $svcnum") or die $dbh->errstr;
144   $dbh->disconnect;
145
146   '';
147 }
148
149 sub sqlmail_replace {
150   my $dbh = sqlmail_connect(shift, shift, shift);
151   my($oldsvcnum, $server_type, $table) = (shift, shift, shift);
152
153   my %attrs = @_;
154   map { $attrs{$_} = $attrs{$_} ? qq!'$attrs{$_}'! : 'NULL'; } keys(%attrs);
155
156   my $query = "SELECT COUNT(*) FROM $table WHERE svcnum = $oldsvcnum";
157   my $result = $dbh->selectrow_arrayref($query) or die $dbh->errstr;
158   
159   if (@$result[0] == 0) {
160     $query = sprintf("INSERT INTO %s (%s) values (%s)",
161                      $table, join(",", keys(%attrs)),
162                      join(',', values(%attrs)));
163     $dbh->do($query) or die $dbh->errstr;
164   } else {
165     $query = sprintf('UPDATE %s SET %s WHERE svcnum = %s',
166                      $table, join(', ', map {"$_ = $attrs{$_}"} keys(%attrs)),
167                      $oldsvcnum);
168     $dbh->do($query) or die $dbh->errstr;
169   }
170
171   $dbh->disconnect;
172
173   '';
174 }
175
176 sub sqlmail_connect {
177   DBI->connect(@_) or die $DBI::errstr;
178 }
179
180 sub update_values {
181
182   # Update records to conform to a particular server_type.
183
184   my ($self, $svc, $svcdb) = (shift,shift,shift);
185   my $svchash = { %{$svc->hashref} } or return ''; # We need a copy.
186
187   if ($svcdb eq 'svc_acct') {
188     if ($self->option('server_type') eq 'courier_crypt') {
189       my $salt = join '', ('.', '/', 0..9,'A'..'Z', 'a'..'z')[rand 64, rand 64];
190       $svchash->{_password} = crypt($svchash->{_password}, $salt);
191
192     } elsif ($self->option('server_type') eq 'dovecot_plain') {
193       $svchash->{_password} = '{PLAIN}' . $svchash->{_password};
194       
195     } elsif ($self->option('server_type') eq 'dovecot_crypt') {
196       my $salt = join '', ('.', '/', 0..9,'A'..'Z', 'a'..'z')[rand 64, rand 64];
197       $svchash->{_password} = '{CRYPT}' . crypt($svchash->{_password}, $salt);
198
199     } elsif ($self->option('server_type') eq 'dovecot_digest_md5') {
200       my $svc_domain = qsearchs('svc_domain', { svcnum => $svc->domsvc });
201       die('Unable to lookup svc_domain with domsvc: ' . $svc->domsvc)
202         unless ($svc_domain);
203
204       my $domain = $svc_domain->domain;
205       my $md5hash = '{DIGEST-MD5}' . md5_hex(join(':', $svchash->{username},
206                                              $domain, $svchash->{_password}));
207       $svchash->{_password} = $md5hash;
208     }
209   } elsif ($svcdb eq 'svc_forward') {
210     if ($self->option('resolve_dstsvc') && $svc->dstsvc_acct) {
211       $svchash->{dst} = $svc->dstsvc_acct->username . '@' .
212                         $svc->dstsvc_acct->svc_domain->domain;
213     }
214   }
215
216   return($svchash);
217
218 }
219
220 1;
221