Subversion Repositories sysadmin_scripts

#! /usr/bin/perl -w

#    archiveIMAP: moves old messages from one IMAP account to another

#    maintaining hierarchy.

#    see http://wiki.linuxservertech.com for additional information

#    Copyright (C) 2014  R. W. Rodolico

#

#    version 1.0, 20140818

#       Initial Release

#

#    version 1.0.1 20140819

#        Removed dependancy on Email::Simple

#        Allowed 'separator' as an element in either source or target

#

#    This program is free software: you can redistribute it and/or modify

#    it under the terms of the GNU General Public License as published by

#    the Free Software Foundation, either version 3 of the License, or

#    (at your option) any later version.

#

#    This program is distributed in the hope that it will be useful,

#    but WITHOUT ANY WARRANTY; without even the implied warranty of

#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

#    GNU General Public License for more details.

#

#    You should have received a copy of the GNU General Public License

#    along with this program.  If not, see <http://www.gnu.org/licenses/>.

#

#    for required libraries

#    apt-get -y install libnet-imap-simple-ssl-perl libyaml-tiny-perl libhash-merge-simple-perl libclone-perl

use strict;

use warnings;

use Net::IMAP::Simple; # libnet-imap-simple-ssl-perl

use POSIX; # to get floor and ceil

use YAML::Tiny; # apt-get libyaml-tiny-perl under debian

use Clone 'clone'; # libclone-perl

use Hash::Merge::Simple qw/ merge clone_merge /; # libhash-merge-simple-perl

use Data::Dumper;

# globals

my $CONFIG_FILE_NAME = 'archiveIMAP.yaml';

# the default values for everything. These are overridden

# by default values in the conf file (.yaml) or by individual

# accounts entries.

my $config = {

   'default' => {

      # where the mail is going to

      'target' => {

                  # these have no defaults. They should be in the configuration file

                  # 'password' => 'password',

                  # 'username' => 'username',

                  # hierarchy can be any combination of <path>, <month> and <year>

                  'hierarchy' => '<path>',

                  # default target server

                  'server' => 'localhost',

                 },

      # where the mail is coming from

      'source' => {

                  # these have no defaults. They should be in the configuration file

                  # 'password' => 'password',

                  # 'username' => 'username',

                  # Anything older than this is archived

                  # number of days unless followed by 'M' or 'Y', in which case it is

                  # multiplied by the number of days in a year (365.2425) or days in a month (30.5)

                  # may be a float, ie 1.25Y is the same as 15M

                  'age' => '1Y',

                  # if set to 1, any folders emptied out will be deleted EXCEPT system folders

                  'deleteEmptyFolders' => 0,

                  # default source server

                  'server' => 'localhost',

                  # these folders are considered system folders and never deleted, case insensitive

                  'system' => [

                                 'Outbox',

                                 'Sent Items',

                                 'INBOX'

                              ],

                  # these folders are ignored, ie not processed at all. Case insensitive

                  'ignore' => [

                                 'Deleted Messages',

                                 'Drafts',

                                 'Junk E-mail',

                                 'Junk',

                                 'Trash'

                               ],

                  # if 1, after successful copy to target, remove from source

                  'deleteOnSuccess' => 0

               },

      # if 1, does a dry run showing what would have happened

      'testing' => 0,

      # if 0, will not be processed

      'enabled' => 1,

   }

   };

#

# find where the script is actually located as cfg should be there

#

sub getScriptLocation {

   use strict;

   use File::Spec::Functions qw(rel2abs);

   use File::Basename;

   return dirname(rel2abs($0));

}

#

# Read the configuration file from current location 

# and return it as a string

#

sub readConfig {

   my $scriptLocation = &getScriptLocation();

   if ( -e "$scriptLocation/$CONFIG_FILE_NAME" ) {

      my $yaml = YAML::Tiny->read( "$scriptLocation/$CONFIG_FILE_NAME" );

      # use clone_merge to merge conf file into $config

      # overwrites anything in $config if it exists in the config file

      $config = clone_merge( $config, $yaml->[0] );

      return 1;

   }

   return 0;

}

