mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ImgList, ComCtrls, ToolWin, ExtCtrls, Buttons,
  SBUtils, SBPKCS11Base, SBPKCS11CertStorage, SBX509, StdCtrls;

type
  TfrmMain = class(TForm)
    MainMenu: TMainMenu;
    mnuFile: TMenuItem;
    mnuOpenStorage: TMenuItem;
    mnuCloseStorage: TMenuItem;
    mnuN: TMenuItem;
    mnuExit: TMenuItem;
    ImageList: TImageList;
    pClient: TPanel;
    lvCerts: TListView;
    mnuHelp: TMenuItem;
    mnuAbout: TMenuItem;
    pToolbar: TPanel;
    cbToolbar: TCoolBar;
    OpenDialog: TOpenDialog;
    pToolbarButtons: TPanel;
    btnAddCert: TSpeedButton;
    btnRemoveCert: TSpeedButton;
    Bevel: TBevel;
    cbSlots: TComboBox;
    lSlots: TLabel;
    btnOpen: TBitBtn;
    OpenDialogCert: TOpenDialog;
    btnFiles: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure mnuOpenStorageClick(Sender: TObject);
    procedure mnuCloseStorageClick(Sender: TObject);
    procedure mnuExitClick(Sender: TObject);
    procedure cbSlotsDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure btnOpenClick(Sender: TObject);
    procedure cbSlotsChange(Sender: TObject);
    procedure lvCertsChange(Sender: TObject; Item: TListItem;
      Change: TItemChange);
    procedure btnAddCertClick(Sender: TObject);
    procedure btnRemoveCertClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure btnFilesClick(Sender: TObject);
  private
    procedure OpenStorage;
    procedure CloseStorage;
    procedure ExitApp;
    procedure AddCertificate;
    procedure RemoveCertificate;
    procedure OpenSession;
    procedure RefreshCertificates;
    procedure ProcessFiles;
    procedure SetupButtons;
    function RequestPassword(const Caption: string; const Prompt: string;
      var Pass: string): boolean;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
  Storage: TElPKCS11CertStorage;
  Session: TElPKCS11SessionInfo;

implementation

uses ProcessorForm, PinForm, AboutForm;

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Storage := nil;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  if Storage <> nil then
  begin
    Storage.Close;
    FreeAndNil(Storage);
    if Session <> nil then Session := nil;
  end;
//  ShowMessage('Not implemented');
end;

procedure TfrmMain.mnuOpenStorageClick(Sender: TObject);
begin
  if Storage <> nil then
    CloseStorage;
  OpenStorage;
end;

procedure TfrmMain.mnuCloseStorageClick(Sender: TObject);
begin
  CloseStorage;
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
  ExitApp;
end;

procedure TfrmMain.OpenStorage;
var
  Path: string;
  i : integer;
  SlotInfo : TElPKCS11SlotInfo;
begin
  if OpenDialog.Execute then
  begin
    Storage := TElPKCS11CertStorage.Create(nil);
    Storage.DLLName := OpenDialog.Filename;
    Path := ExtractFilePath(Storage.DLLName);
    if Path <> '' then
      SetCurrentDir(Path);

    lvCerts.Items.Clear;
    cbSlots.Items.Clear;
    cbSlots.Items.Add('<Please select a slot>');

    try
      Storage.Open;

      for i := 0 to Storage.Module.SlotCount - 1 do
      begin
        SlotInfo := Storage.Module.Slot[i];
        cbSlots.Items.Add(SlotInfo.SlotDescription);
      end;

      cbSlots.ItemIndex := 0;

    except
      on E : Exception do
      begin
        FreeAndNil(Storage);
        MessageDlg('Error opening storage: ' + OpenDialog.Filename + #13#10 + E.Message,
          mtError, [mbOk], 0);
        Exit;
      end;
    end;

    SetupButtons;
  end;
end;

