{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Simple SOAP implementations.                 | }
{ |                                                             | }
{ |                                                             | }
{ |   Copyright (C) - 2010 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code dstributed under MIT license.                 | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }

{$INCLUDE GMCompilerSettings.inc}

unit GMSoap;

interface

uses {$IFDEF JEDIAPI}jwaWinType,{$ELSE}Windows,{$ENDIF}
     GMActiveX, GMStrDef, GMCollections, GMIntf, GMCommon, GMXml, GMHttp, TypInfo;

const

  cDfltSoapPropTypeKinds = [tkInteger, tkChar, tkFloat, tkString,
                            tkWChar, tkLString, tkWString, tkVariant, tkInt64];
                            // tkEnumeration, tkSet


type

  //
  // Include RTTI to access properties at runtime
  //
  {$IFOPT M-} {$DEFINE RTTI_OFF} {$M+} {$ENDIF}
  TGMSoapValueCarrierObj = class(TGMRefCountedObj)
   public
    constructor Create(const ARefLifeTime: Boolean = False); reintroduce; virtual;
  end;
  {$IFDEF RTTI_OFF} {$M-} {$UNDEF RTTI_OFF} {$ENDIF}

  TGMSoapDataObjClass = class of TGMSoapValueCarrierObj;


  IGMLoadProperties = interface(IUNknown)
    ['{590F0CE0-A6C1-4796-B870-4BCC0A68B3C2}']
    procedure LoadProperties(Node: IGMXmlNode; const ForceExist: Boolean = True); stdcall;
  end;


  IGMStoreProperties = interface(IUnknown)
    ['{BDBCD58A-8B7E-4a29-8F2D-5AA7B5C3C0B7}']
    procedure StoreProperties(Node: IGMXmlNode); stdcall;
  end;


  EGMSoapException = class(EGMException);

  EGMSoapExceptionClass = class of EGMSoapException;


  TGMSoapMethodData = record
    NameSpace: TGMString;
    MethodName: TGMString;
  end;


  TGMSoapCallBase = class(TGMRefCountedObj)
   protected
    FTransportLayer: ISequentialStream;
    FXmlParseAttributes: TGMXmlParseAttributes;
    FOperationNS: TGMXmlNamedValueData;

    function InsertSoapEnvelope(const AParentNode: IGMXmlNode; const AAddOperationNS: Boolean = True): IGMXmlNode; virtual;
    function InsertSoapBody(const AParentNode: IGMXmlNode): IGMXmlNode; virtual;
    procedure AddEnvelopeAttributes(const AEnvelopeNode: IGMXmlNode; const AAddOperationNS: Boolean = True); virtual;
    function XmlTreeCreateClass: TGMXmlTreeClass; virtual;

   public
    constructor Create(const ATransportLayer: ISequentialStream; const ASoapPortTypeURL: TGMString; const AXmlParseAttributes: TGMXmlParseAttributes = cDfltXmlParseAttributes; const ARefLifeTime: Boolean = True); reintroduce; overload;
  end;


  TGMSoapClientCall = class(TGMSoapCallBase)
   protected
    FTypeNameSpace: TGMString;

    function WrongContentExceptionCreateClass: EGMExceptionClass; virtual;
    function ValueAsSoapString(const AValue: OleVariant): TGMString; virtual;
    function AddTypeAttributes: Boolean; virtual;

    procedure PrepareHttpRequest(const ARequest: IUnknown); virtual;

    function CreateSoapFaultExceptObj(const ASoapFaultNode: IGMXmlNode; const ACallingName: TGMString): EGMSoapException; virtual; abstract;
    procedure RaiseSoapFault(const ASoapFaultNode: IGMXmlNode; const ACallingName: TGMString); virtual;

    procedure CheckResponseXml(const AResponseXml: IGMXmlTree; const ACallingName: TGMString); virtual;
    procedure CheckResponseContentType(const AResponseContent: ISequentialStream; const AContentType, ACallingName: TGMString); virtual;
    function CheckResponseContent(const AResponseContent: ISequentialStream; const AContentType: TGMString; const ACallingName: TGMString): IGMXmlTree; virtual;
    //function ExtractSoapFaultMessage(const AResponseContent: IStream; var AXml: IGMXmlTree): TGMString;
    procedure AddEnvelopeAttributes(const AEnvelopeNode: IGMXmlNode; const AAddOperationNS: Boolean = True); override;

   public
