clcert.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 clCert;

interface

{$I clVer.inc}

uses
  Classes, SysUtils, clCryptAPI, Windows, clUtils;

type
  TclCertificateFlag = (cfIgnoreCommonNameInvalid, cfIgnoreDateInvalid, cfIgnoreUnknownAuthority,
    cfIgnoreRevocation, cfIgnoreWrongUsage);
  TclCertificateFlags = set of TclCertificateFlag;

  TclCertificate = class;

  EclCryptError = class(Exception)
  private
    FErrorCode: Integer;
  public
    constructor Create(const AErrorMsg: string; AErrorCode: Integer);
    property ErrorCode: Integer read FErrorCode;
  end;

  TclOnGetCertificateEvent = procedure (Sender: TObject; var ACertificate: TclCertificate;
    var Handled: Boolean) of object;

  TclCryptData = class(TclBinaryData);

  TclCertificateStore = class;

  TclCertificate = class
  private
    FCertContext: PCCERT_CONTEXT;
    FIssuedTo: string;
    FEmail: string;
    FIssuedBy: string;
    FValidTo: TDateTime;
    FValidFrom: TDateTime;
    FSerialNumber: string;
    FFriendlyName: string;
    function GetEMailFromSubject: string;
    function GetEMailFromAltSubject: string;
    class function GetLastErrorText: string;
    procedure GetCertInfo;
  public
    constructor Create(ACertContext: PCCERT_CONTEXT);
    constructor CreateFromBinary(AEncoded: PByte; ALength: Integer);
    destructor Destroy; override;
    function Sign(const AData: TclCryptData;
      ADetachedSignature, AIncludeCertificate: Boolean): TclCryptData;
    function VerifyEnveloped(const AData: TclCryptData): TclCryptData;
    procedure VerifyDetached(const AData, ASignature: TclCryptData);
    function Decrypt(const AData: TclCryptData): TclCryptData;
    function Encrypt(const AData: TclCryptData): TclCryptData;
    property Context: PCCERT_CONTEXT read FCertContext;
    property IssuedTo: string read FIssuedTo;
    property IssuedBy: string read FIssuedBy;
    property FriendlyName: string read FFriendlyName;
    property Email: string read FEmail;
    property ValidFrom: TDateTime read FValidFrom;
    property ValidTo: TDateTime read FValidTo;
    property SerialNumber: string read FSerialNumber;
  end;

  TclCertificateInfo = class
  private
    FInfo: CERT_INFO;
    function GetInfo: PCERT_INFO;
  public
    constructor Create;
    destructor Destroy; override;
    property Info: PCERT_INFO read GetInfo;
  end;

  TclCertificateStore = class(TComponent)
  private
    FList: TList;
    FStoreName: string;
    FStoreHandle: HCERTSTORE;
    function GetCount: Integer;
    function GetItem(Index: Integer): TclCertificate;
    procedure InternalLoad(hStore: HCERTSTORE);
    function GenerateKey(AContext: HCRYPTPROV; AKeySpec: DWORD): HCRYPTKEY;
    function GenerateSubject(const ASubject: string): TclCryptData;
    function GenerateCertInfo(ASubject, AIssuer: TclCryptData; ASerialNumber: Integer;
      AValidFrom, AValidTo: TDateTime): TclCertificateInfo;
    function GeneratePublicKeyInfo(AContext: HCRYPTPROV; AKeySpec: DWORD): TclCryptData;
    function SignAndEncodeCert(AContext: HCRYPTPROV; AKeySpec: DWORD; ACertInfo: TclCertificateInfo): TclCryptData;
    procedure SetCertPrivateKey(const AContainer: string; AKeySpec: DWORD; ACertificate: TclCertificate);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Close;
    procedure Add(ACertificate: TclCertificate);
    function AddFrom(ACertificate: TclCertificate): TclCertificate;
    procedure AddFromBinary(const AData: TclCryptData);
    function AddSelfSigned(const ASubject: string; ASerialNumber: Integer;
      AValidFrom, AValidTo: TDateTime): TclCertificate;
    procedure Delete(Index: Integer);
    procedure Remove(ACertificate: TclCertificate);
    procedure LoadFromSystemStore(const AStoreName: string);
    procedure LoadFromStore(AStoreHandle: HCERTSTORE);
    procedure ImportFromPFX(const AFileName, APassword: string);
    procedure ExportToPFX(ACertificate: TclCertificate; const AFileName, APassword: string; AExportPrivateKey: Boolean);
    procedure Install(ACertificate: TclCertificate);
    procedure Uninstall(ACertificate: TclCertificate);
    function IsInstalled(ACertificate: TclCertificate): Boolean;
    function CertificateByEmail(const AEmail: string): TclCertificate;
    function CertificateByIssuedTo(const AIssuedTo: string): TclCertificate;
    function Encrypt(const AData: TclCryptData): TclCryptData;
    property Items[Index: Integer]: TclCertificate read GetItem; default;
    property Count: Integer read GetCount;
  published
    property StoreName: string read FStoreName write FStoreName;
  end;

