Subversion Repositories sysadmin_scripts

Rev

Rev 50 | Rev 52 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
14 rodolico 1
#! /usr/bin/perl -w
2
 
3
#    archiveIMAP: moves old messages from one IMAP account to another
4
#    maintaining hierarchy.
5
#    see http://wiki.linuxservertech.com for additional information
6
#    Copyright (C) 2014  R. W. Rodolico
7
#
8
#    version 1.0, 20140818
9
#       Initial Release
10
#
11
#    version 1.0.1 20140819
12
#        Removed dependancy on Email::Simple
13
#        Allowed 'separator' as an element in either source or target
14
#
50 rodolico 15
#    version 2.0.0 20190817 RWR
16
#        Major revision.
17
#           Config is now YAML
18
#           Default section which will fill in the blanks for anything not filled in on an account, so creating a lot of accounts
19
#              with common values is easier to set up an maintain
20
#           Target folder is configurable on a per account basis, using tags <folder>, <year>, <month> (called hierachy)
21
#
14 rodolico 22
#    This program is free software: you can redistribute it and/or modify
23
#    it under the terms of the GNU General Public License as published by
24
#    the Free Software Foundation, either version 3 of the License, or
25
#    (at your option) any later version.
26
#
27
#    This program is distributed in the hope that it will be useful,
28
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
29
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
30
#    GNU General Public License for more details.
31
#
32
#    You should have received a copy of the GNU General Public License
33
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.
40 rodolico 34
#
35
#    for required libraries
42 rodolico 36
#    apt-get -y install libnet-imap-simple-ssl-perl libyaml-tiny-perl libhash-merge-simple-perl libclone-perl libdate-manip-perl libemail-simple-perl
14 rodolico 37
 
38
use strict;
39
use warnings;
40
use Net::IMAP::Simple; # libnet-imap-simple-ssl-perl
41
use POSIX; # to get floor and ceil
40 rodolico 42
use YAML::Tiny; # apt-get libyaml-tiny-perl under debian
43
use Clone 'clone'; # libclone-perl
44
use Hash::Merge::Simple qw/ merge clone_merge /; # libhash-merge-simple-perl
42 rodolico 45
use Date::Manip; # libdate-manip-perl
46
use Email::Simple; # libemail-simple-perl
47
use Date::Parse;
14 rodolico 48
 
42 rodolico 49
 
40 rodolico 50
use Data::Dumper;
51
 
14 rodolico 52
# globals
40 rodolico 53
my $CONFIG_FILE_NAME = 'archiveIMAP.yaml';
14 rodolico 54
 
40 rodolico 55
# the default values for everything. These are overridden
56
# by default values in the conf file (.yaml) or by individual
57
# accounts entries.
58
my $config = {
59
   'default' => {
60
      # where the mail is going to
61
      'target' => {
62
                  # these have no defaults. They should be in the configuration file
63
                  # 'password' => 'password',
64
                  # 'username' => 'username',
65
                  # hierarchy can be any combination of <path>, <month> and <year>
66
                  'hierarchy' => '<path>',
67
                  # default target server
68
                  'server' => 'localhost',
69
                 },
70
      # where the mail is coming from
71
      'source' => {
72
                  # these have no defaults. They should be in the configuration file
73
                  # 'password' => 'password',
74
                  # 'username' => 'username',
75
                  # Anything older than this is archived
76
                  # number of days unless followed by 'M' or 'Y', in which case it is
77
                  # multiplied by the number of days in a year (365.2425) or days in a month (30.5)
78
                  # may be a float, ie 1.25Y is the same as 15M
79
                  'age' => '1Y',
80
                  # if set to 1, any folders emptied out will be deleted EXCEPT system folders
81
                  'deleteEmptyFolders' => 0,
82
                  # default source server
83
                  'server' => 'localhost',
84
                  # these folders are considered system folders and never deleted, case insensitive
85
                  'system' => [
86
                                 'Outbox',
87
                                 'Sent Items',
88
                                 'INBOX'
89
                              ],
90
                  # these folders are ignored, ie not processed at all. Case insensitive
91
                  'ignore' => [
92
                                 'Deleted Messages',
93
                                 'Drafts',
94
                                 'Junk E-mail',
95
                                 'Junk',
96
                                 'Trash'
97
                               ],
98
                  # if 1, after successful copy to target, remove from source
99
                  'deleteOnSuccess' => 0
100
               },
101
      # if 1, does a dry run showing what would have happened
102
      'testing' => 0,
103
      # if 0, will not be processed
104
      'enabled' => 1,
105
   }
42 rodolico 106
};
40 rodolico 107
 
