fmain.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 453 行

unit fMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SBUtils, SBDomainKeys, ExtCtrls, Clipbrd, SBPEM;

type
  TfrmMain = class(TForm)
    lblStep1: TLabel;
    lblStep3: TLabel;
    lblStep2: TLabel;
    lblStep4: TLabel;
    lblStep5: TLabel;
    lblMessageHeader: TLabel;
    lblMessageBody: TLabel;
    btnLoadMessage: TButton;
    memMessageHeader: TMemo;
    memMessageBody: TMemo;
    lblStep3Result: TLabel;
    btnProcessHeader: TButton;
    dlgOpenMessage: TOpenDialog;
    grpSignatureParameters: TGroupBox;
    grpPrivateKey: TGroupBox;
    lblDomain: TLabel;
    lblSelector: TLabel;
    lblQueryType: TLabel;
    edtDomain: TEdit;
    edtSelector: TEdit;
    cmbQueryType: TComboBox;
    memPrivateKey: TMemo;
    btnPastePrivateKey: TButton;
    btnLoadPrivateKey: TButton;
    dlgOpenPrivateKey: TOpenDialog;
    btnProcessBody: TButton;
    lblStep5Result: TLabel;
    pnlTop: TPanel;
    pnlBottom: TPanel;
    btnReset: TButton;
    lblStep7: TLabel;
    btnSign: TButton;
    lblStep6Result: TLabel;
    lblSignature: TLabel;
    memSignature: TMemo;
    btnSaveMessage: TButton;
    btnSetMethod: TButton;
    lblCanonicalization: TLabel;
    cmbCanonicalization: TComboBox;
    btnSetPrivateKey: TButton;
    lblStep6: TLabel;
    dlgSaveSigned: TSaveDialog;
    lblStep4Notes: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnLoadMessageClick(Sender: TObject);
    procedure btnProcessHeaderClick(Sender: TObject);
    procedure btnPastePrivateKeyClick(Sender: TObject);
    procedure btnLoadPrivateKeyClick(Sender: TObject);
    procedure btnProcessBodyClick(Sender: TObject);
    procedure btnSignClick(Sender: TObject);
    procedure btnSetMethodClick(Sender: TObject);
    procedure btnSetPrivateKeyClick(Sender: TObject);
    procedure btnResetClick(Sender: TObject);
    procedure btnSaveMessageClick(Sender: TObject);
  private
    // Signer
    FSigner: TElDomainKeysSigner;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  // create an instance of verifier
  FSigner := TElDomainKeysSigner.Create(nil);
  // set default values for combos
  cmbCanonicalization.ItemIndex := 1;
  cmbQueryType.ItemIndex := 0;
  // disable all steps except the first one
  btnSetMethod.Enabled := False;          // step 2
  btnProcessHeader.Enabled := False;      // step 3
  btnSetPrivateKey.Enabled := False;      // step 4
  btnProcessBody.Enabled := False;        // step 5
  btnSign.Enabled := False;               // step 6
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  // destroy the instance of verifier
  FreeAndNil(FSigner);
end;

procedure TfrmMain.btnLoadMessageClick(Sender: TObject);
var
  Text: TStringList;
  I: Integer;
  HeaderDone: Boolean;
  S: string;
begin
  // call Open File Dialog
  if dlgOpenMessage.Execute then
  begin
    // create a temporary string list
    Text := TStringList.Create;
    try
      // load content of the file to the temporary string list
      Text.LoadFromFile(dlgOpenMessage.FileName);
      // iterate the content line by line to separate header and body
      HeaderDone := False;
      for I := 0 to Text.Count - 1 do
      begin
        S := Text[I];
        if not HeaderDone then
        begin
          // header is not loaded yet
          memMessageHeader.Lines.Add(S);
          if S = '' then    // first empty line separates header and body
            HeaderDone := True;
        end
        else
        begin
          // header is loaded already
          memMessageBody.Lines.Add(S);
        end;
      end;
    finally
      Text.Free;
    end;
    // if the message was loaded successfully, enable the next step
    btnSetMethod.Enabled := True;
    // and disable the current step
    btnLoadMessage.Enabled := False;
  end;
end;

procedure TfrmMain.btnSetMethodClick(Sender: TObject);
begin
  // setting up a canonicalization method
  case cmbCanonicalization.ItemIndex of
    0: FSigner.Canonicalization := dkSimple;
    1: FSigner.Canonicalization := dkNoFWS;
  else
    MessageDlg('Invalid Canonicalization Method specified', mtError, [mbOk], 0);
    Exit;
  end;
  // enable the next step
  btnProcessHeader.Enabled := True;
  // and disable the current one
  btnSetMethod.Enabled := False;
end;

procedure TfrmMain.btnProcessHeaderClick(Sender: TObject);
var
  Result: Integer;
