#!/usr/bin/perl

# $Header: /mhub4/sources/imap-tools/maildir_to_imap.pl,v 1.5 2012/02/29 01:19:37 rick Exp $

##########################################################################
#   Program name    maildir_to_imap.pl                                   #
#   Written by      Rick Sanders                                         #
#                                                                        #
#   Description                                                          #
#                                                                        #
#   maildir_to_imap is used to copy the messages in a maildir to a       #
#   user's IMAP mailbox.  maildir_to_imap is executed like this:         #
#                                                                        #
#   ./maildir_to_imap.pl -i <user list> -D <imapserver[:port]>           #
#                                                                        #
#   The user list is a file with one or more entries containing the      #
#   location of the user's maildir and his IMAP username and password.   #
#                                                                        #
#   For example:                                                         #
#         /mhub4/maildirs/rwilson@abc.net,rich.wilson,welcome            #
#         /mhub4/maildirs/jane.eyre@abc.net,jane.eyre,mypass             #
#                                                                        #
#   See usage() for a list of arguments                                  #
##########################################################################

use IMAP::Utils;

init();
$debug = 1;
get_user_list( \@users );
migrate_user_list( \@users );

exit;


sub migrate_user_list {

my $users = shift;

  #  Migrate a set of users

  foreach $userinfo ( @$users ) {
     $usercount++;
     ($user) = split(/\s*,\s*/, $userinfo);
     Log("migrate $user");

     #  Start the migration.  Unless maxChildren has been set to 1
     #  fork off child processes to do the migration in parallel.
 
     if ($maxChildren == 1) {
	migrate ($userinfo, $imaphost);
     } else {
  	Log("There are $children running") if $debug;
  	if ( $children < $maxChildren ) {
   	   Log("   Forking to migrate $user") if $debug;
     	   if ( $pid = fork ) {	# Parent
	      Log ("   Parent $$ forked $pid") if $debug;
     	   } elsif (defined $pid) {	# Child
	      Log ("  Child process $$ processing $sourceUser") if $debug;
              migrate($userinfo, $imaphost);
              Log("   $user is done");
              exit 0;
     	   } else {
              Log("Error forking child to migrate $user");
              next;
     	   }
     	   $children++;
     	   $children{$pid} = $user;
  	} 

  	Log ("I'm PID $$") if $debug;
  	while ( $children >= $maxChildren ) {
     	   Log(" $$ - Max children running.  Waiting...") if $debug;
     	   $foundPid = wait;	# Wait for a child to terminate
	   if ($? != 0) {
	      Log ("ERROR: PID $foundPid exited with status $?");
	   }
	   delete $children{$foundPid};
     	   $children--;
  	}
  	Log("OK to launch another user migration") if $debug;
  }

}
}

sub xxxx {

   if ($maxChildren > 1) {
      Log("All children have been launched, waiting for them to finish");
      foreach $pid ( keys(%children) ) {
         $user = $children{$pid};
         Log("Waiting on process $pid ($user) to finish");
         waitpid($pid, 0);
         if ($? != 0) {
            Log ("ERROR: PID $pid exited with status $?");
         }
      }
   }
}


sub    sum {
summarize();
$elapsed = sprintf("%.2f", (time()-$start)/3600);
Log("Elapsed time  $elapsed hours");
Log("Migration completed");
exit;
}