108
 
14 rodolico 109
#
110
# find where the script is actually located as cfg should be there
111
#
112
sub getScriptLocation {
113
   use strict;
114
   use File::Spec::Functions qw(rel2abs);
115
   use File::Basename;
116
   return dirname(rel2abs($0));
117
}
118
 
119
#
120
# Read the configuration file from current location 
121
# and return it as a string
122
#
123
sub readConfig {
124
   my $scriptLocation = &getScriptLocation();
125
   if ( -e "$scriptLocation/$CONFIG_FILE_NAME" ) {
40 rodolico 126
      my $yaml = YAML::Tiny->read( "$scriptLocation/$CONFIG_FILE_NAME" );
127
      # use clone_merge to merge conf file into $config
128
      # overwrites anything in $config if it exists in the config file
129
      $config = clone_merge( $config, $yaml->[0] );
130
      return 1;
14 rodolico 131
   }
40 rodolico 132
   return 0;
14 rodolico 133
}
134
 
40 rodolico 135
# merges default into current account, overwriting anything not defined in account with
136
# value from default EXCEPT arrays labeled in @tags, which will be merged together.
137
sub fixupAccount {
138
   my ( $default, $account ) = @_;
139
 
140
   # these arrays, part of source, will be appended together instead of being overwritten
141
   my @tags = ( 'ignore', 'system' );
142
   # merge the tags in question. NOTE: they can only be in source
143
   foreach my $tag ( @tags) {
144
      if ( $default->{'source'}->{$tag} && $account->{'source'}->{$tag} ) {
145
         my @j = ( @{$default->{'source'}->{$tag}}, @{$account->{'source'}->{$tag}} );
146
         $account->{'source'}->{$tag} = \@j;
147
      }
148
   }
149
   # now, merge account and default, with account taking precedence.
150
   return  clone_merge(  $default, $account );
151
   #my $c = clone_merge(  $default, $account );
152
   #return $c;
153
}
154
 
14 rodolico 155
#
156
# Open an IMAP connection
157
#
158
sub openIMAPConnection {
159
   my ( $server, $username, $password ) = @_;
160
   my $imap = Net::IMAP::Simple->new( $server ) ||
161
    die "Unable to connect to IMAP: $Net::IMAP::Simple::errstr\n";
162
   # Log on
163
   if(!$imap->login( $username, $password )){
164
     die "Login failed: " . $imap->errstr . "\n";
165
   }
166
   return $imap;
167
}
168
 
169
#
170
# returns a string in proper format for RFC which is $age days ago
40 rodolico 171
# $age is a float, possibly followed by a single character modifier
14 rodolico 172
#
173
sub getDate {
174
   my $age = shift;
40 rodolico 175
   # allow modifier to age which contains 'Y' (years) or 'M' (months)
176
   # Simply set multiplier to the correct value, then multiply the value
177
   $age = lc( $age );
178
   if ( $age =~ m/([0-9.]+)([a-z])/ ) {
42 rodolico 179
      # ~0 is the maximum integer which can be stored. Shifting right one gives max unsigned integer
180
      my $multiplier = ($2 eq 'y' ? 365.2425 : ( $2 eq 'm' ? 30.5 : ~0 >> 1) );
40 rodolico 181
      $age = floor( $1 * $multiplier);
182
   }
14 rodolico 183
   my @months = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
184
   my @now = localtime(time - 24 * 60 * 60 * $age);
185
   $now[4] = @months[$now[4]];
186
   $now[5] += 1900;
187
   my $date = sprintf( "%d-%s-%d", $now[3],$now[4],$now[5] ) ; # '1-Jan-2014';
188
   return $date;
189
}
190
 
42 rodolico 191
 