resourcestring
  cMessageNotEncrypted = 'The message is not encrypted';
  cMessageEncrypted = 'The message is already encrypted';
  cMessageSigned = 'The message is already signed';
  cMessageNotSigned = 'The message is not signed';
  cCertificateRequired = 'Certificate required to complete operation';
  cCertificateNotFound = 'The specified certificate not found';

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

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

{ TclCertificate }

constructor TclCertificate.Create(ACertContext: PCCERT_CONTEXT);
begin
  inherited Create();
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Create');{$ENDIF}
  FCertContext := CertDuplicateCertificateContext(ACertContext);
  GetCertInfo();
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Create'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Create', E); raise; end; end;{$ENDIF}
end;

procedure TclCertificate.GetCertInfo();
  function GetDecodedName(AType, AFlags: Integer): string;
  var
    len: Integer;
    p: PChar;
  begin
    len := CertGetNameString(FCertContext, AType, AFlags, nil, nil, 0);
    if (len > 1) then
    begin
      GetMem(p, len);
      CertGetNameString(FCertContext, AType, AFlags, nil, p, len);
      SetString(Result, p, len - 1);
      FreeMem(p);
    end else
    begin
      Result := '';
    end;
  end;

  function GetBinToHex(ABlob: CRYPTOAPI_BLOB): string;
  var
    i: Integer;
    p: Pointer;
  begin
    Result := '';
    for i := ABlob.cbData - 1 downto 0 do
    begin
      p := Pointer(Integer(ABlob.pbData) + i);
      Result := Result + IntToHex(Byte(p^), 2);
    end;
  end;

  function GetFriendlyName: string;
  var
    cbSize: DWORD;
    p: PWideChar;
  begin
    Result := '';
    cbSize := 0;
    if not CertGetCertificateContextProperty(FCertContext,
      CERT_FRIENDLY_NAME_PROP_ID, nil, @cbSize) then Exit;
    if (cbSize < 1) then Exit;

    GetMem(p, cbSize);
    try
      CertGetCertificateContextProperty(FCertContext, CERT_FRIENDLY_NAME_PROP_ID, p, @cbSize);
      Result := string(system.Copy(p, 1, cbSize));
    finally
      FreeMem(p);
    end;
  end;

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 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;
    IsCertDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  FIssuedBy := GetDecodedName(CERT_NAME_SIMPLE_DISPLAY_TYPE, CERT_NAME_ISSUER_FLAG);
  FIssuedTo := GetDecodedName(CERT_NAME_SIMPLE_DISPLAY_TYPE, 0);

  FEmail := GetEMailFromSubject();
  if (FEmail = '') then
  begin
    FEmail := GetEMailFromAltSubject();
  end;

  FValidFrom := ConvertFileTimeToDateTime(FCertContext^.pCertInfo.NotBefore);
  FValidTo := ConvertFileTimeToDateTime(FCertContext^.pCertInfo.NotAfter);

  FSerialNumber := GetBinToHex(FCertContext^.pCertInfo.SerialNumber);

  FFriendlyName := GetFriendlyName();
end;

function TclCertificate.Decrypt(const AData: TclCryptData): TclCryptData;
var
  decryptPara: CRYPT_DECRYPT_MESSAGE_PARA;
  cbDecrypted: DWORD;
  rghCertStore: array[0..0] of HCERTSTORE;
  hStore: HCERTSTORE;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Decrypt');{$ENDIF}
  Result := TclCryptData.Create();
  try
    ZeroMemory(@decryptPara, SizeOf(decryptPara));
    decryptPara.cbSize := SizeOf(decryptPara);
    decryptPara.dwMsgAndCertEncodingType := (X509_ASN_ENCODING or PKCS_7_ASN_ENCODING);
    decryptPara.rghCertStore := @rghCertStore[0];
    decryptPara.cCertStore := 1;
    cbDecrypted := 0;

    hStore := CertOpenStore(CERT_STORE_PROV_MEMORY, 0, 0, 0, nil);
    try
      if (hStore = nil)
        or (not CertAddCertificateContextToStore(hStore, Context, CERT_STORE_ADD_NEW, nil)) then
      begin
        raise EclCryptError.Create(GetLastErrorText(), GetLastError());
      end;
      rghCertStore[0] := hStore;
      if CryptDecryptMessage(@decryptPara, AData.Data, AData.DataSize, nil, @cbDecrypted, nil) then
      begin
        Result.Allocate(cbDecrypted);
        if CryptDecryptMessage(@decryptPara, AData.Data, AData.DataSize, Result.Data, @cbDecrypted, nil) then
        begin
          Result.Reduce(cbDecrypted);
          Exit;
        end;
      end;
    finally
      if (hStore <> nil) then
      begin
        CertCloseStore(hStore, 0);
      end;
    end;
    raise EclCryptError.Create(GetLastErrorText(), GetLastError());
  except
    Result.Free();
    raise;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Decrypt'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Decrypt', E); raise; end; end;{$ENDIF}
