aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--debian/patches/0001-Ignore-custom-lib-PATH.patch2
-rwxr-xr-ximapsync201
-rw-r--r--imapsync.sample20
-rw-r--r--imapsync.service9
-rw-r--r--lib/Net/IMAP/Sync.pm123
5 files changed, 272 insertions, 83 deletions
diff --git a/debian/patches/0001-Ignore-custom-lib-PATH.patch b/debian/patches/0001-Ignore-custom-lib-PATH.patch
index 0786ffa..8199295 100644
--- a/debian/patches/0001-Ignore-custom-lib-PATH.patch
+++ b/debian/patches/0001-Ignore-custom-lib-PATH.patch
@@ -12,8 +12,8 @@ index 4ef47b3..f932686 100755
--- a/imapsync
+++ b/imapsync
@@ -30,7 +30,6 @@ use List::Util 'first';
+ use List::Util 'first';
use DBI ();
- use POSIX 'strftime';
-use lib 'lib';
use Net::IMAP::Sync qw/read_config compact_set $IMAP_text $IMAP_cond/;
diff --git a/imapsync b/imapsync
index 4ef47b3..f80106d 100755
--- a/imapsync
+++ b/imapsync
@@ -28,7 +28,6 @@ use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
use List::Util 'first';
use DBI ();
-use POSIX 'strftime';
use lib 'lib';
use Net::IMAP::Sync qw/read_config compact_set $IMAP_text $IMAP_cond/;
@@ -43,14 +42,33 @@ sub usage(;$) {
print STDERR "TODO $NAME usage\n";
exit $rv;
}
-usage(1) unless GetOptions(\%CONFIG, qw/debug help|h quiet|q oneshot|1/);
+usage(1) unless GetOptions(\%CONFIG, qw/debug help|h config=s quiet|q oneshot|1 check/);
usage(0) if $CONFIG{help};
-my $CONFFILE = 'sync.ini';
-my $CACHEDIR = './imapsync.cache'; # XXX use a config option
-my $DBFILE = "$CACHEDIR/imap.guilhem.org.db";
-my $LOCKFILE = "$CACHEDIR/.imap.guilhem.org.lck";
+my $CONF = read_config( delete $CONFIG{config} // $NAME
+ , [qw/_ local remote/]
+ , database => qr/\A(\P{Control}+)\z/ );
+my ($DBFILE, $LOCKFILE);
+
+{
+ $DBFILE = $CONF->{_}->{database} if defined $CONF->{_};
+ $DBFILE //= $CONF->{remote}->{host}.'.db' if defined $CONF->{remote};
+ $DBFILE //= $CONF->{local}->{host}. '.db' if defined $CONF->{local};
+ die "Missing option database" unless defined $DBFILE;
+
+ unless ($DBFILE =~ /\A\//) {
+ my $dir = ($ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share") .'/'. $NAME;
+ $dir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $dir";
+ $dir = $1;
+ $DBFILE = $dir .'/'. $DBFILE;
+ unless (-d $dir) {
+ mkdir $dir, 0700 or die "Cannot mkdir $dir: $!\n";
+ }
+ }
+
+ $LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r;
+}
my ($DBH, $IMAP);
@@ -67,10 +85,7 @@ $SIG{$_} = sub { clean(); die "$!\n"; } foreach qw/INT TERM/;
#############################################################################
# Lock the database
{
- if (!-d $CACHEDIR) {
- mkdir $CACHEDIR, 0700 or die "Cannot mkdir $CACHEDIR: $!\n";
- }
- elsif (-f $LOCKFILE) {
+ if (-f $LOCKFILE) {
open my $lock, '<', $LOCKFILE or die "Cannot open $LOCKFILE: $!\n";
my $pid = <$lock>;
close $lock;
@@ -153,9 +168,7 @@ $DBH->do('PRAGMA foreign_keys = ON');
sub msg($@) {
my $name = shift;
return unless @_;
- my $prefix = strftime "%b %e %H:%M:%S", localtime;
- $prefix .= " $name" if defined $name;
- $prefix .= ': ';
+ my $prefix = defined $name ? "$name: " : '';
print STDERR $prefix, @_, "\n";
}
@@ -164,7 +177,7 @@ sub msg($@) {
# Connect to the local and remote IMAP servers
foreach my $name (qw/local remote/) {
- my %config = Net::IMAP::Sync::read_config($CONFFILE, $name);
+ my %config = %{$CONF->{$name}};
$config{$_} = $CONFIG{$_} foreach keys %CONFIG;
$config{enable} = 'QRESYNC';
$config{name} = $name;
@@ -502,18 +515,25 @@ my $STH_GET_CACHE = $DBH->prepare(q{
r.UIDVALIDITY as rUIDVALIDITY, r.UIDNEXT as rUIDNEXT, r.HIGHESTMODSEQ as rHIGHESTMODSEQ
FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
});
+my $STH_GET_CACHE_BY_IDX = $DBH->prepare(q{
+ SELECT mailbox,
+ l.UIDVALIDITY as lUIDVALIDITY, l.UIDNEXT as lUIDNEXT, l.HIGHESTMODSEQ as lHIGHESTMODSEQ,
+ r.UIDVALIDITY as rUIDVALIDITY, r.UIDNEXT as rUIDNEXT, r.HIGHESTMODSEQ as rHIGHESTMODSEQ
+ FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
+ WHERE m.idx = ?
+});
# Get the index associated with a mailbox.
my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx FROM mailboxes WHERE mailbox = ?});
# Find local/remote UID from the map.
-my $STH_GET_LOCAL_UID = $DBH->prepare("SELECT lUID FROM mapping WHERE idx = ? and rUID = ?");
-my $STH_GET_REMOTE_UID = $DBH->prepare("SELECT rUID FROM mapping WHERE idx = ? and lUID = ?");
+my $STH_GET_LOCAL_UID = $DBH->prepare(q{SELECT lUID FROM mapping WHERE idx = ? and rUID = ?});
+my $STH_GET_REMOTE_UID = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? and lUID = ?});
# Delete a (idx,lUID,rUID) association.
# /!\ Don't commit before the messages have actually been EXPUNGEd on
# both sides!
-my $STH_DELETE_MAPPING = $DBH->prepare("DELETE FROM mapping WHERE idx = ? and lUID = ?");
+my $STH_DELETE_MAPPING = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ? and lUID = ?});
# Update the HIGHESTMODSEQ.
my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?});
@@ -528,8 +548,9 @@ my $STH_NEWMAILBOX = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed)
my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});
my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});
-# Insert a (idx,lUID,rUID) association.
-my $STH_INSERT_MAPPING = $DBH->prepare("INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)");
+# Insert or retrieve a (idx,lUID,rUID) association.
+my $STH_INSERT_MAPPING = $DBH->prepare(q{INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)});
+my $STH_GET_MAPPING = $DBH->prepare(q{SELECT lUID,rUID FROM mapping WHERE idx = ?});
# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness.
@@ -538,31 +559,136 @@ while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) {
$lIMAP->set_cache($row->{mailbox},
UIDVALIDITY => $row->{lUIDVALIDITY},
UIDNEXT => $row->{lUIDNEXT},
- HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ}
+ HIGHESTMODSEQ => ($CONFIG{check} ? 0 : $row->{lHIGHESTMODSEQ})
);
$rIMAP->set_cache($row->{mailbox},
UIDVALIDITY => $row->{rUIDVALIDITY},
UIDNEXT => $row->{rUIDNEXT},
- HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ}
+ HIGHESTMODSEQ => ($CONFIG{check} ? 0 : $row->{rHIGHESTMODSEQ})
);
}
+# Download some missing UIDs.
+sub fix_missing($$$@) {
+ my $idx = shift;
+ my $mailbox = shift;
+ my $name = shift;
+ my @set = @_;
+
+ my $source = $name eq 'local' ? $lIMAP : $rIMAP;
+ my $target = $name eq 'local' ? $rIMAP : $lIMAP;
+
+ my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE ENVELOPE BODY.PEEK[]/;
+ $source->fetch(compact_set(@set), "($attrs)", sub(%) {
+ my %mail = @_;
+ return unless exists $mail{RFC822}; # not for us
+
+ my $from = first { defined $_ and @$_ } @{$mail{ENVELOPE}}[2,3,4];
+ $from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : '';
+ print STDERR "$name($mailbox): UID $mail{UID} from <$from> ($mail{INTERNALDATE})\n" unless $CONFIG{quiet};
+
+ # don't bother checking for MULTIAPPEND, @set is probably rather small
+ my @mail = ($mail{RFC822}, [ grep {lc $_ ne '\recent'} @{$mail{FLAGS}} ], $mail{INTERNALDATE});
+ my ($uid) = $target->append($mailbox, @mail);
+
+ my ($lUID, $rUID) = $name eq 'local' ? ($mail{UID}, $uid) : ($uid, $mail{UID});
+ print STDERR "$name($mailbox): Adding mapping (lUID,rUID) = ($lUID,$rUID)\n";
+ $STH_INSERT_MAPPING->execute($idx, $lUID, $rUID);
+ });
+}
+
+# Check synchronization of a mailbox between the two servers (in a very crude way)
+my @CHECKED;
+sub check($$$$$) {
+ my ($idx, $lVanished, $lList, $rVanished, $rList) = @_;
+
+ my %lVanished = map {$_ => 1} @$lVanished;
+ my %rVanished = map {$_ => 1} @$rVanished;
+
+ $STH_GET_CACHE_BY_IDX->execute($idx);
+ my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // die "Missing cache for index $idx";
+ die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check
+ my $mailbox = $cache->{mailbox};
+
+ $STH_GET_MAPPING->execute($idx);
+ my %missing = ( local => [], remote => [] );
+ while (defined (my $row = $STH_GET_MAPPING->fetch())) {
+ my ($lUID, $rUID) = @$row;
+ if (defined $lList->{$lUID} and defined $rList->{$rUID}) {
+ # both $lUID and $rUID are known
+ if ($lList->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and
+ $rList->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ}) {
+ # old stuff
+ if ($lList->{$lUID}->[1] ne $rList->{$rUID}->[1]) {
+ warn "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Fixing...\n";
+ # keep it in the hash references so we fix it automatically
+ }
+ else {
+ # no conflict, remove it from the hashes
+ delete $lList->{$lUID};
+ delete $rList->{$rUID};
+ }
+ }
+ else {
+ # delete the old stuff
+ delete $lList->{$lUID} if $lList->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ};
+ delete $rList->{$rUID} if $rList->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ};
+ }
+ }
+ elsif (!defined $lList->{$lUID} and !defined $rList->{$rUID}) {
+ unless ($lVanished{$lUID} and $rVanished{$rUID}) {
+ # will be deleted from the database later
+ warn "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox\n";
+ $lVanished{$lUID} = 1;
+ $rVanished{$rUID} = 1;
+ }
+ }
+ elsif (!defined $lList->{$lUID}) {
+ unless ($lVanished{$lUID}) {
+ warn "WARNING: local($mailbox): No match for remote UID $rUID. Downloading again...\n";
+ push @{$missing{remote}}, $rUID;
+ delete $rList->{$rUID};
+ }
+ }
+ elsif (!defined $rList->{$rUID}) {
+ unless ($rVanished{$rUID}) {
+ warn "WARNING: remote($mailbox): No match for local UID $lUID. Downloading again...\n";
+ push @{$missing{local}}, $lUID;
+ delete $lList->{$lUID};
+ }
+ }
+ $lList->{$lUID} = $lList->{$lUID}->[1] if defined $lList->{$lUID};
+ $rList->{$rUID} = $rList->{$rUID}->[1] if defined $rList->{$rUID};
+ }
+
+ # we'll complain later for modified UIDs without an entry in the database
+
+ @$lVanished = keys %lVanished;
+ @$rVanished = keys %rVanished;
+ push @CHECKED, $idx;
+ return %missing;
+}
+
# Sync known messages. Since pull_updates is the last method call on
# $lIMAP and $rIMAP, it is safe to call get_cache on either object after
# this function, in order to update the HIGHESTMODSEQ.
# Return true if an update was detected, and false otherwise
-sub sync_known_messages($) {
- my $idx = shift;
+sub sync_known_messages($$) {
+ my ($idx, $mailbox) = @_;
my $update = 0;
# loop since processing might produce VANISHED or unsollicited FETCH responses
while (1) {
- my ($lVanished, $lModified) = $lIMAP->pull_updates();
- my ($rVanished, $rModified) = $rIMAP->pull_updates();
+ my ($lVanished, $lModified, $rVanished, $rModified, %missing);
+
+ my $check = ($CONFIG{check} and !grep { $idx == $_} @CHECKED) ? 1 : 0;
+ ($lVanished, $lModified) = $lIMAP->pull_updates($check);
+ ($rVanished, $rModified) = $rIMAP->pull_updates($check);
+ %missing = check($idx, $lVanished, $lModified, $rVanished, $rModified) if $check;
# repeat until we have nothing pending
- return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished;
+ return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished or %missing;
$update = 1;
# process VANISHED messages
@@ -581,7 +707,7 @@ sub sync_known_messages($) {
my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
if (!defined $rUID) {
- warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n";
+ warn "WARNING: remote($mailbox): No match for local vanished UID $lUID. Ignoring...\n";
}
elsif (!exists $rVanished{$rUID}) {
push @rToRemove, $rUID;
@@ -592,7 +718,7 @@ sub sync_known_messages($) {
my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
if (!defined $lUID) {
- warn "WARNING: Couldn't find a matching lUID for (idx,rUID) = ($idx,$rUID)\n";
+ warn "WARNING: local($mailbox): No match for remote vanished UID $rUID. Ignoring...\n";
}
elsif (!exists $lVanished{$lUID}) {
push @lToRemove, $lUID;
@@ -606,7 +732,7 @@ sub sync_known_messages($) {
foreach my $lUID (@$lVanished, @lToRemove) {
my $r = $STH_DELETE_MAPPING->execute($idx, $lUID);
die if $r > 1; # sanity check
- warn "WARNING: Couldn't delete (idx,lUID) pair ($idx,$lUID)\n" if $r == 0;
+ warn "WARNING: Can't delete (idx,lUID) = ($idx,$lUID) from the database\n" if $r == 0;
}
}
@@ -629,7 +755,8 @@ sub sync_known_messages($) {
my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
if (!defined $rUID) {
- warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n";
+ warn "WARNING: remote($mailbox): No match for local updated UID $lUID. Downloading again...\n";
+ push @{$missing{local}}, $lUID;
}
elsif (defined (my $rFlags = $rModified->{$rUID})) {
unless ($lFlags eq $rFlags) {
@@ -653,7 +780,8 @@ sub sync_known_messages($) {
my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
if (!defined $lUID) {
- warn "WARNING: Couldn't find a matching rUID for (idx,rUID) = ($idx,$rUID)\n";
+ warn "WARNING: local($mailbox): No match for remote updated UID $rUID. Downloading again...\n";
+ push @{$missing{remote}}, $rUID;
}
elsif (!exists $lModified->{$lUID}) {
# conflicts are taken care of above
@@ -662,6 +790,9 @@ sub sync_known_messages($) {
}
}
+ fix_missing($idx, $mailbox, 'local', @{$missing{local}}) if @{$missing{local} // []};
+ fix_missing($idx, $mailbox, 'remote', @{$missing{remote}}) if @{$missing{remote} // []};
+
while (my ($lFlags,$lUIDs) = each %lToUpdate) {
$lIMAP->push_flag_updates($lFlags, @$lUIDs);
}
@@ -734,13 +865,13 @@ sub sync_messages($$) {
die if !defined $$idx or defined $STH_GET_INDEX->fetchrow_arrayref(); # sanity check
# there might be flag updates pending
- sync_known_messages($$idx);
+ sync_known_messages($$idx, $mailbox);
$STH_INSERT_LOCAL->execute($$idx, $lIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
$STH_INSERT_REMOTE->execute($$idx, $rIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
}
else {
# update known mailbox
- sync_known_messages($$idx);
+ sync_known_messages($$idx, $mailbox);
$STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
$STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
}
@@ -793,7 +924,7 @@ while(1) {
$rIMAP->select($mailbox);
# sync updates to known messages before fetching new messages
- if (defined $idx and sync_known_messages($idx)) {
+ if (defined $idx and sync_known_messages($idx, $mailbox)) {
# get_cache is safe after pull_update
$STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $idx);
$STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $idx);
@@ -803,7 +934,7 @@ while(1) {
}
}
# clean state!
- exit 0 if $CONFIG{oneshot};
+ exit 0 if $CONFIG{oneshot} or $CONFIG{check};
wait_notifications(900);
}
diff --git a/imapsync.sample b/imapsync.sample
new file mode 100644
index 0000000..51958aa
--- /dev/null
+++ b/imapsync.sample
@@ -0,0 +1,20 @@
+; database = imap.guilhem.org.db
+
+[local]
+type = preauth
+command = /usr/lib/dovecot/imap
+
+[remote]
+; type = imaps
+host = imap.guilhem.org
+; port = 993
+username = guilhem
+password = xxxxxxxxxxxxxxxx
+
+; SSL options
+;SSL_verify_peer = TRUE
+SSL_ca_path = /etc/ssl/certs
+;SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
+;SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605
+
+; vim:ft=dosini
diff --git a/imapsync.service b/imapsync.service
new file mode 100644
index 0000000..e3a47e4
--- /dev/null
+++ b/imapsync.service
@@ -0,0 +1,9 @@
+[Unit]
+Description=IMAP-to-IMAP Syncronization service
+After=network.target
+
+[Service]
+ExecStart=/usr/bin/imapsync
+
+[Install]
+WantedBy=multi-user.target
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm
index 0b95276..bb99dcb 100644
--- a/lib/Net/IMAP/Sync.pm
+++ b/lib/Net/IMAP/Sync.pm
@@ -23,7 +23,6 @@ use strict;
use Config::Tiny ();
use List::Util 'first';
use Socket 'SO_KEEPALIVE';
-use POSIX 'strftime';
use Exporter 'import';
BEGIN {
@@ -50,45 +49,55 @@ my %OPTIONS = (
SSL_ca_path => qr/\A(\P{Control}+)\z/,
SSL_cipher_list => qr/\A(\P{Control}+)\z/,
SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
+ SSL_verify_peer => qr/\A(TRUE|FALSE)\z/i,
);
#############################################################################
# Utilities
-# read_config($conffile, $section, %opts)
-# Read $conffile's default section, then $section (which takes
-# precedence). %opts extends %OPTIONS and maps each option to a
-# regexp validating its values.
+# read_config($conffile, $sections, %opts)
+# Read $conffile's default section, then each section in the array
+# reference $section (which takes precedence). %opts extends %OPTIONS
+# and maps each option to a regexp validating its values.
sub read_config($$%) {
my $conffile = shift;
- my $section = shift;
+ my $sections = shift;
my %opts = (%OPTIONS, @_);
+ $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile
+ unless $conffile =~ /\A\//; # relative path
+
die "No such config file $conffile\n"
unless defined $conffile and -f $conffile and -r $conffile;
my $h = Config::Tiny::->read($conffile);
- die "No such section $section\n" unless defined $h->{$section};
-
- my $conf = $h->{_}; # default section
- $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
-
- # default values
- $conf->{type} //= 'imaps';
- $conf->{host} //= 'localhost';
- $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef;
- $conf->{auth} //= 'PLAIN LOGIN';
- $conf->{STARTTLS} //= 'TRUE';
-
- # untaint and validate the config
- foreach my $k (keys %$conf) {
- die "Invalid option $k\n" unless defined $opts{$k};
- next unless defined $conf->{$k};
- die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k};
- $conf->{$k} = $1;
+
+ my %configs;
+ foreach my $section (@$sections) {
+ my $conf = { %{$h->{_}} }; # default section
+ $configs{$section} = $conf;
+ next unless defined $section and $section ne '_';
+
+ die "No such section $section\n" unless defined $h->{$section};
+ $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
+
+ # default values
+ $conf->{type} //= 'imaps';
+ $conf->{host} //= 'localhost';
+ $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef;
+ $conf->{auth} //= 'PLAIN LOGIN';
+ $conf->{STARTTLS} //= 'TRUE';
+
+ # untaint and validate the config
+ foreach my $k (keys %$conf) {
+ die "Invalid option $k\n" unless defined $opts{$k};
+ next unless defined $conf->{$k};
+ die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k};
+ $conf->{$k} = $1;
+ }
}
- return %$conf;
+ return \%configs;
}
@@ -215,6 +224,16 @@ sub new($%) {
my $self = { @_ };
bless $self, $class;
+ # whether we're allowed to to use read-write command
+ $self->{'read-only'} = uc ($self->{'read-only'} // 'FALSE') ne 'TRUE' ? 0 : 1;
+
+ # where to log
+ $self->{STDERR} //= \*STDERR;
+
+ # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
+ # (cf RFC 3501 section 3)
+ $self->{_STATE} = '';
+
if ($self->{type} eq 'preauth') {
require 'IPC/Open2.pm';
my $command = $self->{command} // $self->fail("Missing preauth command");
@@ -232,9 +251,12 @@ sub new($%) {
$socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
}
else {
+ require 'IO/Socket/SSL.pm';
+ if (defined (my $vrfy = delete $self->{SSL_verify_peer})) {
+ $args{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE';
+ }
my $fpr = delete $self->{SSL_fingerprint};
$args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
- require 'IO/Socket/SSL.pm';
$socket = IO::Socket::SSL->new(%args)
or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
@@ -275,16 +297,6 @@ sub new($%) {
# are considered.
$self->{_MODIFIED} = {};
- # whether we're allowed to to use read-write command
- $self->{'read-only'} = uc ($self->{'read-only'} // 'FALSE') ne 'TRUE' ? 0 : 1;
-
- # where to log
- $self->{STDERR} //= \*STDERR;
-
- # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
- # (cf RFC 3501 section 3)
- $self->{_STATE} = '';
-
# wait for the greeting
my $x = $self->_getline();
$x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x);
@@ -306,8 +318,12 @@ sub new($%) {
require 'IO/Socket/SSL.pm';
$self->_send('STARTTLS');
+ my %sslargs;
+ if (defined (my $vrfy = delete $self->{SSL_verify_peer})) {
+ $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE';
+ }
my $fpr = delete $self->{SSL_fingerprint};
- my %sslargs = %$self{ grep /^SSL_/, keys %$self };
+ $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs)
or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
@@ -384,12 +400,10 @@ sub DESTROY($) {
sub log($@) {
my $self = shift;
return unless @_;
- my $prefix = strftime "%b %e %H:%M:%S", localtime;
- $prefix .= " $self->{name}" if defined $self->{name};
+ my $prefix = defined $self->{name} ? $self->{name} : '';
$prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
$prefix .= ': ';
- my $stderr = $self->{STDERR};
- print $stderr $prefix, @_, "\n";
+ $self->{STDERR}->say($prefix, @_);
}
@@ -665,6 +679,15 @@ sub append($$$@) {
}
+# $self->fetch($set, $flags, [$callback])
+# Issue an UID FETCH command with the given UID $set, $flags, and
+# optional $callback.
+sub fetch($$$$) {
+ my ($self, $set, $flags, $callback) = @_;
+ $self->_send("UID FETCH $set $flags", $callback);
+}
+
+
# $self->notify(@specifications)
# Issue a NOTIFY command with the given mailbox @specifications (cf RFC
# 5465 section 6) to be monitored. Croak if the server did not
@@ -815,13 +838,16 @@ sub next_dirty_mailbox($@) {
}
-# $self->pull_updates()
+# $self->pull_updates([$full])
+# If $full is set, FETCH FLAGS and MODSEQ for each UID up to
+# UIDNEXT-1.
# Get pending updates (unprocessed VANISHED responses and FLAG
# updates), and empty these lists from the cache.
# Finally, update the HIGHESTMODSEQ from the persistent cache to the
# value found in the internal cache.
-sub pull_updates($) {
+sub pull_updates($;$) {
my $self = shift;
+ my $full = shift // 0;
my $mailbox = $self->{_SELECTED} // $self->panic();
my $pcache = $self->{_PCACHE}->{$mailbox};
@@ -831,6 +857,9 @@ sub pull_updates($) {
$self->{_VANISHED} = [];
}
else {
+ $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)")
+ if $full and $pcache->{UIDNEXT} > 1;
+
my @missing;
while (%{$self->{_MODIFIED}}) {
while (my ($uid,$v) = each %{$self->{_MODIFIED}}) {
@@ -838,9 +867,9 @@ sub pull_updates($) {
# FLAG updates can arrive while processing pull_new_messages
# for instance
if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH
- next unless $uid < $pcache->{UIDNEXT} # out of bounds
- and $v->[0] > $pcache->{HIGHESTMODSEQ}; # already seen
- $modified{$uid} = $v->[1];
+ next unless $uid < $pcache->{UIDNEXT} # out of bounds
+ and ($full or $v->[0] > $pcache->{HIGHESTMODSEQ}); # already seen
+ $modified{$uid} = $full ? $v : $v->[1];
} else {
push @missing, $uid;
}
@@ -979,7 +1008,7 @@ sub push_flag_updates($$@) {
}
unless ($self->{quiet}) {
- $self->log("Updated flags ($flags) for UID ".compact_set(@ok));
+ $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok;
$self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '.
"trying again later") if %failed;
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-03 22:58:01 +0000