#!/usr/bin/perl -w
#
# cleanCalendars.pl
#
# Moves old calendar events (except recurrent events) from all calendar folders
# into sub-folder calendars of Archive folder.
#
# Revision: 7-Jan-2023
# Revision: 11-Jan-2023
# Revision: 19-Jan-2023
#
# Mail your comments to support@communigate.ru
#

use strict;
use Socket qw(PF_INET SOCK_STREAM inet_ntoa inet_aton sockaddr_in);
use Encode qw/encode decode/;
use XML::Parser;
use utf8;
use CLI;  #get one from www.communigate.ru/CGPerl

use Data::Dumper;

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

my $CGServerAddress =  '127.0.0.1';   
my $XIMSSPort = 11024;   # ports 11024 (XIMSS) and 106 (PWD/CLI) must be open

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

my $archiveName = "Archive";
my $keepDays = 365*2; # remove events older this number of days

my $debug=0;

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

#### end of the customizeable variables list


binmode(STDOUT, ":utf8");

print "Starting.\n";
my $ip=inet_aton($CGServerAddress) || die "no host: $CGServerAddress\n";
my $CGServerIP=inet_ntoa($ip) || die "no host: $CGServerAddress";


my $errCode;
my @responses;

my $xmlParser = new XML::Parser(Style => 'Tree');

$errCode=XIMSS_Connect($CGServerAddress,$XIMSSPort);
if($errCode) {
  print "Unable to connect to CGPro XIMSS: $errCode\n";
  exit(1);
}
$errCode=XIMSS_Login($Login,$Password);
if($errCode) {
  print "XINSS login failed: $errCode\n";
  exit(1);
}
XIMSS_readProvisioning();


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



# un-comment one of the below lines

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



print "Done\n";
$cli->Logout();
XIMSS_Logout();
XIMSS_Disconnect();

