referenceform.pas

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

unit ReferenceForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls,
  SBUtils, SBXMLCore, SBXMLDefs, SBXMLSec, SBXMLTransform;

type
  TfrmReference = class(TForm)
    lbURI: TLabel;
    lbDigestMethod: TLabel;
    Bevel2: TBevel;
    lbID: TLabel;
    Bevel3: TBevel;
    edURI: TEdit;
    cmbDigestMethod: TComboBox;
    mmData: TMemo;
    edID: TEdit;
    lbTransforms: TListBox;
    btnAddTransform: TButton;
    btnDeleteTransform: TButton;
    cmbTransform: TComboBox;
    Bevel1: TBevel;
    btnOK: TButton;
    btnCancel: TButton;
    btnVerify: TButton;
    edXPath: TEdit;
    lbXPath: TLabel;
    rbURINode: TRadioButton;
    rbURIData: TRadioButton;
    edURINode: TEdit;
    lbDigestValue: TLabel;
    edDigestValue: TEdit;
    edNSMap: TEdit;
    Label1: TLabel;
    edXPathNSMap: TEdit;
    lbXPathNS: TLabel;
    procedure edURINodeExit(Sender: TObject);
    procedure mmDataExit(Sender: TObject);
    procedure rbURIDataClick(Sender: TObject);
    procedure rbURINodeClick(Sender: TObject);
    procedure cmbDigestMethodChange(Sender: TObject);
    procedure cmbTransformChange(Sender: TObject);
    procedure btnVerifyClick(Sender: TObject);
    procedure btnDeleteTransformClick(Sender: TObject);
    procedure btnAddTransformClick(Sender: TObject);
  private
    FDocument: TElXMLDOMDocument;
    FReference: TElXMLReference;
    FURINode: TElXMLDOMNode;
    FVerify: Boolean;

    procedure ExtractURINode;

    procedure SetVerify(const Value: Boolean);
    function GetReference: TElXMLReference;
    procedure SetReference(const Value: TElXMLReference);

    function TransformToStr(Transform: TElXMLTransform): string;
    procedure UpdateDigestValue;
    procedure UpdateTransformChain;
    procedure UpdateURINode(Node: TElXMLDOMNode);
  public
    property Document: TElXMLDOMDocument read FDocument write FDocument;
    property Reference: TElXMLReference read GetReference write SetReference;
    property Verify: Boolean read FVerify write SetVerify;
  end;

var
  frmReference: TfrmReference;

implementation

{$R *.dfm}

{ TfrmReference }

procedure TfrmReference.btnAddTransformClick(Sender: TObject);
var
  C14N: TElXMLC14NTransform;
  XPathTransform: TElXMLXPathTransform;
  s, t: XMLString;
  i: Integer;
begin
  if cmbTransform.Text = 'Base64 transform' then
    FReference.TransformChain.Add(TElXMLBase64Transform.Create)
  else
  if cmbTransform.Text = 'Enveloped signature transform' then
    FReference.TransformChain.Add(TElXMLEnvelopedSignatureTransform.Create)
  else
  if cmbTransform.Text = 'XPath transform' then
  begin
    XPathTransform := TElXMLXPathTransform.Create;
    XPathTransform.XPath := edXPath.Text;

    s := Trim(edXPathNSMap.Text);
    while s <> '' do
    begin
      i := Pos(',', s);
      if i > 0 then
      begin
        t := Trim(Copy(s, 1, i - 1));
        s := Trim(Copy(s, i + 1, MaxInt));
      end
      else
      begin
        t := s;
        s := '';
      end;

      i := Pos('=', t);
      if i > 0 then
        XPathTransform.NamespaceMap.AddNamespace(Trim(Copy(t, 1, i - 1)), Trim(Copy(t, i + 1, MaxInt)));
    end;

    FReference.TransformChain.Add(XPathTransform);
  end
  else
  begin
    C14N := TElXMLC14NTransform.Create;
    if cmbTransform.Text = 'Canonical transform' then
    begin
      C14N.CanonicalizationMethod := xcmCanon;
      FReference.TransformChain.Add(C14N);
    end
    else
    if cmbTransform.Text = 'Canonical with comments transform' then
    begin
      C14N.CanonicalizationMethod := xcmCanonComment;
      FReference.TransformChain.Add(C14N);
    end
    else
    if cmbTransform.Text = 'Minimal canonical transform' then
    begin
      C14N.CanonicalizationMethod := xcmMinCanon;
      FReference.TransformChain.Add(C14N);
    end
    else
      FreeAndNil(C14N);
  end;

  UpdateDigestValue;
  UpdateTransformChain;
end;

