generatecert.pas

著名的SecureBlackBox控件完整源码

  Result := False;

  if (rbFromFile.Checked) then
  begin
    if (edtCertificateFile.Text = '') then
    begin
      ShowMessage('One or several fields have not been specified. Correct, please.');
      Exit;
    end;

    AssignFile(F, edtCertificateFile.Text);
    Reset(F, 1);
    I := 0;
    while not Eof(F) do
    begin
      BlockRead(F, Buffer1[I], 1);
      Inc(I);
    end;

    CloseFile(F);
    Flag := 1;
    if OpenIndex1 = 1 then              // Binary certificate
      CACert.LoadFromBuffer(@Buffer1[0], I)
    else                                // PEM certificate
    begin
      if InputQuery('Password', 'Enter password:', S) then
      begin
        I1 := CACert.LoadFromBufferPEM(@Buffer1[0], I, S);
        while I1 = PEM_DECODE_RESULT_INVALID_PASSPHRASE do
        begin
          MessageDlg('Incorrect password', mtInformation, [mbOk], 0);
          if InputQuery('Password', 'Enter password:', S) then
            I1 := CACert.LoadFromBufferPEM(@Buffer1[0], I, S)
          else
            Exit;
        end;
      end
      else
        Exit;

      case I1 of
        PEM_DECODE_RESULT_INVALID_FORMAT : MessageDlg('Invalid format', mtInformation, [mbOk], 0);
        PEM_DECODE_RESULT_NOT_ENOUGH_SPACE : MessageDlg('Not enough space', mtInformation, [mbOk], 0);
        PEM_DECODE_RESULT_UNKNOWN_CIPHER : MessageDlg('Unknown cipher', mtInformation, [mbOk], 0);
      end;

      Size := 4096;
      CACert.SaveKeyToBufferPEM(@Buffer[0], Size, S);
      if (Size <> 0) then
      begin
        CACert.LoadKeyFromBufferPEM(@Buffer[0], I, S);
        Flag := 0;
        if CACert.PublicKeyAlgorithm = SB_CERT_ALGORITHM_DH_PUBLIC then
        begin
          ShowMessage('This Certificate can not be used for signing');
          Exit;
        end;
      end
      else
      begin
        ShowMessage('This Certificate does not have a private key.');
        Exit;
      end;
    end;

    if (Flag = 1) and (edtPrivateKeyFile.Text <> '') then
    begin
      AssignFile(F, edtPrivateKeyFile.Text);
      Reset(F, 1);
      I := 0;
      while not Eof(F) do
      begin
        BlockRead(F, Buffer1[I], 1);
        Inc(I);
      end;

      CloseFile(F);
      if OpenIndex2 = 1 then // Binary certificate
        CACert.LoadKeyFromBuffer(@Buffer1[0], I)
      else                                // PEM certificate
        CACert.LoadKeyFromBufferPEM(@Buffer1[0], I, '');

      if CACert.PublicKeyAlgorithm = SB_CERT_ALGORITHM_DH_PUBLIC then
      begin
        ShowMessage('This Certificate can not be used for signing');
        Exit;
      end;
    end
    else
      if (Flag = 1) and (edtPrivateKeyFile.Text = '') then
      begin
        ShowMessage('Private key file name has not been specified. Correct, please.');
        Exit;
      end;
  end
  else
  begin
    if (rbFromStorage.Checked) then
    begin
      if ((tvCertificates.Selected = nil) or (tvCertificates.Selected.Data = nil) or
         not (TObject(tvCertificates.Selected.Data) is TElX509Certificate)) then
        ShowMessage('This is not Certificate type. Correct, please.')
      else
      begin
        Size := 4096;
        TElX509Certificate(tvCertificates.Selected.Data).SaveKeyToBuffer(@Buffer[0], Size);
        if Size = 0 then
        begin
          ShowMessage('This Certificate doesn''t have a private key. Correct your choice, please.');
          Exit;
        end
        else
        begin
          TElX509Certificate(tvCertificates.Selected.Data).Clone(CACert,True);
          if CACert.PublicKeyAlgorithm = SB_CERT_ALGORITHM_DH_PUBLIC then
          begin
            ShowMessage('This Certificate can not be used for signing');
            Exit;
          end;
        end;
      end;
    end;
  end;

  Result := True;
