clcert.pas

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

    begin
      GetMem(pStruct, cbStruct);
      CryptDecodeObject(X509_ASN_ENCODING or PKCS_7_ASN_ENCODING, X509_NAME,
        FCertContext.pCertInfo.Subject.pbData, FCertContext.pCertInfo.Subject.cbData,
        0, pStruct, @cbStruct);
			pInfo := PCERT_NAME_INFO(pStruct);
			for i := 0 to pInfo.cRDN - 1 do
      begin
				pEntry := PCERT_RDN(Integer(pInfo.rgRDN) + i * SizeOf(CERT_RDN));
				for j := 0 to pEntry.cRDNAttr - 1 do
        begin
          pRDNAttr := PCERT_RDN_ATTR(Integer(pEntry.rgRDNAttr) + j * SizeOf(CERT_RDN_ATTR));
          if (SameText(string(pRDNAttr.pszObjId), szOID_RSA_emailAddr)) then
					begin
            Result := string(PChar(pRDNAttr.Value.pbData));
						Break;
          end;
        end;
				if (Result <> '') then Break;
      end;
      FreeMem(pStruct);
    end;
  end;
end;

class function TclCertificate.GetLastErrorText: string;
var
  code: DWORD;
  Len: Integer;
  Buffer: array[0..255] of Char;
begin
  code := GetLastError();
  Len := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM,
    Pointer(GetModuleHandle('crypt32.dll')), code, 0, Buffer, SizeOf(Buffer), nil);
  while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  SetString(Result, Buffer, Len);
end;

function TclCertificate.Sign(const AData: TclCryptData;
  ADetachedSignature, AIncludeCertificate: Boolean): TclCryptData;
var
  data: array[0..0] of PByte;
  msgCert: array[0..0] of PCCERT_CONTEXT;
  dwDataSizeArray: array[0..0] of DWORD;
  sigParams: CRYPT_SIGN_MESSAGE_PARA;
  cbSignedBlob: DWORD;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Sign');{$ENDIF}
  Result := TclCryptData.Create();
  try
    ZeroMemory(@sigParams, SizeOf(CRYPT_SIGN_MESSAGE_PARA));
    sigParams.cbSize := SizeOf(CRYPT_SIGN_MESSAGE_PARA);
    sigParams.dwMsgEncodingType := (X509_ASN_ENCODING or PKCS_7_ASN_ENCODING);
    sigParams.pSigningCert := Context;
    sigParams.HashAlgorithm.pszObjId := szOID_RSA_SHA1RSA; //szOID_RSA_MD5
    if AIncludeCertificate then
    begin
      sigParams.cMsgCert := 1;
      sigParams.rgpMsgCert := @msgCert;
      msgCert[0] := Context;
    end;
    data[0] := AData.Data;
    dwDataSizeArray[0] := AData.DataSize;
    cbSignedBlob := 0;
    if CryptSignMessage(@sigParams, ADetachedSignature, 1, @data[0], @dwDataSizeArray[0], nil, @cbSignedBlob) then
    begin
      Result.Allocate(cbSignedBlob);
      if CryptSignMessage(@sigParams, ADetachedSignature, 1, @data[0], @dwDataSizeArray[0], Result.Data, @cbSignedBlob) then
      begin
        Result.Reduce(cbSignedBlob);
        Exit;
      end;
    end;
    raise EclCryptError.Create(GetLastErrorText(), GetLastError());
  except
    Result.Free();
    raise;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Sign'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Sign', E); raise; end; end;{$ENDIF}
end;

function GetSignerCertificate(pvGetArg: PVOID;
  dwCertEncodingType: DWORD; pSignerId: PCERT_INFO;
  hMsgCertStore: HCERTSTORE): PCCERT_CONTEXT; stdcall;
begin
  Result := CertDuplicateCertificateContext(PCCERT_CONTEXT(pvGetArg));
end;

function TclCertificate.VerifyEnveloped(const AData: TclCryptData): TclCryptData;
var
  verifyPara: CRYPT_VERIFY_MESSAGE_PARA;
  cbVerified: DWORD;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'VerifyEnveloped');{$ENDIF}
  Result := TclCryptData.Create();
  try
    ZeroMemory(@verifyPara, SizeOf(verifyPara));
    verifyPara.cbSize := SizeOf(verifyPara);
    verifyPara.dwMsgAndCertEncodingType := (X509_ASN_ENCODING or PKCS_7_ASN_ENCODING);
    verifyPara.pfnGetSignerCertificate := GetSignerCertificate;
    verifyPara.pvGetArg := Context;
    cbVerified := 0;
    if CryptVerifyMessageSignature(@verifyPara, 0, AData.Data, AData.DataSize, nil, @cbVerified, nil) then
    begin
      Result.Allocate(cbVerified);
      if CryptVerifyMessageSignature(@verifyPara, 0, AData.Data, AData.DataSize, Result.Data, @cbVerified, nil) then
      begin
        Result.Reduce(cbVerified);
        Exit;
      end;
    end;
    raise EclCryptError.Create(GetLastErrorText(), GetLastError());
  except
    Result.Free();
    raise;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'VerifyEnveloped'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'VerifyEnveloped', E); raise; end; end;{$ENDIF}
