soaphttptrans.pas

Delphi的Soap一些使用功能控件

var
  Request: HINTERNET;
  RetVal, Flags : DWord;
  AcceptTypes: array of PChar;
begin
  { Connect }
  Connect(True);

  SetLength(AcceptTypes, 2);
  AcceptTypes[0] := PChar('*/*');  { Do not localize }
  AcceptTypes[1] := nil;
  Flags := INTERNET_FLAG_DONT_CACHE;
  if FURLScheme = INTERNET_SCHEME_HTTPS then
  begin
    Flags := Flags or INTERNET_FLAG_SECURE;
    if (soIgnoreInvalidCerts in InvokeOptions) then
      Flags := Flags or (INTERNET_FLAG_IGNORE_CERT_CN_INVALID or
                         INTERNET_FLAG_IGNORE_CERT_DATE_INVALID or
                         SECURITY_FLAG_IGNORE_UNKNOWN_CA);
  end;

  Request := nil;
  try
    Request := HttpOpenRequest(FInetConnect, 'GET', PChar(FURLSite), nil, { Do not localize }
      nil, Pointer(AcceptTypes), Flags, Integer(Self));
    Check(not Assigned(Request), False);

    while True do
    begin
      if (not HttpSendRequest(Request, nil, 0, nil, 0)) then
      begin
        RetVal := HandleWinInetError(GetLastError(), Request);
        case RetVal of
          ERROR_CANCELLED: SysUtils.Abort;
          ERROR_SUCCESS: break;
          ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
        end;
      end
      else
        break;
    end;
  except
    if (Request <> nil) then
      InternetCloseHandle(Request);
    Connect(False);
    raise;
  end;
  Result := Integer(Request);
end;
{$ENDIF}

{$IFDEF USE_INDY}
procedure THTTPReqResp.SetupIndy(IndyHttp: TIDHttp; Request: TStream);

  procedure GetHostAndPort(const AURL: string; var AHost, APort: string);
  var
    Index: Integer;
  begin
    Index := Pos(':', AURL);
    if Index > 0 then
    begin
      AHost := Copy(AURL, 1, Index-1);
      APort := Copy(AURL, Index+1, MaxInt);
    end;
end;

  function IsHTTPS: Boolean;
  var
    Protocol, Host, path, Document, Port, Bookmark: string;
  begin
    ParseURI(FUrl, Protocol, Host, path, Document, Port, Bookmark);
    Result := AnsiSameText(Protocol, 'HTTPS');
  end;

var
  Protocol, Host, Path, Document, Port, Bookmark: string;
begin
{$IFDEF INDY_CUSTOM_IOHANDLER}
  if FIOHandler <> nil then
    IndyHttp.IOHandler := FIOHandler
  else
{$ENDIF}
  begin
    if IsHttps then
    begin
      IndyHttp.IOHandler := TIdSSLIOHandlerSocket.Create(nil);
    end;
  end;

{  if Request is TMimeAttachmentHandler then }
  if FBindingType = btMIME then
  begin
    IndyHttp.Request.ContentType := Format(ContentHeaderMIME, [FMimeBoundary]);
    IndyHttp.Request.CustomHeaders.Add(MimeVersion);
  end else { Assume btSOAP }
  begin
    IndyHttp.Request.ContentType := sTextXML;
    IndyHttp.Request.CustomHeaders.Add(GetSOAPActionHeader);
  end;

  IndyHttp.Request.Accept := '*/*';
  IndyHttp.Request.UserAgent := Self.FAgent;

  { Proxy support configuration }
  if FProxy <> '' then
  begin
    { first check for 'http://localhost:####' }
    ParseURI(FProxy, Protocol, Host, Path, Document, Port, Bookmark);
    { if fail then check for 'localhost:####' }
    if Host = '' then
      GetHostAndPort(FProxy, Host, Port);
    IndyHttp.ProxyParams.ProxyServer := Host;
    if Port <> '' then
      IndyHttp.ProxyParams.ProxyPort := StrToInt(Port);

    { If name/password is used in conjunction with proxy, it's passed
      along for proxy authentication }
    IndyHttp.ProxyParams.ProxyUsername := FUserName;
    IndyHttp.ProxyParams.ProxyPassword := FPassword;
  end else
  begin
    { no proxy with Username/Password implies basic authentication }
    IndyHttp.Request.Username := FUserName;
    IndyHttp.Request.Password := FPassword;
  end;
  IndyHttp.Host := FUrlHost;
  IndyHttp.Port := FUrlPort;
end;
{$ENDIF}