# merges default into current account, overwriting anything not defined in account with

# value from default EXCEPT arrays labeled in @tags, which will be merged together.

sub fixupAccount {

   my ( $default, $account ) = @_;

   # these arrays, part of source, will be appended together instead of being overwritten

   my @tags = ( 'ignore', 'system' );

   # merge the tags in question. NOTE: they can only be in source

   foreach my $tag ( @tags) {

      if ( $default->{'source'}->{$tag} && $account->{'source'}->{$tag} ) {

         my @j = ( @{$default->{'source'}->{$tag}}, @{$account->{'source'}->{$tag}} );

         $account->{'source'}->{$tag} = \@j;

      }

   }

   # now, merge account and default, with account taking precedence.

   return  clone_merge(  $default, $account );

   #my $c = clone_merge(  $default, $account );

   #return $c;

}

#

# Open an IMAP connection

#

sub openIMAPConnection {

   my ( $server, $username, $password ) = @_;

   my $imap = Net::IMAP::Simple->new( $server ) ||

    die "Unable to connect to IMAP: $Net::IMAP::Simple::errstr\n";

   # Log on

   if(!$imap->login( $username, $password )){

     die "Login failed: " . $imap->errstr . "\n";

   }

   return $imap;

}

#

# returns a string in proper format for RFC which is $age days ago

# $age is a float, possibly followed by a single character modifier

#

sub getDate {

   my $age = shift;

   # allow modifier to age which contains 'Y' (years) or 'M' (months)

   # Simply set multiplier to the correct value, then multiply the value

   $age = lc( $age );

   if ( $age =~ m/([0-9.]+)([a-z])/ ) {

      my $multiplier = ($2 == 'y' ? 365.2425 : ( $2 == 'm' ? 30.5 : MAXINT) );

      $age = floor( $1 * $multiplier);

   }

   my @months = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');

   my @now = localtime(time - 24 * 60 * 60 * $age);

   $now[4] = @months[$now[4]];

   $now[5] += 1900;

   my $date = sprintf( "%d-%s-%d", $now[3],$now[4],$now[5] ) ; # '1-Jan-2014';

   return $date;

}

#

# Get a list of all folders to be processed

# currently, it just weeds out items in the ignore list

#

sub getFolders {

   my ($imap, $ignore, $separator) = @_;

   $separator = '\\' . $separator;

   # build a regex that will be used to filter the input

   # assuming Trash, Drafts and Junk are in the ignore list

   # and a period is the separator, the generated regex is

   # (^|(\.))((Trash)|(Drafts)|(Junk))((\.)|$)

   # which basically says ignore those folders, but not substrings of them

   # ie, Junk02 would not be filtered but Junk would

   my $ignoreRegex = "(^|($separator))((" . join( ")\|(", @$ignore ) . "))(($separator)|\$)";

   # read all mailboxes and filter them with above regex into @boxes

   my @boxes = grep{ ! /$ignoreRegex/ } $imap->mailboxes;

   return \@boxes;

}

#

# make a folder on the IMAP account. The folder is assumed to be the

# fully qualified path with the correct delimiters

#

sub makeFolder {

   my ($imap, $folder, $delimiter) = @_;

   print "\n\t\tCreating folder $folder";

   # you must create the parent folder before creating the children

   my $escapedDelimiter = '\\' . $delimiter;

   my @folders = split( $escapedDelimiter, $folder );

   $folder = '';

   # take them from the left and, if they don't exist, create it

   while ( my $subdir = shift @folders ) {

      $folder .= $delimiter if $folder;

      $folder .= $subdir;

      next if $imap->select( $folder ); # already created, so look deeper in hierachy

      print "\n\t\t\tCreating subfolder $folder";

      $imap->create_mailbox( $folder ) || warn $imap->errstr();

      $imap->folder_subscribe( $folder ) || die $imap->errstr();

      unless ( $imap->select( $folder ) ) { # verify it was created

         warn "Unable to create $folder on target account\n";

         return 0;

      } # unless

   } # while

   return $folder;

}

