clsmimemessage.pas

来自「Clever_Internet_Suite_6.2的代码 Clever_Int」· PAS 代码 · 共 1,030 行 · 第 1/3 页

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

unit clSMimeMessage;

interface

{$I clVer.inc}

uses
  Classes, SysUtils, clMailMessage, clCert, clCryptAPI, clEncoder;

type
  TclSMimeBody = class(TclMessageBody)
  private
    FSource: TStrings;
    FBoundary: string;
    procedure SetSource(const Value: TStrings);
    procedure SetBoundary(const Value: string);
    function GetHeader: TStrings;
    procedure SetHeader(const Value: TStrings);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    procedure AssignBodyHeader(ASource: TStrings); override;
    procedure ParseBodyHeader(ABodyPos: Integer; ASource, AFieldList: TStrings); override;
    function GetSourceStream: TStream; override;
    function GetDestinationStream: TStream; override;
    procedure BeforeDataAdded(AData: TStream); override; 
    procedure DataAdded(AData: TStream); override;
    procedure DecodeData(ASource, ADestination: TStream); override;
    procedure EncodeData(ASource, ADestination: TStream); override;
    procedure DoCreate; override;
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear(); override;
    property Header: TStrings read GetHeader write SetHeader;
    property Source: TStrings read FSource write SetSource;
    property Boundary: string read FBoundary write SetBoundary;
  end;

  TclEnvelopedBody = class(TclAttachmentBody)
  private
    FData: TclCryptData;
    procedure SetData(const Value: TclCryptData);
  protected
    function GetSourceStream: TStream; override;
    function GetDestinationStream: TStream; override;
    procedure DataAdded(AData: TStream); override;
    procedure DoCreate; override;
  public
    destructor Destroy; override;
    procedure Clear(); override;
    property Data: TclCryptData read FData write SetData;
  end;

  TclSMimeMessage = class(TclMailMessage)
  private
    FSMimeContentType: string;
    FIsDetachedSignature: Boolean;
    FIsIncludeCertificate: Boolean;
    FOnGetCertificate: TclOnGetCertificateEvent;
    FCertificates: TclCertificateStore;
    FInternalCertStore: TclCertificateStore;
    FIsSecuring: Boolean;
    procedure SetSMimeContentType(const Value: string);
    function GetIsEncrypted: Boolean;
    function GetIsSigned: Boolean;
    function GetCertificate(const AStoreName: string; IsUseSender: Boolean): TclCertificate;
    function GetEncryptCertificates(const AStoreName: string): TclCertificateStore;
    procedure SetIsDetachedSignature(const Value: Boolean);
    procedure SetIsIncludeCertificate(const Value: Boolean);
    procedure SignEnveloped(ACertificate: TclCertificate);
    procedure SignDetached(ACertificate: TclCertificate);
    procedure VerifyDetached;
    procedure VerifyEnveloped;
    function GetRecipientCertificate(const AStoreName: string;
      AEmailList: TStrings): TclCertificate;
    procedure InternalVerify;
    procedure InternalDecrypt;
    function GetEmailCertificate(const AFullEmail,
      AStoreName: string): TclCertificate;
  protected
    procedure DoGetCertificate(var ACertificate: TclCertificate;
      var Handled: Boolean); dynamic;
    procedure ParseContentType(ASource, AFieldList: TStrings); override;
    procedure AssignContentType(ASource: TStrings); override;
    function GetIsMultiPartContent: Boolean; override;
    function CreateBody(ABodies: TclMessageBodies;
      const AContentType, ADisposition: string): TclMessageBody; override;
    function CreateSingleBody(ASource: TStrings; ABodies: TclMessageBodies): TclMessageBody; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear; override;
    procedure Sign;
    procedure Verify;
    procedure Encrypt;
    procedure Decrypt;
    procedure DecryptAndVerify;
    property IsEncrypted: Boolean read GetIsEncrypted;
    property IsSigned: Boolean read GetIsSigned;
    property Certificates: TclCertificateStore read FCertificates;
  published
    property IsDetachedSignature: Boolean read FIsDetachedSignature write SetIsDetachedSignature default True;
    property IsIncludeCertificate: Boolean read FIsIncludeCertificate write SetIsIncludeCertificate default True;
    property SMimeContentType: string read FSMimeContentType write SetSMimeContentType;
    property OnGetCertificate: TclOnGetCertificateEvent read FOnGetCertificate write FOnGetCertificate;
  end;

implementation

uses
  clUtils, Windows{$IFDEF DEMO}, Forms{$ENDIF}{$IFDEF LOGGER}, clLogger{$ENDIF};

{ TclSMimeMessage }

