Перенос почты из TheBat на сервер Cyrus-IMAP

Так исторически сложилось, что у нас много лет используется корпоративная версия почтового клиента TheBat 3.x!
Все пользователи очень привыкли к ней, накоплена огромная адресная книга в нем. Но куча ограничений (TBB файл не более 2Гб, проблемы с TLS, заточенность под Windows) вновь и вновь поднимает вопрос о переходе на что-то иное.

Было несколько попыток перейти, в одну из них было получено описание формата адресной книги и написан парсер переноса записей в LDAP.
Но время показало, что это неудобный формат адресной книги, люди привыкли в отображению как в TheBat — в виде дерева с раскрывающимися ветвями. Это получилось достичь перенеся книгу в виде ldap файла (ldif) в Thunderbird.

Дальше встала проблема перетащить почту. С незапамятных времен у людей настроен лишь pop3 с локальной базой писем, т.е. каждая папка в почтовой программе это файл MESSAGES.TBB с всей перепиской. Есть несколько способов перенести почту.

  • Экспортировать средствами TheBAT всю почту в виде eml файлов и втянуть в новый клиент (предметно рассматриваем thunderbird, сервер только IMAP, без POP3). Для Thunderbid есть плагин (https://addons.mozilla.org/ru/thunderbird/addon/importexporttools/) который тянет все eml файлы из папки. Они автоматически отражаются на сервере и все довольны.
  • Экспортировать все письма также в виде eml файлов, и положить непосредственно на сервер в папку пользовательской почты.

Возникает несколько сложных моментов.

  • Для экспорта писем нужен доступ к пользовательскому рабочему месту с запущенным TheBat.
  • Плагин импорта\экспорта очень нешустро импортирует письма. Особенно с аттачами, особенно когда их сотни.

Решено писать парсер TBB файлов, чтобы заиметь структуру писем понятную серверу cyrus-imapd (имена файлов в виде 1., 2., 3. — порядковый номер с точкой). Выяснено, что формат TBB нехитрый и вполне можно быстро что-то придумать для парсинга.

Я не программист, но люблю perl. Первый вариант выглядит дубовым и код его прост и ужасен. Но на то это и первая версия. Дело свое делает.
Алгоритм очевиден — читаем файл по-байтово, ищем сигнатуру, начинаем вычленять.

use strict;
my $find=0;
my $buff='';
my $header=0;
my $last='';

my $eml_file;

sysopen (my $file, $ARGV[0], 0);
binmode $file;
seek ($file,3080,0);
while (my $len = sysread($file , $buff , 1)){

   if ($find == 5) {
       seek ($file,41,1);
       $header++;
       $find++;
       open $eml_file, '>',$header.'.eml' || die $!;
       binmode $eml_file;
       next; }
   if (ord($buff) == 33)                      { $find=1 ; $last.=$buff; next } # !
   if ((ord($buff) == 9)     &&  ($find==1) ) { $find++ ; $last.=$buff; next } else { $last=''; }
   if ((ord($buff) == 112)   &&  ($find==2) ) { $find++ ; $last.=$buff; next } else { $last=''; }
   if ((ord($buff) == 25)    &&  ($find==3) ) { $find++ ; $last.=$buff; next } else { $last=''; }
   if ((ord($buff) == 48)    &&  ($find==4) ) { $find++ ; $last.=$buff; next } else { $last=''; }
   if ($find<5) {
        print $eml_file  $last,$buff; $last=''; $find=0; next
        }
   if ($find == 6) {
        print $eml_file $buff;
   }
}
close $file;

Производительность на тестовом TBB файле — примерно полтора письма в секунду (с аттачами). Медленно. Терпимо, но медленно. У меня десятки людей, хочется сделать быстрее. Как говориться, лучше день потерять, а потом за 5 минут долететь.
Начал профилироть разными профайлерами, смотрел какие милисекунды на что тратятся. Ничего не выиграл в итоге, хотя по цифрам быстрее.

Вторая версия использует специфику perl, как то переопределение конца строки и перебор этого массива «строк»

use strict;
use warnings;

my $filename = shift // 'MESSAGES.TBB';
my $cd    = 43;    #Заголовок 48 байт, 48 - $marker = 43
my $count = 0;

my $marker = "\x21\x09\x70\x19\x30";

open my $fh, '<:raw', $filename or croak $!;
local $/ = $marker;                 # одно сообщение - одна строка
<$fh>;                              # дропаем глобальный заголовок вначале файла

while ( my $line = <$fh> ) {
    chomp $line;
    my $outfile = sprintf '%d.', ++$count;
    $line = substr $line, $cd; # дропаем заголовок в начале каждого письма
    open my $out_fh, '>:raw', $outfile or croak $!;
    print $out_fh $line;
    close $out_fh or croak $!;
}
close $fh;

Код опрятнее и интереснее, но работает 1 в 1 как и предыдущий. Ну совершенно никакого выигрыша. Решил, что раз все у нас интерпретируемое, то уперся в эту особенность. Надо делать бинарник. Попробовал скомпилировать скрипт с помощью PP — фигня. Бинарник и все. Скорость та же самая.

Надо делать нормальный исполняемый файл. Из того-что под рукой в linux, есть лишь freepascal\lazarus. Буду писать в нем. Чтобы не сильно вспоминать паскаль, просто склонировал первый алгоритм с учетом специфики паскаля. Получилось консольное x64 ELF приложение.

program project1;

{$mode objfpc}{$H+}

uses {$IFDEF UNIX} {$IFDEF UseCThreads}
  cthreads, {$ENDIF} {$ENDIF}
  Classes,
  SysUtils,
  CustApp { you can add units after this };

type

  { tbb2eml_qk }

  tbb2eml_qk = class(TCustomApplication)
  protected
    procedure DoRun; override;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure WriteHelp; virtual;
  end;

  { tbb2eml_qk }

  procedure tbb2eml_qk.DoRun;
  var
    ErrorMsg: string;
//    emlfile: TextFile;
fh:longint;
    MyFile: file;

    TBBNAME: string;

    find: integer;
    buff: byte;
    header: integer;
    last: string;

  begin
    // quick check parameters
    header:=0;
    find:=0;
    last:='';
    TBBNAME:='MESSAGES.TBB';

    ErrorMsg := CheckOptions('f','file');
    if ErrorMsg <> '' then
    begin
      ShowException(Exception.Create(ErrorMsg));
      Terminate;
      Exit;
    end;

    // parse parameters
    if HasOption('h', 'help') then
    begin
      WriteHelp;
      Terminate;
      Exit;
    end;

    if HasOption('f','file') then
    begin
      TBBNAME:=GetOptionValue('f','file');
    end;

    writeln('Using input filename:'+TBBNAME);

    AssignFile(MyFile, TBBNAME);
    Reset(MyFile, 1 { size of read chunk });
    try

      Seek(MyFile, 3080);
      while not EOF(MyFile) do
      begin
        BlockRead(MyFile, buff, 1);

        if find = 5 then
        begin
          Seek(MyFile, FilePos(MyFile) + 41);
          Inc(header);
          Inc(find);

          // save
          writeln('save to:'+inttostr(header)+'.eml');
          fh:=FileCreate(inttostr(header)+'.eml');
          //
          continue;
        end;

        if (buff = 33) then
        begin
          find:=1;
          last := last + chr(buff);
          continue;
        end;
        if ((buff = 9) and (find = 1)) then
        begin
          Inc(find);
          last := last + chr(buff);
          continue;
        end
        else
        begin
          last := '';
        end;
        if ((buff = 112) and (find = 2)) then
        begin
          Inc(find);
          last := last + chr(buff);
          continue;
        end
        else
        begin
          last := '';
        end;
        if ((buff = 25) and (find = 3)) then
        begin
          Inc(find);
          last := last + chr(buff);
          continue;
        end
        else
        begin
          last := '';
        end;
        if ((buff = 48) and (find = 4)) then
        begin
          Inc(find);
          last := last + chr(buff);
          continue;
        end
        else
        begin
          last := '';
        end;

        if (find < 5) then
        begin
          FileWrite(fh, last, length(Last));
          FileWrite(fh, buff,1);
          last := '';
          find := 0;
          continue;
        end;

        if (find = 6) then
        begin
          FileWrite(fh, buff,1);
        end;

      end;


    finally
      CloseFile(MyFile);
    end;

    // stop program loop
    Terminate;
  end;

  constructor tbb2eml_qk.Create(TheOwner: TComponent);
  begin
    inherited Create(TheOwner);
    StopOnException := True;
  end;

  destructor tbb2eml_qk.Destroy;
  begin
    inherited Destroy;
  end;

  procedure tbb2eml_qk.WriteHelp;
  begin
    { add your help code here }
    writeln('Usage: ', ExeName, ' -h');
  end;

var
  Application: tbb2eml_qk;
begin
  Application := tbb2eml_qk.Create(nil);
  Application.Title := 'My Application';
  Application.Run;
  Application.Free;
end.

Запускаю. И понимаю, что я совсем не программист. Скорость в ТРИ раза медленнее, чем все что сделал до этого. Мда.. Чуть позднее подумал, что есть смысл использовать описание структуры как packed record, но опыта мало, и решил утром обдумать тщательнее.

Проходит день, новая попытка и новые подход — Отображение файла в память

Код ультра компактный.

use strict;
use warnings;
use utf8;
use File::Map 'map_file';
my $marker = "\x21\x09\x70\x19\x30";
local $/ = $marker;
my $count=1;
map_file my $tbb, $ARGV[0], '<', 3084;
foreach my $line(split $marker, $tbb)
{
    $line = substr $line, 43;
    open my $fh, '>',$count.'.msg' || die $!;
    print $fh $line;
    close $fh;
    $count++;
}

Запускаю без особой надежды. ЙАХХУ!
Прирост скорости в сотню раз. 500 писем за 8 секунд. Это победа. Остановимся на этом 🙂 Уверен, что есть специальные подходы к такого рода задаче, но я же не программист 😀

Теперь лишь небольшой sh скрипт, который пройдется по серверу, соберет TBB в хомяках, экспортирует все в файлики, положит cyrus-у, вуа-ля.. почта готова.

Спустя пару дней, выяснилось, что существует множество людей, которые имеют немыслимую иерархию папок в TheBat с различным уровнем вложенности. Задача усложняется тем, что они хотят видеть ту же структуру на стороне IMAP сервера. А так, как каждая папка это отдельный MESSAGES.TBB, руками все делать лень.

Пример скрипта для одного юзера, который пройдется по папкам соберет список баз MESSAGES.TBB, сгенерит rc файл для cyrusа, создат на файловой системе папки и извлечет туда письма.

#!/bin/bash

ORIGIFS=$IFS
ORIGOFS=$OFS

IFS=$(echo -en "\n\b")
OFS=$(echo -en "\n\b")

userlogin=username
domain=domain.tld
prefix=/home/${userlogin}/MAIL/${userlogin}/Inbox/
root_folder=./result/
TBB='/MESSAGES.TBB'

for i in `find ${prefix} -type d`; do
        if [ -f ${i}/${TBB} ]; then
        imap_utf8=`echo ${i} | sed -r "s#${prefix}##; s#/#.#g; s#\(|\)##g "`
        imapfolder=`./imapfolder.pl to ${imap_utf8}`
        echo cm \'user.${userlogin}.${imapfolder}\@${domain}\' >> createmaiboxes.rc
        mkdir -p ${root_folder}${imap_utf8}
        ./2tbb.pl ${i}${TBB} ${root_folder}${imap_utf8}
        fi
done
IFS=$ORIGIFS
OFS=$ORIGOFS

Для работы еще нужен мелкий скрипт (+ сам конвертер TBB2EML из абзаца — отображение файла в память) на перле для конвертации имени папок в UTF-7.

use strict;
use warnings;
use utf8::all;
use Encode::IMAPUTF7;
my $folder=$ARGV[1];

binmode(STDOUT,':utf8');

if ($ARGV[0] eq 'to')
    { print Encode::IMAPUTF7::encode('IMAP-UTF-7', $folder) }
    elsif ($ARGV[0] eq 'from')
    { print Encode::IMAPUTF7::decode('IMAP-UTF-7', $folder) }
    print "\n";

по окончании работу у вас файл createmaiboxes.rc
который необходимо скормить cyradm-у

cyradm -u cyrus --systemrc=createmaiboxes.rc localhost