#

# Delete an IMAP folder

#

sub deleteAFolder {

   my ($sourceAccount, $folder, $separator, $systemFolders) = @_;

   return 1 if $folder eq 'INBOX'; # do NOT mess with INBOX

   return 2 if $sourceAccount->select($folder) > 0; # do not mess with it if it still has messages in it

   return 3 if $sourceAccount->mailboxes( $folder . $separator . '*' ); # do not mess with it if it has subfolders

   return 4 if ( ref ( $systemFolders ) eq 'ARRAY' ) && ( grep{$_ eq $folder} @$systemFolders );

   print "\n\t\tDeleting empty folder $folder";

   $sourceAccount->folder_unsubscribe($folder);

   $sourceAccount->delete_mailbox( $folder );

}

# main process loop to handle one account

#

sub processAccount {

   my $account = shift;

   my $date = &getDate( $age );

   print "\t" . ( $deleteOnSuccess ? 'Moving' : 'Copying' ) . " all messages before $date\n";

   # open and log into both source and target, and get the separator used

   my $sourceAccount = &openIMAPConnection( $$source{'server'}, $$source{'username'}, $$source{'password'} );

   my $targetAccount = &openIMAPConnection( $$target{'server'}, $$target{'username'}, $$target{'password'} );

   $$source{'separator'} = $sourceAccount->separator unless $$source{'separator'};

   $$target{'separator'} = $targetAccount->separator unless $$target{'separator'};

   # get a list of all folders to be processed on the source

   $$source{'folders'} = &getFolders( $sourceAccount, $ignore, $$source{'separator'} );

   #print Dumper( $targetAccount );

   #die;

   my $folderList = $$source{'folders'};

   my $count = 0; # count the number of messages processed

   my $processedCount = 0; # count the number of folders processed

   foreach my $folder ( @$folderList ) {

      print "\t$folder";

      my $messages;

      $messages = &processFolder( $sourceAccount, $targetAccount, $folder, $date, $$source{'separator'}, $$target{'separator'}, $deleteOnSuccess );

      $TESTING ? print "Would expunge $folder\n" : $sourceAccount->expunge_mailbox( $folder );

      # delete folder if empty and client has requested it.

      ( $TESTING ? print "Would delete $folder\n" : &deleteAFolder( $sourceAccount, $folder, $$source{'separator'}, $$source{'systemfolder'} ) ) if ( $deleteEmptyFolders );

      print "\n\t\t$messages processed\n";

      $count += $messages;

      $processedCount++;

      # next line used only for testing. Dies after 5 folders on first account

      # last if $processedCount > 5;

   }

   $sourceAccount->quit;

   $targetAccount->quit;

   return $count;

}

#######################################################################

#                   Main                                              #

#######################################################################

# read and evaluate configuration file

&readConfig() || die "could not load config file\n";

#print Dumper( $config ); die;

foreach my $account ( keys %{$config->{'accounts'}} ) {

    $config->{'accounts'}->{$account} = &fixupAccount( $config->{'default'}, $config->{'accounts'}->{$account} );

}

#print Dumper( $config ) ; die;

# just a place to gather some stats

my %processed;

$processed{'Accounts'} = 0;

$processed{'Messages'} = 0;

# grab only the accounts for simplicity

my $accounts = $config->{'accounts'};

# now, process each in turn

foreach my $account ( keys %$accounts ) {

   # talk to user

   print "Processing account $account\n";

   # do the account. This is the main worker bee

   $accounts->{$account}->{'processed'} = &processAccount( $accounts->{$account} );

   print "Done, $accounts->{$account}->{'processed'} messages copied\n";

   $processed{'Accounts'}++;

   $processed{'Messages'} += $accounts->{$account}->{'processed'};

} # foreach loop

print "$processed{'Accounts'} accounts processed, $processed{'Messages'} messages\n";

1;