climap4.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clImap4;

interface

{$I clVer.inc}

uses
  Classes, clMC, clMailMessage, clTcpClient, clImapUtils;

type
  TclCustomImap4 = class(TclCustomMail)
  private
    FCommandTag: Integer;
    FMailBoxSeparator: Char;
    FCurrentMailBox: TclImap4MailBoxInfo;
    FCurrentMessage: Integer;
    FConnectionState: TclImapConnectionState;
    FAutoReconnect: Boolean;
    FIsTaggedCommand: Boolean;
    FTotalBytesToReceive: Integer;
    procedure RaiseError(const AMessage: string);
    function GetNextCommandTag: string;
    function GetLastCommandTag: string;
    procedure SetAutoReconnect(const Value: Boolean);
    procedure Login;
    procedure Authenticate;
    procedure OpenImapSession;
    procedure Logout;
    procedure ParseMailBoxes(AList: TStrings; const ACommand: string);
    procedure ParseSelectedMailBox(const AName: string);
    procedure ParseSearchMessages(AList: TStrings);
    function ParseMessageSize(const AMessageId: string; AIsUid: Boolean): Integer;
    function ParseMessageUid(AIndex: Integer): string;
    function ParseMessageFlags(const AMessageId: string; AIsUid: Boolean): TclMailMessageFlags;
    procedure ParseMessage(const AMessageId: string; AMessage: TclMailMessage; AIsUid: Boolean);
    function GetMessageId(const ACommand, AResponseLine: string; AIsUid: Boolean): string;
    procedure CheckMessageValid(AIndex: Integer);
    procedure CheckUidValid(const AUid: string);
    procedure CheckConnection(AStates: array of TclImapConnectionState);
    procedure DoDataProgress(Sender: TObject; ABytesProceed, ATotalBytes: Int64);
    procedure CramMD5Authenticate;
    procedure NtlmAuthenticate;
    procedure GetCapability(AList: TStrings);
  protected
    function GetDefaultPort: Integer; override;
    function GetResponseCode(const AResponse: string): Integer; override;
    procedure WaitingResponse(const AOkResponses: array of Integer); override;
    procedure OpenSession; override;
    procedure CloseSession; override;

    property AutoReconnect: Boolean read FAutoReconnect write SetAutoReconnect default False;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure StartTls; override;
    procedure SendTaggedCommand(const ACommand: string;
      const Args: array of const; const AOkResponses: array of Integer);
    procedure Noop;
    procedure SelectMailBox(const AName: string);
    procedure ExamineMailBox(const AName: string);
    procedure CreateMailBox(const AName: string);
    procedure DeleteMailBox(const AName: string);
    procedure RenameMailBox(const ACurrentName, ANewName: string);
    procedure SubscribeMailBox(const AName: string);
    procedure UnsubscribeMailBox(const AName: string);
    procedure GetMailBoxes(AList: TStrings; const ACriteria: string = '*');
    procedure GetSubscribedMailBoxes(AList: TStrings);

    procedure SearchMessages(const ASearchCriteria: string; AMessageList: TStrings);
    procedure UidSearchMessages(const ASearchCriteria: string; AMessageList: TStrings);
    procedure DeleteMessage(AIndex: Integer);
    procedure UidDeleteMessage(const AUid: string);
    procedure PurgeMessages;
    procedure CopyMessage(AIndex: Integer; const ADestMailBox: string);
    procedure UidCopyMessage(const AUid, ADestMailBox: string);
    procedure SetMessageFlags(AIndex: Integer; AMethod: TclSetFlagsMethod; AFlags: TclMailMessageFlags);
    procedure UidSetMessageFlags(const AUid: string; AMethod: TclSetFlagsMethod; AFlags: TclMailMessageFlags);
    function GetMessageFlags(AIndex: Integer): TclMailMessageFlags;
    function UidGetMessageFlags(const AUid: string): TclMailMessageFlags;
    function GetMessageSize(AIndex: Integer): Integer;
    function UidGetMessageSize(const AUid: string): Integer;
    function GetMessageUid(AIndex: Integer): string;

    procedure RetrieveMessage(AIndex: Integer); overload;
    procedure RetrieveMessage(AIndex: Integer; AMessage: TclMailMessage); overload;
    procedure UidRetrieveMessage(const AUid: string; AMessage: TclMailMessage);
    procedure RetrieveHeader(AIndex: Integer); overload;
    procedure RetrieveHeader(AIndex: Integer; AMessage: TclMailMessage); overload;
    procedure UidRetrieveHeader(const AUid: string; AMessage: TclMailMessage);
    procedure AppendMessage(const AMailBoxName: string; AFlags: TclMailMessageFlags); overload;
    procedure AppendMessage(const AMailBoxName: string; AMessage: TclMailMessage;
      AFlags: TclMailMessageFlags); overload;
    procedure AppendMessage(const AMailBoxName: string; AMessage: TStrings;
      AFlags: TclMailMessageFlags); overload;

    property CurrentMailBox: TclImap4MailBoxInfo read FCurrentMailBox;
    property MailBoxSeparator: Char read FMailBoxSeparator;
    property CurrentMessage: Integer read FCurrentMessage;
    property ConnectionState: TclImapConnectionState read FConnectionState;
    property LastCommandTag: string read GetLastCommandTag;
  end;

  TclImap4 = class(TclCustomImap4)
  published
    property AutoReconnect;
    property BatchSize;
    property UserName;
    property Password;
    property Server;
    property Port default cDefaultImapPort;
    property TimeOut;
    property UseTLS;
    property CertificateFlags;
    property TLSFlags;
    property BitsPerSec;
    property UseSPA;
    property MailMessage;
    property OnChanged;
    property OnOpen;
    property OnClose;
    property OnGetCertificate;
    property OnVerifyServer;
    property OnSendCommand;
    property OnReceiveResponse;
    property OnProgress;
  end;

