climap4filehandler.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 clImap4FileHandler;

interface

{$I clVer.inc}
{$IFDEF DELPHI6}
  {$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}

{$IFDEF DELPHI7}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_TYPE OFF}
  {$WARN UNSAFE_CAST OFF}
{$ENDIF}

uses
  Classes, clTcpServer, clImap4Server, clImapUtils, clMailMessage, SyncObjs;

type
  TclImap4FileCommandConnection = class(TclImap4CommandConnection)
  private
    FMessages: TStringList;
  public
    constructor Create;
    destructor Destroy; override;
    property Messages: TStringList read FMessages;
  end;

  TclImap4LoadMessageEvent = procedure (Sender: TObject; AConnection: TclImap4CommandConnection;
    const AMailBoxPath, AMessageFile: string; var ACanLoad: Boolean) of object;

  TclImap4FileHandler = class(TComponent)
  private
    FAccessor: TCriticalSection;
    FServer: TclImap4Server;
    FMailBoxDir: string;
    FMailBoxInfoFile: string;
    FOnLoadMessage: TclImap4LoadMessageEvent;
    function GetNextCounter(AConnection: TclImap4CommandConnection): Integer;
    function GetCurrentCounter(AConnection: TclImap4CommandConnection): Integer;
    procedure SetServer(const Value: TclImap4Server);
    procedure SetMailBoxDir(const Value: string);
    procedure SetMailBoxInfoFile(const Value: string);
    procedure DoCreateConnection(Sender: TObject; var AConnection: TclCommandConnection);
    procedure DoCanAppendMessage(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMailBox: string; var Result: TclImap4MailBoxResult);
    procedure DoCopyMessages(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMessageSet, AMailBox: string; AUseUID: Boolean; var Result: TclImap4MailBoxResult);
    procedure DoCreateMailBox(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMailBox: string; var Result: TclImap4MailBoxResult);
    procedure DoDeleteMailBox(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMailBox: string; var Result: TclImap4MailBoxResult);
    procedure DoPurgeMessages(Sender: TObject; AConnection: TclImap4CommandConnection;
      IsSilent: Boolean; AMessageIDs: TStrings; var Result: TclImap4MessageResult);
    procedure DoFetchMessages(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMessageSet, ADataItems: string; AUseUID: Boolean; AResponse: TclImap4FetchResponseList;
      var Result: TclImap4MessageResult);
    procedure DoGetMailBoxes(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AReferenceName, ACriteria: string; AMailBoxes: TclImap4MailBoxList);
    procedure DoGetMailBoxInfo(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMailBox: string; IsSelectMailBox: Boolean; AMailBoxInfo: TclImap4MailBoxInfo;
      var Result: TclImap4MailBoxResult);
    procedure DoMessageAppended(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMailBox: string; AFlags: TclMailMessageFlags; AMessage: TStrings;
      var Result: TclImap4MailBoxResult);
    procedure DoRenameMailBox(Sender: TObject; AConnection: TclImap4CommandConnection;
      const ACurrentName, ANewName: string; var Result: TclImap4MailBoxResult);
    procedure DoSearchMessages(Sender: TObject; AConnection: TclImap4CommandConnection;
      const ASearchCriteria: string; AUseUID: Boolean; AMessageIDs: TStrings;
      var Result: TclImap4MessageResult);
    procedure DoStoreMessages(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMessageSet: string; AFlagsMethod: TclSetFlagsMethod; AFlags: TclMailMessageFlags;
      IsSilent: Boolean; AUseUID: Boolean; AResponse: TclImap4FetchResponseList;
      var Result: TclImap4MessageResult);
    procedure DoSubscribeMailBox(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMailBox: string; var Result: TclImap4MailBoxResult);
    procedure DoUnsubscribeMailBox(Sender: TObject; AConnection: TclImap4CommandConnection;
      const AMailBox: string; var Result: TclImap4MailBoxResult);
    function GetMailBoxPath(const AUserName: string): string;
    function GetIsSubscribed(const AMailBoxPath: string): Boolean;
    procedure SetIsSubscribed(const AMailBoxPath: string; AIsSubscribed: Boolean);
    function GetMessageFlags(AConnection: TclImap4CommandConnection;
      const AMailBoxPath, AMessageFile: string): string;
    function SetMessageFlags(AConnection: TclImap4CommandConnection;
      const AMailBoxPath, AMessageFile: string; AFlagsMethod: TclSetFlagsMethod;
      ANewFlags: TclMailMessageFlags): string;
    function MailBoxToPath(const AMailBox: string): string;
    procedure InternalSubscribeMailBox(AConnection: TclImap4CommandConnection;
      const AMailBox: string; AIsSubscribed: Boolean; var Result: TclImap4MailBoxResult);
    function GetFileTimeStamp(const AFileName: string): Integer;
    procedure FillMessageList(AConnection: TclImap4CommandConnection;
      const AMailBoxPath: string; AList: TStrings);
    procedure UpdateMailBoxInfo(AConnection: TclImap4CommandConnection; const AMailBoxPath: string;
      AMessageList: TStringList; IsSelectMailBox: Boolean;
      var ARecentCount, AUnseenMessages, AFirstUnseen: Integer);
    function BuildMessageInfo(const AUid: string;
      AFlags: TclMailMessageFlags): string;
    procedure ParseMessageInfo(const ASource: string; var AUid: string;
      var AFlags: TclMailMessageFlags);
    function GetMessageList(AConnection: TclImap4CommandConnection): TStringList;
    function GetMessageUID(AConnection: TclImap4CommandConnection;
      const AMessageFile: string): string;
    function GetMsgFileByUID(AList: TStrings; AUID: Integer): string;
    procedure SearchAllMessages(AConnection: TclImap4CommandConnection;
      AUseUID: Boolean; AMessageIDs: TStrings);
    procedure SearchMessages(AConnection: TclImap4CommandConnection;
      const AKey, AParam: string; AUseUID: Boolean; AMessageIDs: TStrings);
    procedure FillTargetList(AConnection: TclImap4CommandConnection;
      const AMessageSet: string; AUseUID: Boolean; ATargetList: TStrings);
    function GenMessageFileName(AConnection: TclImap4CommandConnection): string;
    procedure FetchMessage(AConnection: TclImap4CommandConnection;
      const AMessageFile: string; ARequest: TclImap4FetchRequestList;
      AUseUID: Boolean; AResponseItem: TclImap4FetchResponseItem);
    function GetLocalFileSize(const AFileName: string): Integer;
    procedure FetchHeader(const AMessagePath, ACommand, AParams: string; AResponseItem: TclImap4FetchResponseItem);
    procedure FetchHeaderFields(const AMessagePath, ACommand, AParams: string; AResponseItem: TclImap4FetchResponseItem);
    procedure FetchBodyText(const AMessagePath, ACommand, AParams: string; AResponseItem: TclImap4FetchResponseItem);
    procedure FetchBody(const AMessagePath, ACommand, AParams: string; AResponseItem: TclImap4FetchResponseItem);
    function FetchMessageEnvelope(const AMessagePath: string): string;
    function FetchBodyStructure(const AMessagePath: string): string;
    procedure ParseHeaderFieldParams(const ASource: string;
      AFields: TStrings);
    function GetMessageInternalDate(const AMessagePath: string): TDateTime;
    function DateTimeToImapTime(ADateTime: TDateTime): string;
    function GetMimeBodyStructure(ABodies: TclMessageBodies): string;
    procedure ExtractContentTypeParts(const AContentType: string; var AType, ASubType: string);
    function GetMimeBodySize(ABody: TclMessageBody): string;
    procedure GetUueBodySize(AMessage: TStrings; var ASize,
      ALines: Integer);
    procedure RefreshMailBoxInfo(AConnection: TclImap4CommandConnection);
    function GetMailBoxInfo(AConnection: TclImap4CommandConnection;
      const AMailBox: string; IsSelectMailBox: Boolean;
      AMailBoxInfo: TclImap4MailBoxInfo; AMessageList: TStringList): TclImap4MailBoxResult;
    procedure GetBodyIDs(const AParams: string; var ABodyIDs: array of Integer);
    function GetBodyByIndex(var ABodyIDs: array of Integer;
      AIndex: Integer; ABodies: TclMessageBodies): TclMessageBody;
  protected
    function GetMessageEnvelope(AMessage: TStrings): string; virtual;
    function GetBodyStructure(AMessage: TStrings): string; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure CleanEventHandlers; virtual;
    procedure InitEventHandlers; virtual;
    procedure DoLoadMessage(AConnection: TclImap4CommandConnection;
      const AMailBoxPath, AMessageFile: string; var ACanLoad: Boolean); virtual;
    property Accessor: TCriticalSection read FAccessor;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Server: TclImap4Server read FServer write SetServer;
    property MailBoxDir: string read FMailBoxDir write SetMailBoxDir;
    property MailBoxInfoFile: string read FMailBoxInfoFile write SetMailBoxInfoFile;
    property OnLoadMessage: TclImap4LoadMessageEvent read FOnLoadMessage write FOnLoadMessage;
  end;