end;

destructor TclCertificate.Destroy;
begin
  CertFreeCertificateContext(FCertContext);
  inherited Destroy();
end;

function TclCertificate.Encrypt(const AData: TclCryptData): TclCryptData;
var
  encryptPara: CRYPT_ENCRYPT_MESSAGE_PARA;
  cbEncrypted: DWORD;
  gpRecipientCert: array[0..0] of PCCERT_CONTEXT;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Encrypt');{$ENDIF}
  Result := TclCryptData.Create();
  try
    ZeroMemory(@encryptPara, SizeOf(encryptPara));
    encryptPara.cbSize := SizeOf(encryptPara);
    encryptPara.dwMsgEncodingType := (X509_ASN_ENCODING or PKCS_7_ASN_ENCODING);
    encryptPara.ContentEncryptionAlgorithm.pszObjId := szOID_RSA_RC2CBC;
    gpRecipientCert[0] := Context;
    cbEncrypted := 0;
    if CryptEncryptMessage(@encryptPara, 1, @gpRecipientCert[0], AData.Data, AData.DataSize, nil, @cbEncrypted) then
    begin
      Result.Allocate(cbEncrypted);
      if CryptEncryptMessage(@encryptPara, 1, @gpRecipientCert[0], AData.Data, AData.DataSize, Result.Data, @cbEncrypted) then
      begin
        Result.Reduce(cbEncrypted);
        Exit;
      end;
    end;
    raise EclCryptError.Create(GetLastErrorText(), GetLastError());
  except
    Result.Free();
    raise;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Encrypt'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Encrypt', E); raise; end; end;{$ENDIF}
end;

function TclCertificate.GetEMailFromAltSubject: string;
var
  i: Integer;
  pCertExtension: PCERT_EXTENSION;
  pStruct: Pointer;
  cbStruct: DWORD;
  pInfo: PCERT_ALT_NAME_INFO;
  pEntry: PCERT_ALT_NAME_ENTRY;
begin
  Assert(FCertContext <> nil);
	Assert(FCertContext.pCertInfo <> nil);
	Result := '';
	if (FCertContext.pCertInfo <> nil) then
	begin
		pCertExtension := CertFindExtension(szOID_SUBJECT_ALT_NAME2,
      FCertContext.pCertInfo.cExtension, FCertContext.pCertInfo.rgExtension);
		if (pCertExtension <> nil) then
    begin
      cbStruct := 0;
      if (CryptDecodeObject(X509_ASN_ENCODING or PKCS_7_ASN_ENCODING, szOID_SUBJECT_ALT_NAME2,
        pCertExtension.Value.pbData, pCertExtension.Value.cbData, 0, nil, @cbStruct)) then
      begin
        GetMem(pStruct, cbStruct);
        CryptDecodeObject(X509_ASN_ENCODING or PKCS_7_ASN_ENCODING, szOID_SUBJECT_ALT_NAME2,
          pCertExtension.Value.pbData, pCertExtension.Value.cbData, 0, pStruct, @cbStruct);
				pInfo := PCERT_ALT_NAME_INFO(pStruct);
				for i := 0 to pInfo.cAltEntry - 1 do
        begin
					pEntry := PCERT_ALT_NAME_ENTRY(Integer(pInfo.rgAltEntry) + i * SizeOf(CERT_ALT_NAME_ENTRY));
          if (pEntry.dwAltNameChoice = CERT_ALT_NAME_RFC822_NAME) then
          begin
            Result := string(WideString(pEntry.pwszRfc822Name));
            Break;
          end;
        end;
        FreeMem(pStruct);
      end;
    end;
  end;
end;

function TclCertificate.GetEMailFromSubject: string;
var
  i, j: Integer;
  pStruct: Pointer;
  cbStruct: DWORD;
  pInfo: PCERT_NAME_INFO;
  pEntry: PCERT_RDN;
  pRDNAttr: PCERT_RDN_ATTR;
begin
  Assert(FCertContext <> nil);
	Assert(FCertContext.pCertInfo <> nil);
	Result := '';
	if (FCertContext.pCertInfo <> nil) then
	begin
    cbStruct := 0;
		if (CryptDecodeObject(X509_ASN_ENCODING or PKCS_7_ASN_ENCODING, X509_NAME,
			FCertContext.pCertInfo.Subject.pbData, FCertContext.pCertInfo.Subject.cbData,
			0, nil, @cbStruct)) then