idsoaphttptrans.pas

C/S方式下的HTTPS安全数据传输控件.控件在INDY9 和delphi7下编译通过.可以很好的使用

unit IdSOAPHTTPTrans;

interface

uses
  SysUtils, Classes, WebNode, WSDLNode, Types, IntfInfo, WSDLIntf, SOAPAttachIntf,
  IdHTTP, IdIOHandlerSocket, IdSSLOpenSSL,Dialogs;

type
  EIdSOAPHTTPException = class(Exception)
  private
    FStatusCode: Integer;
  public
    constructor Create(const Msg: string; SCode: Integer = 0);
    constructor CreateFmt(const Msg: string; const Args: array of const; SCode:
  Integer = 0);
    property StatusCode: Integer read FStatusCode write FStatusCode;
  end;

  IdSOAPInvokeOptions = (soNoValueForEmptySOAPAction, { Send "" or absolutely no
    value for empty SOAPAction }
  soIgnoreInvalidCerts { xxx Handle Invalid Server
  Cert and ask HTTP runtime to ignore }
  );

  TIdSOAPInvokeOptions = set of IdSOAPInvokeOptions;
  TIdHTTPReqRespOnLog = procedure (Sender: TComponent; aOutbound, aHeader: Boolean;
    St: TStream) of object;
  TIdHTTPReqResp = class;
  { Provides access to HTTPReqResp component }
  IIdHTTPReqResp = interface
    ['{5FA6A197-32DE-4225-BC85-216CB80D1561}']
    function GetHTTPReqResp: TIdHTTPReqResp;
  end;

  TIdHTTPReqResp = class(TComponent, IInterface, IWebNode, IIdHTTPReqResp)
  private
    FUserSetURL: Boolean;
    FRefCount: Integer;
    FOwnerIsComponent: Boolean;
    FURL: string;
    FBindingType: TWebServiceBindingType;
    FMimeBoundary: string;
    FWSDLView: TWSDLView;
    FSoapAction: string;
    FUseUTF8InHeader: Boolean;
    FInvokeOptions: TIdSOAPInvokeOptions;
    fIdHttp: TIdCustomHttp;
    fOnLog: TIdHTTPReqRespOnLog;
    procedure SetURL(const Value: string);
    function GetSOAPAction: string;
    procedure SetSOAPAction(const SOAPAction: string);
    procedure SetWSDLView(const WSDLVIew: TWSDLView);
    function GetSOAPActionHeader: string;
    protected
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function GetMimeBoundary: string;
    procedure SetMimeBoundary(Value: string);
    procedure Log(aOutbound, aHeader: Boolean; St: TStream); virtual;
    procedure LogString(aOutbound, aHeader: Boolean; S: string);
  public
    constructor Create(Owner: TComponent); override;
    class function NewInstance: TObject; override;
    procedure AfterConstruction; override;
    destructor Destroy; override;
    function GetHTTPReqResp: TIdHTTPReqResp;
    procedure Get(Response: TStream); virtual;
  {IWebNode}
    procedure BeforeExecute(const IntfMD: TIntfMetaData;
  const MethMD: TIntfMethEntry;
  MethodIndex: Integer;
  AttachHandler: IMimeAttachmentHandler);
    procedure Execute(const DataMsg: String; Response: 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;
  published
    property HttpClient: TIdCustomHttp read fIdHttp;
    property WSDLView: TWSDLView read FWSDLView write SetWSDLView;
    property UseUTF8InHeader: Boolean read FUseUTF8InHeader write FUseUTF8InHeader;
    property InvokeOptions: TIdSOAPInvokeOptions read FInvokeOptions write
  FInvokeOptions;
    property OnLog: TIdHTTPReqRespOnLog read fOnLog write fOnLog;
end;

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

constructor EIdSOAPHTTPException.Create(const Msg: string; SCode: Integer = 0);
begin
  inherited Create(Msg);
  FStatusCode := SCode;
end;

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

constructor TIdHTTPReqResp.Create(Owner: TComponent);
begin
  inherited;
  FIdHTTP:= TIdCustomHTTP.Create(Self);
  FIdHttp.Request.AcceptCharSet:= 'utf-8';
  FIdHttp.Request.UserAgent := 'Borland SOAP 1.2'; { Do not localize }
  FInvokeOptions := [soIgnoreInvalidCerts];
end;

destructor TIdHTTPReqResp.Destroy;
begin
  inherited;
end;

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

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

{ IInterface }
function TIdHTTPReqResp._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount)
end;

function TIdHTTPReqResp._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;

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

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

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

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

procedure TIdHTTPReqResp.SetURL(const Value: string);
begin
  FUserSetURL := Value <> '';
  FURL := Value;
end;

procedure TIdHTTPReqResp.SetMimeBoundary(Value: string);
begin
  FMimeBoundary := Value;
end;