end;

procedure TfrmGenerateCert.btnNextClick(Sender: TObject);
var
  Tab: TTabSheet;
begin
  Tab := pcMain.ActivePage;
  if Tab = tsSelectAction then
  begin
    if SelfSignedCertificate or CreateCSR then
      pcMain.ActivePage := tsSelectKeyAndHashAlgorithm
    else
      pcMain.ActivePage := tsSelectParentCertificate;

    btnBack.Enabled := True;
  end
  else if Tab = tsSelectKeyAndHashAlgorithm then
  begin
    if not ValidateKeyLength then
      Exit;

    pcMain.ActivePage := tsEnterFields;
    btnBack.Enabled := True;
  end
  else if Tab = tsSelectKeyAlgorithm then
  begin
    if not ValidateKeyLength then
      Exit;

    pcMain.ActivePage := tsEnterFields;
  end
  else if Tab = tsEnterFields then
  begin
    if not ValidateEnterFields then
      Exit;

    if CreateCSR then
    begin
      lbGenerate.Caption := 'The certificate request will be generated now. This process can take long time, depending on the key length.';
      pcMain.ActivePage := tsGenerate;
      btnNext.Enabled := False;
    end
    else
      pcMain.ActivePage := tsSpecifyPeriod;
  end
  else if Tab = tsSpecifyPeriod then
  begin
    lbGenerate.Caption := 'The certificate will be generated now. This process can take long time, depending on the key length.';
    pcMain.ActivePage := tsGenerate;
    btnNext.Enabled := False;
  end
  else if Tab = tsSelectParentCertificate then
  begin
    if not ProcessSelectParentCertificate then
      Exit;

    pcMain.ActivePage := tsSelectKeyAlgorithm;
  end;
end;

procedure TfrmGenerateCert.btnBackClick(Sender: TObject);
var
  Tab: TTabSheet;
begin
  Tab := pcMain.ActivePage;
  if Tab = tsSelectParentCertificate then
  begin
    pcMain.ActivePage := tsSelectAction;
    btnBack.Enabled := False;
  end
  else if Tab = tsGenerate then
  begin
    if (CreateCSR) then
      pcMain.ActivePage := tsEnterFields
    else
      pcMain.ActivePage := tsSpecifyPeriod;

    btnNext.Enabled := true;
  end
  else if Tab = tsSpecifyPeriod then
  begin
    pcMain.ActivePage := tsEnterFields;
  end
  else if Tab = tsEnterFields then
  begin
    if SelfSignedCertificate or CreateCSR then
    begin
      pcMain.ActivePage := tsSelectKeyAndHashAlgorithm;
      if (CreateCSR) then
        btnBack.Enabled := false;
    end
    else
    begin
      pcMain.ActivePage := tsSelectKeyAlgorithm;
    end;
  end
  else if Tab = tsSelectKeyAlgorithm then
  begin
    pcMain.ActivePage := tsSelectParentCertificate;
  end
  else if Tab = tsSelectKeyAndHashAlgorithm then
  begin
    pcMain.ActivePage := tsSelectAction;
    btnBack.Enabled := false;
  end
  else if Tab = tsSaveCertificateRequest then
    pcMain.ActivePage := tsGenerate;
end;


procedure TfrmGenerateCert.btnRequestClick(Sender: TObject);
begin
  SaveDlg.Title := 'Save Certificate Request';
  SaveDlg.DefaultExt := 'crq';
  SaveDlg.Filter := 'Certificate Requests (*.crq)|*.crq|Certificate Requests in text format (*.csr)|*.csr|PEM Encoded certificate requests (*.pem)|*.pem|Text Files (*.txt)|*.txt';
  SaveDlg.FilterIndex := 1;
  if SaveDlg.Execute then
    edRequest.Text := SaveDlg.FileName;
