smtp.pas

siMail, siMail, siMail, siMail

(*
# (C) Copyright 2003
# Miha Vrhovnik, [e-mail]
#
# 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 2 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, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
#
# The Initial Developer of the Original Code is Miha Vrhovnik (Slovenia).
# Portions created by Miha Vrhovnik are Copyright (c)2000-2003.
# All Rights Reserved.
#==============================================================================
# Contributor(s):
#==============================================================================
# History: see whats new.txt from distribution package
#==============================================================================
*)
unit smtp;

interface

uses Classes, Controls, SysUtils, gnugettext, WinTypes, task, account, SMTPSend,
  Forms, Dialogs, Windows, Messages, mimemess_siMail, SyncObjs, synautil,
  DateUtils, mimepart, flatMime;

const WM_PROGRESS = WM_USER + 1223;

type TsmtpThread = class(TThread)
  private
    Fsmtp: TSMTPSend;
    FHandle: HWND;
    Fcmd: string;
    FMime: TMimeMess;
    FSuccessful: Boolean;
    FtmrHandle: HWND;
    FoldDownload: Integer;
    FCancel: Boolean;
    FDoNotPost: Boolean; //this flag indicates that we should not post progress status
    FmessageNo: Integer;
    FrcptList: TStringList;
    FSignature: String;
    procedure MessageHandler(var Msg: TMessage);
    function buildMessage: Boolean;
    procedure BuildRcptList(mime: TMimeMess);
  public
    procedure Execute; override;
    constructor Create(const smtpComp: TSMTPSend; WndHandle: HWND);
    destructor Destroy; override;
  published
    property Cmd: String read Fcmd write Fcmd;
    property MessageNo: Integer read FmessageNo write FmessageNo;
    property Successful: Boolean read FSuccessful;
    property MsgHandle: HWND read FtmrHandle;
    property Cancel: Boolean read FCancel write FCancel;
    property Mime: TMimeMess read FMime write FMime;
    property Signature: String read FSignature write FSignature;
    property RecipientList: TStringList read FrcptList write FrcptList;
  end;

  TtaskGetMessage = procedure(msgNo: Integer; var mime: TMimeMess) of object;
  TtaskGetSignature = procedure(signatureName: String; var signature: String) of object;

type TsmtpTask = class(TBaseTask)
  private
    Fsmtp: TSMTPSend;
    FHandle: HWND;       //window handle
    FThread: TsmtpThread;
    FTask: TTreeTask;       //task descr
    FrcptList: TStringList;
    FOnGetMessage: TtaskGetMessage;
    FOnGetSignature: TtaskGetSignature;
    procedure CheckError(const Value: Boolean);
    procedure StartThread(const _cmd: String; msgNo: Integer; Mmime: TMimeMess);
    procedure MessageHandler(var Msg: TMessage);
    procedure OnSMTPThreadDone(Sender: TObject);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Execute(_task: TTreeTask); override;
    procedure Cancel; override;
  published
    property OnGetMessage: TtaskGetMessage read FOnGetMessage write FOnGetMessage;
    property OnGetSignature: TtaskGetSignature
      read FOnGetSignature write FOnGetSignature;
  end;

implementation

uses blcksock;

{ TsmtpThread }

function TsmtpThread.buildMessage: Boolean;
var oldMime: TmimeMess;
var mimeMulti: TMimePart;
var flatMsg: TFlatMsg;
var i: Integer;
begin
  Result := False;
  oldMime := FMime;
  oldMime.DecodeMessage;
  oldMime.MessagePart.DecodePart;

  FMime := TMimeMess.Create;

  buildRcptList(oldMime);

  flatMsg := TFlatMsg.Create;
  flatMsg.MakeFlat(oldMime.MessagePart);

    //build headers
  with FMime.Header do begin
    Clear;
    From := oldMime.Header.From;
    ToList.Assign(oldMime.Header.ToList);
    CCList.Assign(oldMime.Header.CCList);
    Subject := oldMime.Header.Subject;
    Organization := oldMime.Header.Organization;
    Date := oldMime.Header.Date;
    XMailer := oldMime.Header.XMailer;
    Priority := oldMime.Header.Priority;
    ReplyTo := oldMime.Header.ReplyTo;
    Notification := oldMime.Header.Notification;
  end;

  if (oldMime.Header.AttachList.Count = 0) and (flatMsg.AttachmentPartCount = 0) then begin //no attachments
    FMime.AddPart(nil).Assign(flatMsg.Parts[0]);
  end
  else begin
    mimeMulti := FMime.AddPartMultipart('mixed', nil);
    FMime.AddPart(mimeMulti).Assign(flatMsg.Parts[0]);

    //add attachments to list
    for i := 0 to oldMime.Header.AttachList.Count - 1 do begin
      oldMime.Header.AttachList.Strings[i] :=
        Trim(UTF8Decode(oldMime.Header.AttachList.Strings[i]));
      if FileExists(oldMime.Header.AttachList.Strings[i]) then
        FMime.AddPartBinaryFromFile(
          oldMime.Header.AttachList.Strings[i], mimeMulti);
    end;

    for i := 0 to flatMsg.AttachmentPartCount - 1 do
      mime.AddPart(mimeMulti).Assign(flatMsg.Attachments[i]);
  end;
  Fmime.EncodeMessage;
  oldMime.Free;
  flatMsg.Free;
  Result := True;
