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
  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;
    fExceptionRemap: TStrings;

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

    function ParseEnvelope : boolean;
    function FindRemap(const s: string): string;
    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);
    function GetXMLMessage: IXMLDocument;
  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 OnBeforeParseEnvelope: TNotifyEvent read fOnBeforeParseEnvelope write fOnBeforeParseEnvelope;
    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 := '';
  fXMLMessage := NewROXmlDocument;
  fNeedInit:= True;
  fInitStr:=tag_Envelope;
//  fXMLMessage.New(tag_Envelope);
  fExceptionRemap := TStringList.Create;
end;

procedure TROSOAPMessage.Initialize(const aTransport : IROTransport; const anInterfaceName, aMessageName: string; aType: TMessageType);
var i : integer;
    lInterfaceName,
    lMessageName: String;
    attrname : string;
    lHttp: IROHTTPTransport;
    attrvalue : variant;
    canwrite : boolean;
begin
  inherited;
  fHeaderNode := nil;
  fNeedInit:= True;
  fInitStr:=ns_Envelope+':'+tag_Envelope;

//  fXMLMessage.New(ns_Envelope+':'+tag_Envelope);
  if fServerTargetNamespace = '' then begin
    fServerTargetNamespace := GetServiceAttribute('', 'TargetNamespace');
    if fServerTargetNamespace = '' then
      fServerTargetNamespace := TempURI;
  end;
  if ((aType = mtResponse) or (aType = mtRequest)) and (fTargetNamespace = '') then begin
    fTargetNamespace := fServerTargetNamespace;
  end;
  if (xsoDocument in SerializationOptions) then begin
    if fInputNamespace <> '' then
      lInterfaceName := fInputNamespace
    else
    if fTargetNamespace <> '' then
      lInterfaceName := fTargetNamespace
    else begin
      if xsoDocument in SerializationOptions then
        lInterfaceName := LibraryName
      else
      lInterfaceName := anInterfaceName;
    end;
  end else
    lInterfaceName := LibraryName +'-'+InterfaceName;

  // should always be refreshed.  
  //if fSoapAction = '' then begin
    fSoapAction :=Format('urn:%s-%s#%s', [LibraryName, anInterfaceName, aMessageName]);
    if Supports(aTransport, IROHttpTransport, lHttp) then
      lHttp.Headers['SOAPAction'] := '"'+fSoapAction +'"';
  //end;


  SetHTTPInfo(aTransport, DataFormatXml);

  fEnvNode := GetXMLMessage.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, False);
    end;

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

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

  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, False);
  end
  else begin
    (Serializer as TROXMLSerializer).CurrentNamespace := lInterfaceName;
    fMessageNode := fBodyNode.Add((Serializer as TROXMLSerializer).Prefix+':'+lMessageName, lInterfaceName);

//    fMessageNode.AddAttribute('xmlns', lInterfacename, False);
  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;
    lexceptclass, exceptfield, 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);

    if detailnode = nil then
      node := nil
    else
      node := detailnode.FirstChild;
    while (node <> nil) and (node.Name = '#text') do
      node := node.NextSibling;
    if node <> nil then
      exceptfield := node.LocalName
    else
      exceptfield := name_Exception;

    lexceptclass := fExceptionRemap.Values[exceptfield];
    if lexceptclass <> '' then
      result := CreateException(lexceptclass, faultstring)
    else
      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
        SerializationOptions := self.SerializationOptions;
        Read(exceptfield, result.ClassInfo, tmp);
      finally
        Free;
      end;
    end;
  end;
end;

procedure TROSOAPMessage.WriteException(aStream : TStream; anException : Exception);
var
    i : integer;
    fault, faultcode, faultstring, detail : IXMLNode;
   { lInterfaceName,} attrname : string;
    attrvalue : variant;
    canwrite : boolean;
begin
  fHeaderNode := nil;
  fNeedInit:=True;
  fInitStr:=ns_Envelope+':'+tag_Envelope;
//  fXMLMessage.New(ns_Envelope+':'+tag_Envelope);
//  if (aType = mtResponse) and (fTargetNamespace = '') then fTargetNamespace := fServerTargetNamespace;
(*  if fInputNamespace <> '' then
    lInterfaceName := fInputNamespace
  else
  if fTargetNamespace <> '' then
    lInterfaceName := fTargetNamespace
  else begin
    if xsoDocument in SerializationOptions then
      lInterfaceName := LibraryName
    else
    lInterfaceName := fTargetNamespace;
  end;
*)
  if fServerTargetNamespace = '' then begin
    fServerTargetNamespace := GetServiceAttribute('', 'TargetNamespace');
    if fServerTargetNamespace = '' then
      fServerTargetNamespace := TempURI;
  end;

  fEnvNode := GetXMLMessage.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, False);
    end;

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


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

  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
      if fServerTargetNamespace <> '' then
        CurrentNamespace := fServerTargetNamespace;

      SerializationOptions := self.SerializationOptions;
      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
    fInitStr:='';
    fNeedInit:=True;