//  constructor Create(const ATransportLayer: ISequentialStream; const ASoapPortTypeURL: TGMString; const AXmlParseAttributes: TGMXmlParseAttributes = cDfltXmlParseAttributes; const ARefLifeTime: Boolean = True); reintroduce;
    constructor Create(const ARefLifeTime: Boolean = True); override;
    function CreateSOAPCallXml(const ASoapMethodName: TGMString; var ANode: IGMXmlNode): IGMXmlTree;
    function AddSoapValue(const AParentNode: IGMXmlNode; const AName: TGMString; const AValue: OleVariant): IGMXmlNode;
    procedure StoreObjProps(const Obj: TObject; Node: IGMXmlNode; const ClassNodeName: TGMString; const TypeKinds: TTypeKinds);
    procedure LoadObjProps(const Obj: TObject; Node: IGMXmlNode; const ForceExist: Boolean; const TypeKinds: TTypeKinds);

    function ExecSoapCall(const ASession: IGMHttpClientSession; const AXML: IGMXmlTree; const ACallingName: TGMString = ''): IGMXmlTree; virtual;
  end;


  TGMSoapServerPort = class;

  IGMSoapServerPort = interface(IUnknown)
    ['{083F2619-5846-461F-B27A-5F78FD34D6B7}']
    function Obj: TGMSoapServerPort;
  end;


  TGMSoapMethod = procedure (const ARequestMethodNode, AResponseBodyNode: IGMXmlNode) of object;

  TGMSoapMethodEntry = class(TGMRefCountedObj, IGMGetName)
   public
    SoapMethod: TGMSoapMethod;
    SoapMethodName: TGMString;
    constructor Create(const AMethodName: TGMString; const ASoapMethod: TGMSoapMethod; const ARefLifeTime: Boolean = False); reintroduce;
    function GetName: TGMString; stdcall;
  end;


  TGMSoapRequestResult = record
   HttpStatusCode: DWORD;
   LogMessage: AnsiString;
   ContentType: AnsiString;
   SOAPMethodName: TGMString;
  end;


  TGMSoapServerPort = class(TGMSoapCallBase, IGMSoapServerPort)
   protected
    FRegisteredSoapMethods: IGMObjArrayCollection;
    FSoapPortName: TGMString;

    function DoTracing: Boolean; virtual;
    function TracePrefix: TGMString; virtual;

    function InsertFaultDetailNode(const AFaultNode: IGMXmlNode; const AExceptObject: TObject): TGMString; virtual; abstract;
    function InsertFaultNode(const ABodyNode: IGMXmlNode; const AExceptObject: TObject): TGMString;

    procedure RegisterSOAPMethod(const AMethodName: AnsiString; const AMethod: TGMSoapMethod);
    function FindSoapMethod(const AMethodName: TGMString): TGMSoapMethod; virtual;

   public
    constructor Create(const ARefLifeTime: Boolean = True); overload; override;
    constructor Create(const ATransportLayer: ISequentialStream; const ASoapPortName, ASoapPortTypeURL: TGMString; const AXmlParseAttributes: TGMXmlParseAttributes = cDfltXmlParseAttributes; const ARefLifeTime: Boolean = True); reintroduce; overload;
    function Obj: TGMSoapServerPort;
//  function ProcessRequest(const AReadStrm, AWriteStrm: ISequentialStream): TGMSoapRequestResult;
    function ProcessRequest: TGMSoapRequestResult; virtual;
//  procedure SendResponseContent(const ATransportLayer: ISequentialStream); virtual;
  end;

  TGMSoapServerCallClass = class of TGMSoapServerPort;


// TSMSUnkResultStateType(GMCheckGetEnumValFromName(TypeInfo(TSMSUnkResultStateType), GMCheckFindXmlSubValue(Node, cSoapResultState)));
// GetEnumName(TypeInfo(SMSHelpTopicType), Ord(ATopic))

function GMSoapStrToInt(const AValue: TGMString; const ADefaultValue: LongInt = 0): LongInt; // ; ACaller: TObject = nil; const ACallingName: TGMString = ''
function GMSoapBoolToStr(const AValue: Boolean): TGMString;
//function GMIso8601DateTimeToStr(const ALocalTime: TDateTime): TGMString;

//function GMAddSoapValue(const AParent: IGMXmlNode; const AName, ANameSpace: TGMString; const AValue: OleVariant): IGMXmlNode;
function GMSoapTypeName(const AVType: LongInt): TGMString;

procedure GMStoreObjProps(const Obj: TObject; Node: IGMXmlNode;
                          const ClassNodeName: TGMString = '';
                          const TypeKinds: TTypeKinds = cDfltSoapPropTypeKinds);


procedure GMLoadObjProps(const AObj: TObject; ANode: IGMXmlNode; const AForceExist: Boolean = True; const ATypeKinds: TTypeKinds = cDfltSoapPropTypeKinds);


const

  cStrEnvNS = 'SOAP-ENV';
//cStrEncNS = 'SOAP-ENC';

  cStrSoapEnv = 'Envelope';
  cStrSoapHeader = 'Header';
  cStrSoapBody = 'Body';
  cStrSoapFault = 'Fault';
  cStrSoapFaultString = 'faultstring'; // <- should be lowercase!
  cStrSoapFaultCode = 'faultcode';     // <- should be lowercase!
  cStrSoapFaultDetail = 'detail';      // <- should be lowercase!

  cStrExec = 'exec';

  cStrXsd = 'xsd';
  cStrXsi = 'xsi';

  cStrType = 'type';
  //cStrHtmlBody = cStrBody;
  //cStrArray = 'Array';

  cStrSoap = 'SOAP';