const
  cMailBoxSection = 'MAILBOXINFO';
  cMessagesSection = 'MESSAGES';

implementation

uses
  Windows, SysUtils, clUtils, IniFiles, clEncoder, clPCRE;

type
  TclMessageBodyIDs = array[0..9] of Integer;

{ TclImap4FileHandler }

procedure TclImap4FileHandler.CleanEventHandlers;
begin
  Server.OnCreateConnection := nil;
  Server.OnGetMailBoxes := nil;
  Server.OnCreateMailBox := nil;
  Server.OnDeleteMailBox := nil;
  Server.OnRenameMailBox := nil;
  Server.OnSubscribeMailBox := nil;
  Server.OnUnsubscribeMailBox := nil;
  Server.OnGetMailBoxInfo := nil;
  Server.OnSearchMessages := nil;
  Server.OnCopyMessages := nil;
  Server.OnFetchMessages := nil;
  Server.OnStoreMessages := nil;
  Server.OnPurgeMessages := nil;
  Server.OnCanAppendMessage := nil;
  Server.OnMessageAppended := nil;
end;

constructor TclImap4FileHandler.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAccessor := TCriticalSection.Create();
  FMailBoxInfoFile := cImapMailBoxInfoFile;
end;

destructor TclImap4FileHandler.Destroy;
begin
  FAccessor.Free();
  inherited Destroy();