end;

procedure TfrmGenerateCert.btnPrivateKeyClick(Sender: TObject);
begin
  SaveDlg.Title := 'Save Private Key';
  SaveDlg.DefaultExt := 'key';
  SaveDlg.Filter := 'Private Keys (*.key)|*.key|MS-secret private keys (*.pvk)|*.pvk|Base64-encoded private keys (*.pem)|*.pem|All Files (*.*)|*.*';
  SaveDlg.FilterIndex := 1;
  if SaveDlg.Execute then
    edPrivateKey.Text := SaveDlg.FileName;
end;

procedure TfrmGenerateCert.btnSaveClick(Sender: TObject);
var
  Ext, Pwd: string;
  Stream: TFileStream;
begin
  if (edRequest.Text = '') or (edPrivateKey.Text = '') then
  begin
    ShowMessage('You must select both files');
    Exit;
  end;

  Stream := TFileStream.Create(edRequest.Text, fmCreate);
  try
    Ext := LowerCase(Copy(edRequest.Text, Length(edRequest.Text) - 3, MaxInt));
    if (Ext = '.csr') or (Ext = '.pem') or (Ext = '.txt') then
      Request.SaveToStreamPEM(Stream)
    else
      Request.SaveToStream(Stream);
  except
    ShowMessage('Failed to save Certificate Signing Request');
    FreeAndNil(Stream);
    Exit;
  end;

  FreeAndNil(Stream);

  Stream := TFileStream.Create(edPrivateKey.Text, fmCreate);
  try
    Ext := LowerCase(Copy(edPrivateKey.Text, Length(edPrivateKey.Text) - 3, MaxInt));
    if (Ext = '.pem') or (Ext = '.pvk') then
    begin
      if not InputQuery('Enter password', 'Enter password for private key', Pwd) then
      begin
        FreeAndNil(Stream);
        Exit;
      end;

      if Ext = '.pem' then
     	Request.SaveKeyToStreamPEM(Stream, Pwd)
      else
        RaiseX509Error(Request.SaveKeyToStreamPVK(Stream, Pwd, True));
    end
    else
      Request.SaveKeyToStream(Stream);
  except
    ShowMessage('Failed to save private key for Certificate Signing Request');
    FreeAndNil(Stream);
    Exit;
  end;

  FreeAndNil(Stream);

  ModalResult := mrOK;
  Close;
end;

procedure TfrmGenerateCert.HandleThreadTerminate(Sender : TObject);
var
  Cert : TElX509Certificate;
  s : string;
  TI,Parent : TTreeNode;
begin
  Generating := False;

  Cert := TCertificateGenerationThread(Sender).Cert;

  Storage.Add(Cert);

  s := GetOIDValue(Cert.SubjectRDN, SB_CERT_OID_COMMON_NAME);
  if s = '' then
    s := GetOIDValue(Cert.SubjectRDN, SB_CERT_OID_ORGANIZATION);
  if s = '' then
    s := GetOIDValue(Cert.SubjectRDN, SB_CERT_OID_EMAIL);

  if not (TObject(MainForm.treeCert.Selected.Data) is TElX509Certificate) then
    Parent := MainForm.treeCert.Selected
  else
    Parent := MainForm.treeCert.Selected.Parent;

  TI:=MainForm.treeCert.Items.AddChildObject(Parent, s, Cert);
  TI.ImageIndex:=3; TI.SelectedIndex:=3;
  StopProgressbar;
  Screen.Cursor := crDefault;
  GlobalCert := Cert;
  Close;
end;

procedure TfrmGenerateCert.HandleCreateCSRThreadTerminate(Sender: TObject);
begin
  StopProgressbar;
  Screen.Cursor := crDefault;
  btnBack.Enabled := true;
  btnCancel.Enabled := true;
  btnGenerate.Enabled := true;
  pcMain.ActivePage := tsSaveCertificateRequest;
end;

