clsoap.pas

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

  context: HCRYPTPROV;
  hash: HCRYPTHASH;
  sigData: TclCryptData;
  sigSize, keySpec: DWORD;
  callerFree: BOOL;
begin
  if (not CryptAcquireCertificatePrivateKey(ACertificate.Context,
    CRYPT_ACQUIRE_COMPARE_KEY_FLAG, nil, @context, @keySpec, @callerFree)) or (not callerFree) then
  begin
    raise EclSoapMessageError.Create(GetLastErrorText('CryptAcquireCertificatePrivateKey'));
  end;
  try
    if not CryptCreateHash(context, CALG_SHA1, 0, 0, @hash) then
    begin
      raise EclSoapMessageError.Create(GetLastErrorText('CryptCreateHash'));
    end;
    sigData := TclCryptData.Create();
    try
      if not CryptHashData(hash, Pointer(AXml), Length(AXml), 0) then
      begin
        raise EclSoapMessageError.Create(GetLastErrorText('CryptHashData'));
      end;
      if not CryptSignHash(hash, AT_KEYEXCHANGE, nil, 0, nil, @sigSize) then
      begin
        raise EclSoapMessageError.Create(GetLastErrorText('CryptSignHash'));
      end;
      sigData.Allocate(sigSize);
      if not CryptSignHash(hash, AT_KEYEXCHANGE, nil, 0, sigData.Data, @sigSize) then
      begin
        raise EclSoapMessageError.Create(GetLastErrorText('CryptSignHash'));
      end;
      SetLength(Result, sigSize);
      system.Move(sigData.Data^, Pointer(Result)^, sigSize);
    finally
      sigData.Free();
      CryptDestroyHash(hash);
    end;
  finally
    CryptReleaseContext(context, 0);
  end;
end;

function TclSoapMessage.GetDigestValue(const AXml: string): string;
var
  context: HCRYPTPROV;
  hash: HCRYPTHASH;
  data: TclCryptData;
  hashSize, dwordSize: DWORD;
begin
  if not CryptAcquireContext(@context, nil, nil, GetAvailableProviderType(), 0) then
  begin
    if not CryptAcquireContext(@context, nil, nil, GetAvailableProviderType(), CRYPT_NEWKEYSET) then
    begin
      raise EclSoapMessageError.Create(GetLastErrorText('CryptAcquireContext'));
    end;
  end;
  try
    if not CryptCreateHash(context, CALG_SHA1, 0, 0, @hash) then
    begin
      raise EclSoapMessageError.Create(GetLastErrorText('CryptCreateHash'));
    end;
    data := TclCryptData.Create();
    try
      if not CryptHashData(hash, Pointer(AXml), Length(AXml), 0) then
      begin
        raise EclSoapMessageError.Create(GetLastErrorText('CryptHashData'));
      end;
      dwordSize := SizeOf(DWORD);
      if not CryptGetHashParam(hash, HP_HASHSIZE, @hashSize, @dwordSize, 0) then
      begin
        raise EclSoapMessageError.Create(GetLastErrorText('CryptGetHashParam'));
      end;
      data.Allocate(hashSize);
      if not CryptGetHashParam(hash, HP_HASHVAL, data.Data, @hashSize, 0) then
      begin
        raise EclSoapMessageError.Create(GetLastErrorText('CryptGetHashParam'));
      end;
      SetLength(Result, data.DataSize);
      system.Move(data.Data^, Pointer(Result)^, data.DataSize);
    finally
      data.Free();
      CryptDestroyHash(hash);
    end;
  finally
    CryptReleaseContext(context, 0);
  end;
end;

class function TclSoapMessage.GetLastErrorText(const AFuncName: string): string;
var
  code: DWORD;
  Len: Integer;
  Buffer: array[0..255] of Char;
begin
  code := GetLastError();
  Len := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM,
    Pointer(GetModuleHandle('crypt32.dll')), code, 0, Buffer, SizeOf(Buffer), nil);
  while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  SetString(Result, Buffer, Len);
  if (Trim(Result) = '') then
  begin
    Result := Format('%s error - %d', [AFuncName, code]);
  end;
end;

procedure TclSoapMessage.SetIdName(const Value: string);
begin
  if (FIdName <> Value) then
  begin
    BeginUpdate();
    FIdName := Value;
    EndUpdate();
  end;
end;

procedure TclSoapMessage.DoTransformData(const Algorithm: string;
  var ATemplate: string; var Handled: Boolean);
begin
  if Assigned(OnTransformData) then
  begin
    OnTransformData(Self, Algorithm, ATemplate, Handled);
  end;
end;

procedure TclSoapMessage.BuildSoapMessage(AEnvelope: IXMLDOMDocument; const ASoapAction: string);
var
  src: TStrings;
