frmmain.pas

著名的SecureBlackBox控件完整源码

unit frmMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, SBUtils, SBSimpleSSL, SBHTTPSClient, SBOCSPCommon, SBOCSPClient, SBHTTPOCSPClient, SBX509,
  SBPKCS7, SBPKCS12, SBPEM, SBCustomCertStorage;

type
  TMainForm = class(TForm)
    dlgOpen: TOpenDialog;
    Label1: TLabel;
    Label2: TLabel;
    cbSignRequest: TCheckBox;
    Label3: TLabel;
    OCSPClient: TElHTTPOCSPClient;
    HTTPClient: TElHTTPSClient;
    CertStorage: TElMemoryCertStorage;
    IssuerCertStorage: TElMemoryCertStorage;
    SigningCertStorage: TElMemoryCertStorage;
    Label4: TLabel;
    btnCheck: TButton;
    btnBrowseCert: TButton;
    btnBrowseIssuerCerts: TButton;
    btnBrowseSignCert: TButton;
    edtCert: TEdit;
    edtIssuerCerts: TEdit;
    edtSignCert: TEdit;
    edtURL: TEdit;
    procedure btnBrowseCertClick(Sender: TObject);
    procedure btnBrowseIssuerCertsClick(Sender: TObject);
    procedure btnBrowseSignCertClick(Sender: TObject);
    procedure btnCheckClick(Sender: TObject);
    procedure OCSPClientCertificateNeeded(Sender: TObject;
      var Certificate: TElX509Certificate);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.btnBrowseCertClick(Sender: TObject);
begin
  if dlgOpen.Execute then
    edtCert.Text := dlgOpen.Filename;
end;

procedure TMainForm.btnBrowseIssuerCertsClick(Sender: TObject);
begin
  if dlgOpen.Execute then
    edtIssuerCerts.Text := dlgOpen.Filename;
end;

procedure TMainForm.btnBrowseSignCertClick(Sender: TObject);
begin
  if dlgOpen.Execute then
    edtSignCert.Text := dlgOpen.Filename;
end;

function AskForPassword(filename : string) : string;
begin
  result := InputBox('Password needed', 'Enter password for ' + ExtractFilename(Filename), '');
end;

procedure LoadCertificates(Filename : string; Storage : TElCustomCertStorage);
var Format : TSBCertFileFormat;
    Cert   : TElX509Certificate;
    Stream : TFileStream;
begin
  Storage.Clear;
  Format := TElX509Certificate.DetectCertFileFormat(Filename);
  if Format = cfUnknown then
  begin
    ShowMessage(FileName + ' doesn''t contain valid certificate(s)');
    exit;
  end;
  Cert := TElX509Certificate.CreatE(nil);
  try
    try
      Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
      try
        case Format of
          cfDER: Cert.LoadFromStream(Stream);
          cfPEM: if Cert.LoadFromStreamPEM(Stream, '') = PEM_DECODE_RESULT_INVALID_PASSPHRASE then
            RaisePEMError(Cert.LoadFromStreamPEM(Stream, AskForPassword(Filename)));
          cfPFX: if Cert.LoadFromStreamPFX(Stream, '') = SB_PKCS12_ERROR_INVALID_PASSWORD then
            RaisePKCS12Error(Cert.LoadFromStreamPFX(Stream, AskForPassword(Filename)));
          cfSPC: RaisePKCS7Error(Cert.LoadFromStreamSPC(Stream));
        end;
      finally
        Stream.Free;
      end;
      Storage.Add(Cert);
    except
      on E : EFOpenError do
      begin
        ShowMessage('Failed to load the certificate(s) from ' + Filename);
      end;
      on E : ESecureBlackboxError do
        Application.ShowException(E);
    end;
  finally
    Cert.Free;
  end;
end;

procedure TMainForm.btnCheckClick(Sender: TObject);
var Reply : ByteArray;
    res : integer;
    ServerResult: TElOCSPServerError;
    Reason : TSBCertificateValidityReason;
    Validity : TSBCertificateValidity;
    i : integer;
