1#!/usr/bin/perl -w
2#  Copyright (c) 2017 Fastmail.  All rights reserved.
3#
4# Author: Bron Gondwana <brong@fastmail.fm>
5#
6# Redistribution and use in source and binary forms, with or without
7# modification, are permitted provided that the following conditions
8# are met:
9#
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12#
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in
15#    the documentation and/or other materials provided with the
16#    distribution.
17#
18# 3. The name "Carnegie Mellon University" must not be used to
19#    endorse or promote products derived from this software without
20#    prior written permission. For permission or any other legal
21#    details, please contact
22#      Office of Technology Transfer
23#      Carnegie Mellon University
24#      5000 Forbes Avenue
25#      Pittsburgh, PA  15213-3890
26#      (412) 268-4387, fax: (412) 268-7395
27#      tech-transfer@andrew.cmu.edu
28#
29# 4. Redistributions of any form whatsoever must retain the following
30#    acknowledgment:
31#    "This product includes software developed by Computing Services
32#     at Carnegie Mellon University (http://www.cmu.edu/computing/)."
33#
34# CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO
35# THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
36# AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE
37# FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
38# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
39# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
40# OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
41
42
43package Cyrus::ImapClone;
44
45use strict;
46use warnings;
47use Date::Parse;
48use Cyrus::SyncProto;
49use Mail::IMAPTalk;
50use Data::Dumper;
51use Digest::SHA qw(sha1_hex);
52use Tie::DataUUID qw($uuid);
53use IO::Socket::SSL;
54use JSON::XS;
55use IO::File;
56
57=pod
58=head1 NAME
59
60Cyrus::ImapClone  - A pure perl interface to clone Cyrus Mailbox.
61
62=head1 EXAMPLES
63
64=cut
65=head1 PUBLIC API
66=over
67=item Cyrus::ImapClone->new()
68=cut
69
70sub new {
71  my $class = shift;
72  my %args = @_;
73
74  my $syncssl = $args{syncssl};
75  my $st = Mail::IMAPTalk->new(
76    Server => $args{synchost},
77    Port => $args{syncport},
78    Username => $args{syncuser},
79    Password => $args{syncpass},
80    AuthzUser => $args{syncauthz},
81    UseSSL => $syncssl,
82    UseBlocking => $syncssl,
83    UseCompress => 1,
84  );
85  die "Failed to setup sync talk" unless $st;
86  my $sp = Cyrus::SyncProto->new($st);
87  if ($args{syncwipe}) {
88    $sp->dlwrite('APPLY', 'UNUSER', $args{synctarget});
89    $st->logout();
90    return;
91  }
92  my $userdata = $sp->dlwrite('GET', 'USER', $args{synctarget});
93
94  my $usessl = $args{imapssl};
95  my $it = Mail::IMAPTalk->new(
96    Server => $args{imaphost},
97    Port => $args{imapport},
98    Username => $args{imapuser},
99    Password => $args{imappass},
100    AuthzUser => $args{imapauthz},
101    SSL_verify_mode => SSL_VERIFY_NONE,
102    UseSSL => $usessl,
103    UseBlocking => $usessl,
104    UseCompress => 1,
105  );
106
107  return bless {
108    syncer => $sp,
109    synctalk => $st,
110    imaptalk => $it,
111    userdata => $userdata,
112    targetuser => $args{synctarget},
113  }, ref($class) || $class;
114}
115
116sub done {
117  my $Self = shift;
118  eval { $Self->{imaptalk}->logout() };
119  eval { $Self->{synctalk}->logout() };
120}
121
122sub DESTROY {
123  my $Self = shift;
124  $Self->done();
125}
126
127sub batchfillrecords {
128  my $Self = shift;
129  my $mboxname = shift;
130  my $records = shift;
131
132  my %todo = %$records;
133  my $total = scalar keys %todo;
134
135  # batch in units of max 10 megabytes plus 1 message
136  while (%todo) {
137    my $size = 0;
138    my %batch;
139    foreach my $uid (sort {$a <=> $b} keys %todo) {
140      $batch{$uid} = delete $todo{$uid};
141      $size += $batch{$uid}{SIZE};
142      last if $size > 1024 * 1024 * 10; # 10 megabytes
143    }
144    $Self->fillrecords($mboxname, \%batch);
145    last unless %todo;
146    print "Batching - still " . scalar(keys %todo) . "/$total to go for $mboxname\n" if $Self->{verbose};
147  }
148}
149
150sub fillrecords {
151  my $Self = shift;
152  my $mboxname = shift;
153  my $records = shift;
154
155  # XXX - smaller batch to control memory usage?
156
157  my $imap = $Self->{imaptalk};
158  my $fetch = $imap->fetch([sort {$a <=> $b} keys %$records], '(rfc822)');
159  my @apply;
160  foreach my $uid (sort {$a <=> $b} keys %$records) {
161    die "MISSING $uid" unless $fetch->{$uid};
162    die "SIZE MISSMATCH $uid" unless $records->{$uid}{SIZE} == length($fetch->{$uid}{rfc822});
163    $records->{$uid}{GUID} = sha1_hex($fetch->{$uid}{rfc822});
164  }
165
166  # let's try to reserve first
167  my @names = map { $_->{MBOXNAME} } @{$Self->{userdata}{MAILBOX}};
168  my %guids = map { $_->{GUID} => 1 } values %$records;
169  my $res = $Self->{syncer}->dlwrite('APPLY', 'RESERVE', {PARTITION => 'default', MBOXNAME => \@names, GUID => [sort keys %guids]});
170  my %missing = map { $_ => 1 } @{$res->{MISSING}[0]};
171
172  return unless %missing;
173
174  foreach my $uid (sort {$a <=> $b} keys %$records) {
175    next unless $missing{$records->{$uid}{GUID}};
176    push @apply, \['default', $records->{$uid}{GUID}, $records->{$uid}{SIZE}, $fetch->{$uid}{rfc822}];
177  }
178
179  return unless @apply;
180
181  $Self->{syncer}->dlwrite('APPLY', 'MESSAGE', \@apply);
182}
183
184sub syncmailbox {
185  my $Self = shift;
186  my $mboxname = shift;
187  my $existing = shift;
188
189  if ($existing) {
190    my $status = $Self->{imaptalk}->status($Self->_sync_to_imap($mboxname), "(HIGHESTMODSEQ UIDVALIDITY)");
191    die "UIDVALIDITY CHANGED" if ($existing->{UIDVALIDITY} != $status->{uidvalidity});
192    return if ($existing->{HIGHESTMODSEQ} == $status->{highestmodseq});
193  }
194
195  $Self->{imaptalk}->examine($Self->_sync_to_imap($mboxname));
196  my $imap = $Self->{imaptalk};
197  my %idata = (
198    UIDVALIDITY => $imap->get_response_code('uidvalidity') + 0,
199    LAST_UID => $imap->get_response_code('uidnext') - 1,
200    HIGHESTMODSEQ => $imap->get_response_code('highestmodseq') || 1,
201    EXISTS => $imap->get_response_code('exists') || 0,
202  );
203
204  # basic sanity checks
205  die "UIDVALIDITY CHANGED" if ($existing and $existing->{UIDVALIDITY} != $idata{UIDVALIDITY});
206  return if ($existing and $existing->{HIGHESTMODSEQ} == $idata{HIGHESTMODSEQ});
207
208  my $sdata = $Self->readup($mboxname, $existing);
209
210  # basic sanity checks again with latest data
211  die "UIDVALIDITY CHANGED " . Dumper($sdata) if ($sdata and $sdata->{UIDVALIDITY} != $idata{UIDVALIDITY});
212  return if ($existing and $existing->{HIGHESTMODSEQ} == $idata{HIGHESTMODSEQ});
213
214  # sanity range checks
215  die "FUTURE CHANGED MODSEQ $sdata->{HIGHESTMODSEQ} > $idata{HIGHESTMODSEQ}" if ($sdata and $sdata->{HIGHESTMODSEQ} > $idata{HIGHESTMODSEQ});
216  die "FUTURE CHANGED UIDS $sdata->{LAST_UID} > $idata{LAST_UID}" if ($sdata and $sdata->{LAST_UID} > $idata{LAST_UID});
217
218  my $time = time();
219
220  unless ($sdata) {
221    print "NEW MAILBOX $mboxname: $idata{EXISTS}\n" if $Self->{verbose};
222
223    my %mb = (
224      ACL => Cyrus::SyncProto::user_acl($Self->{targetuser}),
225      HIGHESTMODSEQ => 0,
226      LAST_APPENDDATE => 0,
227      LAST_UID => 0,
228      MBOXNAME => $mboxname,
229      OPTIONS => 'P',
230      PARTITION => 'default',
231      POP3_LAST_LOGIN => 0,
232      POP3_SHOW_AFTER => 0,
233      QUOTAROOT => $Self->_imap_to_sync('INBOX'),
234      RECENTTIME => 0,
235      RECENTUID => 0,
236      RECORD => [],
237      SYNC_CRC => 0,
238      SYNC_ANNOT_CRC => 0,
239      UIDVALIDITY => $idata{UIDVALIDITY},
240      UNIQUEID => $uuid,
241    );
242
243    push @{$Self->{userdata}{MAILBOX}}, \%mb;
244
245    $sdata = { %mb, RECORD => [] };
246  }
247
248  my $recentuid = $idata{LAST_UID};
249  my @applyrecords;
250
251  # clever logic here..
252  if ($sdata->{LAST_UID}) {
253    # re-fetch flags only
254    my $end = $sdata->{LAST_UID};
255    my $fetch = $imap->fetch("1:$end", "(uid flags modseq)", "(changedsince $sdata->{HIGHESTMODSEQ})");
256    foreach my $record (grep { _notexpunged($_) } @{$sdata->{RECORD}}) {
257      my $uid = $record->{UID};
258      next unless $fetch->{$uid};
259      my @flags = @{$fetch->{$uid}{flags}};
260      if (grep { lc $_ eq '\\recent' } @flags) {
261        $recentuid = $uid if $recentuid > $uid;
262      }
263
264      # update the record and the CRC
265      $sdata->{SYNC_CRC} ^= $Self->{syncer}->record_crc($record);
266      $record->{FLAGS} = _cleanflags(@flags);
267      $record->{MODSEQ} = $fetch->{$uid}{modseq}[0];
268      $record->{LAST_UPDATED} = $time;
269      $sdata->{SYNC_CRC} ^= $Self->{syncer}->record_crc($record);
270      push @applyrecords, $record;
271    }
272  }
273
274  my $first = $sdata->{LAST_UID} + 1;
275  my $last = $idata{LAST_UID};
276  if ($last >= $first) {
277    my $fetch = $imap->fetch("$first:$last", "(uid flags modseq internaldate rfc822.size)");
278    my %records;
279    foreach my $uid (sort {$a <=> $b} keys %$fetch) {
280      my @flags = @{$fetch->{$uid}{flags}};
281      if (grep { lc $_ eq '\\recent' } @flags) {
282        $recentuid = $uid if $recentuid > $uid;
283      }
284
285      $records{$uid} = {
286        # ANNOTATIONS => [],
287        FLAGS => _cleanflags(@flags),
288        # GUID to be filled
289        INTERNALDATE => _mkunixtime($fetch->{$uid}{internaldate}),
290        LAST_UPDATED => $time,
291        MODSEQ => $fetch->{$uid}{modseq}[0],
292        SIZE => $fetch->{$uid}{'rfc822.size'},
293        UID => $uid,
294      };
295    }
296    $Self->batchfillrecords($mboxname, \%records);
297    foreach my $uid (sort {$a <=> $b} keys %records) {
298      push @applyrecords, $records{$uid};
299      push @{$sdata->{RECORD}}, $records{$uid};
300      $sdata->{SYNC_CRC} ^= $Self->{syncer}->record_crc($records{$uid});
301    }
302  }
303
304  if ($idata{EXISTS} != scalar(grep { _notexpunged($_) } @{$sdata->{RECORD}})) {
305    # we need to expunge something - let's see what..
306    print "DOING EXPUNGE CHECK FOR $mboxname\n" if $Self->{verbose};
307    my $uids = $imap->search('uid', "1:$last");
308    my %exists = map { $_ => 1 } @$uids;
309    foreach my $record (grep { _notexpunged($_) } @{$sdata->{RECORD}}) {
310      next if $exists{$record->{UID}};
311      # update the record and the CRC
312      $sdata->{SYNC_CRC} ^= $Self->{syncer}->record_crc($record);
313      push @{$record->{FLAGS}}, "\\Expunged";
314      $record->{MODSEQ} = $idata{HIGHESTMODSEQ};
315      $record->{LAST_UPDATED} = $time;
316      push @applyrecords, $record;
317    }
318  }
319
320  $sdata->{HIGHESTMODSEQ} = $idata{HIGHESTMODSEQ};
321  $sdata->{LAST_UID} = $idata{LAST_UID};
322  $sdata->{RECENTTIME} = $time;
323  $sdata->{RECENTUID} = $recentuid;
324
325  $Self->{syncer}->dlwrite('APPLY', 'MAILBOX', {%$sdata, RECORD => [sort { $a->{UID} <=> $b->{UID} } @applyrecords]});
326
327  $Self->writedown($sdata);
328}
329
330sub readup {
331  my $Self = shift;
332  my $mboxname = shift;
333  my $existing = shift;
334
335  if ($existing and $Self->{cachedir} and $Self->cachepath($existing->{UNIQUEID})) {
336    my $file = IO::File->new($Self->cachepath($existing->{UNIQUEID}), "r");
337    my $data = eval { $file->getline() };
338    my $perl = eval { decode_json($data) };
339    if ($perl and $perl->{UNIQUEID} eq $existing->{UNIQUEID} and $perl->{HIGHESTMODSEQ} eq $existing->{HIGHESTMODSEQ} and $perl->{UIDVALIDITY} eq $existing->{UIDVALIDITY} and $perl->{LAST_UID} eq $existing->{LAST_UID}) {
340      print "READING $mboxname FROM CACHE\n" if $Self->{verbose};
341      return $perl;
342    }
343    else {
344      use Data::Dumper;
345      my %check =  map { $_ => $perl->{$_} } qw(UNIQUEID HIGHESTMODSEQ UIDVALIDITY LAST_UID);
346      print "INVALID $mboxname CACHE: " . Dumper(\%check, $existing) if $Self->{verbose};
347    }
348  }
349
350  my $res = eval { $Self->{syncer}->dlwrite('GET', 'FULLMAILBOX', $mboxname)->{MAILBOX}[0] };
351
352  $Self->writedown($res) if $res;
353
354  return $res;
355}
356
357sub writedown {
358  my $Self = shift;
359  my $data = shift;
360  return unless $Self->{cachedir};
361  my @records = sort { $a->{UID} <=> $b->{UID} } @{$data->{RECORD}};
362  $data->{RECORD} = \@records;
363  eval {
364    my $file = IO::File->new($Self->cachepath($data->{UNIQUEID}, 1), 'w');
365    $file->print(encode_json($data));
366  };
367}
368
369sub cachepath {
370  my $Self = shift;
371  my $uniqueid = shift;
372  my $make = shift;
373  return unless $Self->{cachedir};
374  my $dir = "$Self->{cachedir}/$Self->{targetuser}";
375  my $path = "$dir/$uniqueid.cache";
376  return (-f $path ? $path : undef) unless $make;
377  mkdir $dir unless -d $dir;
378  return $path;
379}
380
381sub _notexpunged {
382  my $record = shift;
383  my @expunged = grep { lc $_ eq '\\expunged' } @{$record->{FLAGS}};
384  return not scalar @expunged;
385}
386
387sub _cleanflags {
388  my @flags = @_;
389  my @clean = grep { lc $_ ne '\\recent' } @flags;
390  return \@clean;
391}
392
393sub _mkunixtime {
394  my $time = shift;
395  return str2time($time);
396}
397
398sub syncmailboxes {
399  my $Self = shift;
400  my $userdata = $Self->{userdata};
401
402  my $list = $Self->{imaptalk}->list('INBOX', '*');
403  my %mbox = map { $Self->_imap_to_sync($_->[2]) => 1 } @$list;
404
405  foreach my $mailbox (@{$userdata->{MAILBOX}}) {
406    if (delete $mbox{$mailbox->{MBOXNAME}}) {
407      $Self->syncmailbox($mailbox->{MBOXNAME}, $mailbox);
408    } else {
409      $Self->{syncer}->apply_unmailbox($mailbox->{MBOXNAME});
410    }
411  }
412  foreach my $new (sort keys %mbox) {
413    $Self->syncmailbox($new);
414  }
415}
416
417sub syncsubs {
418  my $Self = shift;
419  my $userdata = $Self->{userdata};
420  my $lsub = $Self->{imaptalk}->lsub('INBOX', '*');
421  my %sub = map { $Self->_imap_to_sync($_->[2]) => 1 } @$lsub;
422
423  foreach my $existing (@{$userdata->{LSUB}[0]}) {
424    next if delete $sub{$existing};
425    $Self->{syncer}->apply_unsub($existing, $Self->{targetuser});
426  }
427  foreach my $new (keys %sub) {
428    $Self->{syncer}->apply_sub($new, $Self->{targetuser});
429  }
430}
431
432sub syncquota {
433  my $Self = shift;
434  my $userdata = $Self->{userdata};
435  my $quota = $Self->{imaptalk}->getquotaroot('INBOX');
436  my $name = $quota->{quotaroot}[1];
437  my $amount = $quota->{$name}[2];
438  my $existing = $Self->{userdata}{QUOTA}[0];
439  if ($existing and not $amount) {
440    $Self->{syncer}->dlwrite('APPLY', 'UNQUOTA', $existing->{ROOT});
441    return;
442  }
443  return if not $amount;
444  return if ($existing and $amount == $existing->{STORAGE});
445  $Self->{syncer}->dlwrite('APPLY', 'QUOTA', { ROOT => $Self->_imap_to_sync('INBOX'), STORAGE => $amount });
446}
447
448sub syncuser {
449  my $Self = shift;
450  $Self->syncmailboxes();
451  $Self->syncsubs();
452  $Self->syncquota();
453  return 1;
454}
455
456sub _imap_to_sync {
457  my $Self = shift;
458  my $name = shift;
459  my ($l, $d) = _splituser($Self->{targetuser});
460  my $res = '';
461  $res = "$d!" if $d;
462  $res .= "user.$l";
463  $name =~ s/^INBOX//i;
464  return "$res$name";
465}
466
467sub _sync_to_imap {
468  my $Self = shift;
469  my $name = shift;
470  $name =~ s/^(.*\!)//;
471  $name =~ s/^user\.[^.]+//;
472  return "INBOX$name";
473}
474
475sub _splituser {
476  my $user = shift;
477  return split /\@/, $user;
478}
479
480=back
481=head1 AUTHOR AND COPYRIGHT
482
483Bron Gondwana <brong@fastmail.fm> - Copyright 2017 FastMail
484
485Licenced under the same terms as Cyrus IMAPd.
486
487=cut
488
4891;
490