begin
  src := TStringList.Create();
  try
    src.Text := string(AEnvelope.xml);
    BuildSoapMessage(src, ASoapAction);
  finally
    src.Free();
  end;
end;

function TclSoapMessage.GetIsSigned: Boolean;
var
  dom: IXMLDOMDocument;
begin
  try
    CheckRequestExists();
    dom := CoDOMDocument.Create();
    dom.loadXML(TclXmlItem(Self.Items[0]).XmlData);
    Result := (dom.selectSingleNode('//' + GetDsNodeName('Signature')) <> nil);
  except
    Result := False;
  end;
end;

procedure TclSoapMessage.SetIsIncludeCertificate(const Value: Boolean);
begin
  if (FIsIncludeCertificate <> Value) then
  begin
    BeginUpdate();
    FIsIncludeCertificate := Value;
    EndUpdate();
  end;
end;

procedure TclSoapMessage.Clear;
begin
  Certificates.Close();
  inherited Clear();
end;

procedure TclSoapMessage.SetSignatureStyle(const Value: TclSignatureStyle);
begin
  if (FSignatureStyle <> Value) then
  begin
    BeginUpdate();
    FSignatureStyle := Value;
    EndUpdate();
  end;
end;

procedure TclSoapMessage.BuildSoapMessage(const AEnvelope, ASoapAction: string);
var
  env: TStrings;
begin
  env := TStringList.Create();
  try
    env.Text := AEnvelope;
    BuildSoapMessage(env, ASoapAction);
  finally
    env.Free();
  end;
end;

function TclSoapMessage.GetAvailableProviderType: DWORD;
var
  i, len: DWORD;
begin
  i := 0;
  while CryptEnumProviderTypes(i, nil, 0, @Result, nil, @len) do
  begin
    if (Result in [PROV_RSA_FULL, PROV_DSS, PROV_RSA_SCHANNEL,
      PROV_DSS_DH, PROV_DH_SCHANNEL, PROV_RSA_AES]) then Exit;
    Inc(i);
  end;
  Result := PROV_RSA_FULL;
end;

function TclSoapMessage.CreateItem(AHeader, AFieldList: TStrings): TclHttpRequestItem;
var
  contentType: string;
begin
  if SameText(Header.ContentType, 'multipart/related') then
  begin
    contentType := GetHeaderFieldValue(AHeader, AFieldList, 'Content-Type');
    if SameText(GetHeaderFieldValueItem(contentType, ''), 'text/xml') then
    begin
      Result := AddXmlData('');
    end else
    begin
      Result := AddAttachment();
    end;
  end else
  begin
    Result := inherited CreateItem(AHeader, AFieldList);
  end;
end;

procedure TclSoapMessage.CreateSingleItem(AStream: TStream);
var
  s: string;
begin
  if (Header.ContentType = '') or (system.Pos('multipart/related', LowerCase(Header.ContentType)) > 0)
    or (system.Pos('text/xml', LowerCase(Header.ContentType)) > 0) then
  begin
    SetLength(s, AStream.Size);
    AStream.Read(Pointer(s)^, AStream.Size);
    AddXmlData(s).AfterAddData();
  end else
  begin
    inherited CreateSingleItem(AStream);
  end;
end;

function TclSoapMessage.GetContentType: string;
const
  RequestTypes: array[Boolean] of string = ('text/xml', 'multipart/related');
var
  i: Integer;
  isXmlData: Boolean;
begin
  isXmlData := False;
  for i := 0 to Count - 1 do
  begin
    if (Items[i] is TclSoapMessageItem) then
    begin
      isXmlData := True;
    end;
  end;
  if isXmlData then
  begin
    Result := RequestTypes[Count > 1];
  end else
  begin
    Result := inherited GetContentType();
  end;
end;

function TclSoapMessage.AddXmlData(const AXmlData: string): TclXmlItem;
begin
  BeginUpdate();
  try
    Result := Add(TclXmlItem) as TclXmlItem;
    Result.XmlData := AXmlData;
  finally
    EndUpdate();
  end;
end;

function TclSoapMessage.AddAttachment: TclAttachmentItem;
begin
  Result := Add(TclAttachmentItem) as TclAttachmentItem;
end;

function TclSoapMessage.CreateHeader: TclHttpRequestHeader;
begin
  Result := TclSoapMessageHeader.Create();
end;

function TclSoapMessage.GetHeader: TclSoapMessageHeader;
begin
  Result := inherited Header as TclSoapMessageHeader;
end;

procedure TclSoapMessage.SetHeader(const Value: TclSoapMessageHeader);
begin
  Header := Value;
end;