procedure TfrmMain.CloseStorage;
begin
  Storage.Close;
  cbSlots.Items.Clear;
  lvCerts.Items.Clear;
  FreeAndNil(Storage);
  if Session <> nil then Session := nil;
  SetupButtons;
end;

procedure TfrmMain.ExitApp;
begin
  if Storage <> nil then
    CloseStorage;
  Application.Terminate;
end;

procedure TfrmMain.AddCertificate;
var
  Cert: TElX509Certificate;
  F : {$ifndef DELPHI_NET}TFileStream{$else}FileStream{$endif};
  R : integer;
  Pass : string;
begin
  if OpenDialogCert.Execute then
  begin
    {$ifndef DELPHI_NET}
    F := TFileStream.Create(OpenDialogCert.Filename, fmOpenRead);
    {$else}
    F := FileStream.Create(OpenDialogCert.Filename, FileMode.Open, FileAccess.Read);
    {$endif}
    try
      if RequestPassword('Password request', 'Please enter password for certificate:', Pass) then
      begin;
        Cert := TElX509Certificate.Create(nil);
        try
          R := Cert.LoadFromStreamPFX(F, Pass);
        except
          Cert.Free;
          raise;
        end;
        if R = 0 then
        begin
          try
            Storage.Add(Cert, true);
          finally
            Cert.Free;
          end;
          RefreshCertificates;
        end
        else
          MessageDlg('Failed to load certificate, error ' + IntToHex(R, 4),
            mtError, [mbOk], 0);
      end;
    finally
      F.Free;
    end;
  end;
end;

procedure TfrmMain.RemoveCertificate;
var
  S : string;
  Cert : TElX509Certificate;
begin
  if (lvCerts.Selected <> nil) and (lvCerts.Selected.Index < Storage.Count) then
  begin
    Cert := Storage.Certificates[lvCerts.Selected.Index];
    S := 'Subject: ' + Cert.SubjectName.CommonName + #13#10 +
      'Issuer: ' + Cert.IssuerName.CommonName;
    if MessageDlg('The following certificate will be deleted:'#13#10 + S,
      mtWarning, [mbYes, mbNo], 0) = mrYes then
    begin
      Storage.Remove(lvCerts.Selected.Index);
      RefreshCertificates;
    end;
  end;
end;

procedure TfrmMain.OpenSession;
var
  Pin : string;
  RO  : boolean;
begin
  { Checking whether we can establish a new session }
  if cbSlots.ItemIndex <= 0 then
    Exit;
  if not Storage.Module.Slot[cbSlots.ItemIndex - 1].TokenPresent then
  begin
    MessageDlg('Token not found in specified slot', mtError, [mbOk], 0);
    Exit;
  end;
  { Closing current session }
  if Session <> nil then
  begin
    lvCerts.Items.Clear;
    Session.Logout;
    Storage.CloseSession(0);
    Session := nil;
  end;
  { Opening new session }
  RO := Storage.Module.Slot[cbSlots.ItemIndex - 1].ReadOnly;
  try
    Session := Storage.OpenSession(cbSlots.ItemIndex - 1, RO);
  except
    on E : ECertStorageError do
    begin
      if not RO then
        Session := Storage.OpenSession(cbSlots.ItemIndex - 1, true)
      else
        Raise;
    end;
  end;
  if (Session <> nil) and (RequestPassword('PIN request', 'Please enter your PIN:', Pin)) then
  begin
    try
      Session.Login(utUser, Pin);
    except
      Storage.CloseSession(0);
      Session := nil;
    end;
  end;
  RefreshCertificates;
  SetupButtons;
end;

procedure TfrmMain.RefreshCertificates;
var
  i : integer;
  Cert: TElX509Certificate;
  Item: TListItem;
  S : string;
  function GetAlgStr(alg : integer): string;
  begin
    case alg of
      SB_CERT_ALGORITHM_ID_RSA_ENCRYPTION : Result := 'RSA';
      SB_CERT_ALGORITHM_ID_DSA : Result := 'DSA';
      SB_CERT_ALGORITHM_DH_PUBLIC : Result := 'DH';
    else
      Result := 'Unknown';
    end;
  end;