end;

procedure TclImap4FileHandler.InitEventHandlers;
begin
  Server.OnCreateConnection := DoCreateConnection;
  Server.OnGetMailBoxes := DoGetMailBoxes;
  Server.OnCreateMailBox := DoCreateMailBox;
  Server.OnDeleteMailBox := DoDeleteMailBox;
  Server.OnRenameMailBox := DoRenameMailBox;
  Server.OnSubscribeMailBox := DoSubscribeMailBox;
  Server.OnUnsubscribeMailBox := DoUnsubscribeMailBox;
  Server.OnGetMailBoxInfo := DoGetMailBoxInfo;
  Server.OnSearchMessages := DoSearchMessages;
  Server.OnCopyMessages := DoCopyMessages;
  Server.OnFetchMessages := DoFetchMessages;
  Server.OnStoreMessages := DoStoreMessages;
  Server.OnPurgeMessages := DoPurgeMessages;
  Server.OnCanAppendMessage := DoCanAppendMessage;
  Server.OnMessageAppended := DoMessageAppended;
end;

procedure TclImap4FileHandler.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation <> opRemove) then Exit;
  if (AComponent = FServer) then
  begin
    CleanEventHandlers();
    FServer := nil;
  end;
end;

procedure TclImap4FileHandler.SetServer(const Value: TclImap4Server);
begin
  if (FServer <> Value) then
  begin
{$IFDEF DELPHI5}
    if (FServer <> nil) then
    begin
      FServer.RemoveFreeNotification(Self);
      CleanEventHandlers();
    end;
{$ENDIF}
    FServer := Value;
    if (FServer <> nil) then
    begin
      FServer.FreeNotification(Self);
      InitEventHandlers();
    end;
  end;