procedure THTTPReqResp.Get(Resp: TStream);
{$IFNDEF USE_INDY}
var
  Context: Integer;
{$ENDIF}
{$IFDEF USE_INDY}
  procedure LoadFromURL(URL: string; Stream: TStream);
  var
    IndyHTTP: TIDHttp;
    Protocol, Host, Path, Document, Port, Bookmark: string;
  begin
    IndyHTTP := TIDHttp.Create(Nil);
    try
      IndyHttp.Request.Accept := '*/*';
      IndyHttp.Request.UserAgent := Self.FAgent;
      IndyHttp.Request.ContentType := sTextXml;
      if FProxy <> '' then
      begin
        ParseURI(FProxy, Protocol, Host, Path, Document, Port, Bookmark);
        IndyHttp.ProxyParams.ProxyServer := Host;
        IndyHttp.ProxyParams.ProxyPort := StrToInt(Port);
        IndyHttp.ProxyParams.ProxyUsername := FUserName;
        IndyHttp.ProxyParams.ProxyPassword := FPassword;
      end else
      begin
        { no proxy with Username/Password implies basic authentication }
        IndyHttp.Request.Username := FUserName;
        IndyHttp.Request.Password := FPassword;
      end;
      { IndyHttp.Intercept := FIntercept; }
      IndyHttp.Get(URL, Stream);
    finally
      IndyHTTP.Free;
    end;
  end;
{$ENDIF}
begin
  { GETs require a URL }
  if URL = '' then
    raise ESOAPHTTPException.Create(SEmptyURL);
{$IFDEF USE_INDY}
  { GET with INDY }
  LoadFromURL(URL, Resp);
{$ELSE}
  Context := SendGet;
  try
    Receive(Context, Resp, True);
  finally
    if Context <> 0  then
      InternetCloseHandle(Pointer(Context));
    Connect(False);
  end;
{$ENDIF}
end;
{ Here the RIO can perform any transports specific setup before call - XML serialization is done }
procedure THTTPReqResp.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 }
      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 ESOAPHTTPException.CreateFmt(sCantGetURL, [WSDLView.Service, WSDLView.Port, WSDLView.WSDL.FileName]);
      InitURL(FURL);
    end
    else
      raise ESOAPHTTPException.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;

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

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

procedure THTTPReqResp.CheckContentType;
begin
  { NOTE: Content-Types are case insensitive! }
  {       Here we're not validating that we
          have a valid content-type; rather
          we're checking for some common invalid
          ones }
  if SameText(FContentType, ContentTypeTextPlain) or
     SameText(FContentType, STextHtml) then
    raise ESOAPHTTPException.CreateFmt(SInvalidContentType, [FContentType]);
end;

procedure THTTPReqResp.Execute(const Request: TStream; Response: TStream);

  function IsErrorStatusCode(Code: Integer): Boolean;
  begin
    case Code of
      404, 405, 410:
        Result := True;
      else
        Result := False;
    end;
  end;

{$IFDEF USE_INDY}
  procedure PostData(const Request: TStream; Response: TStream);
  var
    IndyHTTP: TIDHttp;
  begin
    IndyHTTP := TIDHttp.Create(Nil);
    try
      SetupIndy(IndyHTTP, Request);
      IndyHttp.Post(FURL, Request, Response);
      FContentType := IndyHttp.Response.RawHeaders.Values[SContentType];
      FMimeBoundary := GetMimeBoundaryFromType(FContentType);
      if Response.Size = 0 then
        raise ESOAPHTTPException.Create(SInvalidHTTPResponse);
      CheckContentType;
    finally
      if Assigned(IndyHttp.IOHandler) then
{$IFDEF INDY_CUSTOM_IOHANDLER}
        { Don't free the IOHandler if we did not create it }
        if FIOHandler = nil then
{$ENDIF}
        IndyHttp.IOHandler.Free;
      FreeAndNil(IndyHTTP);
    end;
  end;

var
{$ELSE}
var
  Context: Integer;
{$ENDIF}
  CanRetry: Boolean;
  LookUpUDDI: Boolean;
  AccessPoint: String;
  PrevError: String;
begin
  LookUpUDDI := False;
  CanRetry := (soAutoCheckAccessPointViaUDDI in FInvokeOptions) and
              (Length(FUDDIBindingKey) > 0) and
              (Length(FUDDIOperator) > 0);
{$IFDEF USE_INDY}
  PostData(Request, Response);
{$ELSE}
  while (True) do
  begin
    { Look up URL from UDDI?? }
    if LookUpUDDI and CanRetry then
    begin
      try
        CanRetry := False;
        AccessPoint := '';
        AccessPoint := GetBindingkeyAccessPoint(FUDDIOperator, FUDDIBindingKey);
      except
        { Ignore UDDI lookup error }
      end;
      { If UDDI lookup failed or we got back the same URL we used...
        raise the previous execption message }
      if (AccessPoint = '') or SameText(AccessPoint, FURL) then
        raise ESOAPHTTPException.Create(PrevError);
      SetURL(AccessPoint);
    end;

    Context := Send(Request);
    try
      try
        Receive(Context, Response);
        Exit;
      except
        on Ex: ESOAPHTTPException do
        begin
          Connect(False);
          if not CanRetry or not IsErrorStatusCode(Ex.StatusCode) then
            raise;
          { Trigger UDDI Lookup }
          LookUpUDDI := True;
          PrevError := Ex.Message;
        end;
        else
        begin
          Connect(False);
          raise;
        end;
      end;
    finally
      if Context <> 0  then
        InternetCloseHandle(Pointer(Context));
    end;
  end;
{$ENDIF}
end;

{$IFDEF DEXTER_UP}
function THTTPReqResp.GetAgentIsStored: Boolean;
begin
  Result := FAgent <> 'Borland SOAP 1.2';
end;
{$ENDIF}


end.