begin
  lvCerts.Items.Clear;
  for i := 0 to Storage.Count - 1 do
  begin                    
    Cert := Storage.Certificates[i];
    Item := lvCerts.Items.Add;
    Item.ImageIndex := 3;
    { Subject }
    S := Cert.SubjectName.CommonName;
    if S = '' then
      S := Cert.SubjectName.Organization;
    Item.Caption := S;
    { Issuer }
    S := Cert.IssuerName.CommonName;
    if S = '' then
      S := Cert.IssuerName.Organization;
    Item.SubItems.Add(S);
    { Validity period }
    Item.SubItems.Add(DateToStr(Cert.ValidFrom));
    Item.SubItems.Add(DateToStr(Cert.ValidTo));
    { Algorithm }
    S := GetAlgStr(Cert.PublicKeyAlgorithm);
    S := S + ' (' + IntToStr(Cert.GetPublicKeySize) + ' bits)';
    Item.SubItems.Add(S);
  end;
end;

procedure TfrmMain.SetupButtons;
begin
  btnAddCert.Enabled := (Session <> nil);
  btnRemoveCert.Enabled := (Session <> nil);
  mnuCloseStorage.Enabled := (Storage <> nil);
  btnOpen.Enabled := Storage <> nil;
end;

function TfrmMain.RequestPassword(const Caption: string; const Prompt: string;
  var Pass: string): boolean;
begin
  frmPIN.lPrompt.Caption := Prompt;
  frmPIN.Caption := Caption;
  if frmPIN.ShowModal = mrOk then
  begin
    Pass := frmPIN.EditPin.Text;
    Result := true;
  end
  else
    Result := false;
end;

procedure TfrmMain.cbSlotsDrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  Img : integer;
begin
  cbSlots.Canvas.FillRect(Rect);
  if (Index <> 0) then
  begin
    if Storage.Module.Slot[Index - 1].TokenPresent then
      Img := 1
    else
      Img := 2;
    ImageList.Draw(cbSlots.Canvas, Rect.Left, Rect.Top, Img);
  end;
  cbSlots.Canvas.TextOut(Rect.Left + ImageList.Width + 2, Rect.Top,
    cbSlots.Items[Index]);
end;

procedure TfrmMain.btnOpenClick(Sender: TObject);
begin
  OpenSession;
end;

procedure TfrmMain.cbSlotsChange(Sender: TObject);
begin
  btnOpen.Enabled := cbSlots.ItemIndex > 0;
end;

procedure TfrmMain.lvCertsChange(Sender: TObject; Item: TListItem;
  Change: TItemChange);
begin
  btnRemoveCert.Enabled := Item <> nil;
  btnFiles.Enabled := Item <> nil;
end;

procedure TfrmMain.btnAddCertClick(Sender: TObject);
begin
  AddCertificate;
end;

procedure TfrmMain.btnRemoveCertClick(Sender: TObject);
begin
  if lvCerts.Selected <> nil then
    RemoveCertificate;
end;

procedure TfrmMain.mnuAboutClick(Sender: TObject);
begin
  frmAbout.ShowModal;
end;

procedure TfrmMain.btnFilesClick(Sender: TObject);
begin
  if lvCerts.Selected <> nil then
    ProcessFiles;
end;

procedure TfrmMain.ProcessFiles;
var
  Cert : TElX509Certificate;
begin
  if (lvCerts.Selected <> nil) and (lvCerts.Selected.Index < Storage.Count) then
  begin
    Cert := Storage.Certificates[lvCerts.Selected.Index];
    frmProcessor.CertStorage.Clear;
    frmProcessor.CertStorage.Add(Cert, true);
    frmProcessor.ShowModal;
  end;
end;


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

end.