192
# calculateTargetFolder
193
# we are passed the target and the message
194
# pattern is carot (^) separated and may contain
195
# special placeholders <path>, <year>, <month>
196
# anything else is inserted directly
197
sub calculateTargetFolder {
198
   my ( $message, $source, $target ) = @_;
199
   # we may be sorting by date
200
   my $email = Email::Simple->new( join( '', @$message ) );
201
   my $msgDate = $email->header('Date');
202
   my @t = strptime( $msgDate );
203
   my $month = $t[4]+1;
204
   $month = '0' . $month if $month < 10;
205
   my $year = $t[5]+1900;
50 rodolico 206
   # also, may need the source hierarchy
207
   my $sourceFolder = join ( $target->{'separator'}, @{ $source->{'source folder list'} } );
42 rodolico 208
   # now, build the path on the new machine
209
   my $targetPattern = join( $target->{'separator'}, @{ $target->{'hierachy pattern'} } );
210
   $targetPattern =~ s/<path>/$sourceFolder/gi;
211
   $targetPattern =~ s/<month>/$month/gi;
212
   $targetPattern =~ s/<year>/$year/gi;
213
   # return the string we created, separated by
214
   # the delimiters for the target
215
   return $targetPattern;
216
}
217
 
218
 
219
# If folder has messages that match the criteria, move them to target
220
# creates the target folder if necessary
14 rodolico 221
#
42 rodolico 222
sub processFolder {
223
   my ( $source, $target, $folder, $TESTING ) = @_;
224
   #$dateBefore, $sourceDelimiter, $targetDelimiter, $deleteOnSuccess
225
   print "\n=== Processing $folder\n";
226
   my $sourceAccount = $source->{'connection'};
227
   my $targetAccount = $target->{'connection'};
228
   my $numMessages = 0;
229
   $sourceAccount->expunge_mailbox( $folder ); # clean it up so we don't copy deleted messages
230
   $sourceAccount->select( $folder ) or die "Could not connect to folder $folder\n"; # move into the correct folder for the source
231
   my @ids = $sourceAccount->search_sent_before( $source->{'before date'} ); # use sent_before to get the sent date from message
232
#   print join( "\n\t\t\t", @ids ) . "\n";
233
   return 0 unless @ids; # we have nothing to copy, so exit
234
   # make life easier by precalculating some paths as array pointers
235
   my @sourceFolders = split( '\\' . $source->{'separator'}, $folder );
236
   my @pattern = split '\\^', $target->{'hierarchy'};
237
   $source->{'source folder list'} = \@sourceFolders;
238
   $target->{'hierachy pattern'} = \@pattern;
239
#   print "\n\nDumping information\n";
240
#   print "Source Folder $folder\n";
241
#   print "Source Separator $source->{'separator'}\n";
242
#   print Dumper( $source->{'source folder list'} ) . "\n";
243
#   print "Target Separator $target->{'separator'}\n";
244
#   print "Target Hierarchy $target->{'hierarchy'}\n";
245
#   print Dumper( $target->{'hierachy pattern'} ) . "\n";
246
 
247
#   print 'Source => ' . join( "\n", @sourceFolders ) . "\n";
248
#   print 'Pattern => ' . join( "\n", @pattern ) . "\n";
249
 
250
 
251
   # process each message to be done
252
   foreach my $id ( @ids ) {
253
      # get the flags
254
      my @flags = $sourceAccount->msg_flags( $id );
255
      # get the message
256
      my $message = $sourceAccount->get( $id ) or die $sourceAccount->errstr;
257
      # calculate where we are going to move this to
258
      my $targetFolder = &calculateTargetFolder( $message, $source, $target );
259
      if ( $TESTING ) {
50 rodolico 260
         print "Would have " . ( $source->{'deleteOnSuccess'} ? 'moved' : 'copied' )  . " message to $targetFolder\n";
42 rodolico 261
         next;
262
      }
50 rodolico 263
      if ( $target->{'connection'}->select( $targetFolder ) || &makeFolder( $target->{'connection'}, $targetFolder, $target->{'separator'} ) ) {
264
         if ( $target->{'connection'}->put( $targetFolder, $message, @flags ) ) {
42 rodolico 265
            $source->{'connection'}->delete( $id ) if ( $source->{'deleteOnSuccess'} ) ;
266
            $numMessages++;
267
         } else {
50 rodolico 268
            die "Could not write to target, aborting\n$targetFolder->{'connection'}->errstr\n";
42 rodolico 269
         }
270
      } else {
50 rodolico 271
         warn "\t\t$targetFolder not found in target and could not create it\n";
42 rodolico 272
      }
273
 
274
   }
275
   return $numMessages;
276
}
277
 
278
 
279
 