implementation

uses Classes, SysUtils, GMWinInetAPI, GMINetBase
     {$IFDEF DELPHI6},Variants{$ENDIF}
     ;


const

  cStrHttpContentHtml = 'text/html';

  
resourcestring

  //RStrNoHttpStatusCode = 'The server did not transfer a http status code';
  RStrNoSoapFaultMsg = 'No SOAP fault message transmitted by the server';
  //RStrResponseContentStream = 'The response content stream';
  RStrResonseContentNotXml = 'The response content is not XML/HTML';
  RStrNoSOAPMethodNode = 'No SOAP method XML node found';
  RStrEmptySoapMethodName = 'Empty Soap method name';
  RStrSoapMethodNotImpl = 'SOAP method "%s" not implemented';
//RStrSOAPCallLogMsg = 'WFM SOAP call';
  RStrException = 'Exception';
  RStrUsingSoapPort = 'Using SOAP port';


  //RStrInvalidIntFmt = 'Invalid integer value: %s';


{ ------------------------- }
{ ---- Global Routines ---- }
{ ------------------------- }

function GMSoapStrToInt(const AValue: TGMString; const ADefaultValue: LongInt): LongInt; // ; ACaller: TObject; const ACallingName: TGMString
begin
  if Length(GMStrip(AValue, cWhiteSpace)) <= 0 then Result := ADefaultValue else Result := GMStrToInt(AValue);
  //Result := GMStrToInt(GMMakeDezInt(AValue));
//  try
//   Result := GMStrToInt(AValue);
//except
// raise EGMException.ObjError(GMFormat(RStrInvalidIntFmt, [AValue]), ACaller, ACallingName);
//end;
end;

//function GMSoapStrToInt(const AValue: TGMString; ACaller: TObject): LongInt;
//begin
//end;

function GMSoapTypeName(const AVType: LongInt): TGMString;
begin
  case VarTYpeMask and AVType of
   varInteger: Result := 'int';
   varDate:    Result := 'dateTime';
   varBoolean: Result := 'boolean';
   else Result := 'TGMString';
  end;
end;

function GMSoapBoolToStr(const AValue: Boolean): TGMString;
begin
  Result := GMBoolToStr(AValue, 'false', 'true');
end;

function GMSoapVarToStr(const AValue: OleVariant): TGMString;
begin
  case VarType(AValue) of
   varBoolean: Result := GMSoapBoolToStr(AValue);
   varDate: Result := GMIso8601DateTimeToStr(AValue);
   else Result := AValue;
  end;
end;

function GMAddSoapValue(const AParent: IGMXmlNode; const AName, ANameSpace: TGMString; const AValue: OleVariant): IGMXmlNode;
begin
  if AParent <> nil then
     Result := AParent.Obj.Owner.CreateNewNode(AParent, AName, AValue, ANameSpace);
end;

procedure GMStoreObjProps(const Obj: TObject; Node: IGMXmlNode; const ClassNodeName: TGMString; const TypeKinds: TTypeKinds);
var Count, i: Integer; PropList: PPropList; PIStore: IGMStoreProperties;
begin
  if (Obj = nil) or (Node = nil) then Exit;
  if Obj.ClassInfo = nil then raise EGMSoapException.ObjError(GMFormat(RStrNeedRTTI, [Obj.ClassName]), Obj, 'GMStoreObjProps');
  {ToDo: Klassentyp f�r XML Knoten?}
  if ClassNodeName <> '' then Node := GMCreateXmlNode(Node, ClassNodeName);
  Count := GetTypeData(PTypeInfo(Obj.ClassInfo))^.PropCount;
  if Count > 0 then
   begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
     GetPropInfos(PTypeInfo(Obj.ClassInfo), PropList);
     for i:=0 to Count-1 do
      if PropList^[i].PropType^{$IFNDEF FPC}^{$ENDIF}.Kind in TypeKinds then
         GMAddSoapValue(Node, PropList^[i].Name, '', GetPropValue(Obj, PropList^[i].Name, False));
    finally
     FreeMem(PropList);
    end;
   end;
  if Obj.GetInterface(IGMStoreProperties, PIStore) then PIStore.StoreProperties(Node);
end;