end;

procedure TclCertificate.VerifyDetached(const AData, ASignature: TclCryptData);
var
  verifyPara: CRYPT_VERIFY_MESSAGE_PARA;
  rgpbToBeSigned: array[0..0] of PBYTE;
  rgcbToBeSigned: array[0..0] of DWORD;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'VerifyDetached');{$ENDIF}
  ZeroMemory(@verifyPara, SizeOf(verifyPara));
  verifyPara.cbSize := SizeOf(verifyPara);
  verifyPara.dwMsgAndCertEncodingType := (X509_ASN_ENCODING or PKCS_7_ASN_ENCODING);
  verifyPara.pfnGetSignerCertificate := GetSignerCertificate;
  verifyPara.pvGetArg := Context;
  rgpbToBeSigned[0] := AData.Data;
  rgcbToBeSigned[0] := AData.DataSize;
  if not CryptVerifyDetachedMessageSignature(@verifyPara,
    0, ASignature.Data, ASignature.DataSize, 1, @rgpbToBeSigned[0], @rgcbToBeSigned[0], nil) then
  begin
    raise EclCryptError.Create(GetLastErrorText(), GetLastError());
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'VerifyDetached'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'VerifyDetached', E); raise; end; end;{$ENDIF}
end;

constructor TclCertificate.CreateFromBinary(AEncoded: PByte; ALength: Integer);
begin
  inherited Create();
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'CreateFromBinary');{$ENDIF}
  FCertContext := CertCreateCertificateContext(X509_ASN_ENCODING or PKCS_7_ASN_ENCODING,
    AEncoded, ALength);
  FCertContext := CertDuplicateCertificateContext(FCertContext);
  if (FCertContext = nil) then
  begin
    raise EclCryptError.Create(GetLastErrorText(), GetLastError());
  end;
  GetCertInfo();
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'CreateFromBinary'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'CreateFromBinary', E); raise; end; end;{$ENDIF}
end;

{ TclCertificateStore }

procedure TclCertificateStore.Add(ACertificate: TclCertificate);
begin
  FList.Add(ACertificate);
end;

procedure TclCertificateStore.Close;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
  begin
    Items[i].Free();
  end;
  FList.Clear();
  if (FStoreHandle <> nil) then
  begin
    CertCloseStore(FStoreHandle, 0);
    FStoreHandle := nil;
  end;
end;

constructor TclCertificateStore.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FList := TList.Create();
  FStoreName := '';
end;

destructor TclCertificateStore.Destroy;
begin
  Close();
  FList.Free();
  inherited Destroy();
end;

procedure TclCertificateStore.AddFromBinary(const AData: TclCryptData);
var
  hStore: HCERTSTORE;
begin
  hStore := CryptGetMessageCertificates((X509_ASN_ENCODING or PKCS_7_ASN_ENCODING),
    0, 0, AData.Data, AData.DataSize);
  if (hStore <> nil) then
  begin
    try
      InternalLoad(hStore);
    finally
      CertCloseStore(hStore, 0);
    end;
  end else
  begin
    raise EclCryptError.Create(TclCertificate.GetLastErrorText(), GetLastError());
  end;
end;

function TclCertificateStore.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TclCertificateStore.GetItem(Index: Integer): TclCertificate;
begin
  Result := TclCertificate(FList[Index]);
end;

procedure TclCertificateStore.LoadFromSystemStore(const AStoreName: string);
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'LoadFromSystemStore: ' + AStoreName);{$ENDIF}
  Close();
  FStoreName := AStoreName;
  FStoreHandle := CertOpenSystemStore(0, PChar(StoreName));
  if (FStoreHandle <> nil) then
  begin
    InternalLoad(FStoreHandle);
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'LoadFromSystemStore'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'LoadFromSystemStore', E); raise; end; end;{$ENDIF}
end;

function TclCertificateStore.CertificateByEmail(const AEmail: string): TclCertificate;
var
  i: Integer;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'CertificateByEmail: ' + AEmail);{$ENDIF}
  for i := 0 to Count -1 do
  begin
    Result := Items[i];
    if SameText(Result.GetEMailFromSubject(), AEmail) or
      SameText(Result.GetEMailFromAltSubject(), AEmail) then
    begin
      Exit;
    end;
  end;
  raise EclCryptError.Create(cCertificateNotFound, -1);
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'CertificateByEmail'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'CertificateByEmail', E); raise; end; end;{$ENDIF}
end;