280
#
14 rodolico 281
# Get a list of all folders to be processed
282
# currently, it just weeds out items in the ignore list
283
#
284
sub getFolders {
285
   my ($imap, $ignore, $separator) = @_;
286
   $separator = '\\' . $separator;
287
   # build a regex that will be used to filter the input
288
   # assuming Trash, Drafts and Junk are in the ignore list
289
   # and a period is the separator, the generated regex is
290
   # (^|(\.))((Trash)|(Drafts)|(Junk))((\.)|$)
291
   # which basically says ignore those folders, but not substrings of them
292
   # ie, Junk02 would not be filtered but Junk would
293
   my $ignoreRegex = "(^|($separator))((" . join( ")\|(", @$ignore ) . "))(($separator)|\$)";
294
   # read all mailboxes and filter them with above regex into @boxes
42 rodolico 295
   my @boxes = grep{ ! /$ignoreRegex/i } $imap->mailboxes;
14 rodolico 296
   return \@boxes;
297
}
298
 
299
#
300
# make a folder on the IMAP account. The folder is assumed to be the
301
# fully qualified path with the correct delimiters
302
#
303
sub makeFolder {
304
   my ($imap, $folder, $delimiter) = @_;
305
 
306
   print "\n\t\tCreating folder $folder";
307
   # you must create the parent folder before creating the children
308
   my $escapedDelimiter = '\\' . $delimiter;
309
   my @folders = split( $escapedDelimiter, $folder );
310
   $folder = '';
311
   # take them from the left and, if they don't exist, create it
312
   while ( my $subdir = shift @folders ) {
313
      $folder .= $delimiter if $folder;
314
      $folder .= $subdir;
315
      next if $imap->select( $folder ); # already created, so look deeper in hierachy
316
      print "\n\t\t\tCreating subfolder $folder";
317
      $imap->create_mailbox( $folder ) || warn $imap->errstr();
318
      $imap->folder_subscribe( $folder ) || die $imap->errstr();
319
      unless ( $imap->select( $folder ) ) { # verify it was created
320
         warn "Unable to create $folder on target account\n";
321
         return 0;
322
      } # unless
323
   } # while
324
   return $folder;
325
}
326
 
327
#
328
# Delete an IMAP folder
329
#
330
sub deleteAFolder {
42 rodolico 331
   my ($source, $folder, $TESTING ) = @_;
332
   my $sourceAccount = $source->{'connection'};
333
   my $separator = $source->{'separator'};
14 rodolico 334
   return 1 if $folder eq 'INBOX'; # do NOT mess with INBOX
335
   return 2 if $sourceAccount->select($folder) > 0; # do not mess with it if it still has messages in it
336
   return 3 if $sourceAccount->mailboxes( $folder . $separator . '*' ); # do not mess with it if it has subfolders
42 rodolico 337
   return 4 if $source->{'system folders'}->{lc $folder}; # do not mess with system folders
338
   print "\n\t\tDeleting empty folder $folder" . ( $TESTING ? ' Dry Run' : '' );
339
   return if $TESTING;
14 rodolico 340
   $sourceAccount->folder_unsubscribe($folder);
341
   $sourceAccount->delete_mailbox( $folder );
342
}
343
 
344
 