procedure GMLoadObjProps(const AObj: TObject; ANode: IGMXmlNode; const AForceExist: Boolean; const ATypeKinds: TTypeKinds);
var Count, i: Integer; PropList: PPropList; ValNode: IGMXmlNode; PILoad: IGMLoadProperties;
begin
  if (AObj = nil) or (ANode = nil) then Exit;
  if AObj.ClassInfo = nil then raise EGMSoapException.ObjError(GMFormat(RStrNeedRTTI, [AObj.ClassName]), AObj, 'GMLoadObjProps');
  Count := GetTypeData(PTypeInfo(AObj.ClassInfo))^.PropCount;
  if Count > 0 then
   begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
     GetPropInfos(PTypeInfo(AObj.ClassInfo), PropList);
     for i:=0 to Count-1 do
      if PropList^[i].PropType^{$IFNDEF FPC}^{$ENDIF}.Kind in ATypeKinds then
       begin
        if AForceExist then
         ValNode := ANode.Obj.CheckFindSubNode(PropList^[i].Name)
        else
         ValNode := ANode.Obj.FindSubNode(PropList^[i].Name);

        if (ValNode <> nil) and (ValNode.Obj.StrValue <> '') then SetPropValue(AObj, PropList^[i].Name, ValNode.Obj.StrValue)
        else
         case PropList^[i].PropType^.Kind of
          tkChar, tkString, tkWChar, tkLString, tkWString: SetPropValue(AObj, PropList^[i].Name, '');
          tkInteger, tkFloat, tkInt64: SetPropValue(AObj, PropList^[i].Name, 0);
          tkVariant: SetPropValue(AObj, PropList^[i].Name, Null);
          //tkClass, tkInterface: SetPropValue(AObj, PropList^[i].Name, nil);
         end;
       end;
    finally
     FreeMem(PropList);
    end;
   end;
  if AObj.GetInterface(IGMLoadProperties, PILoad) then PILoad.LoadProperties(ANode, AForceExist);
end;


{ -------------------------------- }
{ ---- TGMSoapValueCarrierObj ---- }
{ -------------------------------- }

constructor TGMSoapValueCarrierObj.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
end;


{ ------------------------- }
{ ---- TGMSoapCallBase ---- }
{ ------------------------- }

constructor TGMSoapCallBase.Create(const ATransportLayer: ISequentialStream; const ASoapPortTypeURL: TGMString; const AXmlParseAttributes: TGMXmlParseAttributes; const ARefLifeTime: Boolean);
begin
  Create(ARefLifeTime);
  FTransportLayer := ATransportLayer;
  FXmlParseAttributes := AXmlParseAttributes;
  FOperationNS := GMXmlNamedValueData(cStrExec, ASoapPortTypeURL);
//FOperationNS.Value := URLExctractResourcePath(ASoapPortTypeURL);
end;

function TGMSoapCallBase.XmlTreeCreateClass: TGMXmlTreeClass;
begin
  Result := TGMXmlTree;
end;

function TGMSoapCallBase.InsertSoapEnvelope(const AParentNode: IGMXmlNode; const AAddOperationNS: Boolean): IGMXmlNode;
begin
  if AParentNode = nil then Exit;
  Result := GMCreateXmlNode(AParentNode, cStrSoapEnv, '', cStrEnvNS);
  AddEnvelopeAttributes(Result, AAddOperationNS);
end;

function TGMSoapCallBase.InsertSoapBody(const AParentNode: IGMXmlNode): IGMXmlNode;
begin
  if AParentNode = nil then Exit;
  Result := GMCreateXmlNode(AParentNode, cStrSoapBody, '', cStrEnvNS);
end;

procedure TGMSoapCallBase.AddEnvelopeAttributes(const AEnvelopeNode: IGMXmlNode; const AAddOperationNS: Boolean);
begin
  if AEnvelopeNode <> nil then
   with AEnvelopeNode.Obj do
    begin
     Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, cStrEnvNS), '"http://schemas.xmlsoap.org/soap/envelope/"'));
     if AAddOperationNS and (Length(FOperationNS.Name) > 0) and (Length(FOperationNS.Value) > 0) then
        Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, FOperationNS.Name), GMXmlAttrQuote(FOperationNS.Value)));
    end;
end;


{ --------------------------- }
{ ---- TGMSoapClientCall ---- }
{ --------------------------- }

constructor TGMSoapClientCall.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FTypeNameSpace := cStrXsi;
end;

function TGMSoapClientCall.AddTypeAttributes: Boolean;
begin
  Result := Length(FTypeNameSpace) > 0;
end;

function TGMSoapClientCall.WrongContentExceptionCreateClass: EGMExceptionClass;
begin
  Result := EGMSoapException;
end;

function TGMSoapClientCall.ValueAsSoapString(const AValue: OleVariant): TGMString;
begin
  Result := GMSoapVarToStr(AValue);
end;