sub migrate {
  
my $userinfo = shift;
my $imaphost = shift;

   my ($user,$pwd,$userpath) = split(/,/, $userinfo);

   return unless connectToHost($imaphost, \$dst);
   return unless login($user,$pwd, $dst);

   get_maildir_folders( $userpath, \%folders );

   my $messages;
   foreach $maildir_folder ( keys %folders ) {
      print STDERR "maildir_folder $maildir_folder\n";
      $maildir_folder =~ s/\&/&-/;   # Encode the '&' char
      $maildir_folder =~ s/\s+$//;
      $folder_path = $folders{"$maildir_folder"};
      createMbx( $maildir_folder, $dst ) unless mbxExists( $maildir_folder, $dst );

      get_maildir_msgs( $folder_path, \@msgs );
      my $msgcount = $#msgs + 1;
      Log("     $maildir_folder ($msgcount msgs) $folder_path");
 
      next if !@msgs;

      $inserted=0;
      foreach $msgfn ( @msgs ) {
         $inserted++ if insert_msg( $msgfn, $maildir_folder, $dst );
      }
      Log("     Inserted $inserted messages into $maildir_folder\n");
   }

   $conn_timed_out=0;

}

sub init {

use Getopt::Std;
use Fcntl;
use Socket;
use IO::Socket;
use sigtrap;
use FileHandle;
require "ctime.pl";
   
   $start = time();

   #  Set up signal handling
   $SIG{'ALRM'} = 'signalHandler';
   $SIG{'HUP'}  = 'signalHandler';
   $SIG{'INT'}  = 'signalHandler';
   $SIG{'TERM'} = 'signalHandler';
   $SIG{'URG'}  = 'signalHandler';

   getopts('H:i:L:n:ht:M:SLdD:Um:I');

   # usage() if $opt_h;
   #  usage();

   $userlist     = $opt_i;
   $logfile      = $opt_L;
   $maxChildren  = $opt_n;
   $usage        = $opt_h;
   $timeout      = $opt_t;
   $imaphost     = $opt_H;
   $imaphost     = $opt_D;
   $mbxList      = $opt_m;
   $debug=1      if $opt_d;
   $showIMAP=1   if $opt_I;

   $timeout = 45 unless $timeout;
   $maxChildren = 1 unless $maxChildren;

   IMAP::Utils::init();
   $logfile = "maildir_to_imap.log" unless $logfile;
   openLog($logfile);
   Log("$0 starting");

   $date = ctime(time);
   chomp($date);

}

sub usage {

   print "\nUsage:  iu-maildirtoimap -i <users> -D imapHost\n\n";
   print "Optional arguments:\n\n";
   print " -i <file of usernames>\n";
   print " -n <number of simultaneous migration processes to run>\n";
   print " -m <list of mailboxes> eg Inbox,Drafts,Sent\n";
   print " -L <logfile, default is maildir_to_imap.log>\n";
   print " -t <timeout in seconds>\n";
   print " -d debug mode\n";
   print " -I record IMAP protocol exchanges\n\n";
   exit;

}


sub format_bytes {

my $bytes = shift;

   #  Format the number nicely

   if ( length($bytes) >= 10 ) {
      $bytes = $bytes/1000000000;
      $tag = 'GB';
   } elsif ( length($bytes) >= 7 ) {
      $bytes = $bytes/1000000;
      $tag = 'MB';
   } else {
      $bytes = $bytes/1000;
      $tag = 'KB';
   }

   # commafy
   $_ = $bytes;
   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
   $bytes = sprintf("%.2f", $_) . " $tag";

   return $bytes;
}


sub commafy {

my $number = shift;

   $_ = $number;
   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
   $number = $_;

   return $number;
}

#  Reconnect to a server after a timeout error.
#
sub reconnect {

my $checkpoint = shift;
my $conn = shift;

   Log("This is reconnect, conn is $conn") if $debug;
   logout( $conn );
   close $conn;
   sleep 5;
   ($mbx,$shost,$suser,$spwd,$dhost,$duser,$dpwd) = split(/\|/, $checkpoint);
   if ( $conn eq $src ) {
      $host = $shost;
      $user = $suser;
      $pwd  = $spwd;
   } else { 
      $host = $dhost;
      $user = $duser;
      $pwd  = $dpwd;
   }
   connectToHost($host,$conn);
   login($user,$pwd,$conn);
   selectMbx( $mbx, $conn );
   createMbx( $mbx, $dst );   # Just in case
   Log("leaving reconnect");
}