exit;

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 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 processAccount {
  my $account=$_[0];
  print "Account: $account\n";

   
  my $mailboxesList=$cli->ListMailboxes(accountName=>$account);  
  unless($mailboxesList) {
    print "*** Can't list mailboxes for $account: ".$cli->getErrMessage."\n";
    return;
  }
  foreach(keys %$mailboxesList) {
    my $data=@$mailboxesList{$_};
    next if(/^$archiveName\//);
    if(ref $data eq 'ARRAY') {
      $data=@$data[0];
    }   
    if(ref $data eq 'HASH') {
      my $nMessages=@$data{'Messages'};
      if($nMessages) {
        $nMessages=~s/^#//;
        if($nMessages>0 && $data->{Class} && $data->{Class} eq 'IPF.Appointment') {
          processCalendar($account,$_);
        }
      }  
    }
  }  
  
}

sub processCalendar {
  my ($account,$mailbox)=@_;
  my $mailboxUTF8 = encode('UTF-8',imap_utf7_decode($mailbox));
  my $calendarName = "~$account/$mailboxUTF8";

  my $errCode = checkError( XIMSS_command('calendarOpen',{calendar=>$calendarName}) );
  if($errCode) {
    print "Failed to open calendar '$calendarName': $errCode\n";
    return;
  }

  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time()-$keepDays*24*60*60); 
  my $tm2 = sprintf("%04d%02d%02dT%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec);
  my $tm1 = sprintf("%04d%02d%02dT%02d%02d%02d",$year+1900 - 10,$mon+1,$mday,$hour,$min,$sec);
  $errCode=checkError( XIMSS_command('findEvents ',{calendar=>$calendarName,timeFrom=>$tm1, timeTill=>$tm2}) );
  if($errCode) {
    print "Failed to browse '$calendarName': $errCode\n";
    return;
  }
  
  my @eventList;
  
  foreach my $line (@responses) {
    my $item=$xmlParser->parse($line);
#print Dumper($item);    
    if($item->[0] eq 'events') {
      my $items  = $item->[1]->[0]->{'items'};
      for(my $i=0;$i<$items;$i++) {
        my $ref = $item->[1]->[2*$i+2]->[0];
        next if($ref->{'recurrence'} && $ref->{'recurrence'} eq 'yes');
        push(@eventList,$ref->{'UID'});
      }         
    }
  }
  
  $errCode = checkError( XIMSS_command('calendarClose',{calendar=>$calendarName}) );
  if($errCode) {
    print "Failed to close calendar '$calendarName': $errCode\n";
    return;
  }

  return if(scalar @eventList == 0);

  my $count=0;
  $errCode = checkError( XIMSS_command('folderOpen',{folder=>$calendarName,sortField=>"INTERNALDATE",sortOrder=>"asc"},"<field>UID</field><field>Date</field>") );
  if($errCode) {
    print "Failed to open '$calendarName': $errCode\n";
    return;
  }
    
  foreach my $uid (@eventList) {
    $errCode = checkError( XIMSS_command('messageMove',{folder=>$calendarName,targetMailbox=>"~$account/$archiveName/$mailboxUTF8",mailboxClass=>"IPF.Appointment"},"<UID>$uid</UID>") );
    if($errCode) {
      print "Failed to move $uid '$calendarName'->'$archiveName/$mailboxUTF8': $errCode\n";
    } else {
      $count++;
    }
  };   
    
    
  $errCode = checkError( XIMSS_command('folderClose',{folder=>$calendarName}) );
  if($errCode) {
    print "Failed to close '$calendarName': $errCode\n";
    # return;
  }
  print "  $count events moved from '$calendarName'\n";
}

sub imap_utf7_decode {
	my ($s) = @_;

	$s =~ s/\+/PLUSPLACEHOLDER/g;
	$s =~ s/&([^,&\-]*),([^,\-&]*)\-/&$1\/$2\-/g;
	$s =~ s/&(?!\-)/\+/g;
	$s =~ s/&\-/&/g;
	$s =~ s/PLUSPLACEHOLDER/+-/g;
	return decode("UTF-7",$s);
	#return Unicode::String::utf7($s)->latin1;
}

sub XIMSS_Connect {
  my ($address,$port)=@_;
  $port=11024 unless($port);
  
  my $iaddr   = inet_aton($address);
  unless($iaddr) {
    return "no host: $address";
  }  
  my $paddr   = sockaddr_in($port, $iaddr);

  my $proto   = getprotobyname('tcp');
  unless(socket(SOCK, PF_INET, SOCK_STREAM, $proto)) {
    return "socket error: $!";
  }  
  unless(connect(SOCK, $paddr)) {
    return "connect error: $!";
  }
  undef;
}

sub XIMSS_Disconnect {
  close (SOCK) || die "close: $!";
}

sub XIMSS_Login {
  my ($login,$password)=@_;
  return checkError(XIMSS_command('login',{authData=>$login,password=>$password, exeTime=>1 }));
}

sub XIMSS_Logout {
  return checkError(XIMSS_command('bye'));
}


our $idCounter=0;

sub XIMSS_command {
  my ($command, $paramsRef,$body)=($_[0],$_[1],$_[2]);

  my $id='a'.$idCounter++;
  my $cmd="<$command id=\"$id\"";
  if($paramsRef) {
    if(ref($paramsRef) eq 'HASH') {
      foreach(keys(%$paramsRef)) {
        if(@$paramsRef{$_}) {
          $cmd.=" $_=\"@$paramsRef{$_}\"";
        } else {
          $cmd.=" $_=\"\"";
        }  
      }
    } else {
      $cmd.=' '.$paramsRef;
    }
  }  
  if($body) {
    $cmd.=">$body</$command>";
   } else {  
    $cmd.='/>';
  }
  sendCommand($cmd);
#  sleep(1);
  @responses=();
#  while(isReadable()) {
  while(1) {
    my $line = readLine(); 
    print "response: $line\n" if($debug);
    if($line =~ /^<response id=\"$id\"/ ) { #"
      return $line;
    }
    push(@responses,$line);
  }
  undef;
}

sub XIMSS_readProvisioning {
  while(isReadable()) {
    my $line = readLine();
    print "provisioned: $line\n\n" if($debug);
    push(@responses,$line);
  }
}


 
sub checkError {
  my $dataRef=$_[0];
  return '' unless($dataRef);
  #print "errorCheck=".Dumper($dataRef)."\n";  

  if(ref($dataRef) eq 'ARRAY') { #parsed XML
    my $lastItem=$dataRef->[scalar(@$dataRef)-1];
    if(ref($lastItem) eq 'ARRAY') {
      $lastItem=$lastItem->[0];
      if(ref($lastItem) eq 'HASH') {
        my $eText=@$lastItem{'errorText'};
        return $eText if($eText);
      }
    }
  } else { #raw XML string
    if($dataRef=~/errorText=\"(.*?)\"/) { #"
      return $1;
    }
  }
  return '';
} 
 
sub sendCommand {
  my ($command)=@_;
  print "sending: $command\n" if($debug);
  send(SOCK,$command ."\0",0);
}

sub isReadable {
 my $rin = '';
 vec($rin, fileno(SOCK), 1) = 1;
 return select( $rin, undef, undef, 0);
}
    
sub readLine {
  my $ln='';
  for(;;) {
    my $ch;
    recv(SOCK,$ch,1,0);
    last if($ch eq "\0");
    $ln.=$ch;
  }
  return $ln;
}



__END__