function TGMSoapClientCall.AddSoapValue(const AParentNode: IGMXmlNode; const AName: TGMString; const AValue: OleVariant): IGMXmlNode;
begin
  if AParentNode = nil then Exit;
  Result := GMCreateXmlNode(AParentNode, AName, ValueAsSoapString(AValue));
  if AddTypeAttributes then
     Result.Obj.Attributes.Add(Result.Obj.AttributeCreateClass.Create(GMXmlQualifiedName(FTypeNameSpace, cStrType), GMXmlAttrQuote(GMXmlQualifiedName(cStrXsd, GMSoapTypeName(VarType(AValue))))));
end;

procedure TGMSoapClientCall.AddEnvelopeAttributes(const AEnvelopeNode: IGMXmlNode; const AAddOperationNS: Boolean);
begin
  inherited;
  if AEnvelopeNode <> nil then
   with AEnvelopeNode.Obj do
    if AddTypeAttributes then Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, FTypeNameSpace), '"http://www.w3.org/2001/XMLSchema-instance"'));

// with AEnvelopeNode.Obj do
//  begin
//   //Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, cStrEnvNS), '"http://schemas.xmlsoap.org/soap/envelope/"'));
//   if AddTypeAttributes then Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, FTypeNameSpace), '"http://www.w3.org/2001/XMLSchema-instance"'));
////   Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, cStrXsd), '"http://www.w3.org/2001/XMLSchema"'));
////   Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, cStrXsi), '"http://www.w3.org/2001/XMLSchema-instance"'));
////   Attributes.Add(AttributeCreateClass.Create(GMXmlQualifiedName(cStrXmlns, cStrEncNS), '"http://schemas.xmlsoap.org/soap/encoding/"'));
//  end;
end;

procedure TGMSoapClientCall.StoreObjProps(const Obj: TObject; Node: IGMXmlNode; const ClassNodeName: TGMString; const TypeKinds: TTypeKinds);
var Count, i: Integer; PropList: PPropList; PIStore: IGMStoreProperties;
begin
  if (Obj = nil) or (Node = nil) then Exit;
  if Obj.ClassInfo = nil then raise EGMSoapException.ObjError(GMFormat(RStrNeedRTTI, [Obj.ClassName]), Obj, 'StoreObjProps');
  {ToDo: Klassentyp f�r XML Knoten?}
  if ClassNodeName <> '' then Node := GMCreateXmlNode(Node, ClassNodeName, '');
  Count := GetTypeData(PTypeInfo(Obj.ClassInfo))^.PropCount;
  if Count > 0 then
   begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
     GetPropInfos(PTypeInfo(Obj.ClassInfo), PropList);
     for i:=0 to Count-1 do
      if PropList^[i].PropType^{$IFNDEF FPC}^{$ENDIF}.Kind in TypeKinds then
       AddSoapValue(Node, PropList^[i].Name, GetPropValue(Obj, PropList^[i].Name, False));
    finally
     FreeMem(PropList);
    end;
   end;
  if Obj.GetInterface(IGMStoreProperties, PIStore) then PIStore.StoreProperties(Node);
end;

procedure TGMSoapClientCall.LoadObjProps(const Obj: TObject; Node: IGMXmlNode; const ForceExist: Boolean; const TypeKinds: TTypeKinds);
var Count, i: Integer; PropList: PPropList; ValNode: IGMXmlNode; PILoad: IGMLoadProperties;
begin
  if (Obj = nil) or (Node = nil) then Exit;
  if Obj.ClassInfo = nil then raise EGMSoapException.ObjError(GMFormat(RStrNeedRTTI, [Obj.ClassName]), Obj, 'GMLoadObjProps');
  Count := GetTypeData(PTypeInfo(Obj.ClassInfo))^.PropCount;
  if Count > 0 then
   begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
     GetPropInfos(PTypeInfo(Obj.ClassInfo), PropList);
     for i:=0 to Count-1 do
      if PropList^[i].PropType^{$IFNDEF FPC}^{$ENDIF}.Kind in TypeKinds then
       begin
        if ForceExist then
         ValNode := Node.Obj.CheckFindSubNode(PropList^[i].Name)
        else
         ValNode := Node.Obj.FindSubNode(PropList^[i].Name);

        if (ValNode <> nil) and (ValNode.Obj.StrValue <> '') then SetPropValue(Obj, PropList^[i].Name, ValNode.Obj.StrValue)
        else
         case PropList^[i].PropType^.Kind of
          tkChar, tkString, tkWChar, tkLString, tkWString: SetPropValue(Obj, PropList^[i].Name, '');
          tkInteger, tkFloat, tkInt64: SetPropValue(Obj, PropList^[i].Name, 0);
          tkVariant: SetPropValue(Obj, PropList^[i].Name, Null);
          //tkClass, tkInterface: SetPropValue(Obj, PropList^[i].Name, nil);
         end;
       end;
    finally
     FreeMem(PropList);
    end;
   end;
  if Obj.GetInterface(IGMLoadProperties, PILoad) then PILoad.LoadProperties(Node, ForceExist);
end;