begin
  // call the ProcessHeader method if the signer
  Result := FSigner.ProcessHeader(memMessageHeader.Lines);
  if Result = SB_DK_SIGNER_ERROR_SUCCESS then
  begin
    // the ProcessHeader method returned no error
    lblStep3Result.Caption := 'Succeeded. The message can be signed';
    edtDomain.Text := FSigner.Domain;
    // enable the next step
    btnSetPrivateKey.Enabled := True;
    // and disable the current step
    btnProcessHeader.Enabled := False;
    // scroll the form to make Step 4 controls visible
    //ScrollInView(btnSign);
  end
  else
  begin
    // ProcessHeader method returned an error
    case Result of
      SB_DK_SIGNER_ERROR_INVALID_STATE:
        begin
          // returned if the ProcessHeader and ProcessBodyLine
          // methods are called in wrang order; so this error will
          // not be returned in this demo app
          lblStep3Result.Caption := 'Internal error. Press "RESET" to start from top';
        end;
      SB_DK_SIGNER_ERROR_INVALID_HEADER:
        begin
          // returned if signer has failed to parse message header
          lblStep3Result.Caption := 'Invalid header format. Press "RESET" to start from top';
        end;
      SB_DK_SIGNER_ERROR_EMPTY_HEADER:
        begin
          // returned if empty header was passed
          lblStep3Result.Caption := 'Empty message header. Press "RESET" to start from top';
        end;
      SB_DK_SIGNER_ERROR_INVALID_SENDER:
        begin
          // returned if the Sender field of the message is empty
          lblStep3Result.Caption := 'Sender field doesn'' contain any address. Press "RESET" to start from top';
        end;
      SB_DK_SIGNER_ERROR_SEVERAL_SENDERS:
        begin
          // returned if the Sender field of the message contains several addresses
          lblStep3Result.Caption := 'Sender field contains several addresses. Press "RESET" to start from top';
        end;
      SB_DK_SIGNER_ERROR_NO_DOMAIN:
        begin
          // returned if the Sender or From field does not contain a valid address,
          // so the signer has failed to extract a domain name
          lblStep3Result.Caption := 'Failed to extract a domain name. Press "RESET" to start from top';
        end;
      SB_DK_SIGNER_ERROR_NO_AUTHOR:
        begin
          // returned if the message doesn't contain Sender nor From fields
          lblStep3Result.Caption := 'Cannot find the author of the message. Press "RESET" to start from top';
        end;
    else
      // actually the ProcessHeader method returns only the codes handled above,
      // but just in case...
      lblStep3Result.Caption := 'Unknown error. Press "RESET" to start from top';
    end;
    // disable the current step; Reset method of signer must be called
    // to process next message
    btnProcessHeader.Enabled := False;
  end;
end;

procedure TfrmMain.btnPastePrivateKeyClick(Sender: TObject);
begin
  memPrivateKey.Lines.Clear;
  if Clipboard.HasFormat(CF_TEXT) then
    memPrivateKey.Lines.Text := Clipboard.AsText;
end;

procedure TfrmMain.btnLoadPrivateKeyClick(Sender: TObject);
begin
  if dlgOpenPrivateKey.Execute then
  begin
    memPrivateKey.Lines.Clear;
    memPrivateKey.Lines.LoadFromFile(dlgOpenPrivateKey.FileName);
  end;
end;

procedure TfrmMain.btnSetPrivateKeyClick(Sender: TObject);
var
  S, KeyType, Buffer: string;
  Result, BufferSize: Integer;
begin
  // setting the selector
  if edtSelector.Text = '' then
  begin
    MessageDlg('Selector MUST be specified', mtError, [mbOk], 0);
    edtSelector.SetFocus;
    Exit;
  end;
  FSigner.Selector := edtSelector.Text;
  // setting the query type
  case cmbQueryType.ItemIndex of
    0: FSigner.QueryType := dkDNS;
  else
    MessageDlg('Invalid Query Type specified', mtError, [mbOk], 0);
    Exit;
  end;
  // decoding the private key
  S := memPrivateKey.Lines.Text;
  KeyType := '';
  BufferSize := 0;
  // estimate output buffer size
  Result := SBPEM.Decode(@S[1], Length(S), nil, '', BufferSize, KeyType);
  if (Result <> PEM_DECODE_RESULT_NOT_ENOUGH_SPACE) or (BufferSize = 0) then
  begin
    // we expected "Not Enough Space" error but got something different
    MessageDlg('Cannot decode the private key', mtError, [mbOk], 0);
    Exit;
  end;
  if not SameText(KeyType, 'RSA PRIVATE KEY') then
  begin
    // by now only RSA keys can be used
    MessageDlg('RSA private key is expected', mtError, [mbOk], 0);
    Exit;
  end;
  // actually decode the key
  SetLength(Buffer, BufferSize);
  Result := SBPEM.Decode(@S[1], Length(S), @Buffer[1], '', BufferSize, KeyType);
  if (Result <> PEM_DECODE_RESULT_OK) or (BufferSize = 0) then
  begin
    MessageDlg('Failed to decode the private key', mtError, [mbOk], 0);
    Exit;
  end;
  if not FSigner.SetPrivateKey(@Buffer[1], BufferSize) then
  begin
    MessageDlg('Failed to set the private key', mtError, [mbOk], 0);
    Exit;
  end;
  // enable the next step
  btnProcessBody.Enabled := True;
  // and disable the current one
  btnSetPrivateKey.Enabled := False;
  // scroll the form to bottom
  ScrollInView(pnlBottom);