procedure TfrmGenerateCert.rbFromStorageClick(Sender: TObject);
begin
  tvCertificates.Enabled := True;
  edtCertificateFile.Enabled := False;
  edtPrivateKeyFile.Enabled := False;
  btnLoadCertificate.Enabled := False;
  btnLoadPrivateKey.Enabled := False;
  rbFromFile.Checked := False;
end;

procedure TfrmGenerateCert.rbFromFileClick(Sender: TObject);
begin
  tvCertificates.Enabled := False;
  edtCertificateFile.Enabled := True;
  edtPrivateKeyFile.Enabled := True;
  btnLoadCertificate.Enabled := True;
  btnLoadPrivateKey.Enabled := True;
  rbFromStorage.Checked := False;
end;

procedure TfrmGenerateCert.SetCreateCSR(const Value: Boolean);
begin
  FCreateCSR := Value;
  if FCreateCSR then
  begin
    Caption := 'Certificate Signing Request generation';
    pcMain.ActivePage := tsSelectKeyAndHashAlgorithm;
  end
  else
  begin
    Caption := 'Certificate generation';
    pcMain.ActivePage := tsSelectAction;
  end;
  pcMainChange(Self);
end;

function TfrmGenerateCert.GetSelfSignedCertificate: Boolean;
begin
  Result := rbSelfSigned.Checked;
end;

function TfrmGenerateCert.GetKeyLength: Integer;
begin
  if SelfSignedCertificate or CreateCSR then
    Result := StrToIntDef(cbPublicKeyLen.Text, 0)
  else
    Result := StrToIntDef(cbKeyLen.Text, 0);
end;

function TfrmGenerateCert.GetPublicKeyAndHashAlgorithm: Integer;
begin
  try
    // Take algorithm from items
    Result:=
      Integer(rgPublicKeyAndHash.Items.Objects[rgPublicKeyAndHash.ItemIndex]);
  except Result:=0; end;
end;

function TfrmGenerateCert.GetPublicKeyAlgorithm: Integer;
begin
  if rbRSA.Checked then
    Result := SB_CERT_ALGORITHM_ID_RSA_ENCRYPTION
  else if rbDSA.Checked then
    Result := SB_CERT_ALGORITHM_ID_DSA
  else
    Result := SB_CERT_ALGORITHM_DH_PUBLIC;
end;

{ TRequestGenerationThread }

constructor TRequestGenerationThread.Create(CreateSuspended: Boolean);
begin
  inherited Create(CreateSuspended);
end;

constructor TRequestGenerationThread.Create(ARequest: TElCertificateRequest; AAlg, AKeyLen, AHash: Integer);
begin
  inherited Create(True);
  FreeOnTerminate := True;
  FRequest := ARequest;
  FAlg := AAlg;
  FKeyLen := AKeyLen;
  FHash := AHash;
end;

destructor TRequestGenerationThread.Destroy;
begin
  inherited;
end;

procedure TRequestGenerationThread.Execute;
begin
  FRequest.Generate(FAlg, FKeyLen, FHash);
end;

procedure TfrmGenerateCert.pcMainChange(Sender: TObject);
begin
  lblInfo.Caption:=pcMain.ActivePage.Hint;
end;

class procedure TfrmGenerateCert.DoCreateCertificate;
var Instance : TfrmGenerateCert;
begin
  Instance:=TfrmGenerateCert.Create(nil);
  Instance.CreateCSR := False;
  Instance.ShowModal;
  Instance.Free;
end;

class procedure TfrmGenerateCert.DoCreateCSR;
var Instance : TfrmGenerateCert;
begin
  Instance:=TfrmGenerateCert.Create(nil);
  Instance.CreateCSR := True;
  Instance.ShowModal;
  Instance.Free;
end;

procedure TfrmGenerateCert.tmGenerateTimer(Sender: TObject);
begin
  pbGenerate.Position:=pbGenerate.Position + 5;
  if pbGenerate.Position >= 100 then pbGenerate.Position:=0;
  Update; Application.ProcessMessages;
end;

end.