//    fXMLMessage.New;

    GetXMLMessage.LoadFromStream(aStream);

  except
    on e: Exception do begin
      // If something went wrong we recreate it because fXMLMessage is expected to be instantiated.
      if (fXMLMessage=NIL)
        then begin
          fXMLMessage := NewROXmlDocument;
          fInitStr:='';
          fNeedInit:=True;
          //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 EROException.Create('Cannot parse SOAP error: '+e.Message);
    end;
  end;
  if not ParseEnvelope then ProcessException; // In case there's one
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 := GetXMLMessage.DocumentNode;

  if assigned(fOnBeforeParseEnvelope) then fOnBeforeParseEnvelope(self);
  { 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 := fServiceName;

    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 fServiceName <> '' then begin
        MessageName := FindRemap(localname);
        if MessageName <> '' then begin
          LibraryName := fMessageNode.NamespaceURI;
          if LibraryName = '' then
            LibraryName:= fBodyNode.NamespaceURI;
          if LibraryName = '' then
            LibraryName := fEnvNode.NamespaceURI;
        end;
      end;

      if MessageName = '' then begin
        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;
    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 (Pos('___', localname) > 0) then begin
        InterfaceName := copy(localname, 1, Pos('___', localname)-1);
        MessageName := Copy(localname, Pos('___', localname)+3, MaxInt);
      end else begin
        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;
      if fServiceName <> '' then InterfaceName := fServiceName;
    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, False);
      if (pos(':', LibraryName) <> 0) then
        AddAttribute('xmlns', LibraryName, False)
      else
        AddAttribute('xmlns', 'urn:' + LibraryName, False);
      Add('ID').Value := GUIDToString(GetClientID);
    end;
  end else begin
    with HeaderNode.Add(HeaderNameSpace+':'+id_ClientID) do begin
      AddAttribute('SOAP-ENV:mustUnderstand', 0, False);
      Value := GUIDToString(GetClientID);
    end;
  end;

  if Assigned(fOnEnvelopeComplete)
    then fOnEnvelopeComplete(Self);

  GetXMLMessage.SaveToStream(aStream);

  inherited;
end;

procedure TROSOAPMessage.GetModuleInfo(aStream : TStream; const aTransport : IROTransport; var aFormat : TDataFormat);
var lib : TRODLLIbrary;
    wsdl : TRODLToWSDL;
    http : IROHTTPTransport;
    i : Integer;
    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;

    wsdl := TRODLToWSDL.Create(NIL);
    try
      if Supports(aTransport, IROHTTPTransport, http) then begin
        targetservice := http.GetQueryParameter('service');
      end;

      if (Trim(CustomLocation)='') then begin
        if (http<>NIL)
          then wsdl.Location := http.Location+http.PathInfo;
      end
      else wsdl.Location := CustomLocation;
      if (targetservice = '') and assigned(http) then begin
        wsdl.TargetXsd := http.GetQueryParameter('xsd');
      end;
      wsdl.ExternalTypesAsReferences := xsoExternalTypesAsReferences in SerializationOptions;
      wsdl.UseDocument := xsoDocument in SerializationOptions;
      wsdl.UseLiteral := xsoSendUntyped in SerializationOptions;
      wsdl.ShowClientId := xsoClientIdInWsdl in SerializationOptions;
      if fServerTargetNamespace = '' then begin
        fServerTargetNamespace := GetServiceAttribute('', 'TargetNamespace');
        if fServerTargetNamespace = '' then
          fServerTargetNamespace := TempURI;
      end;
      wsdl.TargetNamespace := ServerTargetNamespace;

      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!

      try
      wsdl.Convert(lib, targetservice);
      except
        on e: Exception do begin
          aFormat := 'text/html';
          s := '<html><head><title>Error</title></head><body><font size=7>Error</font><br />An error occured generating WSDL: '+e.Message+'</body></html>';
          aStream.Position := 0;
          aStream.Size := 0;
          aStream.Write(s[1], Length(S));
          exit;
        end;
      end;
      aStream.Position := 0;
      aStream.Size := 0;
      wsdl.Buffer.SaveToStream(aStream);
    finally
      wsdl.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
  fExceptionRemap.Free;
  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 copy(aNames[i], 1, 6) = 'fault_' then begin
      fExceptionRemap.Add(copy(aNames[i], 7, MAxInt)+'='+avalues[I]);
    end else
    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 = '';
    fSoapAction := lAction;
      aHttp.Headers['SOAPAction'] := '"'+lAction+'"';
    if fTargetLocationWasSet then
      aHttp.TargetURL := lTargetUrl;
  end;
end;

procedure TROSOAPMessage.UnsetAttributes(aTransport: IROTransport);
var
  aHttp: IROHTTPTransport;
begin
  fTargetNamespace := '';
  fExceptionRemap.Clear;
  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'];
    fServiceName := lHttp.GetQueryParameter('service');

    lHttp := nil;
  end
  else begin
    fSoapAction := '';
    fServiceName := '';
  end;
end;


function TROSOAPMessage.FindRemap(const s: string): string;
var
  i: Integer;
  lVal: string;
  lList: TStrings;
begin
  result := '';
  if fServiceName = '' then exit;
  lList := GetServiceAttributes(fServiceName);
  if lList = nil then exit;
  for i := lList.Count -1 downto 0 do begin
    lVal := lList[i];
    if (copy(lVal,1,6) = 'remap_') and (Copy(lVal,pos('=', lVal)+1, MaxInt) = s) then begin
      lVal := copy(lVal, 7, Pos('=', LvaL)-7);
      result := lVal;
    end;
  end;
end;


function TROSOAPMessage.GetXMLMessage: IXMLDocument;
begin
  if fNeedInit then begin
    fXMLMessage.New(fInitStr);
    fNeedInit := False;
  end;
  Result:= fXMLMessage;
end;

initialization
  RegisterMessageClass(TROSOAPMessage);

end.