function TIdHTTPReqResp.GetMimeBoundary: string;
begin
  Result := FMimeBoundary;
end;

function TIdHTTPReqResp.GetSOAPActionHeader: string;
begin
  if (SoapAction = '') then
    Result := SHTTPSoapAction + ':'
  else if (SoapAction = '""') then
    Result := SHTTPSoapAction + ': ""'
  else
    Result := SHTTPSoapAction + ': ' + '"' + SoapAction + '"';
end;

{ Here the RIO can perform any transports specific setup before call - XML
serialization is done }
procedure TIdHTTPReqResp.BeforeExecute(const IntfMD: TIntfMetaData;
  const MethMD: TIntfMethEntry;
  MethodIndex: Integer;
  AttachHandler: IMimeAttachmentHandler);
var
  MethName: InvString;
  Binding: InvString;
  QBinding: IQualifiedName;
begin
  if FUserSetURL then
  begin
    MethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
    FSoapAction := InvRegistry.GetActionURIOfInfo(IntfMD.Info, MethName,
    MethodIndex);
  end
  else
  begin
  { User did *NOT* set a URL }
    if WSDLView <> nil then
    begin
    { Make sure WSDL is active }
      if fIdHttp.ProxyParams.ProxyServer <> '' then
      begin
        WSDLView.Proxy:= fIdHttp.ProxyParams.ProxyServer + ':'+IntToStr(fIdHttp.ProxyParams.ProxyPort);
        WSDLView.UserName:= fIdHttp.ProxyParams.ProxyUsername;
        WSDLView.Password:= fIdHttp.ProxyParams.ProxyPassword;
      end
      else
      begin
      { no proxy with Username/Password implies basic authentication }
        WSDLView.UserName:= fIdHttp.Request.Username;
        WSDLView.Password:= fIdHttp.Request.Password;
      end;
      WSDLView.Activate;
      QBinding := WSDLView.WSDL.GetBindingForServicePort(WSDLView.Service, WSDLView.Port);
      if QBinding <> nil then
      begin
        Binding := QBinding.Name;
        MethName:= InvRegistry.GetMethExternalName(WSDLView.IntfInfo, WSDLView.Operation);
      { TODO: Better to Pass in QBinding here to avoid tricky confusion due to
      lack of namespace }
        FSoapAction := WSDLView.WSDL.GetSoapAction(Binding, MethName, 0);
      end;
    {NOTE: In case we can't get the SOAPAction - see if we have something in the
    registry }
    { It can't hurt:) }
      if FSoapAction = '' then
        InvRegistry.GetActionURIOfInfo(IntfMD.Info, MethName, MethodIndex);
    { Retrieve URL }
      FURL := WSDLView.WSDL.GetSoapAddressForServicePort(WSDLView.Service, WSDLView.Port);
      if (FURL = '') then
        raise EIdSOAPHTTPException.CreateFmt(sCantGetURL, [WSDLView.Service, WSDLView.Port, WSDLView.WSDL.FileName]);
    end
    else
      raise EIdSOAPHTTPException.Create(sNoWSDLURL);
  end;
  { Are we sending attachments?? }
  if AttachHandler <> nil then
  begin
    FBindingType := btMIME;
  { If yes, ask MIME handler what MIME boundary it's using to build the Multipart
  packet }
    FMimeBoundary := AttachHandler.MIMEBoundary;
  { Also customize the MIME packet for transport specific items }
    if UseUTF8InHeader then
      AttachHandler.AddSoapHeader(Format(ContentTypeTemplate, [ContentTypeUTF8]))
    else
      AttachHandler.AddSoapHeader(Format(ContentTypeTemplate, [ContentTypeNoUTF8]));
    AttachHandler.AddSoapHeader(GetSOAPActionHeader);
  end
  else
    FBindingType := btSOAP;
end;

function DateTimemsToStr(aDT: TDateTime): string;
begin
  Result:= FormatDateTime(ShortDateFormat+' hh:nn:ss.zzz', aDT);
end;

const
  ProtocolVersionString: array[TIdHTTPProtocolVersion] of string = ('1.0', '1.1');

procedure TIdHTTPReqResp.Execute(const Request: TStream; Response: TStream);
var
  URI: TIdURI;
  ContentType: string;
begin
  fIdHttp.Request.CustomHeaders.Clear;
  if FBindingType = btMIME then
  begin
    fIdHttp.Request.ContentType:= Format(ContentHeaderMIME, [FMimeBoundary]);
    fIdHttp.Request.CustomHeaders.Add(MimeVersion);
  end
  else { Assume btSOAP }
  begin
    fIdHttp.Request.ContentType := sTextXML;
    fIdHttp.Request.CustomHeaders.Add(GetSOAPActionHeader);
  end;
  URI := TIdURI.Create(fURL);
  try
    if URI.Port <> '' then
    {$IFDEF INDY10}
      fIdHttp.URL.Port := URI.Port;
    {$ELSE}
      fIdHttp.URL.Port := URI.Port;
    {$ENDIF}
    if URI.Host <> '' then
      fIdHttp.{$IFDEF INDY10}URL.{$ENDIF}Host := URI.Host
    else
      fIdHttp.{$IFDEF INDY10}URL.{$ENDIF}Host := Copy(fURL, Length('http://')+1,
    Pos(':' + URI.Port, fURL) - (Length('http://')+1));
  finally
    URI.Free;
  end;
  {$IFNDEF INDY10}
    fIdHttp.InputBuffer.Clear;
  {$ENDIF}
  try // log here to log correct stamp
    LogString(False, True, Format('POST %s HTTP/%s [%s @ %s]', [fURL,
    ProtocolVersionString[fIdHttp.ProtocolVersion], Name, DateTimeMsToStr(Now)])+#13#10);
    //fIdHttp.Request.CustomHeaders.Values['X-Debug']:= Format('%s %s', [UrlS,
  //  DateTimeToXMLDateTime(Now));
   // fIdHttp.Request.SetHeaders; // postponed to log correct RawHeaders
   // LogString(False, True, fIdHttp.Request.RawHeaders.Text);
  //  Log(False, False, Request);
    Request.Position:= 0;
  except
  end;
  try
    try
      fIdHttp.Post(fURL, Request, Response);
    except
      on E: Exception do
      begin
        try
          LogString(True, True, E.Message+#13#10);
          ShowMessage(E.Message);
      //    e.
        
        except
        end;
        raise;
      end;
    end;
  finally
    if Response.Size > 0 then
    begin
      try
        LogString(True, True, fIdHttp.ResponseText+Format(' [%s @ %s]', [Name,
        DateTimeMsToStr(Now)])+#13#10);
        LogString(True, True, fIdHttp.Response.RawHeaders.Text);
        Log(True, False, Response);
        Response.Position:= 0;
      except
      end;
    end;
  end;
  ContentType := fIdHttp.Response.RawHeaders.Values[SContentType];
  FMimeBoundary := GetMimeBoundaryFromType(ContentType);
  if Response.Size = 0 then
    raise EIdSOAPHTTPException.Create(SInvalidHTTPResponse);
  if SameText(ContentType, ContentTypeTextPlain) or
  SameText(ContentType, STextHtml) then
    raise EIdSOAPHTTPException.CreateFmt(SInvalidContentType, [ContentType]);
end;

procedure TIdHTTPReqResp.Execute(const DataMsg: String; Response: TStream);
var
  Stream: TMemoryStream;
begin
  Stream := TMemoryStream.Create;
  try
    Stream.SetSize(Length(DataMsg));
    Stream.Write(DataMsg[1], Length(DataMsg));
    Execute(Stream, Response);
  finally
    Stream.Free;
  end;
end;

function TIdHTTPReqResp.Execute(const Request: TStream): TStream;
begin
  Result := TMemoryStream.Create;
  Execute(Request, Result);
end;

procedure TIdHTTPReqResp.Get(Response: TStream);
begin
  if URL = '' then
    raise EIdSOAPHTTPException.Create(SEmptyURL);
  fIdHttp.Request.Accept := '*/*';
  fIdHttp.Request.ContentType := sTextXml;
  fIdHttp.Request.CustomHeaders.Clear;
  try
    LogString(False, True, Format('GET %s HTTP/%s [%s @ %s]', [fURL,
    ProtocolVersionString[fIdHttp.ProtocolVersion], Name, DateTimeMsToStr(Now)])+#13#10);
    //fIdHttp.Request.CustomHeaders.Values['X-Debug']:= Format('%s %s', [UrlS,
    //DateTimeToXMLDateTime(Now)]);
    fIdHttp.Request.SetHeaders; // postponed to log correct RawHeaders
    LogString(False, True, fIdHttp.Request.RawHeaders.Text);
  except
  end;
  try
    fIdHttp.Get(URL, Response);
  finally
    if Response.Size > 0 then
    begin
      try
        LogString(True, True, fIdHttp.ResponseText+Format(' [%s @ %s]', [Name,
        DateTimeMsToStr(Now)])+#13#10);
        LogString(True, True, fIdHttp.Response.RawHeaders.Text);
        Log(True, False, Response);
        Response.Position:= 0;
      except
      end;
    end;
  end;
end;

procedure TIdHTTPReqResp.Log(aOutbound, aHeader: Boolean; St: TStream);
begin
  if Assigned(fOnLog) then
  begin
    St.Position:= 0;
    fOnLog(Self, aOutbound, aHeader, St);
  end;
end;

procedure TIdHTTPReqResp.LogString(aOutbound, aHeader: Boolean; S: string);
var
  St: TStringStream;
begin
  St:= TStringStream.Create(S);
  try
    Log(aOutbound, aHeader, St);
  finally
    St.Free;
  end;
end;

end.