const
  IMAP_OK = 10;
  IMAP_NO = 20;
  IMAP_BAD = 30;
  IMAP_PREAUTH = 40;
  IMAP_BYE = 50;
  IMAP_CONTINUE = 60;

resourcestring
  cImapInvalidMailboxName = 'Mailbox name is invalid, it must not be empty or begin with mailbox separator';
  cInvalidArgument = 'Function arguments are invalid';
  cMailMessageNoInvalid = 'Message number is invalid, must be greater than 0';
  cMailMessageUidInvalid = 'Message UID is invalid, must be numeric and greater than 0';
  cSocketErrorConnect = 'The connection to the server has failed';
  cInvalidAuthMethod = 'Unable to logon to the server using Secure Password Authentication';

implementation

uses 
  SysUtils, clUtils, clCryptUtils, clSocket, clSspiAuth,
  clEncoder{$IFDEF DEMO}, Forms, Windows, clCert{$ENDIF};

{ TclCustomImap4 }

constructor TclCustomImap4.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCurrentMailBox := TclImap4MailBoxInfo.Create();
  Port := cDefaultImapPort;
  FIsTaggedCommand := False;
  FMailBoxSeparator := '/';
end;

procedure TclCustomImap4.CloseSession;
begin
  Logout();
end;

{$IFDEF DEMO}
{$IFNDEF IDEDEMO}
var
  IsDemoDisplayed: Boolean = False;
{$ENDIF}
{$ENDIF}

