1072 lines
37 KiB
ObjectPascal
1072 lines
37 KiB
ObjectPascal
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 Finalize; 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;
|
|
|
|
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;
|
|
|
|
procedure TROSOAPMessage.Finalize;
|
|
begin
|
|
inherited;
|
|
fSoapAction := '';
|
|
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.
|
|
fXMLMessage:=nil;
|
|
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. |