#!/usr/bin/perl -w

# an alternative to built-in emails archiving in CommuniGate Pro 
#
# Mail your comments to support@communigate.ru


use strict;
use CLI;  #get one from www.communigate.ru/CGPerl
use POSIX qw(mktime);

####  YOU SHOLD REDEFINE THESE VARIABLES !!!

my $CGServerAddress = '127.0.0.1';
my $Login='postmaster';
my $Password='pass';


my $archiveAfter=60; # days

my $ArchiveMailbox="Archive";
#my $ArchiveMailbox="&BBAEQARFBDgEMg-";

my $IncomingMailbox="Received";
my $OutgoingMailbox="Sent";
#my $IncomingMailbox="&BBIERQQ+BDQETwRJBDgENQ-";
#my $OutgoingMailbox="&BBgEQQRFBD4ENARPBEkEOAQ1-";

# also un-commend one of the lines below to choose between all domains/one domain/one account

#### end of the customizeable variables list


my $imap = new IO::Socket::INET(   PeerAddr => $CGServerAddress,
                                    PeerPort => 143,
                                    Timeout  => 600
                               ) 
   || die "*** Can't connect to CGPro via IMAP.\n";                                

$imap->autoflush(1);
my $responseLine = <$imap>;

print $imap "x LOGIN $Login $Password\015\012";
do {
  $responseLine = <$imap>;
}until($responseLine =~/^x /);
die "*** Can't login to CGPro IMAP: $responseLine.\n"
  unless($responseLine =~ /^x OK/);



my $cli = new CGP::CLI( { PeerAddr => $CGServerAddress,
                          PeerPort => 106,
                          login    => $Login,
                          password => $Password } )
   || die "*** Can't login to CGPro CLI: ".$CGP::ERR_STRING."\n";

my $archiveDate=time()-$archiveAfter*60*60*24;

# un-comment one of the below lines


#processAccount('aaa');

processAccount('user@company.com');
#processDomain('company.com');
#processAllDomains();
#processFile('accountList.txt');



print "Done\n";
$cli->Logout();
print $imap "x LOGOUT\015\012";
exit;