#  Handle signals

sub signalHandler {

my $sig = shift;

   if ( $sig eq 'ALRM' ) {
      Log("Caught a SIG$sig signal, timeout error");
      $conn_timed_out = 1;
   } else {
      Log("Caught a SIG$sig signal, shutting down");
      exit;
   }
}

#  Get the total message count and bytes and write
#  it to the log.  

sub summarize {

   #  Each child appends its totals to /tmp/migrateEmail.sum so
   #  we read the lines and add up the grand totals.

   $totalUsers=$totalMsgs=$totalBytes=0;
   open(SUM, "</tmp/migrateIMAP.sum");
   while ( <SUM> ) {
      chomp;
      ($msgs,$bytes) = split(/\|/, $_);
      $totalUsers++;
      $totalMsgs  += $msgs;
      $totalBytes += $bytes;
   }

   $_ = $totalMsgs;
   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;  #  Commafy the message total
   $totalMsgs = $_;
   $totalBytes = formatBytes( $totalBytes );

   Log("Summary of migration");
   Log("Migrated $totalUsers users, $totalMsgs messages, $totalBytes.");

}

sub fix_ts {

my $date = shift;

   #  Make sure the hrs part of the date is 2 digits.  At least
   #  one IMAP server expects this.

   $$date =~ s/^\s+//;
   $$date =~ /(.+) (.+):(.+):(.+) (.+)/;
   my $hrs = $2;
   
   return if length( $hrs ) == 2;

   my $newhrs = '0' . $hrs if length( $hrs ) == 1;
   $$date =~ s/ $hrs/ $newhrs/;

}

sub stats {

   print "\n";
   print "Users migrated   $users\n";
   print "Total messages   $total_msgs\n";
   print "Total bytes      $total_bytes\n";

   $elapsed = time() - $start;
   $minutes = $elapsed/60;
   print "Elapsed time     $minutes minutes\n";

}

sub processArgs {

   if ( !getopts( "" ) ) {
      usage();
   }
}

#  Handle signals

sub signalHandler {

my $sig = shift;

   if ( $sig eq 'ALRM' ) {
      Log("Caught a SIG$sig signal, timeout error");
      $conn_timed_out = 1;
   } else {
      Log("Caught a SIG$sig signal, shutting down");
      exit;
   }
   Log("Resuming");
}

sub insert_msg {

my $msgfn   = shift;
my $folder  = shift;
my $dst     = shift;

   #  Put a message in the user's folder

#  Log("insert $msgfn into $folder") if $debug;

   my $flag = 'Unseen';
   if ( $msgfn =~ /,/ ) {
      $flag = '\\Seen' if $msgfn =~ /,S$/;
   }

   if ( !open(MESSAGE, "<$msgfn")) {
      Log( "    Can't open message fn $msgfn: $!" );
      return 0;
   }
   my ($date,$message,$msgid);
   while( <MESSAGE> ) {
       chomp;
       # print STDERR "message line $_\n";
       if ( /^Date: (.+)/ and !$date ) {
          $date = $1;
       }
       if ( /^Message-Id: (.+)/i and !$msgid ) {
          $msgid = $1;
          Log("msgid $msgid") if $debug;
       }
       $message .= "$_\r\n";
   }
   close MESSAGE;

   fix_date( \$date );

   $status = insert_imap_msg( $dst, $folder, \$message, $flag, $date );

   return $status;

}

sub entry_exists {

my $mail  = shift;
my $ldap  = shift;
my $pwd   = shift;
my $dn;
my $i;

   my $attrs = [ 'mailpassword' ];
   my $base = 'o=site';
   my $filter = "mail=$mail";

   my $result = $ldap->search(
            base   => $base,
            filter => $filter,
            scope  => "subtree",
            attrs  => $attrs
   );

   if ( $result->code ) {
      my $error = $result->code;
      my $errtxt = ldap_error_name( $result->code );
      Log("Error searching for $filter: $errtxt");
      exit;
   }

   my @entries = $result->entries;
   my $i = $#entries + 1;

   $entry = $entries[0];
   $$pwd = $entry->get_value( 'mailpassword' );

   return $i;
}