procedure TclSoapMessage.InitHeader;
begin
  inherited InitHeader();
  if (Count > 1) and (Items[0] is TclSoapMessageItem) then
  begin
    if (Header.Start = '') then
    begin
      Header.Start := (Items[0] as TclSoapMessageItem).ContentID;
    end;

    if (Header.SubType = '') then
    begin
      Header.SubType := (Items[0] as TclSoapMessageItem).ContentType;
    end;
  end;
end;

{ TclXmlCanonicalizer }

function WideStringReplace(const S, OldPattern, NewPattern: WideString): WideString;
var
  SearchStr, Patt, NewStr: WideString;
  Offset: Integer;
begin
  SearchStr := S;
  Patt := OldPattern;

  NewStr := S;
  Result := '';
  while (SearchStr <> '') do
  begin
    Offset := system.Pos(Patt, SearchStr);
    if Offset = 0 then
    begin
      Result := Result + NewStr;
      Break;
    end;
    Result := Result + system.Copy(NewStr, 1, Offset - 1) + NewPattern;
    NewStr := system.Copy(NewStr, Offset + Length(OldPattern), MaxInt);
    SearchStr := system.Copy(SearchStr, Offset + Length(Patt), MaxInt);
  end;
end;

function TclXmlCanonicalizer.NormalizeAttributeValue(AValue: WideString): WideString;
begin
  Result := AValue;
  Result := WideStringReplace(Result, '"', '&quot;');
  Result := WideStringReplace(Result, #9, #32);
  Result := WideStringReplace(Result, #13#10, #32);
  Result := WideStringReplace(Result, #13, #32);
  Result := WideStringReplace(Result, #10, #32);
end;

function TclXmlCanonicalizer.NormalizeText(AText: WideString): WideString;
begin
  Result := AText;
  Result := WideStringReplace(Result, #13#10, #10);
  Result := WideStringReplace(Result, #13, #10);
end;

function TclXmlCanonicalizer.BuildAttributes(ANode: IXMLDOMNode): WideString;
var
  i: Integer;
  attributes, namespaces: TclWideStringList;
  element: IXMLDOMElement;
  Temp: Pointer;
begin
  Result := '';
  if not Supports(ANode, IXMLDOMElement, Temp) then Exit;

  attributes := nil;
  namespaces := nil;
  try
    attributes := TclWideStringList.Create();
    attributes.Sorted := True;

    namespaces := TclWideStringList.Create();
    namespaces.Sorted := True;

    element := (ANode as IXMLDOMElement);
    for i := 0 to element.attributes.length - 1 do
    begin
      if (system.Pos('xmlns', LowerCase(element.attributes.item[i].nodeName)) = 1) then
      begin
        namespaces.Add(element.attributes.item[i].nodeName + '="'
          + NormalizeAttributeValue(VarToWideStr(element.attributes.item[i].nodeValue)) + '"');
      end else
      begin
        attributes.Add(element.attributes.item[i].nodeName + '="'
          + NormalizeAttributeValue(VarToWideStr(element.attributes.item[i].nodeValue)) + '"');
      end;
    end;
    for i := 0 to namespaces.Count - 1 do
    begin
      Result := Result + ' ' + Trim(namespaces[i]);
    end;
    for i := 0 to attributes.Count - 1 do
    begin
      Result := Result + ' ' + Trim(attributes[i]);
    end;
  finally
    namespaces.Free();
    attributes.Free();
  end;
end;

function TclXmlCanonicalizer.BuildXmlString(ARootNode: IXMLDOMNode): WideString;
var
  i: Integer;
  Temp: Pointer;
begin
  if Supports(ARootNode, IXMLDOMText, Temp) then
  begin
    Result := Result + NormalizeText(VarToWideStr(ARootNode.nodeValue));
  end else
  begin
    Result := '<' + ARootNode.nodeName + BuildAttributes(ARootNode) + '>';
    for i := 0 to ARootNode.childNodes.length - 1 do
    begin
      Result := Result + BuildXmlString(ARootNode.childNodes.item[i]);
    end;
    Result := Result + '</' + ARootNode.nodeName + '>';
  end;
end;

function TclXmlCanonicalizer.Canonicalize(ARootNode: IXMLDOMNode): string;
var
  dom: IXMLDOMDocument;
begin
  dom := CoDOMDocument.Create();
  dom.loadXML(ARootNode.xml);
  Result := TclCharSetTranslator.TranslateToUtf8(BuildXmlString(dom.lastChild));
end;

{ TclSoapMessageItem }

procedure TclSoapMessageItem.Assign(Source: TPersistent);
var
  Src: TclSoapMessageItem;
begin
  BeginUpdate();
  try
    if (Source is TclSoapMessageItem) then
    begin
      Src := (Source as TclSoapMessageItem);

      ContentType := Src.ContentType;
      CharSet := Src.CharSet;
      ContentID := Src.ContentID;
      ContentLocation := Src.ContentLocation;