sub processFile {
  my ($fname)=@_;
  open(FILE,$fname) || die "can't open $fname: $!\n";
  while(<FILE>) {
    chomp;
    next if(/^#/);
    my $account=$_;
    if(length($account)>3) {
      processAccount($account);
    }
  }
  close(FILE);
}

sub processAllDomains {
  my $DomainList = $cli->ListDomains()
               || die "*** Can't get the domain list: ".$cli->getErrMessage.", quitting";
  foreach(@$DomainList) {
    processDomain($_);
  }
}         

sub processDomain {
  my $domain=$_[0];
#  print "Domain: $domain\n";

  my $cookie="";
  do {
    my $data=$cli->ListDomainObjects($domain,5000,undef,'ACCOUNTS',$cookie);
    unless($data) {
      print "*** Can't get accounts for $domain: ".$cli->getErrMessage."\n";
      return;
    }
    $cookie=$data->[4];
    foreach(keys %{$data->[1]} ) {
      processAccount("$_\@$domain"); 
    }
  }while($cookie ne '');
 
}


sub processAccount {
  my ($account)=@_;
  print "Account: $account\n";  

  $cli->CreateMailbox($account,"$ArchiveMailbox");
  $cli->CreateMailbox($account,"$ArchiveMailbox/$IncomingMailbox");
  $cli->CreateMailbox($account,"$ArchiveMailbox/$OutgoingMailbox");
  
  processMailbox($account,'INBOX',"$IncomingMailbox",1);
  
  my $prefs=$cli->GetAccountEffectivePrefs($account);
  my $sentBox=$prefs->{SentBox} || "Sent Items";
  processMailbox($account,$sentBox,"$OutgoingMailbox",1);
  
  #archive sub-folders of INBOX without separating dates
  my $mailboxesList=$cli->ListMailboxes(accountName=>$account,filter =>'INBOX/*');  
  unless($mailboxesList) {
    print "*** Can't list mailboxes for $account: ".$cli->getErrMessage."\n";
    return;
  }
  foreach(sort keys %$mailboxesList) {
    my $data=@$mailboxesList{$_};
    if(ref $data eq 'ARRAY') {
      $data=@$data[0];
    }   
    if(ref $data eq 'HASH') {
      my $mailbox=$_;
      my $target=$mailbox; $target=~s/^INBOX\///;
      processMailbox($account,$mailbox,"$IncomingMailbox/$target",0);
    }
  }
}


sub MakeDateString {
  my ($theTime)=@_;
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =  gmtime($theTime);
  return sprintf("%04d-%02d",$year+1900,$mon+1);
}

sub ConvDate {
  my ($sec,$min,$hour,$mday,$month,$year);
  my %mNames=qw(Jan 0 Feb 1 Mar 2 Apr 3 May 4 Jun 5
                Jul 6 Aug 7 Sep 8 Oct 9 Nov 10 Dec 11);
  if($_[0] =~ /(\d{1,2}).(\w\w\w).(\d\d\d\d)/) {
    $mday=$1;
    $month=$mNames{$2};
    $year=$3-1900;
    $hour=0;
    $min=0;
    $sec=0;
  } else{
    print "Unknown date format: \"$_[0]\" ";
    return time();
  }
  return POSIX::mktime($sec,$min,$hour,$mday,$month,$year);
}

sub processMailbox {
  my ($account,$mailbox,$target,$splitDates)=@_;
  #print "Mailbox: $mailbox\n";
  
  print $imap "x SELECT \"~$account/$mailbox\"\015\012";
  do {
    $responseLine = <$imap>;
  }until($responseLine =~/^x /);
  unless($responseLine =~ /^x OK/) {
    print "*** Can't select ~$account/$mailbox: $responseLine.\n";
    return;
  }
  
  my %msgList;
  print $imap "x FETCH 1:* (UID INTERNALDATE)\015\012";
  do {
    $responseLine = <$imap>;
    if($responseLine=~/UID (\d+).*INTERNALDATE \"(\S+) /) { #"
      my $d=ConvDate($2);
      if($d<$archiveDate) {
        $msgList{$1}=$d;
        #print "$1 $2\n";
      }
    }    
  }until($responseLine =~/^x /);
  unless($responseLine =~ /^x OK/) {
    print "*** Can't fetch ~$account/$mailbox: $responseLine.\n";
    return;
  }
  
  unless($splitDates) {
    my $boxName="~$account/$ArchiveMailbox/$target";
    print $imap "x CREATE \"$boxName\"\015\012";
    do {
      $responseLine = <$imap>;
    }until($responseLine =~/^x /);
    print $imap "x UID MOVE ".join(',',sort {$a <=> $b} keys %msgList)." \"$boxName\"\015\012";
    do {
      $responseLine = <$imap>;
    }until($responseLine =~/^x /);
    unless($responseLine =~ /^x OK/) {
      print "*** Can't move to $boxName: $responseLine.\n";
      #return;
    }  
    print scalar(keys %msgList)." messages archived from ~$account/$mailbox\n";
    return;
  }
  
  my (@msgID,@msgDate);
  foreach (sort {$msgList{$a} <=> $msgList{$b} } keys %msgList) {
    push(@msgID,$_);
    push(@msgDate,$msgList{$_});
  }
  my $idx=0;
  while($idx<scalar(@msgID)) {
    my $boxDate=MakeDateString($msgDate[$idx]);
    my $boxName="~$account/$ArchiveMailbox/$target/$boxDate";
    print $imap "x CREATE \"$boxName\"\015\012";
    do {
      $responseLine = <$imap>;
    }until($responseLine =~/^x /);
    my $n=1;
    while($idx+$n<scalar(@msgID) && $boxDate eq MakeDateString($msgDate[$idx+$n]) ) {
      $n++;
    }

    print $imap "x UID MOVE ".join(',',@msgID[$idx ... $idx+$n-1])." \"$boxName\"\015\012";
    do {
      $responseLine = <$imap>;
    }until($responseLine =~/^x /);
    unless($responseLine =~ /^x OK/) {
      print "*** Can't move to $boxName: $responseLine.\n";
      #return;
    }
    $idx+=$n;
  }
  print scalar(@msgID)." messages archived from ~$account/$mailbox\n";
}