function TGMSoapClientCall.CreateSOAPCallXml(const ASoapMethodName: TGMString; var ANode: IGMXmlNode): IGMXmlTree;
begin
  Result := XmlTreeCreateClass.CreateWrite;
  ANode := GMCreateXmlNode(InsertSoapBody(InsertSoapEnvelope(Result.Obj.RootNode)), GMXmlQualifiedName(FOperationNS.Name, ASoapMethodName));
end;

procedure TGMSoapClientCall.RaiseSoapFault(const ASoapFaultNode: IGMXmlNode; const ACallingName: TGMString);
  function BuildFaultMsg: TGMString;
  var Node: IGMXmlNode;
  begin
    if (ASoapFaultNode <> nil) and ASoapFaultNode.Obj.FindSubNodeIntoVar(cStrSoapFaultString, nil, Node) then Result := GMStrip(Node.Obj.StrValue);
    if Length(Result) <= 0 then Result := RStrNoSoapFaultMsg;
  end;
var SoapExceptObj: EGMSoapException;
begin
  SoapExceptObj := nil;
  try
   SoapExceptObj := CreateSoapFaultExceptObj(ASoapFaultNode, ACallingName);
   if SoapExceptObj = nil then SoapExceptObj := EGMSoapException.ObjError(BuildFaultMsg, Self, BuildCallingName(ACallingName, {$I %CurrentRoutine%}));
  except
   GMFreeAndNil(SoapExceptObj);
  end;

  if SoapExceptObj <> nil then
   begin
    if Length(SoapExceptObj.Message) <= 0 then SoapExceptObj.Message := BuildFaultMsg;
    raise SoapExceptObj;
   end;
end;

procedure TGMSoapClientCall.CheckResponseXml(const AResponseXml: IGMXmlTree; const ACallingName: TGMString);
var node: IGMXmlNode;
begin
  if AResponseXml = nil then Exit;

  if GMGetXmlNodeByPath(AResponseXml.Obj.RootNode, [cStrSoapEnv, cStrSoapBody, cStrSoapFault], node) then
     RaiseSoapFault(node, BuildCallingName(ACallingName, {$I %CurrentRoutine%}));

//if AResponseXml.Obj.RootNode.Obj.FindSubNode(cStrSoapEnv, node, 1) then
// if node.Obj.FindSubNode(cStrSoapBody, node, 1) then
//  if node.Obj.FindSubNode(cStrSoapFault, node, 1) then RaiseSoapFault(node, BuildCallingName(ACallingName, {$I %CurrentRoutine%}));
end;

procedure TGMSoapClientCall.CheckResponseContentType(const AResponseContent: ISequentialStream; const AContentType, ACallingName: TGMString);
begin
  if CompareText(cStrHttpContentXml, AContentType) <> 0 then
   raise WrongContentExceptionCreateClass.ObjError(GMStringJoin(GMTerminateStr(GMFormat(RStrWrongContentType, [AContentType, cStrHttpContentXml])), c2NewLine,
         GMExtractAnyTextResponse(AResponseContent, AContentType)), Self, BuildCallingName(ACallingName, {$I %CurrentRoutine%}));
end;

function TGMSoapClientCall.CheckResponseContent(const AResponseContent: ISequentialStream; const AContentType: TGMString; const ACallingName: TGMString): IGMXmlTree;
//var StreamPosKeeper: IUnknown;
begin
  if AResponseContent = nil then Exit; // begin Result := XmlTreeCreateClass.CreateRead(AResponseContent); Exit; end;
   //raise EGMException.ObjError(MsgPointerIsNil(RStrResponseContentStream), Self, {$I %CurrentRoutine%});
//StreamPosKeeper := TGMIStreamPosKeeper.Create(AResponseContent);

//if not GMIsXmlContent(AResponseContent) then
// raise WrongContentExceptionCreateClass.ObjError(RStrResonseContentNotXml, Self, BuildCallingName(ACallingName, {$I %CurrentRoutine%}));

  if CompareText(cStrHttpContentXml, AContentType) = 0 then Result := XmlTreeCreateClass.CreateRead(AResponseContent, FXmlParseAttributes)
  else
  //if CompareText(cStrHttpContentHtml, AContentType) <> 0 then Result := TGMHtmlTree.CreateRead(AResponseContent, FXmlParseAttributes - [paCheckHasXmlToken]);
  if CompareText(cStrHttpContentHtml, AContentType) = 0 then Result := TGMHtmlTree.CreateRead(AResponseContent, cRelaxedHtmlParseAttributes);

//else
// raise WrongContentExceptionCreateClass.ObjError(GMStringJoin(GMTerminateStr(GMFormat(RStrWrongContentType, [AContentType, cStrHttpContentXml])), c2NewLine,
//        GMExtractAnyTextResponse(AResponseContent, AContentType)), Self, BuildCallingName(ACallingName, {$I %CurrentRoutine%}));

  //
  // When Result is nil a later check of the content type will fail!
  //
  if Result <> nil then CheckResponseXml(Result, ACallingName);