end;

procedure TfrmMain.btnProcessBodyClick(Sender: TObject);
var
  I, Result: Integer;
begin
  // call ProcessBodyLine method of signer for each line of the message body
  for I := 0 to memMessageBody.Lines.Count - 1 do
  begin
    Result := FSigner.ProcessBodyLine(memMessageBody.Lines[I]);
    if Result <> SB_DK_SIGNER_ERROR_SUCCESS then
    begin
      // SB_DK_SIGNER_ERROR_INVALID_STATE code will be returned if
      // ProcessBodyLine is called before ProcessHeader; so this
      // code will not be returned in this demo app
      lblStep5Result.Caption := 'Internal error';
      // disable the current step; Reset method of signer must be called
      // to process next message
      btnProcessBody.Enabled := False;
      Exit;
    end;
  end;
  // the body is processed successfully
  lblStep5Result.Caption := 'Succeeded';
  // enable the next step
  btnSign.Enabled := True;
  // and disable the current one
  btnProcessBody.Enabled := False;
  // scroll the form to bottom
  ScrollInView(pnlBottom);
end;

procedure TfrmMain.btnSignClick(Sender: TObject);
var
  Result: Integer;
begin
  // sign the message
  Result := FSigner.Sign(memSignature.Lines);
  if Result = SB_DK_SIGNER_ERROR_SUCCESS then
  begin
    lblStep6Result.Caption := 'Succeeded';
  end
  else
  begin
    // Sign method returned an error
    case Result of
      SB_DK_SIGNER_ERROR_INVALID_STATE:
        begin
          // returned if Sign method is called before ProcessHeader;
          // so this error code will not be returned in this demo
          lblStep6Result.Caption := 'Internal error';
        end;
      SB_DK_SIGNER_ERROR_NO_SELECTOR:
        begin
          // returned if no Selector was set; this error code
          // will not be returned in this demo
          lblStep6Result.Caption := 'No selector specified';
        end;
      SB_DK_SIGNER_ERROR_NO_DOMAIN:
        begin
          // returned if the ProcessHeader method was unable to determine
          // a domain name to be used to sign the message and returned
          // the corresponding error code; this error code
          // will not be returned in this demo
          lblStep6Result.Caption := 'No domain name specified';
        end;
      SB_DK_SIGNER_ERROR_NO_PRIVATE_KEY:
        begin
          // returned if no private key is set; this error code
          // will not be returned in this demo
          lblStep6Result.Caption := 'No private key is set';
        end;
      SB_DK_SIGNER_ERROR_FAILURE:
        begin
          // the signed has failed while signing the message
          lblStep6Result.Caption := 'Failed to sign the message';
        end;
    else
      // actually the Sign method returns only the codes handled above,
      // but just in case...
      lblStep6Result.Caption := 'Unknown error';
    end;
  end;
  // disable the current step
  btnSign.Enabled := False;
  // scroll the form to bottom
  ScrollInView(pnlBottom);
end;

procedure TfrmMain.btnSaveMessageClick(Sender: TObject);
var
  F: TextFile;
  I: Integer;
begin
  if dlgSaveSigned.Execute then
  begin
    AssignFile(F, dlgSaveSigned.FileName);
    try
      Rewrite(F);
    except
      MessageDlg(Format('Failed to open the file (%s)', [dlgSaveSigned.FileName]), mtError, [mbOk], 0);
      Exit;
    end;
    try
      // the signature must be written before the original message header
      for I := 0 to memSignature.Lines.Count - 1 do
        WriteLn(F, memSignature.Lines[I]);
      // write the original message header
      for I := 0 to memMessageHeader.Lines.Count - 1 do
        WriteLn(F, memMessageHeader.Lines[I]);
      // write the original message body
      for I := 0 to memMessageBody.Lines.Count - 1 do
        WriteLn(F, memMessageBody.Lines[I]);
    finally
      CloseFile(F);
    end;
  end;
end;

procedure TfrmMain.btnResetClick(Sender: TObject);
begin
  // reset the signer
  FSigner.Reset;
  // clear controls
  memMessageHeader.Lines.Clear;
  memMessageBody.Lines.Clear;
  lblStep3Result.Caption := '';
  edtDomain.Text := '';
  lblStep5Result.Caption := '';
  lblStep6Result.Caption := '';
  memSignature.Lines.Clear;
  // enable the first step
  btnLoadMessage.Enabled := True;
  // scroll the form to top
  ScrollInView(pnlTop);
end;


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

end.