clsoap.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clSoap;

interface

{$I clVer.inc}
{$IFDEF DELPHI7}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_TYPE OFF}
{$ENDIF}

uses
  Windows, Classes, SysUtils, clCert, clHttpRequest, clHttpHeader
  {$IFDEF DELPHI6}, Variants, msxml {$ELSE}, msxml_tlb{$ENDIF};

type
  EclSoapMessageError = class(Exception);

  TclSignatureStyle = (ssDotNet, ssJava);

  TclTransformDataEvent = procedure (Sender: TObject; const
    Algorithm: string; var ATemplate: string; var Handled: Boolean) of object;

  TclSoapMessageHeader = class(TclHttpRequestHeader)
  private
    FStart: string;
    FSoapAction: string;
    FSubType: string;
    procedure SetSoapAction(const Value: string);
    procedure SetStart(const Value: string);
    procedure SetSubType(const Value: string);
  protected
    procedure RegisterFields; override;
    procedure InternalParseHeader(AHeader, AFieldList: TStrings); override;
    procedure InternalAssignHeader(AHeader: TStrings); override;
    procedure ParseContentType(AHeader, AFieldList: TStrings); override;
    procedure AssignContentType(AHeader: TStrings); override;
  public
    procedure Clear; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Start: string read FStart write SetStart;
    property SubType: string read FSubType write SetSubType;
    property SoapAction: string read FSoapAction write SetSoapAction;
  end;  

  TclSoapMessageItem = class(TclHttpRequestItem)
  private
    FContentID: string;
    FContentType: string;
    FContentLocation: string;
    FContentTransferEncoding: string;
    FExtraFields: TStrings;
    FCharSet: string;
    FKnownFields: TStrings;
    procedure SetContentID(const Value: string);
    procedure SetContentLocation(const Value: string);
    procedure SetContentTransferEncoding(const Value: string);
    procedure SetContentType(const Value: string);
    procedure SetCharSet(const Value: string);
    procedure SetExtraFields(const Value: TStrings);
    procedure ListChangeEvent(Sender: TObject);
    function GetHeader: TStream;
    procedure ParseExtraFields(AHeader, AFieldList: TStrings);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    procedure ParseHeader(AHeader, AFieldList: TStrings); override;
    function GetData: TStream; override;
    procedure RegisterField(const AField: string);
    procedure RegisterFields; virtual;
  public
    constructor Create(AOwner: TclHttpRequest); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property ContentType: string read FContentType write SetContentType;
    property CharSet: string read FCharSet write SetCharSet;
    property ContentID: string read FContentID write SetContentID;
    property ContentLocation: string read FContentLocation write SetContentLocation; 
    property ContentTransferEncoding: string read FContentTransferEncoding write SetContentTransferEncoding;
    property ExtraFields: TStrings read FExtraFields write SetExtraFields;
  end;

  TclXmlItem = class(TclSoapMessageItem)
  private
    FXmlData: string;
    procedure SetXmlData(const Value: string);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    procedure AddData(const AData: PChar; ADataSize: Integer); override;
    procedure AfterAddData; override;
    function GetData: TStream; override;
  public
    procedure Assign(Source: TPersistent); override;
    property XmlData: string read FXmlData write SetXmlData;
  end;

  TclAttachmentItem = class(TclSoapMessageItem)
  protected            
    procedure AddData(const AData: PChar; ADataSize: Integer); override;
    procedure AfterAddData; override;
    function GetData: TStream; override;
  end;

  TclSoapMessage = class(TclHttpRequest)
  private
    FSignReferences: TStrings;
    FSignTransforms: TStrings;
    FIdName: string;
    FIsIncludeCertificate: Boolean;
    FSignatureStyle: TclSignatureStyle;
    FOnGetCertificate: TclOnGetCertificateEvent;
    FOnTransformData: TclTransformDataEvent;
    FCertificates: TclCertificateStore;
    function GetAvailableProviderType: DWORD;
    class function GetLastErrorText(const AFuncName: string): string;
    procedure SetSignReferences(const Value: TStrings);
    procedure SetSignTransforms(const Value: TStrings);
    procedure DoListChanged(Sender: TObject);
    function GetNameSpace(ANode: IXMLDOMNode): string;
    function CreateSignature(ACertificate: TclCertificate; ASignedInfo: IXMLDomNode): IXMLDomNode;
    function CreateSignedInfo(ADom: IXMLDomDocument): IXMLDomNode;
    function CreateSecuredKeyInfo(ACertificate: TclCertificate; ASignature: IXMLDOMNode): IXMLDOMNode;
    function GetDigestValue(const AXml: string): string;
    function GetSignatureValue(ACertificate: TclCertificate; const AXml: string): string;
    function GetCertificate: TclCertificate;
    procedure SetIdName(const Value: string);
    procedure SetSignatureStyle(const Value: TclSignatureStyle);
    function TransformData(const AData: IXMLDomNode; const Algorithm: string): IXMLDomNode;
    function CreateTransforms(const AReference, AData: IXMLDomNode): IXMLDomNode;
    function ApplyTransforms(const AReference, AData: IXMLDomNode): IXMLDomNode;
    procedure CheckRequestExists;
    procedure RemoveNode(ANode: IXMLDOMNode);
    function GetIsSigned: Boolean;
    procedure SetIsIncludeCertificate(const Value: Boolean);
    function GetCertificateFromNode(ANode: IXMLDOMNode): TclCertificate;
    procedure VerifySignature(ASecurity: IXMLDOMNode);
    procedure VerifyReferenceDigests(ADom: IXMLDOMDocument; ASignature: IXMLDOMNode);
    procedure VerifySignatureValue(ACertificate: TclCertificate;
      const AData, ASignature: string); overload;
    procedure VerifySignatureValue(ACertificate: TclCertificate;
      const AData: IXMLDOMNode; const ASignature: string); overload;
    procedure VerifyDigestValue(const AData: IXMLDOMNode; const ADigestValue: string);
    function GetDsNodeName(const AName: string): string;
    function GetDsNameSpace(const AName: string): string;
    function GetHeader: TclSoapMessageHeader;
    procedure SetHeader(const Value: TclSoapMessageHeader);
  protected
    function CreateHeader: TclHttpRequestHeader; override;
    function CreateItem(AHeader, AFieldList: TStrings): TclHttpRequestItem; override;
    procedure CreateSingleItem(AStream: TStream); override;
    function GetContentType: string; override;
    procedure InitHeader; override;
    procedure DoGetCertificate(var ACertificate: TclCertificate; var Handled: Boolean); dynamic;
    procedure DoTransformData(const Algorithm: string; var ATemplate: string; var Handled: Boolean); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BuildSoapMessage(const AEnvelope, ASoapAction: string); overload;
    procedure BuildSoapMessage(AEnvelope: TStrings; const ASoapAction: string); overload;
    procedure BuildSoapMessage(AEnvelope: IXMLDOMDocument; const ASoapAction: string); overload;
    function AddXmlData(const AXmlData: string): TclXmlItem;
    function AddAttachment: TclAttachmentItem;
    procedure Sign;
    procedure Verify;
    procedure Clear; override;
    property IsSigned: Boolean read GetIsSigned;
    property Certificates: TclCertificateStore read FCertificates;
  published
    property Header: TclSoapMessageHeader read GetHeader write SetHeader;
    property SignReferences: TStrings read FSignReferences write SetSignReferences;
    property SignTransforms: TStrings read FSignTransforms write SetSignTransforms;
    property IdName: string read FIdName write SetIdName;
    property IsIncludeCertificate: Boolean read FIsIncludeCertificate write SetIsIncludeCertificate default True;
    property SignatureStyle: TclSignatureStyle read FSignatureStyle write SetSignatureStyle default ssDotNet;
    property OnGetCertificate: TclOnGetCertificateEvent read FOnGetCertificate write FOnGetCertificate;
    property OnTransformData: TclTransformDataEvent read FOnTransformData write FOnTransformData;
  end;

  TclXmlCanonicalizer = class
  private
    function BuildXmlString(ARootNode: IXMLDOMNode): WideString;
    function BuildAttributes(ANode: IXMLDOMNode): WideString;
    function NormalizeAttributeValue(AValue: WideString): WideString;
    function NormalizeText(AText: WideString): WideString;
  public
    function Canonicalize(ARootNode: IXMLDOMNode): string;
  end;