end;

procedure TGMSoapClientCall.PrepareHttpRequest(const ARequest: IUnknown);
begin
  {ToDo: Add "SOAPAction" header here!}

//   soapaction    = "SOAPAction" ":" [ <"> URI-reference <"> ]
//   URI-reference = <as defined in RFC 2396 [4]>

  // Nothing! May be used by derived classes to add request headers.
end;

function TGMSoapClientCall.ExecSoapCall(const ASession: IGMHttpClientSession; const AXML: IGMXmlTree; const ACallingName: TGMString): IGMXmlTree;
var responseStrm: ISequentialStream; xmlStrm: IStream; request: IGMHttpClientRequest; uriParts: RGMUriComponents;
    contentType: TGMString;
begin
  if (ASession = nil) or (AXML = nil) then Exit;

  xmlStrm := TGMMemoryIStream.Create;
  //SrcStrm := TGMStreamAdapter.Create(xmlStrm);
  AXML.Obj.SaveToStream(xmlStrm);

  uriParts := GMParseUri(FOperationNS.Value);
//request := FConnection.CreateHttpRequest(cStrHttpPost, FSoapPortURL);
  request := TGMHttpClientRequest.Create(cGMHttpAgent);
  PrepareHttpRequest(request);

  //request.AddHeaders(GMFormat('%s: %s', [cStrHdrUserAgent, cStrUserAgent]));
//request.Obj.SendRequest('', xmlStrm.Obj.Memory, xmlStrm.Obj.Size, cGMTracePrefixes[tpXml]);
  responseStrm := ASession.ExecuteRequest(request, GMBuildUri('', '', '', '', '', uriParts.Path, uriParts.Query, uriParts.Fragment),
                                          cHttpMethodPOST, xmlStrm, cStrHttpContentXml);

//responseStrm := TGMMemoryIStream.Create;
//request.Obj.ReadResponseContent(responseStrm); // <- read responseStrm before HttpCheck to show it in the trace

//contentType := GMStrip(GMFirstWord(request.Obj.GetStrHeader(HTTP_QUERY_CONTENT_TYPE), ';,'), cWhiteSpace);
  contentType := GMStrip(GMFirstWord(GMGetINetHeaderStrValue(request.Obj.ReceivedHeaders, cHttpContentType), ';,'), cWhiteSpace);

//httpCode := request.Obj.GetIntHeader(HTTP_QUERY_STATUS_CODE, -1);

  //
  // Check the content before checking the content-type, because SOAP faults may be delivered as text/html by the server!
  //
  Result := CheckResponseContent(responseStrm, contentType, {$I %CurrentRoutine%});
  CheckResponseContentType(responseStrm, contentType, {$I %CurrentRoutine%});

  //if httpCode = -1 then raise EGMException.ObjError(RStrNoHttpStatusCode, Self, {$I %CurrentRoutine%});

  //
  // SOAP faults come with HTTP code 500 - server error, so check for SOAP fault before raising a normal HTTP server error!
  //
//if httpCode <> HTTP_STATUS_OK then
// HttpCheck(httpCode, [HTTP_STATUS_OK], GMExtractAnyTextResponse(responseStrm, contentType), Self, {$I %CurrentRoutine%});

  //GMCheckHTTPResponseContentType(request, cStrHttpContentXml, Self, {$I %CurrentRoutine%}, SoapFaultMsg);
  if Result = nil then Result := XmlTreeCreateClass.CreateRead(responseStrm, FXmlParseAttributes);
end;


{ ---------------------------- }
{ ---- TGMSoapMethodEntry ---- }
{ ---------------------------- }