procedure TclCustomImap4.OpenSession;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsDemoDisplayed) and (not IsEncoderDemoDisplayed)
      and (not IsCertDemoDisplayed) and (not IsMailMessageDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
    IsCertDemoDisplayed := True;
    IsMailMessageDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  WaitingResponse([IMAP_OK, IMAP_PREAUTH]);

  FCommandTag := 0;
  ExplicitStartTls();

  OpenImapSession();
end;

procedure TclCustomImap4.Login;
begin
  if (Password <> '') then
  begin
    SendTaggedCommand('LOGIN "%s" "%s"', [UserName, Password], [IMAP_OK]);
  end else
  begin
    SendTaggedCommand('LOGIN "%s"', [UserName], [IMAP_OK]);
  end;
end;

procedure TclCustomImap4.CramMD5Authenticate;
var
  resp, DecodedResponse: string;
  Encoder: TclEncoder;
begin
  SendTaggedCommand('AUTHENTICATE %s', ['CRAM-MD5'], [IMAP_CONTINUE]);
  Encoder := TclEncoder.Create(nil);
  try
    resp := Copy(Response.Text, 3, MaxInt);
    Encoder.DecodeString(resp, DecodedResponse, cmMIMEBase64);
    DecodedResponse := HMAC_MD5(DecodedResponse, Password);
    DecodedResponse := UserName + ' ' + DecodedResponse;
    Encoder.EncodeString(DecodedResponse, resp, cmMIMEBase64);
    SendCommandSync(resp, [IMAP_OK]);
  finally
    Encoder.Free();
  end;
end;

procedure TclCustomImap4.NtlmAuthenticate;
var
  sspi: TclNtAuthClientSspi;
  encoder: TclEncoder;
  buf: TStream;
  authIdentity: TclAuthIdentity;
  challenge: string;
begin
  SendTaggedCommand('AUTHENTICATE %s', ['NTLM'], [IMAP_CONTINUE]);

  sspi := nil;
  encoder := nil;
  buf := nil;
  authIdentity := nil;
  try
    sspi := TclNtAuthClientSspi.Create();
    encoder := TclEncoder.Create(nil);
    encoder.SuppressCrlf := True;

    buf := TMemoryStream.Create();

    if (UserName <> '') then
    begin
      authIdentity := TclAuthIdentity.Create(UserName, Password);
    end;

    while not sspi.GenChallenge('NTLM', buf, Server, authIdentity) do
    begin
      buf.Position := 0;
      encoder.EncodeToString(buf, challenge, cmMIMEBase64);
      SendCommandSync(challenge, [IMAP_CONTINUE]);

      challenge := system.Copy(Response.Text, 3, MaxInt);
      buf.Size := 0;
      encoder.DecodeFromString(challenge, buf, cmMIMEBase64);
      buf.Position := 0;
    end;

    if (buf.Size > 0) then
    begin
      buf.Position := 0;
      encoder.EncodeToString(buf, challenge, cmMIMEBase64);
      SendCommandSync(challenge, [IMAP_OK]);
    end;
  finally
    authIdentity.Free();
    buf.Free();
    encoder.Free();
    sspi.Free();
  end;
end;

procedure TclCustomImap4.GetCapability(AList: TStrings);
var
  i: Integer;
  s: string;
begin
  SendTaggedCommand('CAPABILITY', [], [IMAP_OK]);
  AList.Clear();
  for i := 0 to Response.Count - 1 do
  begin
    s := Response[i];
    if (System.Pos('* CAPABILITY ', UpperCase(s)) = 1) then
    begin
      s := system.Copy(s, Length('* CAPABILITY ') + 1, Length(s));
      s := StringReplace(s, ' ', #13#10, [rfReplaceAll]);
      AddTextStr(AList, s, False);
    end;
  end;
end;

procedure TclCustomImap4.Authenticate;
var
  list: TStrings;
begin
  list := TStringList.Create();
  try
    GetCapability(list);
    if FindInStrings(list, 'AUTH=NTLM') > -1 then
    begin
      NtlmAuthenticate();
    end else
    if FindInStrings(list, 'AUTH=CRAM-MD5') > -1 then
    begin
      CramMD5Authenticate();
    end else
    begin
      RaiseError(cInvalidAuthMethod);
    end;
  finally
    list.Free();
  end;
end;

procedure TclCustomImap4.OpenImapSession;
begin
  FCommandTag := 0;
  if (LastResponseCode = IMAP_OK) then
  begin
    if UseSPA then
    begin
      Authenticate();
    end else
    begin
      Login();
    end;
    FConnectionState := csAuthenticated;
  end else
  if (LastResponseCode = IMAP_PREAUTH) then
  begin
    FConnectionState := csAuthenticated;
  end;
end;

function TclCustomImap4.GetNextCommandTag: string;
begin