procedure TclSMimeMessage.AssignContentType(ASource: TStrings);
begin
  if IsEncrypted or (IsSigned and not IsDetachedSignature) then
  begin
    AddHeaderArrayField(ASource, [ContentType,
      'smime-type=' + SMimeContentType,
      'boundary="' + Boundary + '"',
      'name="smime.p7m"'], 'Content-Type', ';');
    AddHeaderArrayField(ASource, ['attachment',
      'filename="smime.p7m"'], 'Content-Disposition', ';');
  end else
  if (IsSigned and IsDetachedSignature) then
  begin
    AddHeaderArrayField(ASource, [ContentType,
      'boundary="' + Boundary + '"',
      'protocol="application/x-pkcs7-signature"',
      'micalg=SHA1'], 'Content-Type', ';');
  end else
  begin
    inherited AssignContentType(ASource);
  end;
end;

procedure TclSMimeMessage.Clear;
begin
  BeginUpdate();
  try
    if not FIsSecuring then
    begin
      Certificates.Close();
    end;
    SMimeContentType := '';
    inherited Clear();
  finally
    EndUpdate();
  end;
end;

constructor TclSMimeMessage.Create(AOwner: TComponent);
begin
  FInternalCertStore := TclCertificateStore.Create(nil);
  FCertificates := TclCertificateStore.Create(nil);
  FCertificates.StoreName := 'addressbook';
  inherited Create(AOwner);
  FIsDetachedSignature := True;
  FIsIncludeCertificate := True;
  FIsSecuring := False;
end;

procedure TclSMimeMessage.Decrypt;
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 IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisplayed)
      and (not IsCertDemoDisplayed) 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;
    IsMailMessageDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
    IsCertDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

  InternalDecrypt();
end;

procedure TclSMimeMessage.DecryptAndVerify;
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 IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisplayed)
      and (not IsCertDemoDisplayed) 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;
    IsMailMessageDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
    IsCertDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'DecryptAndVerify');{$ENDIF}
  repeat
    if IsEncrypted then
    begin
      InternalDecrypt();
    end else
    if IsSigned then
    begin
      InternalVerify();
    end else
    begin
      Break;
    end;
  until False;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'DecryptAndVerify'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'DecryptAndVerify', E); raise; end; end;{$ENDIF}
end;

procedure TclSMimeMessage.DoGetCertificate(var ACertificate: TclCertificate;
  var Handled: Boolean);
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'DoGetCertificate');{$ENDIF}
  if Assigned(OnGetCertificate) then
  begin
    OnGetCertificate(Self, ACertificate, Handled);
{$IFDEF LOGGER}clPutLogMessage(Self, edEnter, 'DoGetCertificate - event exists, cert: %d, handled: %d', nil, [Integer(ACertificate), Integer(Handled)]);{$ENDIF}
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'DoGetCertificate'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'DoGetCertificate', E); raise; end; end;{$ENDIF}
end;

procedure TclSMimeMessage.Encrypt;
var
  certs: TclCertificateStore;
  srcData, encData: TclCryptData;
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 IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisplayed)
      and (not IsCertDemoDisplayed) 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;
    IsMailMessageDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
    IsCertDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Encrypt');{$ENDIF}

  if IsEncrypted then
  begin
    raise EclMailMessageError.Create(cMessageEncrypted);
  end;
  FIsSecuring := True;
  srcData := nil;
  certs := nil;
  BeginUpdate();
  try
    certs := GetEncryptCertificates('addressbook');

    srcData := TclCryptData.Create();
    srcData.AssignByStrings(MessageSource);
    encData := certs.Encrypt(srcData);
    try
      Bodies.Clear();
      TclEnvelopedBody.Create(Bodies).Data := encData;
    except
      encData.Free();
      raise;
    end;
    ContentType := 'application/x-pkcs7-mime';
    SMimeContentType := 'enveloped-data';
    Encoding := cmMIMEBase64;
  finally
    srcData.Free();
    certs.Free();
    EndUpdate();
    FIsSecuring := False;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Encrypt'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Encrypt', E); raise; end; end;{$ENDIF}
end;

function TclSMimeMessage.GetEmailCertificate(const AFullEmail,
  AStoreName: string): TclCertificate;
  
  function GetCertificateByStore(AStore: TclCertificateStore; const AEmail: string): TclCertificate;
  begin
    try
      Result := AStore.CertificateByEmail(AEmail);
    except
      on EclCryptError do
      begin
        Result := nil;
      end;
    end;
  end;

var
  name, email: string;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'GetEmailCertificate, email: %s, store: %s', nil, [AFullEmail, AStoreName]);{$ENDIF}
  GetEmailAddressParts(AFullEmail, name, email);
  Result := GetCertificateByStore(Certificates, email);
  if (Result = nil) then
  begin