soaphttptrans.pas

Delphi的Soap一些使用功能控件

{*******************************************************}
{                                                       }
{       CodeGear Delphi Visual Component Library        }
{         SOAP Transports                               }
{                                                       }
{  	    Copyright (c) 1995-2007 CodeGear	        }
{                                                       }
{*******************************************************}

unit SOAPHTTPTrans;

{$IFDEF LINUX}
  {$DEFINE USE_INDY}
{$ENDIF}
{$IFDEF MSWINDOWS}
//  {$DEFINE USE_INDY}
{$ENDIF}

{$IFNDEF VER150}
{$INCLUDE 'CompVer.inc'}
{$ENDIF}

{$IFDEF HIGHLANDER_UP}
  // {$DEFINE PICK_FIRST_CERTIFICATE}
  {$DEFINE INDY_CUSTOM_IOHANDLER}
{$ENDIF}

interface

uses
  SysUtils, Classes, WebNode, WSDLNode, Types, IntfInfo, WSDLIntf, SOAPAttachIntf,
{$IFDEF USE_INDY}
IdHTTP, IdIOHandler, IdIOHandlerSocket, IdSSLOpenSSL;
{$ELSE}
  WinSock, WinInet;
(*$HPPEMIT '#pragma link "wininet.lib"' *)
{$ENDIF}
type

  ESOAPHTTPException = class(Exception)
  private
    FStatusCode: Integer;
  public
{$IF CompilerVersion <= 15.0}
    constructor Create(const Msg: string; SCode: Integer = 0);
{$ELSE}
    constructor Create(const Msg: string; SCode: Integer = 0; Dummy: Integer = 0);
{$IFEND}    
    constructor CreateFmt(const Msg: string; const Args: array of const; SCode: Integer = 0; Dummy: Integer = 0);

    property StatusCode: Integer read FStatusCode write FStatusCode;
  end;

  SOAPInvokeOptions = (soNoValueForEmptySOAPAction,   { Send "" or absolutely no value for empty SOAPAction }
                       soIgnoreInvalidCerts,          { Handle Invalid Server Cert and ask HTTP runtime to ignore }
                       soNoSOAPActionHeader,          { Don't send SOAPAction - use very very carefully!! }
                       soAutoCheckAccessPointViaUDDI  { if we get a status code 404/405/410 - contact UDDI }
                       );
  TSOAPInvokeOptions= set of SOAPInvokeOptions;

  THTTPReqResp = class;

  { Provides access to HTTPReqResp component }
  IHTTPReqResp = interface
  ['{5FA6A197-32DE-4225-BC85-216CB80D1561}']
    function GetHTTPReqResp: THTTPReqResp;
  end;

  TBeforePostEvent = procedure(const HTTPReqResp: THTTPReqResp; Data: Pointer) of object;
  TPostingDataEvent= procedure(Sent: Integer; Total: Integer) of object;
  TReceivingDataEvent= procedure(Read: Integer; Total: Integer) of object;

  THTTPReqResp = class(TComponent, IInterface, IWebNode, IHTTPReqResp)
  private
    FUserSetURL: Boolean;
    FRefCount: Integer;
    FOwnerIsComponent: Boolean;
    FConnected: Boolean;
    FURL: string;
    FAgent: string;
    FBindingType: TWebServiceBindingType;
    FMimeBoundary: string;
    FContentType: string;
    FUserName: string;
    FPassword: string;
    FURLHost: string;
    FURLSite: string;
    FURLPort: Integer;
    FURLScheme: Integer;
    FProxy: string;
    FProxyByPass: string;
{$IFNDEF USE_INDY}
    FInetRoot: HINTERNET;
    FInetConnect: HINTERNET;
{$ENDIF}
    FConnectTimeout: Integer;
    FSendTimeout: Integer;
    FReceiveTimeout: Integer;
    FWSDLView: TWSDLView;
    FSoapAction: string;
    FUseUTF8InHeader: Boolean;
    FInvokeOptions: TSOAPInvokeOptions;
    FUDDIBindingKey: WideString;
    FUDDIOperator: String;
    FOnBeforePost: TBeforePostEvent;
    FOnPostingData: TPostingDataEvent;
    FOnReceivingData: TReceivingDataEvent;
    FMaxSinglePostSize: Integer;

{$IFDEF USE_INDY}
  {$IFDEF INDY_CUSTOM_IOHANDLER}
    FIOHandler: TIdIOHandler;
  {$ENDIF}
{$ENDIF}

    procedure SetURL(const Value: string);
    function  GetSOAPAction: string;
    procedure SetSOAPAction(const SOAPAction: string);
    procedure SetWSDLView(const WSDLVIew: TWSDLView);
    function  GetSOAPActionHeader: string;
    procedure InitURL(const Value: string);
    procedure SetUsername(const NameValue: string);
    procedure SetPassword(const PasswordValue: string);
    procedure SetProxy(const ProxyValue: string);
{$IFDEF DEXTER_UP}
    function  GetAgentIsStored:Boolean;
{$ENDIF}
  protected
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function GetMimeBoundary: string;
    procedure SetMimeBoundary(Value: string);
  public
    constructor Create(Owner: TComponent); override;
    class function NewInstance: TObject; override;
    procedure AfterConstruction; override;
    destructor Destroy; override;
    function  GetHTTPReqResp: THTTPReqResp;
    procedure CheckContentType;
{$IFNDEF USE_INDY}
    procedure Check(Error: Boolean; ShowSOAPAction: Boolean = False);
    procedure Connect(Value: Boolean);
    function  Send(const ASrc: TStream): Integer; virtual;
    function  SendGet: Integer; virtual;
    procedure Receive(Context: Integer; Resp: TStream; IsGet: Boolean = False); virtual;
{$ENDIF}
{$IFDEF USE_INDY}
    procedure SetupIndy(IndyHttp: TIDHttp; Request: TStream);
{$ENDIF}
    procedure Get(Resp: TStream); virtual;
    {IWebNode}
    procedure BeforeExecute(const IntfMD: TIntfMetaData;
                            const MethMD: TIntfMethEntry;
                            MethodIndex: Integer;
                            AttachHandler: IMimeAttachmentHandler);
    procedure Execute(const DataMsg: String; Resp: TStream); overload; virtual;
    procedure Execute(const Request: TStream; Response: TStream); overload; virtual;
    function  Execute(const Request: TStream): TStream; overload; virtual;
    property  URL: string read FURL write SetURL;
    property  SoapAction: string read GetSOAPAction write SetSOAPAction;
    { Can these be exposed when using Indy too?? }
    property  ConnectTimeout: Integer read FConnectTimeout write FConnectTimeout;
    property  SendTimeout: Integer read FSendTimeout write FSendTimeout;
    property  ReceiveTimeout: Integer read FReceiveTimeout write FReceiveTimeout;
    property  MaxSinglePostSize: Integer read FMaxSinglePostSize write FMaxSinglePostSize;

{$IFDEF USE_INDY}
  {$IFDEF INDY_CUSTOM_IOHANDLER}
    property IOHandler: TIdIOHandler read FIOHandler write FIOHandler;
  {$ENDIF}
{$ENDIF}

  published
    property  WSDLView: TWSDLView read FWSDLView write SetWSDLView;
{$IFDEF DEXTER_UP}
    property  Agent: string read FAgent write FAgent stored GetAgentIsStored;
{$ELSE}
    property  Agent: string read FAgent write FAgent;
{$ENDIF}
    property  UserName: string read FUserName write SetUserName;
    property  Password: string read FPassword write SetPassword;
    property  Proxy: string read FProxy write SetProxy;
    property  ProxyByPass: string read FProxyByPass write FProxyByPass;
{$IFDEF DEXTER_UP}
    property  UseUTF8InHeader: Boolean read FUseUTF8InHeader write FUseUTF8InHeader default False;
{$ELSE}
    property  UseUTF8InHeader: Boolean read FUseUTF8InHeader write FUseUTF8InHeader;
{$ENDIF}
    property  InvokeOptions: TSOAPInvokeOptions read FInvokeOptions write FInvokeOptions;
    property  UDDIBindingKey: WideString read FUDDIBindingKey write FUDDIBindingKey;
    property  UDDIOperator: String read FUDDIOperator write FUDDIOperator;

    { Events }
    property  OnBeforePost: TBeforePostEvent read FOnBeforePost write FOnBeforePost;
    property  OnPostingData: TPostingDataEvent read FOnPostingData write FOnPostingData;
    property  OnReceivingData: TReceivingDataEvent read FOnReceivingData write FOnReceivingData;
  end;

implementation


uses Variants, SOAPConst, XMLDoc, XMLIntf, InvokeRegistry, WSDLItems,
     SOAPAttach, UDDIHelper,
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
{$IFNDEF USE_INDY}
xmldom;
{$ELSE}
IdIntercept, IdException, IdURI, IdGlobal, IdHeaderList, IdHTTPHeaderInfo;
{$ENDIF}

{$IFDEF USE_INDY}
procedure ParseURI(AURI: string; var VProtocol, VHost, VPath, VDocument,
                       VPort, VBookmark : string);
var
  URI: TIdURI;
begin
  URI := TIdURI.Create(AURI);
  try
    VProtocol := URI.Protocol;
    VHost := URI.Host;
    VPath := URI.Path;
    VDocument := URI.Document;
    VPort := URI.Port;
    VBookmark := URI.Bookmark;
  finally
    URI.Free;
  end;
end;
{$ENDIF}

{$IF CompilerVersion <= 15.0}
constructor ESOAPHTTPException.Create(const Msg: string; SCode: Integer = 0);
{$ELSE}
constructor ESOAPHTTPException.Create(const Msg: string; SCode: Integer = 0; Dummy: Integer = 0);
{$IFEND}
begin
  inherited Create(Msg);
  FStatusCode := SCode;
end;

constructor ESOAPHTTPException.CreateFmt(const Msg: string; const Args: array of const; SCode: Integer; Dummy: Integer);
begin
  inherited CreateFmt(Msg, Args);
  FStatusCode := SCode;
end;

constructor THTTPReqResp.Create(Owner: TComponent);
begin
  inherited;
{$IFNDEF USE_INDY}
  FInetRoot := nil;
  FInetConnect := nil;
{$ENDIF}
  FUserSetURL := False;
  FInvokeOptions := [soIgnoreInvalidCerts, soAutoCheckAccessPointViaUDDI];
  FAgent := 'Borland SOAP 1.2'; { Do not localize }
  FMaxSinglePostSize := $8000;
  { Default this to true to allow Clients to send International Characters without having to
    explicit set this. 
    NOTE: This is a change from previous versions but it seems better based on the number of
          reports whose ultimate solution is related to not having enabled this property 
          The property still specifies the default as False as we cannot break interfaces for
          this release. We'll reconsider the 'default' in a subsequent release. }
  FUseUTF8InHeader := True;
end;

destructor THTTPReqResp.Destroy;
begin
{$IFNDEF USE_INDY}
  if Assigned(FInetConnect) then
    InternetCloseHandle(FInetConnect);
  FInetConnect := nil;
  if Assigned(FInetRoot) then
    InternetCloseHandle(FInetRoot);
  FInetRoot := nil;
{$ENDIF}
  FConnected := False;
  inherited;
end;

class function THTTPReqResp.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  THTTPReqResp(Result).FRefCount := 1;
end;

procedure THTTPReqResp.AfterConstruction;
begin
  inherited;
  FOwnerIsComponent := Assigned(Owner) and (Owner is TComponent);
  InterlockedDecrement(FRefCount);
end;

{ IInterface }

function THTTPReqResp._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount)
end;

function THTTPReqResp._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  { If we are not being used as a TComponent, then use refcount to manage our
    lifetime as with TInterfacedObject. }
  if (Result = 0) and not FOwnerIsComponent then
    Destroy;
end;

{$IFNDEF USE_INDY}
procedure THTTPReqResp.Check(Error: Boolean; ShowSOAPAction: Boolean);
var
  ErrCode: Integer;
  S: string;
begin
  ErrCode := GetLastError;
  if Error and (ErrCode <> 0) then
  begin
    SetLength(S, 256);
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_FROM_HMODULE, Pointer(GetModuleHandle('wininet.dll')),
      ErrCode, 0, PChar(S), Length(S), nil);
    SetLength(S, StrLen(PChar(S)));
    while (Length(S) > 0) and (S[Length(S)] in [#10, #13]) do
      SetLength(S, Length(S) - 1);
    raise ESOAPHTTPException.CreateFmt('%s - URL:%s - SOAPAction:%s', [S, FURL, SoapAction]);      { Do not localize }
  end;
end;
{$ENDIF}

function THTTPReqResp.GetHTTPReqResp: THTTPReqResp;
begin
  Result := Self;
end;

function THTTPReqResp.GetSOAPAction: string;
begin
  if (FSoapAction = '') and not (soNoValueForEmptySOAPAction in FInvokeOptions) then
    Result := '""'
  else
    Result := FSoapAction;
end;

procedure THTTPReqResp.SetSOAPAction(const SOAPAction: string);
begin
  FSoapAction := SOAPAction;
end;

procedure THTTPReqResp.SetWSDLView(const WSDLVIew: TWSDLView);
begin
  FWSDLView := WSDLView;
end;

procedure THTTPReqResp.SetURL(const Value: string);
begin
  if Value <> '' then
    FUserSetURL := True
  else
    FUserSetURL := False;
  InitURL(Value);
{$IFNDEF USE_INDY}
  { Here we always disconnect if a new URL comes in...
    this ensures that we don't keep a connection to
    a wrong host }
  Connect(False);
{$ENDIF}  
end;

procedure THTTPReqResp.InitURL(const Value: string);
{$IFNDEF USE_INDY}
var
  URLComp: TURLComponents;
  P: PChar;
{$ELSE}
const
  http = 'http://';
var
  IndyHTTP: TIDHttp;
  URI, Protocol, Host, path, Document, Port, Bookmark: string;
{$ENDIF}
begin
  if Value <> '' then
  begin
{$IFNDEF USE_INDY}
    FillChar(URLComp, SizeOf(URLComp), 0);
    URLComp.dwStructSize := SizeOf(URLComp);
    URLComp.dwSchemeLength := 1;
    URLComp.dwHostNameLength := 1;
    URLComp.dwURLPathLength := 1;
    P := PChar(Value);
    InternetCrackUrl(P, 0, 0, URLComp);