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