resourcestring
  cSoapDataNotFound = 'Can not find the specified SOAP data item';
  cSoapFormatError = 'SOAP request format error';
  cGetNameSpaceFailed = 'Unable to obtain the namespace for the envelope node';
  cRequestEmpty = 'The xml data is not specified in the SOAP request object';
  cReferencesEmpty = 'The SOAP References are not defined for the SOAP request object';
  cVerifyDigestFailed = 'Digest values are different';
  
implementation

uses
  clCryptAPI{$IFDEF DEMO}, Forms{$ENDIF}, clEncoder, clUtils, clXmlUtils, clTranslator, clStreams;
                                           
const
  dsNameSpace = 'ds';
  wsseNameSpace = 'wsse';

{$IFNDEF DELPHI6}
function VarToWideStr(const V: Variant): WideString;
begin
  Result := WideString(VarToStr(V));
end;
{$ENDIF}

{ TclSoapMessage }

procedure TclSoapMessage.BuildSoapMessage(AEnvelope: TStrings; const ASoapAction: string);
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsHttpRequestDemoDisplayed) and (not IsCertDemoDisplayed)
      and (not IsEncoderDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsHttpRequestDemoDisplayed := True;
    IsCertDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

  Clear();
  AddXmlData(AEnvelope.Text);
  Header.ContentType := 'text/xml';
  Header.SoapAction := ASoapAction;
end;

constructor TclSoapMessage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCertificates := TclCertificateStore.Create(nil);
  FCertificates.StoreName := 'addressbook';
  FSignReferences := TStringList.Create();
  FSignTransforms := TStringList.Create();
  TStringList(FSignReferences).OnChange := DoListChanged;
  TStringList(FSignTransforms).OnChange := DoListChanged;
  FIdName := 'Id';
  FSignatureStyle := ssDotNet;
  FIsIncludeCertificate := True;
end;

destructor TclSoapMessage.Destroy;
begin
  FSignTransforms.Free();
  FSignReferences.Free();
  FCertificates.Free();
  inherited Destroy();
end;

procedure TclSoapMessage.DoListChanged(Sender: TObject);
begin
  BeginUpdate();
  EndUpdate();
end;

procedure TclSoapMessage.SetSignReferences(const Value: TStrings);
begin
  FSignReferences.Assign(Value);
end;

procedure TclSoapMessage.SetSignTransforms(const Value: TStrings);
begin
  FSignTransforms.Assign(Value);
end;

procedure TclSoapMessage.CheckRequestExists;
begin
  if (Self.Count = 0) or (not (Self.Items[0] is TclSoapMessageItem))
    or (TclXmlItem(Self.Items[0]).XmlData = '') then
  begin
    raise EclSoapMessageError.Create(cRequestEmpty);
  end;
end;

procedure TclSoapMessage.Sign;
var
  dom: IXMLDOMDocument;
  envNameSpace: string;
  envelope, header, security,
  signedInfo, signature: IXMLDOMNode;
  cert: TclCertificate;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsHttpRequestDemoDisplayed) and (not IsCertDemoDisplayed)
      and (not IsEncoderDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsHttpRequestDemoDisplayed := True;
    IsCertDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

  CheckRequestExists();
  if (SignReferences.Count = 0) then
  begin
    raise EclSoapMessageError.Create(cReferencesEmpty);
  end;
  if IsSigned then
  begin
    raise EclSoapMessageError.Create(cMessageSigned);
  end;
  dom := CoDOMDocument.Create();
  dom.loadXML(TclXmlItem(Self.Items[0]).XmlData);
  envNameSpace := GetNameSpace(dom.lastChild);
  if (envNameSpace = '') then
  begin
    raise EclSoapMessageError.Create(cGetNameSpaceFailed);
  end;
  header := dom.selectSingleNode('//' + envNameSpace + ':Header');
  if (header = nil) then
  begin
    envelope := dom.selectSingleNode('//' + envNameSpace + ':Envelope');
    if (envelope = nil) then
    begin
      raise EclSoapMessageError.Create(cSoapFormatError);
    end;
    header := dom.createElement(envNameSpace + ':Header');
    envelope.insertBefore(header, envelope.firstChild);
  end;
  signedInfo := CreateSignedInfo(dom);

  cert := GetCertificate();

  signature := CreateSignature(cert, signedInfo);
  security := CreateSecuredKeyInfo(cert, signature);

  header.insertBefore(security, header.firstChild);
  TclXmlItem(Self.Items[0]).XmlData := dom.xml;
end;

procedure TclSoapMessage.RemoveNode(ANode: IXMLDOMNode);
begin
  if (ANode <> nil) and (ANode.parentNode <> nil) then
  begin
    ANode.parentNode.removeChild(ANode);
  end;
end;

function TclSoapMessage.GetCertificateFromNode(ANode: IXMLDOMNode): TclCertificate;
var
  certValue, encodedCertValue: string;
  encoder: TclEncoder;
begin
  Result := nil;
  if system.Pos('Base64Binary', GetAttributeValue(ANode, 'EncodingType')) = 0 then Exit;

  encoder := TclEncoder.Create(nil);
  try
    encodedCertValue := string(ANode.text);
    encodedCertValue := StringReplace(encodedCertValue, #32, '', [rfReplaceAll]);
    encoder.DecodeString(encodedCertValue, certValue, cmMIMEBase64);

    Result := TclCertificate.CreateFromBinary(PByte(certValue), Length(certValue));
    Certificates.Add(Result);
  finally
    encoder.Free();
  end;
end;

function TclSoapMessage.GetDsNodeName(const AName: string): string;
begin
  Result := AName;
  if (Result <> '') and (SignatureStyle = ssJava) then
  begin
    Result := dsNameSpace + ':' + Result;
  end;
end;

function TclSoapMessage.GetDsNameSpace(const AName: string): string;
begin
  Result := AName;
  if (Result <> '') and (SignatureStyle = ssJava) then
  begin
    Result := Result + ':' + dsNameSpace;
  end;
end;

procedure TclSoapMessage.VerifyDigestValue(const AData: IXMLDOMNode; const ADigestValue: string);
var
  canonicalizer: TclXmlCanonicalizer;
  encoder: TclEncoder;
  encodedDig, digest, calculated: string;
begin
  encoder := nil;
  canonicalizer := nil;
  try
    encoder := TclEncoder.Create(nil);
    canonicalizer := TclXmlCanonicalizer.Create();

    encodedDig := StringReplace(ADigestValue, #32, '', [rfReplaceAll]);
    encoder.DecodeString(encodedDig, digest, cmMIMEBase64);
    calculated := GetDigestValue(canonicalizer.Canonicalize(AData));
    if (calculated <> digest) then
    begin
      raise EclSoapMessageError.Create(cVerifyDigestFailed);
    end;
  finally
    canonicalizer.Free();
    encoder.Free();
  end;
end;

procedure TclSoapMessage.VerifySignatureValue(ACertificate: TclCertificate;