unit uROSOAPMessage;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Core Library                                      }
{                                                                            }
{ compiler: Delphi 5 and up, Kylix 2 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the RemObjects SDK             }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}

{$I RemObjects.inc}

interface

uses
  {$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
  Classes, Variants, uROClient, uROClientIntf, uROTypes, TypInfo, SysUtils, uROXMLIntf,
  uROSerializer, uROXMLSerializer;

type TAttribute = record
       Name, Value : string;
     end;

const
  EncodingStyle = 'http://schemas.xmlsoap.org/soap/encoding/';
  EnvelopeStyle = 'http://schemas.xmlsoap.org/soap/envelope/';
  TempURI = 'http://tempuri.org/';

  Namespace_Env = 'env';

  id_FaultCode   = 'faultcode';
  id_FaultString = 'faultstring';
  id_FaultActor  = 'faultactor';
  id_FaultDetail = 'detail';

  id_ClientID = 'ROClientID';

  HeaderNameSpace = 'HNS';

  EnvelopeAttributes : array[0..4] of TAttribute = (
    (Name: 'xmlns:SOAP-ENV'; Value: 'http://schemas.xmlsoap.org/soap/envelope/'),
    (Name: 'xmlns:xsd';      Value: 'http://www.w3.org/2001/XMLSchema'),
    (Name: 'xmlns:xsi';      Value: 'http://www.w3.org/2001/XMLSchema-instance'),
    (Name: 'xmlns:HNS';      Value: TempURI),
    (Name: 'xmlns:SOAP-ENC'; Value: EncodingStyle));

type
  { Misc }
  TROSOAPMessage = class;

  TSOAPFaultEvent = procedure(const aFaultNode : IXMLNode;
                              const aFaultCode, aFaultString, aFaultActor, aFaultDetail : string) of object;

  TROEnvelopeCompleteEvent = procedure(Sender : TROSOAPMessage) of object;
  TROAttributeWriteEvent = procedure(Sender : TROSOAPMessage; var AttributeName : string; var AttributeValue : variant; var CanWrite : boolean) of object;

  { TROSOAPMessage }

  IROSOAPMessage = interface(IROMessage)
  ['{30F638D3-FD52-44D2-80D5-6A877F2877CE}']
    function GetEnvNode : IXMLNode;
    function GetBodyNode : IXMLNode;
    function GetMessageNode: IXMLNode;
    function GetFaultNode : IXMLNode;
    function GetHeader : IXMLNode;
    function GetLibraryName: string;

    property EnvelopeNode : IXMLNode read GetEnvNode;
    property BodyNode: IXMLNode read GetBodyNode;
    property MessageNode: IXMLNode read GetMessageNode;
    property FaultNode : IXMLNode read GetFaultNode;
    property HeaderNode : IXMLNode read GetHeader;
    property LibraryName: string read GetLibraryName;
  end;

  TROSoapMode = (sRPCEncoding, sRPCLiteral, sDocumentLiteral, sUnknown);
  { TROSOAPMessage }
  TROSOAPMessage = class(TROMessage, IROModuleInfo, IROSOAPMessage, IRONamedModuleInfo)
  private
    fXMLMessage : IXMLDocument;

    fEnvNode,
    fBodyNode,
    fHeaderNode,
    fMessageNode,
    fFaultNode : IXMLNode;
    fCustomLocation: string;

    fOnSOAPFault: TSOAPFaultEvent;
    fLibraryName: string;
    fOnEnvelopeComplete: TROEnvelopeCompleteEvent;

    fSoapAction,
    fFaultNameSpace : string;
    fOnWriteEnvelopeAttribute: TROAttributeWriteEvent;
    fInputNamespace,
    fOverrideInputName,
    fOverrideOutputName: string;
    fServerTargetNamespace, fTargetNamespace: string;
    fTargetLocationWasSet: Boolean;
    fOnAfterParseEnvelope: TNotifyEvent;

    function ParseEnvelope : boolean;
    function GetHeader: IXMLNode;
    function GetSerializationOptions: TROXMLSerializationOptions;
    procedure SetSerializationOptions(const Value: TROXMLSerializationOptions);
    procedure SetLibraryName(const Value: string);
    function GetBodyNode: IXMLNode;
    function GetEnvNode: IXMLNode;
    function GetFaultNode: IXMLNode;
    function GetMessageNode: IXMLNode;
    function GetLibraryName: string;
    function GetSoapMode: TROSoapMode;
    procedure SetSoapMode(const Value: TROSoapMode);

  protected
    { Internals }
    procedure InitObject; override;
    function CreateSerializer : TROSerializer; override;
    function ReadException : Exception; override;
    procedure WriteException(aStream : TStream; anException : Exception); override;

    { IROMessage }
    procedure Initialize(const aTransport : IROTransport; const anInterfaceName, aMessageName : string; aType: TMessageType); overload; override;
    procedure Initialize(const aTransport : IROTransport; const aLibraryName, anInterfaceName, aMessageName : string; aType: TMessageType); overload; override;


    procedure WriteToStream(aStream : TStream); override;
    procedure ReadFromStream(aStream : TStream); override;

    { IROModuleInfo }
    procedure GetModuleInfo(aStream : TStream; const aTransport : IROTransport; var aFormat : TDataFormat); override;

    function ModuleInfoName: string;
    procedure InitializeExceptionMessage(const aTransport: IROTransport;
      const aLibraryName: String; const anInterfaceName: String;
      const aMessageName: String); override;

    procedure SetAttributes(aTransport: IROTransport;
      const aNames: array of String; const aValues: array of String); override;
    procedure UnsetAttributes(aTransport: IROTransport);  override;
    procedure InitializeRead(const aTransport: IROTransport); override;
  public
    destructor Destroy; override;

    property EnvelopeNode : IXMLNode read GetEnvNode;
    property BodyNode: IXMLNode read GetBodyNode;
    property MessageNode: IXMLNode read GetMessageNode;
    property FaultNode : IXMLNode read GetFaultNode;
    property HeaderNode : IXMLNode read GetHeader;

    procedure Assign(iSource:TPersistent); override;
    property LibraryName : string read GetLibraryName write SetLibraryName;
    function IsValidMessage(aData: PChar; aLength: Integer): boolean; override;
  published
    property CustomLocation : string read fCustomLocation write fCustomLocation;
    property ServerTargetNamespace : string read fServerTargetNamespace write fServerTargetNamespace;
    property SerializationOptions : TROXMLSerializationOptions read GetSerializationOptions write SetSerializationOptions;
    property OnSOAPFault : TSOAPFaultEvent read fOnSOAPFault write fOnSOAPFault;
    property OnEnvelopeComplete : TROEnvelopeCompleteEvent read fOnEnvelopeComplete write fOnEnvelopeComplete;
    property OnWriteEnvelopeAttribute : TROAttributeWriteEvent read fOnWriteEnvelopeAttribute write fOnWriteEnvelopeAttribute;
    property OnAfterParseEnvelope: TNotifyEvent read fOnAfterParseEnvelope write fOnAfterParseEnvelope;
    property SoapMode: TROSoapMode read GetSoapMode write SetSoapMode stored false;
  end;


implementation

uses {$IFDEF DELPHI5}ComObj,{$ENDIF} // for StringToGuid and vice-versa
     uRORes, uRODL, uRODLToXML, uRODLToWSDL, uROHTTPTools, uROClasses;

{ TROSOAPMessage }
procedure TROSOAPMessage.InitObject;
begin
  inherited;
  fServerTargetNamespace := TempURI;
  fXMLMessage := NewROXmlDocument;
  fXMLMessage.New(tag_Envelope);
end;

procedure TROSOAPMessage.Initialize(const aTransport : IROTransport; const anInterfaceName, aMessageName: string; aType: TMessageType);
var i : integer;
    lInterfaceName,
    lMessageName: String;
    attrname : string;
    attrvalue : variant;
    canwrite : boolean;
begin
  inherited;
  fHeaderNode := nil;
  fXMLMessage.New(ns_Envelope+':'+tag_Envelope);
  if fInputNamespace <> '' then
    lInterfaceName := fInputNamespace
  else
  if fTargetNamespace <> '' then
    lInterfaceName := fTargetNamespace
  else begin
    if xsoDocument in SerializationOptions then
      lInterfaceName := LibraryName
    else
    lInterfaceName := anInterfaceName;
  end;

  SetHTTPInfo(aTransport, DataFormatXml);

  fEnvNode := fXMLMessage.DocumentNode;

  for i := 0 to High(EnvelopeAttributes) do
    with EnvelopeAttributes[i] do begin
      attrname := Name;
      attrvalue := Value;
      canwrite := TRUE;

      if Name = 'xmlns:HNS' then attrvalue := ServerTargetNamespace;

      if Assigned(fOnWriteEnvelopeAttribute)
        then fOnWriteEnvelopeAttribute(Self, attrname, attrvalue, canwrite);

      if canwrite
        then fEnvNode.AddAttribute(attrname, attrvalue);
    end;

  { Sets variables for easier access in the other methods }
  fHeaderNode := fEnvNode.Add(ns_Envelope+':'+tag_Header);

  fBodyNode := fEnvNode.Add(ns_Envelope+':'+tag_Body);
  fBodyNode.AddAttribute('SOAP-ENV:encodingStyle', EncodingStyle);
  //fBodyNode.AddAttribute('xmlns:'+ns_Custom, 'urn:'+{TempURI}lInterfacename);
  if (LibraryName = '') then LibraryName := 'DefaultLibrary';
  if Pos(':', LibraryName) = 0 then LibraryName := 'urn:'+LibraryName;
  fBodyNode.AddAttribute('xmlns:'+ns_Custom, LibraryName{TempURI});

  lMessageName := Unprefix(aMessageName); // when document & literal are true
  if xsoDocument in SerializationOptions then begin
    if (aType = mtRequest) then begin
      if fOverrideInputName = '' then
        lMessageName := anInterfaceName+'___'+lMessageName
      else
        lMessageName := fOverrideInputName;
    end else if (aType = mtResponse) then begin
      if fOverrideOutputName = '' then
        lMessageName := anInterfaceName+'___'+lMessageName
      else
        lMessageName := fOverrideOutputName;
    end;
  end;

  if Pos(':', lInterfaceName) = 0 then lInterfaceName := 'urn:'+lInterfaceName;

  if not (xsoSendUntyped in SerializationOptions) then begin
    if copy(lMessageName,1,4)='urn:' then Delete(lMessageName, 1,4);
    fMessageNode := fBodyNode.Add('NS1:'+lMessageName);

    fMessageNode.AddAttribute('xmlns:NS1', {'urn:' + } lInterfaceName);
  end
  else begin
    fMessageNode := fBodyNode.Add(lMessageName);

    fMessageNode.AddAttribute('xmlns', lInterfacename);
  end;

  (Serializer as TROXMLSerializer).SetStorageRef(pointer(fMessageNode));
end;

procedure TROSOAPMessage.Initialize(const aTransport: IROTransport;
  const aLibraryName, anInterfaceName, aMessageName: string; aType: TMessageType);
begin
  LibraryName := aLibraryName;
  Initialize(aTransport, anInterfaceName, aMessageName, aType);
end;

function TROSOAPMessage.ReadException : Exception;
var faultcode, faultstring, faultactor, faultdetail : string;
    node, detailnode : IXMLNode;
    exnme : string;
    tmp: Exception;
    //isroexception : boolean;
    exclass : ExceptionClass;
begin
  result := NIL;

  if Assigned(fFaultNode) then begin
    node := fFaultNode.GetNodeByName(id_FaultCode);
    if not Assigned(node) then node := fFaultNode.GetNodeByName(fFaultNameSpace + ':' + id_FaultCode);

    if Assigned(node)
      then faultcode := node.Value
      else faultcode := '';

    exnme := faultcode;

    node := fFaultNode.GetNodeByName(id_FaultString);
    if not Assigned(node) then node := FindChildNode(fFaultNode, id_FaultString, -1, true);
    if Assigned(node) then faultstring := node.Value else faultstring := '';

    node := fFaultNode.GetNodeByName(id_FaultActor);
    if not Assigned(node) then node := FindChildNode(fFaultNode, id_FaultActor, -1, true);
    if Assigned(node) then faultactor := node.Value else faultactor := '';

    detailnode := fFaultNode.GetNodeByName(id_FaultDetail);
    if not Assigned(detailnode) then detailnode := FindChildNode(fFaultNode, id_FaultDetail, -1, true);
    if Assigned(detailnode) then faultdetail := detailnode.Value else faultdetail := '';

    if Assigned(fOnSOAPFault)
      then fOnSOAPFault(fFaultNode, faultcode, faultstring, faultactor, faultdetail);

    result := CreateException(exnme, faultstring);
    if Result <> nil then
      exclass := ExceptionClass(result.ClassType)
    else
      exclass := nil;

    if (exclass <> nil) and (exclass.InheritsFrom(EROException) and (detailnode<>NIL) and (detailnode.ChildrenCount > 0)) then begin
      tmp := result;
      // It must have a detail in which the fields of the exception are serialized
      with TROXMLSerializer.Create(pointer(detailnode)) do try
        Read(name_Exception, result.ClassInfo, tmp);
      finally
        Free;
      end;
    end;
  end;
end;

procedure TROSOAPMessage.WriteException(aStream : TStream; anException : Exception);
var
    i : integer;
    fault, faultcode, faultstring, detail : IXMLNode;
    attrname : string;
    attrvalue : variant;
    canwrite : boolean;
begin
  inherited;
  fHeaderNode := nil;
  fXMLMessage.New(ns_Envelope+':'+tag_Envelope);

  fEnvNode := fXMLMessage.DocumentNode;

  for i := 0 to High(EnvelopeAttributes) do
    with EnvelopeAttributes[i] do begin
      attrname := Name;
      attrvalue := Value;
      canwrite := TRUE;

      if Assigned(fOnWriteEnvelopeAttribute)
        then fOnWriteEnvelopeAttribute(Self, attrname, attrvalue, canwrite);

      if canwrite
        then fEnvNode.AddAttribute(attrname, attrvalue);
    end;

  { Sets variables for easier access in the other methods }
  fHeaderNode := fEnvNode.Add(ns_Envelope+':'+tag_Header);

  fBodyNode := fEnvNode.Add(ns_Envelope+':'+tag_Body);
  fBodyNode.AddAttribute('SOAP-ENV:encodingStyle', EncodingStyle);
  //fBodyNode.AddAttribute('xmlns:'+ns_Custom, 'urn:'+{TempURI}lInterfacename);
  if (LibraryName = '') then LibraryName := 'DefaultLibrary';
  if pos(':', LibraryName) = 0 then LibraryName := 'urn:'+LibraryName;
  fBodyNode.AddAttribute('xmlns:'+ns_Custom,  LibraryName{TempURI});

  fault := fBodyNode.Add(ns_Envelope+':'+tag_Fault);

  faultcode := fault.Add(id_FaultCode);
  faultcode.Value := UTF8Encode(anException.ClassName);

  faultstring := fault.Add(id_FaultString);
  faultstring.Value := UTF8Encode(anException.Message);

  if (anException is EROException) then begin
    detail := fault.Add(id_FaultDetail);
    with TROXMLSerializer.Create(pointer(detail)) do try
      SerializationOptions := []; // No reference nodes. Write at the right places
      Write(name_Exception, anException.ClassInfo, anException);
    finally
      Free;
    end;
  end;

  WriteToStream(aStream);
  inherited;
end;

procedure TROSOAPMessage.ReadFromStream(aStream: TStream);
var
  encryptedheader: array[0..5] of char;
begin
  inherited;

  aStream.Position := 0;

  try
    fXMLMessage.New;

    fXMLMessage.LoadFromStream(aStream);

    if not ParseEnvelope then ProcessException; // In case there's one
  except
    // If something went wrong we recreate it because fXMLMessage is expected to be instantiated.
    if (fXMLMessage=NIL)
      then begin
        fXMLMessage := NewROXmlDocument;
        fXMLMessage.New;
      end;

    aStream.Position := 0;
    aStream.Read(encryptedheader, 6);
    if (encryptedheader[0] = 'r') and (encryptedheader[1] = 'o') and
      (encryptedheader[2] = 'r') and (encryptedheader[3] = 'o') and
      (encryptedheader[4] = 'c') and (encryptedheader[5] = 'k') then
    RaiseInvalidStreamError(err_InvalidHeaderEncrypted, [], aStream);

    raise;
  end;
end;

function TROSOAPMessage.ParseEnvelope : boolean;
var localname,
    namespace  : string;
    i, k : integer;
    item, item2 : IXMLNode;
    cidnode : IXMLNode;
begin

  fBodyNode := NIL;
  fHeaderNode := NIL;
  fMessageNode := NIL;
  fFaultNode := NIL;
  fEnvNode := fXMLMessage.DocumentNode;

  { Checks the document is non empty and that the main tag is a tag_Envelope (required by SOAP spec) }
  SplitNodeName(fEnvNode, namespace, localname);
  if (localname<>tag_Envelope)
    then RaiseError(err_InvalidEnvelope, [inf_InvalidEnvelopeNode]);

  { Loads the nodes in the Body.
    I am intentionally not picky in the position of BODY and HEADER tags. Specs say HEADER should be first if present and
    BODY second. I just ignore this because requirement. It seems to be a totally useless detail. }

  //SetClientID(EmptyGUID);

  for i := 0 to (fEnvNode.ChildrenCount-1) do begin
    item := fEnvNode.Children[i];

    SplitNodeName(item, namespace, localname);
    // Body
    if (localname=tag_Body) then begin
      fBodyNode := item;

      { Loads the FAULT or BODY.
        Althought the spec say you might have multiple BODY blocks I only consider one for now.
        I might change this in the future if an issue arises with this decision.
        If there ar multiple FAULTs or multiple BODYs the last one is the considered one }

      for k := 0 to (fBodyNode.ChildrenCount-1) do begin
        item2 := fBodyNode.Children[k];

        SplitNodeName(item2, namespace, localname);
        if (localname='#text') then Continue;

        if (localname=tag_Fault) then begin
          fFaultNameSpace := namespace;
          fFaultNode := item2;
          fMessageNode := fFaultNode;
          Break;
        end
        else begin
          fMessageNode := item2;
          Break;
        end;
      end;
    end

    // Header
    else if (localname=tag_Header) then begin
      fHeaderNode := item;

      for k := 0 to (fHeaderNode.ChildrenCount-1) do begin
        cidnode := fHeaderNode.Children[k];
        SplitNodeName(cidnode, namespace, localname);

        if (localname = 'ROClientIDHeader') then begin
          cidnode := FindChildNode(cidnode, 'ID', -1, true);
          if (cidnode <> nil) and (VarToStr(cidnode.Value) <> '') then
            SetClientID(StringToGuid(cidnode.Value));
        end else
        if (localname=id_ClientID) then begin
          if (cidnode.Value<>'')
            then SetClientID(StringToGUID(cidnode.Value));

          Break;
        end;
      end;
      //else SetClientID(EmptyGUID);
    end;
  end;

  if not Assigned(fBodyNode) then RaiseError(err_InvalidEnvelope, [inf_AbsentBody]);
  if not Assigned(fMessageNode) then RaiseError(err_InvalidEnvelope, [inf_AbsentMessage]);

  // Determines the interface and message name

  result := not Assigned(fFaultNode);
  if result then begin
    //xmlns:NS1="ITestService"
//    if (fMessageNode.AttributeCount>0) then begin
//      localname := '';
//
//      for i := 0 to (fMessageNode.AttributeCount-1) do
//        if (Pos('urn:', fMessageNode.Attributes[i].Value)=1) then begin
//          localname := fMessageNode.Attributes[i].Value;
//          Break;
//        end;
//
//      if (localname='')
//        then localname := fMessageNode.Attributes[0].Value;
//
//      libraryname := Copy(localname, pos(':', localname) + 1, pos('-', localname) - 1 - pos(':', localname));
//      Delete(localname, 1, Pos('-', localname)); // urn:SOAPLibrary-SOAPService
//
//      interfacename := localname;
//    end;
    MessageName := '';
    LibraryName := '';
    InterfaceName := '';

    if fSoapAction <> '' then begin
      localname := fSoapAction;
      if localname[1] = '"' then deletE(Localname, 1,1);
      if (localname <> '') and (localname[Length(LocalName)] = '"') then deletE(Localname, Length(LocalName),1);
      if pos(':', localname) <> 0 then delete(localname, 1, pos(':', localname));
      if (pos('-', localname) > 0) and (pos('#', localname) > 0) then begin
        LibraryName := copy(LocalName, 1, pos('-', LocalName) -1);
        Delete(localname, 1, pos('-', localname));
        InterfaceName := copy(LocalName, 1, pos('#', LocalName) -1);
        Delete(localname, 1, pos('#', localname));
        MessageName := localname;
      end;
    end else
    if (xsoDocument in SerializationOptions) and (pos('___', fMessageNode.LocalName) > 0) then begin
      localname := fMessageNode.LocalName;

      InterfaceName := copy(localname, 1, pos('___', localname)-1);
      MessageName := copy(localname, pos('___', localname)+3, MaxInt);
      LibraryName := fMessageNode.NamespaceURI;
    end;


    if (MessageName = '') or (InterfaceName = '') or (LibraryName = '') then begin
      localname := '';

    if copy(fMessageNode.NamespaceURI, 1, 4) = 'urn:' then
      localname := Copy(fMessageNode.NamespaceURI, 5, Maxint)
    else if copy(fBodyNode.NamespaceURI, 1, 4) = 'urn:' then
      localname := Copy(fBodyNode.NamespaceURI, 5, Maxint)
    else if copy(fEnvNode.NamespaceURI, 1, 4) = 'urn:' then
      localname := Copy(fEnvNode.NamespaceURI, 5, Maxint)
    else if copy(fMessageNode.NamespaceURI, 1, 4) = 'urn:' then
      localname := Copy(fMessageNode.NamespaceURI, 5, Maxint);


      if (localname='') and (fMessageNode.AttributeCount > 0)
        then localname := fMessageNode.Attributes[0].Value;

      libraryname := Copy(localname, pos(':', localname) + 1, pos('-', localname) - 1 - pos(':', localname));

      InterfaceName := localname;
      if (Pos('-', localname)>0) then begin
        Delete(localname, 1, Pos('-', localname)); // urn:SOAPLibrary-SOAPService
        InterfaceName := localname;
      end
      else begin
        if localname <> '' then
          InterfaceName := localname
        else
        if (fMessageNode.AttributeCount>0) // Tries to extract it from the node that contains the method name
          then InterfaceName := fMessageNode.Attributes[0].Value;
      end;

      SplitNodeName(fMessageNode, namespace, localname);
      if (xsoDocument in SerializationOptions) and (Copy(localname, 1, Length(InterfaceName)+1) = InterfaceName+'_') then begin
        Delete(localname, 1, Length(InterfaceName) + 1);
        if copy(localname, Length(LocalName)-1, 2) = 'In' then
          Delete(localname, Length(LocalName) -1, 2);
        if copy(localname, Length(LocalName)-2, 3) = 'Out' then
          Delete(localname, Length(LocalName) -2, 3);
      end;
      MessageName := localname;
    end;

    (Serializer as TROXMLSerializer).SetStorageRef(pointer(fMessageNode));

    if assigned(fOnAfterParseEnvelope) then fOnAfterParseEnvelope(self);
  end;
end;

procedure TROSOAPMessage.WriteToStream(aStream: TStream);
begin
  if xsoDocument in SerializationOptions then begin
    with HeaderNode.Add('ROClientIDHeader') do begin
      AddAttribute('SOAP-ENV:mustUnderstand', 0);
      if (pos(':', LibraryName) <> 0) then
        AddAttribute('xmlns', LibraryName)
      else
        AddAttribute('xmlns', 'urn:' + LibraryName);
      Add('ID').Value := GUIDToString(GetClientID);
    end;
  end else begin
    with HeaderNode.Add(HeaderNameSpace+':'+id_ClientID) do begin
      AddAttribute('SOAP-ENV:mustUnderstand', 0);
      Value := GUIDToString(GetClientID);
    end;
  end;

  if Assigned(fOnEnvelopeComplete)
    then fOnEnvelopeComplete(Self);

  fXMLMessage.SaveToStream(aStream);

  inherited;
end;

procedure TROSOAPMessage.GetModuleInfo(aStream : TStream; const aTransport : IROTransport; var aFormat : TDataFormat);
var lib : TRODLLIbrary;
    wsdl : TRODLToWSDL;
    http : IROHTTPTransport;
    i : Integer;
    httpparams : TStringList;
    s, targetservice : string;
begin
  lib := NIL;
  targetservice := '';

  inherited GetModuleInfo(aStream, aTransport, aFormat); // Sets ContentType for HTTP transports already

  aFormat := DataFormatXml;

  try
    with TXMLToRODL.Create do try
      lib := Read(aStream);
    finally
      Free;
    end;

    httpparams := TStringList.Create;
    wsdl := TRODLToWSDL.Create(NIL);
    try
      if Supports(aTransport, IROHTTPTransport, http) then begin
        httpparams.Text := http.QueryString
      end;

      if (Trim(CustomLocation)='') then begin
        if (http<>NIL)
          then wsdl.Location := http.Location+http.PathInfo;
      end
      else wsdl.Location := CustomLocation;
      wsdl.ExternalTypesAsReferences := xsoExternalTypesAsReferences in SerializationOptions;
      wsdl.UseDocument := xsoDocument in SerializationOptions;
      wsdl.UseLiteral := xsoSendUntyped in SerializationOptions;
      wsdl.ShowClientId := xsoClientIdInWsdl in SerializationOptions;
      wsdl.TargetNamespace := ServerTargetNamespace;

      targetservice := httpparams.Values['Service'];

      if (lib.ServiceCount > 1) and (TargetService = '') and (xsoSplitServiceWsdls in SerializationOptions) then begin
        aFormat := 'text/html';
        aStream.Position := 0;
        aStream.Size := 0;
        s := '<html>'#13#10'<head>'#13#10'<title>'+lib.Name+'</title>'#13#10'</head>'#13#10'<body>'#13#10'<p><font size="7">';
        s := s + lib.Name +'</font></p>'#13#10'<p>The following services are supported:</p><ul>';
        for i := 0 to lib.ServiceCount -1 do
          s := s + '<li><a href="'+fCustomLocation+'?service='+lib.Services[i].Name+'">'+lib.Services[i].Name+'</a></li>'#13#10;
        s := s + '</ul></body></html>';
        aStream.Write(s[1], length(s));
        exit;
      end;
      http := NIL; // Clean up. Don't remove!

      wsdl.Convert(lib, targetservice);
      aStream.Position := 0;
      aStream.Size := 0;
      wsdl.Buffer.SaveToStream(aStream);
    finally
      wsdl.Free;
      httpparams.Free;
    end;
  finally
    if Assigned(lib) then
      lib.Free;
  end;
end;

function TROSOAPMessage.GetHeader: IXMLNode;
begin
  // Services like the Amazon one just don't accept empty headers (or don't know how to handle them).
  // Because of this I just create it on demand.

  if (fHeaderNode=NIL) then begin
    {fHeaderNode := fXMLMessage.createElement(tag_Header);
    fEnvNode.insertBefore(fHeaderNode, fBodyNode);}
    fHeaderNode := fEnvNode.Add(tag_Header);
  end;

  result := fHeaderNode;
end;

function TROSOAPMessage.CreateSerializer : TROSerializer;
begin
  result := TROXMLSerializer.Create(pointer(fMessageNode));
end;

function TROSOAPMessage.GetSerializationOptions: TROXMLSerializationOptions;
begin
  result := TROXMLSerializer(Serializer).SerializationOptions
end;

procedure TROSOAPMessage.SetSerializationOptions(
  const Value: TROXMLSerializationOptions);
begin
  TROXMLSerializer(Serializer).SerializationOptions := Value
end;

procedure TROSOAPMessage.Assign(iSource: TPersistent);
var lSource:TROSOAPMessage;
begin
  inherited;
  if Assigned(iSource) then begin

    if not (iSource is TROSOAPMessage) then RaiseError('Cannot Assign a %s t a %s',[ClassName,iSource.ClassName]);

    lSource := (iSource as TROSOAPMessage);
    self.CustomLocation := lSource.CustomLocation;
    self.SerializationOptions := lSource.SerializationOptions;
    self.OnSOAPFault := lSource.OnSOAPFault;
    self.OnEnvelopeComplete := lSource.OnEnvelopeComplete;
    self.OnWriteEnvelopeAttribute := lSource.OnWriteEnvelopeAttribute;
    Self.OnAfterParseEnvelope := lSource.OnAfterParseEnvelope;
    self.ServerTargetNamespace := lSource.ServerTargetNamespace;
  end;
end;

procedure TROSOAPMessage.SetLibraryName(const Value: string);
begin
  fLibraryName := Value;
end;

function TROSOAPMessage.GetBodyNode: IXMLNode;
begin
  result := fBodyNode
end;

function TROSOAPMessage.GetEnvNode: IXMLNode;
begin
  result := fEnvNode
end;

function TROSOAPMessage.GetFaultNode: IXMLNode;
begin
  result := fFaultNode
end;

function TROSOAPMessage.GetMessageNode: IXMLNode;
begin
  result := fMessageNode
end;

function TROSOAPMessage.GetLibraryName: string;
begin
  result := fLibraryName
end;

destructor TROSOAPMessage.Destroy;
begin
  inherited;
end;

function TROSOAPMessage.ModuleInfoName: string;
begin
  Result := 'wsdl';
end;

procedure TROSOAPMessage.InitializeExceptionMessage(
  const aTransport: IROTransport; const aLibraryName, anInterfaceName,
  aMessageName: String);
begin
  inherited;
  SetHTTPInfo(aTransport, DataFormatXml);
end;


function TROSOAPMessage.IsValidMessage(aData: PChar;
  aLength: Integer): boolean;
var
  str: string;
begin
  SetString(str, aData, aLength);
  Result := Pos(ns_Envelope+':'+tag_Envelope, str) > 0;
end;


function TROSOAPMessage.GetSoapMode: TROSoapMode;
begin
  if xsoDocument in SerializationOptions then begin
    if (xsoSendUntyped in SerializationOptions) and ([xsoWriteMultiRefArray, xsoWriteMultiRefObject, xsoEncodedXML] * SerializationOptions = []) then
      result := sDocumentLiteral
    else
      result := sUnknown;
  end else begin
    if xsoSendUntyped in SerializationOptions then
      result := sRPCLiteral
    else
      result := sRPCEncoding;
  end;
end;

procedure TROSOAPMessage.SetSoapMode(const Value: TROSoapMode);
begin
  case Value of
    sRPCEncoding:
      begin
        SerializationOptions := SerializationOptions - [xsoSendUntyped, xsoDocument];
        SerializationOptions := SerializationOptions + [xsoWriteMultiRefArray, xsoWriteMultiRefObject, xsoEncodedXML];
      end;
    sRPCLiteral:
      begin
        SerializationOptions := SerializationOptions + [xsoSendUntyped];
        SerializationOptions := SerializationOptions - [xsoWriteMultiRefArray, xsoWriteMultiRefObject, xsoEncodedXML, xsoDocument];
      end;
    sDocumentLiteral:
      begin
        SerializationOptions := SerializationOptions + [xsoSendUntyped, xsoDocument];
        SerializationOptions := SerializationOptions - [xsoWriteMultiRefArray, xsoWriteMultiRefObject, xsoEncodedXML];
      end;
  end;
end;

procedure TROSOAPMessage.SetAttributes(aTransport: IROTransport;
  const aNames, aValues: array of String);
var
  lStyle,
  lUse,
  lAction,
  lTargetUrl: string;
  aHttp: IROHTTPTransport;

  i: Integer;
begin
  fTargetLocationWasSet := False;
  for i := 0 to Length(aNames) -1 do begin
    if aNames[i] = 'InputNamespace' then
      fInputNamespace := aValues[i]
    else if aNames[i] = 'Action' then
      lAction := aValues[i]
    else if aNames[i] = 'Location' then
      lTargetUrl := aValues[i]
    else if aNames[i] = 'Style' then
      lStyle := aValues[i]
    else if aNames[i] = 'Use' then
      lUse := aValues[i]
    else if aNames[i] = 'SOAPInputNameOverride' then
      fOverrideInputName := aValues[i]
    else if aNames[i] = 'SOAPOutputNameOverride' then
      fOverrideOutputName := aValues[i]
    else if aNames[i] = 'TargetNamespace' then
      fTargetNamespace := aValues[i];
  end;
  if (lUse = 'literal') then begin
    if lStyle = 'document' then
      SetSoapMode(sDocumentLiteral)
    else if lStyle <> '' then
      SetSoapMode(sRPCLiteral);
  end else if lUse <> '' then begin
    SetSoapMode(sRPCEncoding);
  end;
  if Supports(aTransport, IROHTTPTransport, aHttp) then begin
    fTargetLocationWasSet := aHttp.TargetURL = '';
      aHttp.Headers['SOAPAction'] := '"'+lAction+'"';
    if fTargetLocationWasSet then
      aHttp.TargetURL := lTargetUrl;
  end;
end;

procedure TROSOAPMessage.UnsetAttributes(aTransport: IROTransport);
var
  aHttp: IROHTTPTransport;
begin
  fTargetNamespace := '';
  fOverrideInputName := '';
  fOverrideOutputName := '';
  if fTargetLocationWasSet and Supports(aTransport, IROHTTPTransport, aHttp) then begin
    aHttp.TargetURL := '';
  end;
end;

procedure TROSOAPMessage.InitializeRead(const aTransport: IROTransport);
var
  lHttp: IROHTTPTransport;
begin
  if Supports(aTransport, IROHTTPTransport, lHttp) then begin
    fSoapAction := lHttp.Headers['SOAPAction'];
    lHttp := nil;
  end
  else
    fSoapAction := '';
end;


initialization
  RegisterMessageClass(TROSOAPMessage);

end.