constructor TGMSoapMethodEntry.Create(const AMethodName: TGMString; const ASoapMethod: TGMSoapMethod; const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  SoapMethodName := AMethodName;
  SoapMethod := ASoapMethod;
end;

function TGMSoapMethodEntry.GetName: TGMString;
begin
  Result := SoapMethodName;
end;


{ --------------------------- }
{ ---- TGMSoapServerPort ---- }
{ --------------------------- }

constructor TGMSoapServerPort.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FRegisteredSoapMethods := TGMObjArrayCollection.Create(True, False, True, GMCompareByName, True);
end;

constructor TGMSoapServerPort.Create(const ATransportLayer: ISequentialStream; const ASoapPortName, ASoapPortTypeURL: TGMString;
  const AXmlParseAttributes: TGMXmlParseAttributes; const ARefLifeTime: Boolean);
begin
  inherited Create(ATransportLayer, ASoapPortTypeURL, AXmlParseAttributes, ARefLifeTime);
  FSoapPortName := ASoapPortName;
end;

function TGMSoapServerPort.Obj: TGMSoapServerPort;
begin
  Result := Self;
end;

function TGMSoapServerPort.DoTracing: Boolean;
begin
  Result := {$IFDEF DEBUG}True{$ELSE}False{$ENDIF};
end;

function TGMSoapServerPort.TracePrefix: TGMString;
begin
  Result := cStrSoap;
end;

procedure TGMSoapServerPort.RegisterSOAPMethod(const AMethodName: AnsiString; const AMethod: TGMSoapMethod);
begin
  FRegisteredSoapMethods.Add(TGMSoapMethodEntry.Create(AMethodName, AMethod));
end;

function TGMSoapServerPort.FindSoapMethod(const AMethodName: TGMString): TGMSoapMethod;
var nameObj: IUnknown; methodEntry: TGMSoapMethodEntry;
begin
  nameObj := TGMNameObj.Create(AMethodName);
  if FRegisteredSoapMethods.Find(nameObj, methodEntry) then Result := methodEntry.SoapMethod else Result := nil;
end;

function TGMSoapServerPort.InsertFaultNode(const ABodyNode: IGMXmlNode; const AExceptObject: TObject): TGMString;
var faultNode: IGMXmlNode;
begin
  if (ABodyNode = nil) or (AExceptObject = nil) then Exit;
  faultNode := GMCreateXmlNode(ABodyNode, cStrSoapFault, '', cStrEnvNS);

  GMCreateXmlNode(faultNode, cStrSoapFaultCode, AExceptObject.ClassName);
  GMCreateXmlNode(faultNode, cStrSoapFaultString, RStrException); // GMMsgFromExceptObj(AExceptObject, False)

  Result := InsertFaultDetailNode(faultNode, AExceptObject);
end;

//function TGMSoapServerPort.ProcessRequest(const AReadStrm, AWriteStrm: ISequentialStream): TGMSoapRequestResult;
function TGMSoapServerPort.ProcessRequest: TGMSoapRequestResult;
var requestXml, responseXml: IGMXmlTree; responseBodyNode, requestBodyNode, requestMethodNode: IGMXmlNode; // responseEnvNode
    errMsg: TGMString; soapMethod: TGMSoapMethod;
begin
  if DoTracing then vfGMTrace(RStrUsingSoapPort + ': "' + FSoapPortName+'"', TracePrefix);

  responseXml := XmlTreeCreateClass.CreateWrite;
//responseEnvNode := InsertSoapEnvelope(responseXml.Obj.RootNode);
//GMCreateXmlNode(responseEnvNode, cStrSoapHeader, '', cStrEnvNS);
  responseBodyNode := InsertSoapBody(InsertSoapEnvelope(responseXml.Obj.RootNode));
  try
   // Check request content type, or just read the requestXml? Would cause requestXml related exception if other content was sent

   //
   // Parsing the calling XML should already be wrapped by SOAP fault handling
   //
   requestXml := XmlTreeCreateClass.CreateRead(FTransportLayer, FXmlParseAttributes);
   requestBodyNode := GMCheckGetXmlNodeByPath(requestXml.Obj.RootNode, [cStrSoapEnv, cStrSoapBody]);

   GMQueryInterface(requestBodyNode.Obj.SubNodes.First, IGMXmlNode, requestMethodNode);
   if requestMethodNode = nil then raise EGMSoapException.ObjError(RStrNoSOAPMethodNode, Self, {$I %CurrentRoutine%});

   Result.SOAPMethodName := requestMethodNode.Obj.Name;
   Result.LogMessage := TracePrefix + ' "' + requestMethodNode.Obj.Name + '"';

   if Length(requestMethodNode.Obj.Name) <= 0 then raise EGMSoapException.ObjError(RStrEmptySoapMethodName, Self, {$I %CurrentRoutine%});

   soapMethod := FindSoapMethod(requestMethodNode.Obj.Name);
   if not Assigned(soapMethod) then raise EGMSoapException.ObjError(GMFormat(RStrSoapMethodNotImpl, [requestMethodNode.Obj.Name]), Self, {$I %CurrentRoutine%});
   soapMethod(requestMethodNode, responseBodyNode);

   Result.HttpStatusCode := HTTP_STATUS_OK;
  except
// if DoTracing then GMTraceException(GMExceptObject);
   responseXml := XmlTreeCreateClass.CreateWrite;
// responseXml.Obj.RootNode.Obj.SubNodes.Clear;
   errMsg := InsertFaultNode(InsertSoapBody(InsertSoapEnvelope(responseXml.Obj.RootNode, False)), ExceptObject);
   if Length(Result.LogMessage) <= 0 then Result.LogMessage := errMsg;
   Result.HttpStatusCode := HTTP_STATUS_SERVER_ERROR;
  end;

  responseXml.Obj.SaveToStream(FTransportLayer);
end;

//procedure TGMSoapServerPort.SendResponseContent(const ATransportLayer: ISequentialStream);
//begin
//
//end;


end.