sub get_user_list {

my $users    = shift;

   #  Build a list of the users and their maildirs

   open(F, "<$userlist") or die "Can't open user list $userlist: $!";
   while( <F> ) {
      chomp;
      s/^\s+//;
      next if /^#/;
      next unless $_;
      my( $maildir,$user,$pwd) = split(/,/, $_);
      push( @$users, "$user,$pwd,$maildir" );
   }
   close F;

}

sub getMailboxList {

my $user = shift;
my $conn = shift;
my @mbxs;
my @mailboxes;

   #  Get a list of the user's mailboxes
   #
  if ( $mbxList ) {
      #  The user has supplied a list of mailboxes so only processes
      #  the ones in that list
      @mbxs = split(/,/, $mbxList);
      foreach $mbx ( @mbxs ) {
         trim( *mbx );
         push( @mailboxes, $mbx );
      }
      return @mailboxes;
   }

   if ($debug) { Log("Get list of user's mailboxes",2); }

   sendCommand ($conn, "1 LIST \"\" *");
   undef @response;
   while ( 1 ) {
	$response = readResponse ($conn);
	if ( $response =~ /^1 OK/i ) {
		last;
	}
	elsif ( $response !~ /^\*/ ) {
		Log ("unexpected response: $response");
		return 0;
	}
   }

   undef @mbxs;

   for $i (0 .. $#response) {
        $response[$i] =~ s/\s+/ /;
        if ( $response[$i] =~ /"$/ ) {
           $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i;
           $mbx = $3;
        } else {
           $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i;
           $mbx = $3;
        }
	$mbx =~ s/^\s+//;  $mbx =~ s/\s+$//;

	if ($response[$i] =~ /NOSELECT/i) {
		if ($debug) { Log("$mbx is set NOSELECT,skip it",2); }
		next;
	}
	if (($mbx =~ /^\#/) && ($user ne 'anonymous')) {
		#  Skip public mbxs unless we are migrating them
		next;
	}
	if ($mbx =~ /^\./) {
		# Skip mailboxes starting with a dot
		next;
	}
	push ( @mbxs, $mbx ) if $mbx ne '';
   }

   if ( $mbxList ) {
      #  The user has supplied a list of mailboxes so only processes
      #  those
      @mbxs = split(/,/, $mbxList);
   }

   return @mbxs;
}

#  getMsgList
#
#  Get a list of the user's messages in the indicated mailbox on
#  the source host
#
sub getMsgList {

my $mailbox = shift;
my $msgs    = shift;
my $conn    = shift;
my $seen;
my $empty;
my $msgnum;
my $from;
my $flags;

   @$msgs  = ();
   trim( *mailbox );
   sendCommand ($conn, "1 EXAMINE \"$mailbox\"");
   undef @response;
   $empty=0;
   while ( 1 ) {
	$response = readResponse ( $conn );
	if ( $response =~ / 0 EXISTS/i ) { $empty=1; }
	if ( $response =~ /^1 OK/i ) {
		# print STDERR "response $response\n";
		last;
	}
	elsif ( $response !~ /^\*/ ) {
		Log ("unexpected response: $response");
		# print STDERR "Error: $response\n";
		return 0;
	}
   }

   if ( $empty ) {
      Log("$mailbox is empty");
      return;
   }

   Log("Fetch the header info") if $debug;

   sendCommand ( $conn, "1 FETCH 1:* (uid flags internaldate body[header.fields (From Date)])");
   undef @response;
   while ( 1 ) {
	$response = readResponse ( $conn );
	return if $conn_timed_out;
	if ( $response =~ /^1 OK/i ) {
	   last;
	} elsif ( $response =~ /could not be processed/i ) {
           Log("Error:  response from server: $response");
           return;
        } elsif ( $response =~ /^1 NO|^1 BAD/i ) {
           return;
        }
   }

   $flags = '';
   for $i (0 .. $#response) {
	$seen=0;
	$_ = $response[$i];

	last if /OK FETCH complete/;

        if ($response[$i] =~ /FLAGS/) {
           #  Get the list of flags
           $response[$i] =~ /FLAGS \(([^\)]*)/;
           $flags = $1;
           $flags =~ s/\\Recent//;
        }

        if ( $response[$i] =~ /INTERNALDATE/) {
           $response[$i] =~ /INTERNALDATE (.+) BODY/;
           # $response[$i] =~ /INTERNALDATE "(.+)" BODY/;
           $date = $1;

           $date =~ /"(.+)"/;
           $date = $1;
           $date =~ s/"//g;
        }

        if ( $response[$i] =~ /\* (.+) FETCH/ ) {
           ($msgnum) = split(/\s+/, $1);
        }

        if ( $msgnum && $date ) {
           if ( $unseen ) {
	      push (@$msgs,"$msgnum|$date|$flags") unless $flags =~ /Seen/i;
           } else {
	      push (@$msgs,"$msgnum|$date|$flags");
           }
           $msgnum = $date = '';
        }
   }

}

#  insert_imap_msg
#
#  This routine inserts an RFC822 message into a user's folder
#
sub insert_imap_msg {

my $conn    = shift;
my $mbx     = shift;
my $message = shift;
my $flags   = shift;
my $date    = shift;
my ($lsn,$lenx);

   $lenx = length($$message);
   Log("   Inserting message") if $debug;
   Log("message size $lenx bytes");

   $date =~ s/\((.+)\)//;
   $date =~ s/\s+$//g;

   $totalBytes = $totalBytes + $lenx;
   $totalMsgs++;

   #  Create the mailbox unless we have already done so
   if ($destMbxs{"$mbx"} eq '') {
      createMbx( $mbx, $conn );
   } 
   $destMbxs{"$mbx"} = '1';

   $flags =~ s/\\Recent//i;
   $flags =~ s/Unseen//i;

   if ( $date ) {
      sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \"$date\" \{$lenx\}");
   } else {
      sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \{$lenx\}");
   }
   
   $response = readResponse ($conn);
   if ($conn_timed_out) {
       Log ("unexpected response timeout appending message");
       push(@errors,"Error appending message to $mbx for $user");
       return 0;
   }
	
   if ( $response !~ /^\+/ ) {
       Log ("unexpected APPEND response: >$response<");
       # next;
       push(@errors,"Error appending message to $mbx for $user");
       return 0;
   }

   print $conn "$$message\r\n";

   undef @response;
   while ( 1 ) {
       $response = readResponse ($conn);
       if ( $response =~ /^1 OK/i ) {
	   last;
       }
       elsif ( $response !~ /^\*/ ) {
	   Log ("Unexpected APPEND response: >$response<");
	   # next;
	   return 0;
       }
   }

   return 1;
}

