david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
916 lines
31 KiB
ObjectPascal
916 lines
31 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
|
|
{$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.
|