end;

procedure TsmtpThread.BuildRcptList(mime: TMimeMess);
var i: Integer;
begin
    //1st spot is occupied by from field
  FRcptList.Add(GetEmailAddr(UTF8Decode(mime.Header.From)));

  for i := 0 to mime.Header.ToList.Count - 1 do begin
    FRcptList.Add(GetEmailAddr(UTF8Decode(mime.Header.ToList.Strings[i])));
  end;

  for i := 0 to mime.Header.CCList.Count - 1 do begin
    FRcptList.Add(GetEmailAddr(UTF8Decode(mime.Header.CCList.Strings[i])));
  end;

  for i := 0 to mime.Header.BCCList.Count - 1 do begin
    FRcptList.Add(GetEmailAddr(UTF8Decode(mime.Header.BCCList.Strings[i])));
  end;

end;

constructor TsmtpThread.Create(const smtpComp: TSMTPSend; WndHandle: HWND);
begin
  FSmtp := smtpComp;
  FHandle := WndHandle;
  FtmrHandle := AllocateHWnd(MessageHandler);
  inherited Create(True);
  FreeOnTerminate := True;
end;

destructor TsmtpThread.Destroy;
begin
  DeallocateHWnd(FtmrHandle);
  inherited Destroy;
end;

procedure TsmtpThread.Execute;
label start;
var i: Integer;
var err: Boolean;
begin
  try
    TaskCriticalCancel.Acquire;
    Cancel := False;
    TaskCriticalCancel.Release;
    SetTimer(FtmrHandle, 0, 50, nil);
   //progress and cancelation check is performed on 50ms intervals

    FDoNotPost := True;
    if cmd = 'login' then begin
      FSuccessful := Fsmtp.Login;
    end
    else if cmd = 'build' then begin
      FrcptList.Clear;
      FSuccessful := buildMessage;
    end
    else if cmd = 'mail' then begin
      FDoNotPost := False;
      FSuccessful := False;
      if FSmtp.MailFrom(FrcptList.Strings[0], Length(FMime.Lines.Text)) then begin
        for i := 1 to FrcptList.Count - 1 do begin
          err := FSmtp.MailTo(FrcptList.Strings[i]);
          if not err then
            break;
        end;
        if err then begin
          FoldDownload := FSmtp.Sock.SendCounter;
          FSuccessful := FSmtp.MailData(FMime.Lines);
        end;
      end;
        //update progress bar to show 100%
      PostMessage(FtmrHandle, WM_TIMER, 0, 0);
    end
    else if cmd = 'logout' then begin
      FSuccessful := FSmtp.Logout;
    end;

    KillTimer(FtmrHandle, 0); //we do not need timer while in suspend
    FtmrHandle := 0;
   except
    on E: Exception do ShowMessage(E.Message);
  end;
end;

procedure TsmtpThread.MessageHandler(var Msg: TMessage);
var tmp: Integer;
begin
    //update progress bar
  if Msg.Msg = WM_TIMER then begin
    Msg.Result := 1;
    if not FDoNotPost then begin
      tmp := Fsmtp.Sock.SendCounter;
      if msg.WParam = 0 then
        PostMessage(FHandle, WM_PROGRESS, tmp - FoldDownload, 0)
      else
        PostMessage(FHandle, WM_PROGRESS, Msg.WParam, 0);
      FoldDownload := tmp;
    end;

        //check if cancel was isued
    TaskCriticalCancel.Acquire;
    if Cancel then begin
      Fsmtp.Timeout := 1;
      Fsmtp.Sock.CloseSocket;
      Self.Terminate;
    end;
    TaskCriticalCancel.Release;
  end
end;

{ TsmtpTask }

procedure TsmtpTask.Cancel;
begin
  TaskCriticalCancel.Acquire;
  FThread.Cancel := True;
  TaskCriticalCancel.Release;
end;


//display last error communication msg
procedure TsmtpTask.CheckError(const Value: Boolean);
var msg: String;
begin
  if Value then begin
    if Assigned(OnComm) then OnComm(FSmtp.ResultString, False)
  end
  else begin
    msg := Fsmtp.Sock.LastErrorDesc;
    if msg = '' then msg := Fsmtp.ResultString;
    if msg = '' then msg := _('Unknown error.');
    if Assigned(OnComm) then OnComm(msg, True);
  end;
end;