sub get_maildir_folders {

my $userpath = shift;
my $folders  = shift;

   #  Get a list of the user's folders 
   
   %$folders = ();

   if ( $mbxList ) {
      #  The user has supplied a list of mailboxes
      foreach $mbx ( split(/,/, $mbxList ) ) {
         $$folders{"$mbx"} = $userpath . '/.' . $mbx;
      }
      return;
   }

   opendir D, $userpath;
   my @files = readdir( D );
   closedir D;

   $$folders{'INBOX'} = $userpath;
   foreach $fn ( @files ) {
      next if $fn eq '.';
      next if $fn eq '..';
      next unless $fn =~ /^\./;
      my $fname = $fn;
      $fname =~ s/\./\//;
      $fname =~ s/^\///;
      $$folders{"$fname"} = "$userpath/$fn";
   }

}

sub get_maildir_msgs {

my $path = shift;
my $msgs = shift;
my @subdirs = qw( tmp cur new );

   @$msgs = ();
   foreach $subdir ( @subdirs ) {
      opendir D, "$path/$subdir";
      my @files = readdir( D );
      closedir D;

      foreach $fn ( @files ) {
         next if $fn =~ /^\./;
         my $msgfn = "$path/$subdir/$fn";
         push( @$msgs, $msgfn );
      }
   }

}