const
  status : array[TElOCSPServerError] of string =
    ('Success', 'Malformed request', 'Internal error', 'Try later', '', 'Signature required', 'Unauthorized');
begin
  LoadCertificates(edtCert.Text, CertStorage);
  LoadCertificates(edtIssuerCerts.Text, IssuerCertStorage);

  OCSPClient.IncludeSignature := cbSignRequest.Checked;
  if OCSPClient.IncludeSignature then
    LoadCertificates(edtSignCert.Text, SigningCertStorage);

  OCSPClient.URL := Trim(edtURL.Text);

  OCSPClient.Nonce := DateTimeToStr(Now); // In real life use some cryptographically strong random data

  res := OCSPClient.PerformRequest(ServerResult, Reply);
  if res <> 0 then
  begin
    case res of
      SB_OCSP_ERROR_NO_PARAMETERS: ShowMessage('URL not specified');
      SB_OCSP_ERROR_NO_REPLY: ShowMessage('Failed to retrieve a reply from OCSP server');
      SB_OCSP_ERROR_WRONG_SIGNATURE: ShowMessage('Reply from OCSP server contains invalid or broken signature');
      SB_OCSP_ERROR_NO_CERTIFICATES: ShowMessage('No certificates have been specified for checking');
      SB_OCSP_ERROR_NO_ISSUER_CERTIFICATES: ShowMessage('No issuer certificates were found');
      else
        ShowMessage(Format('Error %x happened when trying to check certificate status', [res]));
    end;
  end
  else
  begin
    ShowMessage('The server replied with the following status: ' + status[ServerResult]);
    if ServerResult = oseSuccessful then
    begin
      // First validate the server certificates
      Validity := cvStorageError;
      if OCSPClient.ReplyCertificates.Count = 0 then
        ShowMessage('The server didn''t include signing certificates to the reply');
      for i := OCSPClient.ReplyCertificates.Count - 1 downto 0 do
      begin
        Validity := OCSPClient.ReplyCertificates.Validate(OCSPClient.ReplyCertificates.Certificates[i], Reason);
        if Validity = cvInvalid then
          break;
      end;
      if Validity = cvInvalid then
        ShowMessage('One of certificates, used to sign the reply, is not valid');

      // Next, check certificate's status
      for i := 0 to CertStorage.Count -1 do
      begin
        case OCSPClient.CertStatus[i] of
          csGood: ShowMessage(Format('Certificate %d is ok', [i]));
          csRevoked: ShowMessage(Format('Certificate %d has been revoked at %s', [i, DateTimeToStr(OCSPClient.RevocationTime[i])]));
          csUnknown: ShowMessage(Format('Certificate %d is not known to OCSP server', [i]));
        end;
      end; 
    end;
  end;
end;

procedure TMainForm.OCSPClientCertificateNeeded(Sender: TObject;
  var Certificate: TElX509Certificate);
begin
  Certificate := nil;
  // in real life you need to look for certificates with
  // subject name equal to OCSPClient.ServerName
end;

initialization

  SetLicenseKey('ADDCD14AD06709806817E0B3D7BFD0A2222D536FE156466C5D5FE65DB5DEAE76' + 
  'FFDEBC07E915A5751C12C01C783958872A38E4A5EDA140E7247E0F2E56442A3C' + 
  'F3E9347AD8FDE52083A0DFC86BC00ECB0FD0CF1B51159A2BCB84F6EA6349EF47' + 
  '5C15A59AFCC55F7C3AAD26C279628B5D91B1DC94BD2385354A70CCA3B76101D9' + 
  'F41C84A639FC3CCE4BA8F0CC4A66DCD150114A3F58C1AD46B7B94643741BC20A' + 
  '8DCA83AB921480951B423CAA19EF1863A47CA2C3422E7E5634BED98939A5AE43' + 
  'DE1E4BAD79E66D8A5C973B3455656C8C9B6FF024FADD6CDA02D0F506D98493C8' +
  'BD1ED7B237DB75FA31F2C82654490CDDDEE24E19939137B9E1DB05508733B22F');

end.