procedure TfrmReference.btnDeleteTransformClick(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to lbTransforms.Items.Count - 1 do
    if lbTransforms.Selected[i] then
    begin
      FReference.TransformChain.Delete(i);
      Break;
    end;

  UpdateDigestValue;
  UpdateTransformChain;
end;

procedure TfrmReference.btnVerifyClick(Sender: TObject);
var
  dv: ByteArray;
begin
  dv := FReference.DigestValue;
  FReference.UpdateDigestValue;
  if SBUtils.CompareMem(FReference.DigestValue, dv) then
    MessageDlg('Verified OK', mtInformation, [mbOK], 0)
  else
    MessageDlg('BAD digest or data', mtError, [mbOK], 0);

  FReference.DigestValue := dv;
end;

procedure TfrmReference.cmbDigestMethodChange(Sender: TObject);
begin
  case cmbDigestMethod.ItemIndex of
    0: FReference.DigestMethod := xdmMD5;
    1: FReference.DigestMethod := xdmSHA1;
    2: FReference.DigestMethod := xdmSHA224;
    3: FReference.DigestMethod := xdmSHA256;
    4: FReference.DigestMethod := xdmSHA384;
    5: FReference.DigestMethod := xdmSHA512;
    6: FReference.DigestMethod := xdmRIPEMD160;
  else
    FReference.DigestMethod := xdmSHA1;
  end;

  UpdateDigestValue;
end;

procedure TfrmReference.cmbTransformChange(Sender: TObject);
begin
  edXPath.Enabled := (cmbTransform.Text = 'XPath transform');
  lbXPath.Enabled := edXPath.Enabled;
  lbXPathNS.Enabled := edXPath.Enabled;
  edXPathNSMap.Enabled := edXPath.Enabled;
end;

procedure TfrmReference.edURINodeExit(Sender: TObject);
begin
  ExtractURINode;

  if rbURINode.Checked then
  begin
    FReference.URINode := FURINode;
    UpdateDigestValue;
  end;
end;

procedure TfrmReference.ExtractURINode;
var
  NodeSet: TElXMLNodeSet;
  NSMap: TElXMLNamespaceMap;
  s, t: XMLString;
  i: Integer;
begin
  if edNSMap.Text = '' then
    NodeSet := FDocument.SelectNodes(edURINode.Text)
  else
  begin
    NSMap := TElXMLNamespaceMap.Create;
    try
      s := Trim(edNSMap.Text);
      while s <> '' do
      begin
        i := Pos(',', s);
        if i > 0 then
        begin
          t := Trim(Copy(s, 1, i - 1));
          s := Trim(Copy(s, i + 1, MaxInt));
        end
        else
        begin
          t := s;
          s := '';
        end;

        i := Pos('=', t);
        if i > 0 then
          NSMap.AddNamespace(Trim(Copy(t, 1, i - 1)), Trim(Copy(t, i + 1, MaxInt)));
      end;

      NodeSet := FDocument.SelectNodes(edURINode.Text, NSMap);
    finally
      FreeAndNil(NSMap);
    end;
  end;

  try
    if NodeSet.Count > 0 then
      FURINode := NodeSet.Node[0]
    else
      FURINode := nil;

  finally
    FreeAndNil(NodeSet);
  end;
end;

function TfrmReference.GetReference: TElXMLReference;
begin
  FReference.ID := edID.Text;
  FReference.URI := edURI.Text;

  Result := FReference;
end;

procedure TfrmReference.mmDataExit(Sender: TObject);
begin
  FReference.URIData := BytesOfString(mmData.Text);
  UpdateDigestValue;
end;

procedure TfrmReference.rbURIDataClick(Sender: TObject);
begin
  rbURINode.Checked := not rbURIData.Checked;
  if rbURINode.Checked then
    FReference.URINode := FURINode
  else
    FReference.URINode := nil;

  UpdateDigestValue;
end;

procedure TfrmReference.rbURINodeClick(Sender: TObject);
begin
  rbURIData.Checked := not rbURINode.Checked;
  if rbURINode.Checked then
    FReference.URINode := FURINode
  else
    FReference.URINode := nil;

  UpdateDigestValue;
end;

procedure TfrmReference.SetReference(const Value: TElXMLReference);
begin
  FReference := Value;
  edID.Text := FReference.ID;
  edURI.Text := FReference.URI;

  case FReference.DigestMethod of
    xdmMD5: cmbDigestMethod.ItemIndex := 0;
    xdmSHA1: cmbDigestMethod.ItemIndex := 1;
    xdmSHA224: cmbDigestMethod.ItemIndex := 2;
    xdmSHA256: cmbDigestMethod.ItemIndex := 3;
    xdmSHA384: cmbDigestMethod.ItemIndex := 4;
    xdmSHA512: cmbDigestMethod.ItemIndex := 5;
    xdmRIPEMD160: cmbDigestMethod.ItemIndex := 6;
  end;

  FURINode := FReference.URINode;
  UpdateURINode(FURINode);
  mmData.Text := StringOfBytes(FReference.URIData);

  rbURINode.Checked := Assigned(FURINode);

  if Verify then
  begin
    if Length(FReference.DigestValue) > 0 then
      edDigestValue.Text := BinaryToString(@FReference.DigestValue[0], Length(FReference.DigestValue))
    else
      edDigestValue.Text := '';
  end
  else
    UpdateDigestValue;

  UpdateTransformChain;
end;

procedure TfrmReference.SetVerify(const Value: Boolean);
begin
  FVerify := Value;
  btnAddTransform.Enabled := not FVerify;
  btnDeleteTransform.Enabled := not FVerify;
  edID.ReadOnly := FVerify;
  edURI.ReadOnly := FVerify;
  btnVerify.Visible := FVerify;
end;

function TfrmReference.TransformToStr(Transform: TElXMLTransform): string;
begin
  Result := 'Unknown transform';
  if Transform is TElXMLBase64Transform then
    Result := 'Base64 transform'
  else
  if Transform is TElXMLC14NTransform then
  begin
    if TElXMLC14NTransform(Transform).CanonicalizationMethod = xcmCanon then
      Result := 'Canonical transform'
    else
    if TElXMLC14NTransform(Transform).CanonicalizationMethod = xcmCanonComment then
      Result := 'Canonical with comments transform'
    else
    if TElXMLC14NTransform(Transform).CanonicalizationMethod = xcmMinCanon then
      Result := 'Minimal canonical transform';
  end
  else
  if Transform is TElXMLEnvelopedSignatureTransform then
    Result := 'Enveloped signature transform'
  else
  if Transform is TElXMLXPathTransform then
    Result := 'XPath transform';
end;

procedure TfrmReference.UpdateDigestValue;
begin
  if Verify then
    Exit;

  try
    FReference.UpdateDigestValue;
    if Length(FReference.DigestValue) > 0 then
      edDigestValue.Text := BinaryToString(@FReference.DigestValue[0], Length(FReference.DigestValue))
    else
      edDigestValue.Text := '';
  except
    edDigestValue.Text := '';
  end;
end;

procedure TfrmReference.UpdateTransformChain;
var
  i: Integer;
begin
  lbTransforms.Clear;
  for i := 0 to FReference.TransformChain.Count - 1 do
    lbTransforms.Items.AddObject(TransformToStr(FReference.TransformChain.Transforms[i]), FReference.TransformChain.Transforms[i]);

  edXPath.Enabled := (cmbTransform.Text = 'XPath transform');
  lbXPath.Enabled := edXPath.Enabled;
  lbXPathNS.Enabled := edXPath.Enabled;
  edXPathNSMap.Enabled := edXPath.Enabled;
end;

procedure TfrmReference.UpdateURINode(Node: TElXMLDOMNode);
var
  PrevNode: TElXMLDOMNode;
  NSMap: TElXMLNamespaceMap;
  s, p, Path: XMLString;
  i, k: Integer;
begin
  if not Assigned(Node) then
  begin
    edURINode.Text := '';
    edNSMap.Text := '';
    Exit;
  end;

  NSMap := TElXMLNamespaceMap.Create;
  Path := '';
  while not (Node is TElXMLDOMDocument) do
  begin
    i := 0;
    PrevNode := Node.PreviousSibling;
    while Assigned(PrevNode) do
    begin
      if (PrevNode.NodeName = Node.NodeName) and
         (PrevNode.NamespaceURI = Node.NamespaceURI) then
        Inc(i);

      PrevNode := PrevNode.PreviousSibling;
    end;

    s := Node.NodeName;
    if Node.NamespaceURI <> '' then
    begin
      p := '';
      if Node.Prefix <> '' then
        p := Node.Prefix
      else
      begin
        for k := 0 to NSMap.Count - 1 do
          if NSMap.URI[k] = Node.NamespaceURI then
          begin
            p := NSMap.Prefix[k];
            Break;
          end;

        if p = '' then
        begin
          p := 'x';
          k := 1;
          while NSMap.FindNamespace(p) <> '' do
          begin
            Inc(k);
            p := 'x' + IntToStr(k);
          end;
        end;

        NSMap.AddNamespace(p, Node.NamespaceURI);
      end;

      s := p + ':' + s
    end;

    if i > 0 then
      Path := '/' + s + '[' + IntToStr(i + 1) + ']' + Path
    else
      Path := '/' + s + Path;

    Node := Node.ParentNode;
  end;

  if Path = '' then
    Path := '/';

  s := '';
  for i := 0 to NSMap.Count - 1 do
    if (NSMap.Prefix[i] <> '') and (NSMap.Prefix[i] <> 'xml') then
    begin
      if s <> '' then
        s := s + ', ';

      s := s + NSMap.Prefix[i] + '=' + NSMap.URI[i];
    end;

  FreeAndNil(NSMap);

  edURINode.Text := Path;
  edNSMap.Text := s;
end;

end.