constructor TsmtpTask.Create;
begin
  inherited;
  FSmtp := TSmtpSend.Create;
  FRcptList := TStringList.Create;
  FHandle := AllocateHWnd(MessageHandler);
  TaskCriticalCancel := TCriticalSection.Create;
end;

destructor TsmtpTask.Destroy;
begin
  DeallocateHWnd(FHandle);
  FHandle := 0;
  FSmtp.Free;
  FRcptList.Free;
  TaskCriticalCancel.Free;
  inherited;
end;

procedure TsmtpTask.Execute(_task: TTreeTask);
begin
  NoErrors := False; //we set this to false at the end of procedure to true
  FTask := _task;
    //application then knows if there was error
  with Fsmtp do begin
    TargetHost := TAccount(FTask.config).SMTPServer;
    if TAccount(FTask.config).SMTPAuthType <> smtpAuthNone then begin
      if TAccount(FTask.config).SMTPSamePwdAsForIncoming then begin
        Password := TAccount(FTask.config).POP3Password;
        Username := TAccount(FTask.config).POP3UserName;
      end
      else begin
        Password := TAccount(FTask.config).SMTPPassword;
        Username := TAccount(FTask.config).SMTPUserName;
      end;
    end;
    TargetPort := IntToStr(TAccount(FTask.config).SMTPPort);

    Timeout := TAccount(FTask.config).SMTPTimeout * 1000;
    Sock.MaxBandwidth := 512 * 1024; //512 kb/s
    case TAccount(FTask.config).SMTPSecureConnection of
      scAutoTSL:
        AutoTLS := True;
      scSSL:
        FullSSL := True;
    end;
  end;

  //LOGIN
  if Assigned(OnStatus) then OnStatus(_('Connecting ...'));
  StartThread('login', 0, nil);
end;

procedure TsmtpTask.MessageHandler(var Msg: TMessage);
begin
  if Msg.Msg = WM_PROGRESS then begin
    if Assigned(OnProgress) then OnProgress(Msg.WParam, tsdUpdate);
  end;
end;

procedure TsmtpTask.StartThread(const _cmd: String; msgNo: Integer; Mmime: TMimeMess);
begin
  FThread := TsmtpThread.Create(Fsmtp, FHandle);
  with FThread do begin
    Priority := tpLower;
    OnTerminate := OnSMTPThreadDone;
    MessageNo := msgNo;
    Mime := Mmime;
    Cmd := _cmd;
    RecipientList := Self.FrcptList;
    Resume;
  end;
end;

procedure TsmtpTask.OnSMTPThreadDone(Sender: TObject);
var i: Integer;
var mime: TmimeMess;
var tmpstr: String;
begin
        //display last messages
    CheckError(Fthread.Successful);
    if Fthread.Cancel then begin
      if Assigned(OnDone) then OnDone();
      Exit;
    end;
    if not Fthread.Successful then begin
            //clean up
      if Assigned(OnStatus) then
        OnStatus(_('Error. I''m cleaning up.'));
      Fthread.Terminate;
      Fthread.Resume;
      if Assigned(OnDone) then OnDone();
      Exit;
    end;
    if Fthread.Cmd = 'login' then begin
      i := 1;

      if Assigned(OnStatus) then
        OnStatus(Format(_('Building message %d of %d ...'), [i,
          Length(FTask.MessageID)]));

      mime := TMimeMess.Create;
      if Assigned(OnGetMessage) then
        OnGetMessage(FTask.messageID[i - 1], mime);

      StartThread('build', i, mime);

    end
    else if Fthread.Cmd = 'build' then begin
      mime := Fthread.Mime;
      i := FThread.MessageNo;
      if Assigned(OnProgress) then
        OnProgress(Length(FThread.Mime.Lines.Text), tsdMessage);
      if Assigned(OnStatus) then
        OnStatus(Format(_('Sending message %d of %d ...'),
          [FThread.MessageNo, Length(FTask.MessageID)]));
      StartThread('mail', i, mime);
    end
    else if Fthread.Cmd = 'mail' then begin
      i := FThread.MessageNo;
      if Assigned(OnMessage) then
        OnMessage(FThread.Mime.Lines, FTask.messageID[i - 1], 0);
      FThread.Mime.Free;
      Inc(i);

      if i > Length(FTask.MessageID) then begin
        if Assigned(OnStatus) then
          OnStatus(_('Loging Off ...'));
        StartThread('logout', 0, nil);
      end
      else begin
        if Assigned(OnStatus) then
          OnStatus(Format(_('Building message %d of %d ...'),
            [i, Length(FTask.MessageID)]));

        mime := TMimeMess.Create;
        if Assigned(OnGetMessage) then
          OnGetMessage(FTask.messageID[i - 1], mime);

        StartThread('build', i, mime);
      end;
    end
    else if Fthread.Cmd = 'logout' then begin
            //clean up
      if Assigned(OnStatus) then
        OnStatus(_('Done.'));
      NoErrors := True;
      if Assigned(OnDone) then OnDone();
    end;

end;

end.