end;

function TclImap4FileHandler.GetMailBoxPath(const AUserName: string): string;
begin
  Result := AddTrailingBackSlash(MailBoxDir) + AddTrailingBackSlash(AUserName);
end;

function TclImap4FileHandler.GetIsSubscribed(const AMailBoxPath: string): Boolean;
var
  ini: TIniFile;
begin
  Result := FileExists(AMailBoxPath + MailBoxInfoFile);
  if not Result then Exit;

  ini := TIniFile.Create(AMailBoxPath + MailBoxInfoFile);
  try
    Result := ini.ReadBool(cMailBoxSection, 'Subscribed', False);
  finally
    ini.Free();
  end;
end;

procedure TclImap4FileHandler.SetIsSubscribed(const AMailBoxPath: string; AIsSubscribed: Boolean);
var
  ini: TIniFile;
begin
  ini := TIniFile.Create(AMailBoxPath + MailBoxInfoFile);
  try
    ini.WriteBool(cMailBoxSection, 'Subscribed', AIsSubscribed);
  finally
    ini.Free();
  end;
end;

function TclImap4FileHandler.MailBoxToPath(const AMailBox: string): string;
begin
  if SameText('INBOX', AMailBox) then
  begin
    Result := '';
  end else
  begin
    Result := StringReplace(AMailBox, Server.MailBoxSeparator, '\', [rfReplaceAll]);
  end;
end;

procedure TclImap4FileHandler.DoGetMailBoxes(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AReferenceName, ACriteria: string;
  AMailBoxes: TclImap4MailBoxList);
  
  procedure CollectMailboxes(const ARegEx, APath, ABase: string);
  var
    sr: TSearchRec;
    found: string;
    item: TclImap4MailBoxItem;
  begin
    if SysUtils.FindFirst(APath + '*.*', faDirectory, sr) = 0 then
    begin
      repeat
        if ((sr.Attr and faDirectory) <> 0) and (sr.Name <> '.') and (sr.Name <> '..') then
        begin
          found := ABase + sr.Name;
          if not SameText(found, 'INBOX') then
          begin
            if RE_Match(found, ARegEx, PCRE_CASELESS) then
            begin
              item := AMailBoxes.Add();
              item.Name := StringReplace(found, '\', Server.MailBoxSeparator, [rfReplaceAll]);
              item.IsSubscribed := GetIsSubscribed(APath + sr.Name + '\');
            end;
            CollectMailboxes(ARegEx, APath + sr.Name + '\', found + Server.MailBoxSeparator);
          end else
          begin
            CollectMailboxes(ARegEx, APath + 'INBOX' + '\', 'INBOX' + Server.MailBoxSeparator);
          end;
        end;
      until SysUtils.FindNext(sr) <> 0;
      SysUtils.FindClose(sr);
    end;
  end;
  
var
  i: Integer;
  pattern, regEx: string;
  item: TclImap4MailBoxItem;
begin
  pattern := AReferenceName + ACriteria;
  regEx := '^';
  for i := 1 to Length(pattern) do
  begin
    case pattern[i] of
      '*' : regEx := regEx + '.*';
      '%' : regEx := regEx + '[^' + Server.MailBoxSeparator + ']*';
      '+', '-', '.', '$', '(', ')': regEx := regEx + '\' + pattern[i];
      else regEx := regEx + pattern[i];
    end;
  end;
  regEx := regEx + '$';

  if RE_Match('INBOX', regEx, PCRE_CASELESS) then
  begin
    item := AMailBoxes.Add();
    item.Name := 'INBOX';
    item.IsSubscribed := GetIsSubscribed(GetMailBoxPath(AConnection.UserName));
  end;

  CollectMailboxes(regEx, GetMailBoxPath(AConnection.UserName), '');
end;

procedure TclImap4FileHandler.DoCreateMailBox(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMailBox: string; var Result: TclImap4MailBoxResult);
var
  path: string;
begin
  if SameText('INBOX', AMailBox) then
  begin
    Result := mrAccessDenied;
    Exit;
  end;
  
  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(AMailBox));

  if DirectoryExists(path) then
  begin
    Result := mrAlreadyExists;
  end else
  if ForceFileDirectories(path) then
  begin
    Result := mrSuccess;
  end else
  begin
    Result := mrAccessDenied;
  end;
end;

procedure TclImap4FileHandler.DoDeleteMailBox(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMailBox: string; var Result: TclImap4MailBoxResult);
var
  path: string;
begin
  if SameText('INBOX', AMailBox) then
  begin
    Result := mrAccessDenied;
    Exit;
  end;

  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(AMailBox));

  if DirectoryExists(path) then
  begin
    if DeleteRecursiveDir(path) then
    begin
      Result := mrSuccess;
    end else
    begin
      Result := mrAccessDenied;
    end;
  end else
  begin
    Result := mrNotFound;
  end;
end;

procedure TclImap4FileHandler.DoRenameMailBox(Sender: TObject; AConnection: TclImap4CommandConnection;
  const ACurrentName, ANewName: string; var Result: TclImap4MailBoxResult);
var
  curName, newName: string;
begin
  if SameText('INBOX', ACurrentName) or SameText('INBOX', ANewName) then
  begin
    Result := mrAccessDenied;
    Exit;
  end;

  curName := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(ACurrentName));
  newName := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(ANewName));

  if DirectoryExists(curName) then
  begin
    if not DirectoryExists(newName) then
    begin
      if RenameFile(curName, newName) then
      begin
        Result := mrSuccess;
      end else
      begin
        Result := mrAccessDenied;
      end;
    end else
    begin
      Result := mrAlreadyExists;
    end;
  end else
  begin
    Result := mrNotFound;
  end;
end;

procedure TclImap4FileHandler.InternalSubscribeMailBox(AConnection: TclImap4CommandConnection;
  const AMailBox: string; AIsSubscribed: Boolean; var Result: TclImap4MailBoxResult);
var
  path: string;
begin
  path := GetMailBoxPath(AConnection.UserName) + AddTrailingBackSlash(MailBoxToPath(AMailBox));

  if DirectoryExists(path) then
  begin
    try
      SetIsSubscribed(path, AIsSubscribed);
      Result := mrSuccess;
    except
      Result := mrAccessDenied;
    end;
  end else
  begin
    Result := mrNotFound;
  end;
end;

procedure TclImap4FileHandler.DoSubscribeMailBox(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMailBox: string; var Result: TclImap4MailBoxResult);
begin
  InternalSubscribeMailBox(AConnection, AMailBox, True, Result);
end;

procedure TclImap4FileHandler.DoUnsubscribeMailBox(Sender: TObject;
  AConnection: TclImap4CommandConnection; const AMailBox: string; var Result: TclImap4MailBoxResult);
begin
  InternalSubscribeMailBox(AConnection, AMailBox, False, Result);
end;

function TclImap4FileHandler.GetFileTimeStamp(const AFileName: string): Integer;
var
  Handle: THandle;
  FindData: TWin32FindData;
  pTime: TFileTime;
  s: string;
begin
  s := AFileName;
  if (s <> '') and (s[Length(s)] = '\') then
  begin