sub imap_message_exists {

my $msgid = shift;
my $conn  = shift;
my $msgnum;
my $loops;

   # Search a mailbox on the server for a message by its msgid.

   Log("   Search for $msgid") if $debug;
   sendCommand ( $conn, "1 SEARCH header Message-Id \"$msgid\"");
   while (1) {
        $response = readResponse ($conn);
        if ( $response =~ /\* SEARCH /i ) {
           ($dmy, $msgnum) = split(/\* SEARCH /i, $response);
           ($msgnum) = split(/ /, $msgnum);
        }

        last if $response =~ /^1 OK|^1 NO|^1 BAD/;
        last if $response =~ /complete/i;

        last if $loops++ > 10;
   }

   if ( $debug ) {
      Log("$msgid was not found") unless $msgnum;
   }

   return $msgnum;
}

sub fix_date {

my $date = shift;

   #  Try to make the date acceptable to IMAP

   return if $$date eq '';
   fix_ts( $date );

   $$date =~ s/\((.+)\)$//;
   $$date =~ s/\s+$//g;

   if ( $$date =~ /\s*,\s*/ ) {
      ($dow,$$date) = split(/\s*,\s*/, $$date);
   }
   $$date =~ s/ /-/;
   $$date =~ s/ /-/;

   return;

   my @terms = split(/\s+/, $$date);

   if ( $terms[0] =~ /(.+),/ ) {
      my $dow = $1;
      if ( length( $dow ) > 3 ) {
         #  Day of week can't be more than 3 chars
         my $DOW = substr($dow,0,3);
         $$date =~ s/$dow/$DOW/;
      }
   } 

   if ( $terms[1] =~ /jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec/i ) {
      #  The month and day are swapped.
      my $temp = $terms[1];
      $terms[1] = $terms[2];
      $terms[2] = $temp;
   }

   if ( $terms[5] =~ /\((.+)\)/ ) {
      #  The date is missing the TZ offset
      $terms[5] = "+0000 ($1)";
   }

   if ( $terms[5] =~ /"(.+)"/ ) {
      #  The TZ code has quotes instead of parens
      $terms[5] =~ s/"/\(/;
      $terms[5] =~ s/"/\)/;
      $terms[5] = "+0000 $terms[5]";
   }

   if ( $terms[5] =~ /-[0-9]-[0-9][0-9]/ ) {
      #  Lots of dates are like '-0-500'
      $terms[5] =~ s/-//g;
      $terms[5] = '-' . $terms[5];
   }

   if ( $terms[5] eq '-0-100' ) {
      #  Don't know what this is supposed to mean
      $terms[5] = "+0000";
   }

   if ( $terms[5] eq '00800' ) {
      $terms[5] = "+0800";
   }

   if ( $terms[5] eq '-' ) {
      $terms[5] .= $terms[6];
      $terms[5] =~ s/\s+//g;
      $terms[6] = '';
   }
   if ( $terms[4] =~ /\./ ) {
      $terms[4] =~ s/\./:/g;
   }

   if ( $terms[5] =~ /[a-zA-Z]/ ) {
      $terms[5] = "-0000 ($terms[5])" unless $terms[5] eq 'UT';
   }

   $$date = join( " ", @terms );

}