function TclCertificateStore.CertificateByIssuedTo(const AIssuedTo: string): TclCertificate;
var
  i: Integer;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'CertificateByIssuedTo: ' + AIssuedTo);{$ENDIF}
  for i := 0 to Count -1 do
  begin
    Result := Items[i];
    if SameText(Result.IssuedTo, AIssuedTo) then
    begin
      Exit;
    end;
  end;
  raise EclCryptError.Create(cCertificateNotFound, -1);
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'CertificateByIssuedTo'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'CertificateByIssuedTo', E); raise; end; end;{$ENDIF}
end;

procedure TclCertificateStore.Delete(Index: Integer);
begin
  Items[Index].Free();
  FList.Delete(Index);
end;

procedure TclCertificateStore.ImportFromPFX(const AFileName, APassword: string);
var
  PFX: CRYPT_DATA_BLOB;
  data: TclCryptData;
  stream: TStream;
  psw: PWideChar;
  hStore: HCERTSTORE;
begin
  stream := nil;
  data := nil;
  try
    stream := TFileStream.Create(AFileName, fmOpenRead);
    data := TclCryptData.Create();
    data.Allocate(stream.Size);
    stream.Read(data.Data^, data.DataSize);
    PFX.cbData := data.DataSize;
    PFX.pbData := data.Data;
    psw := PWideChar(WideString(APassword));

    hStore := PFXImportCertStore(@PFX, psw, CRYPT_EXPORTABLE);
    if (hStore <> nil) then
    begin
      try
        InternalLoad(hStore);
      finally
        CertCloseStore(hStore, 0);
      end;
    end else
    begin
      raise EclCryptError.Create(TclCertificate.GetLastErrorText(), GetLastError());
    end;
  finally
    data.Free();
    stream.Free();
  end;
end;

procedure TclCertificateStore.InternalLoad(hStore: HCERTSTORE);
var
  hCertContext: PCCERT_CONTEXT;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'InternalLoad');{$ENDIF}
  hCertContext := nil;
  repeat
    hCertContext := CertEnumCertificatesInStore(hStore, hCertContext);
    if (hCertContext <> nil) then
    begin
      Add(TclCertificate.Create(hCertContext));
    end;
  until (hCertContext = nil);
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'InternalLoad'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'InternalLoad', E); raise; end; end;{$ENDIF}
end;

procedure TclCertificateStore.LoadFromStore(AStoreHandle: HCERTSTORE);
begin
  Close();
  FStoreName := '';
  FStoreHandle := AStoreHandle;
  if (FStoreHandle <> nil) then
  begin
    InternalLoad(FStoreHandle);
  end;
end;

procedure TclCertificateStore.Install(ACertificate: TclCertificate);
var
  hStore, hPersistStore: HCERTSTORE;
begin
  hPersistStore := nil;
  hStore := FStoreHandle;
  try
    if (hStore = nil) then
    begin
      hPersistStore := CertOpenSystemStore(0, PChar(StoreName));
      hStore := hPersistStore;
    end;
    if (hStore = nil)
      or (not CertAddCertificateContextToStore(hStore, ACertificate.Context, CERT_STORE_ADD_NEW, nil)) then
    begin
      raise EclCryptError.Create(TclCertificate.GetLastErrorText(), GetLastError());
    end;
  finally
    if (hPersistStore <> nil) then
    begin
      CertCloseStore(hPersistStore, CERT_CLOSE_STORE_FORCE_FLAG);
    end;
  end;
end;

procedure TclCertificateStore.Uninstall(ACertificate: TclCertificate);
begin
  if not CertDeleteCertificateFromStore(CertDuplicateCertificateContext(ACertificate.Context)) then
  begin
    raise EclCryptError.Create(TclCertificate.GetLastErrorText(), GetLastError());
  end;
end;

function TclCertificateStore.IsInstalled(ACertificate: TclCertificate): Boolean;
var
  cont: PCCERT_CONTEXT;
  hStore, hPersistStore: HCERTSTORE;
begin
  Result := False;
  hPersistStore := nil;
  hStore := FStoreHandle;
  try
    if (hStore = nil) then
    begin
      hPersistStore := CertOpenSystemStore(0, PChar(StoreName));
      hStore := hPersistStore;
    end;
    if (hStore = nil) then              
    begin         
      raise EclCryptError.Create(TclCertificate.GetLastErrorText(), GetLastError());