40 rodolico 345
# main process loop to handle one account
14 rodolico 346
#
347
sub processAccount {
40 rodolico 348
   my $account = shift;
349
 
51 rodolico 350
   exit unless $account->{'enabled'}; # blow it off if it is not enabled
42 rodolico 351
   my $TESTING = $account->{'testing'}; # create mini global if we should test this account
50 rodolico 352
 
353
   print "========= Test Mode ========\n" if $TESTING;
14 rodolico 354
 
355
   # open and log into both source and target, and get the separator used
42 rodolico 356
   foreach my $acct ( 'target','source' ) {
357
      $account->{$acct}->{'connection'} = &openIMAPConnection( $account->{$acct}->{'server'}, $account->{$acct}->{'username'}, $account->{$acct}->{'password'} );
358
      unless ( $account->{$acct}->{'connection'} ) {
359
         warn "Unable to open $acct for $account->{$acct}->{username}, aborting move: $!\n";
360
         return -1;
361
      }
362
      $account->{$acct}->{'separator'} = $account->{$acct}->{'connection'}->separator unless $account->{$acct}->{'separator'};
363
   }
14 rodolico 364
 
42 rodolico 365
   # just being set up for convenience and readability
366
   my $source = $account->{'source'};
367
   my $target = $account->{'target'};
368
 
369
   my %temp = map{ lc($_) => 1 } @{$source->{'system'}};
370
   $source->{'system folders'} = \%temp;
371
 
50 rodolico 372
   $source->{'before date'} = &getDate( $source->{'age'} );
42 rodolico 373
   print "\t" . ( $source->{'deleteOnSuccess'} ? 'Moving' : 'Copying' ) . " all messages before $source->{'before date'}\n";
374
 
14 rodolico 375
   # get a list of all folders to be processed on the source
42 rodolico 376
   $source->{'folders'} = &getFolders( $source->{'connection'}, $source->{'ignore'}, $source->{'separator'} );
377
 
50 rodolico 378
   if ( $TESTING ) {
379
      print Dumper( $source );
380
      print "Source above, press enter to continue: "; my $j = <STDIN>;
381
      print Dumper( $target );
382
      print "Target above, Press enter to continue: "; $j = <STDIN>;
383
   }
42 rodolico 384
 
385
   my $folderList = $source->{'folders'};
14 rodolico 386
   my $count = 0; # count the number of messages processed
387
   my $processedCount = 0; # count the number of folders processed
388
   foreach my $folder ( @$folderList ) {
38 rodolico 389
      my $messages;
42 rodolico 390
      $messages = &processFolder( $source, $target, $folder, $TESTING ); #, $date, $$source{'separator'}, $$target{'separator'}, $deleteOnSuccess );
391
 
392
      $TESTING ? print "Would expunge $folder\n" : $source->{'connection'}->expunge_mailbox( $folder );
14 rodolico 393
      # delete folder if empty and client has requested it.
50 rodolico 394
      &deleteAFolder( $source, $folder, $TESTING ) if $account->{'source'}->{'deleteEmptyFolders'};
14 rodolico 395
      print "\n\t\t$messages processed\n";
396
      $count += $messages;
397
      $processedCount++;
398
      # next line used only for testing. Dies after 5 folders on first account
50 rodolico 399
      last if $processedCount > 5 and $TESTING;
14 rodolico 400
   }
42 rodolico 401
 
402
   $source->{'connection'}->quit;
403
   $target->{'connection'}->quit;
14 rodolico 404
   return $count;
405
}
406
 
40 rodolico 407
 
408
 
14 rodolico 409
#######################################################################
410
#                   Main                                              #
411
#######################################################################
412
 
413
# read and evaluate configuration file
40 rodolico 414
&readConfig() || die "could not load config file\n";
415
#print Dumper( $config ); die;
416
foreach my $account ( keys %{$config->{'accounts'}} ) {
417
    $config->{'accounts'}->{$account} = &fixupAccount( $config->{'default'}, $config->{'accounts'}->{$account} );
14 rodolico 418
}
419
 
40 rodolico 420
#print Dumper( $config ) ; die;
14 rodolico 421
 
40 rodolico 422
# just a place to gather some stats
14 rodolico 423
my %processed;
424
$processed{'Accounts'} = 0;
425
$processed{'Messages'} = 0;
426
 
40 rodolico 427
# grab only the accounts for simplicity
428
my $accounts = $config->{'accounts'};
42 rodolico 429
 
50 rodolico 430
#die Dumper( $accounts );
42 rodolico 431
 
40 rodolico 432
# now, process each in turn
433
foreach my $account ( keys %$accounts ) {
14 rodolico 434
   # talk to user
435
   print "Processing account $account\n";
40 rodolico 436
   # do the account. This is the main worker bee
437
   $accounts->{$account}->{'processed'} = &processAccount( $accounts->{$account} );
438
   print "Done, $accounts->{$account}->{'processed'} messages copied\n";
14 rodolico 439
   $processed{'Accounts'}++;
40 rodolico 440
   $processed{'Messages'} += $accounts->{$account}->{'processed'};
42 rodolico 441
   # free up space we allocated since we stored a bunch of stuff in there, and we don't need it anymore
442
   $accounts->{$account} = undef; 
14 rodolico 443
} # foreach loop
444
 
445
print "$processed{'Accounts'} accounts processed, $processed{'Messages'} messages\n";
446
 
40 rodolico 447
 
14 rodolico 448
1;
449