lib/delphi/src/Thrift.Transport.WinHTTP.pas

(*
 * Licensed to the Apache Software Foundation (ASF) under one
 * or more contributor license agreements. See the NOTICE file
 * distributed with this work for additional information
 * regarding copyright ownership. The ASF licenses this file
 * to you under the Apache License, Version 2.0 (the
 * "License"); you may not use this file except in compliance
 * with the License. You may obtain a copy of the License at
 *
 *   http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing,
 * software distributed under the License is distributed on an
 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 * KIND, either express or implied. See the License for the
 * specific language governing permissions and limitations
 * under the License.
 *)
unit Thrift.Transport.WinHTTP;

{$I Thrift.Defines.inc}
{$SCOPEDENUMS ON}

interface

uses
  Classes,
  SysUtils,
  Math,
  Generics.Collections,
  Thrift.Collections,
  Thrift.Transport,
  Thrift.Exception,
  Thrift.Utils,
  Thrift.WinHTTP,
  Thrift.Stream;

type
  TWinHTTPClientImpl = class( TTransportImpl, IHTTPClient)
  strict private
    FUri : string;
    FInputStream : IThriftStream;
    FOutputMemoryStream : TMemoryStream;
    FDnsResolveTimeout : Integer;
    FConnectionTimeout : Integer;
    FSendTimeout : Integer;
    FReadTimeout : Integer;
    FCustomHeaders : IThriftDictionary<string,string>;
    FSecureProtocols : TSecureProtocols;

    function CreateRequest: IWinHTTPRequest;
    function SecureProtocolsAsWinHTTPFlags : Cardinal;

  strict private
    type
      TErrorInfo = ( SplitUrl, WinHTTPSession, WinHTTPConnection, WinHTTPRequest, RequestSetup, AutoProxy );

      THTTPResponseStream = class( TThriftStreamImpl)
      strict private
        FRequest : IWinHTTPRequest;
        FTransportControl : ITransportControl;
      strict protected
        procedure Write( const pBuf : Pointer; offset: Integer; count: Integer); override;
        function Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; override;
        procedure CheckReadBytesAvailable( const value : Integer);  override;
        procedure ConsumeReadBytes( const count : Integer);
        procedure Open; override;
        procedure Close; override;
        procedure Flush; override;
        function IsOpen: Boolean; override;
        function ToArray: TBytes; override;
      public
        constructor Create( const aRequest : IWinHTTPRequest; const aTransportCtl : ITransportControl);
        destructor Destroy; override;
      end;

  strict protected
    function GetIsOpen: Boolean; override;
    procedure Open(); override;
    procedure Close(); override;
    function  Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; override;
    procedure Write( const pBuf : Pointer; off, len : Integer); override;
    procedure Flush; override;
    procedure CheckReadBytesAvailable( const value : Integer); override;

    procedure SetDnsResolveTimeout(const Value: Integer);
    function GetDnsResolveTimeout: Integer;
    procedure SetConnectionTimeout(const Value: Integer);
    function GetConnectionTimeout: Integer;
    procedure SetSendTimeout(const Value: Integer);
    function GetSendTimeout: Integer;
    procedure SetReadTimeout(const Value: Integer);
    function GetReadTimeout: Integer;
    function GetSecureProtocols : TSecureProtocols;
    procedure SetSecureProtocols( const value : TSecureProtocols);

    function GetCustomHeaders: IThriftDictionary<string,string>;
    procedure SendRequest;

    property DnsResolveTimeout: Integer read GetDnsResolveTimeout write SetDnsResolveTimeout;
    property ConnectionTimeout: Integer read GetConnectionTimeout write SetConnectionTimeout;
    property SendTimeout: Integer read GetSendTimeout write SetSendTimeout;
    property ReadTimeout: Integer read GetReadTimeout write SetReadTimeout;
    property CustomHeaders: IThriftDictionary<string,string> read GetCustomHeaders;
  public
    constructor Create( const AUri: string; const aTransportCtl : ITransportControl = nil);
    destructor Destroy; override;
  end;

implementation


{ TWinHTTPClientImpl }

constructor TWinHTTPClientImpl.Create(const AUri: string; const aTransportCtl : ITransportControl);
begin
  inherited Create( aTransportCtl);
  FUri := AUri;

  // defaults according to MSDN
  FDnsResolveTimeout := 0; // no timeout
  FConnectionTimeout := 60 * 1000;
  FSendTimeout       := 30 * 1000;
  FReadTimeout       := 30 * 1000;

  FSecureProtocols := DEFAULT_THRIFT_SECUREPROTOCOLS;

  FCustomHeaders := TThriftDictionaryImpl<string,string>.Create;
  FOutputMemoryStream := TMemoryStream.Create;
end;

destructor TWinHTTPClientImpl.Destroy;
begin
  Close;
  FreeAndNil( FOutputMemoryStream);
  inherited;
end;

function TWinHTTPClientImpl.CreateRequest: IWinHTTPRequest;
var
  pair    : TPair<string,string>;
  session : IWinHTTPSession;
  connect : IWinHTTPConnection;
  url     : IWinHTTPUrl;
  sPath   : string;
  info    : TErrorInfo;
begin
  info := TErrorInfo.SplitUrl;
  try
    url := TWinHTTPUrlImpl.Create( FUri);

    info := TErrorInfo.WinHTTPSession;
    session := TWinHTTPSessionImpl.Create('Apache Thrift Delphi WinHTTP');
    session.EnableSecureProtocols( SecureProtocolsAsWinHTTPFlags);

    info := TErrorInfo.WinHTTPConnection;
    connect := session.Connect( url.HostName, url.Port);

    info := TErrorInfo.WinHTTPRequest;
    sPath   := url.UrlPath + url.ExtraInfo;
    result  := connect.OpenRequest( (url.Scheme = 'https'), 'POST', sPath, THRIFT_MIMETYPE);

    // setting a timeout value to 0 (zero) means "no timeout" for that setting
    info := TErrorInfo.RequestSetup;
    result.SetTimeouts( DnsResolveTimeout, ConnectionTimeout, SendTimeout, ReadTimeout);

    // headers
    result.AddRequestHeader( 'Content-Type: '+THRIFT_MIMETYPE, WINHTTP_ADDREQ_FLAG_ADD);
    for pair in FCustomHeaders do begin
      Result.AddRequestHeader( pair.Key +': '+ pair.Value, WINHTTP_ADDREQ_FLAG_ADD);
    end;

    // enable automatic gzip,deflate decompression
    result.EnableAutomaticContentDecompression(TRUE);

    // AutoProxy support
    info := TErrorInfo.AutoProxy;
    result.TryAutoProxy( FUri);
  except
    on e:TException do raise;
    on e:Exception do raise TTransportExceptionUnknown.Create( e.Message+' (at '+EnumUtils<TErrorInfo>.ToString(Ord(info))+')');
  end;
end;


function TWinHTTPClientImpl.SecureProtocolsAsWinHTTPFlags : Cardinal;
const
  PROTOCOL_MAPPING : array[TSecureProtocol] of Cardinal = (
    WINHTTP_FLAG_SECURE_PROTOCOL_SSL2,
    WINHTTP_FLAG_SECURE_PROTOCOL_SSL3,
    WINHTTP_FLAG_SECURE_PROTOCOL_TLS1,
    WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1,
    WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2
  );
var
  prot : TSecureProtocol;
  protos : TSecureProtocols;
begin
  result := 0;
  protos := GetSecureProtocols;
  for prot := Low(TSecureProtocol) to High(TSecureProtocol) do begin
    if prot in protos
    then result := result or PROTOCOL_MAPPING[prot];
  end;
end;


function TWinHTTPClientImpl.GetDnsResolveTimeout: Integer;
begin
  Result := FDnsResolveTimeout;
end;

procedure TWinHTTPClientImpl.SetDnsResolveTimeout(const Value: Integer);
begin
  FDnsResolveTimeout := Value;
end;

function TWinHTTPClientImpl.GetConnectionTimeout: Integer;
begin
  Result := FConnectionTimeout;
end;

procedure TWinHTTPClientImpl.SetConnectionTimeout(const Value: Integer);
begin
  FConnectionTimeout := Value;
end;

function TWinHTTPClientImpl.GetSendTimeout: Integer;
begin
  Result := FSendTimeout;
end;

procedure TWinHTTPClientImpl.SetSendTimeout(const Value: Integer);
begin
  FSendTimeout := Value;
end;

function TWinHTTPClientImpl.GetReadTimeout: Integer;
begin
  Result := FReadTimeout;
end;

procedure TWinHTTPClientImpl.SetReadTimeout(const Value: Integer);
begin
  FReadTimeout := Value;
end;

function TWinHTTPClientImpl.GetSecureProtocols : TSecureProtocols;
begin
  Result := FSecureProtocols;
end;

procedure TWinHTTPClientImpl.SetSecureProtocols( const value : TSecureProtocols);
begin
  FSecureProtocols := Value;
end;

function TWinHTTPClientImpl.GetCustomHeaders: IThriftDictionary<string,string>;
begin
  Result := FCustomHeaders;
end;

function TWinHTTPClientImpl.GetIsOpen: Boolean;
begin
  Result := True;
end;

procedure TWinHTTPClientImpl.Open;
begin
  FreeAndNil( FOutputMemoryStream);
  FOutputMemoryStream := TMemoryStream.Create;
end;

procedure TWinHTTPClientImpl.Close;
begin
  FInputStream := nil;
  FreeAndNil( FOutputMemoryStream);
end;

procedure TWinHTTPClientImpl.Flush;
begin
  try
    SendRequest;
  finally
    FreeAndNil( FOutputMemoryStream);
    FOutputMemoryStream := TMemoryStream.Create;
    ASSERT( FOutputMemoryStream <> nil);
  end;
end;

procedure TWinHTTPClientImpl.CheckReadBytesAvailable( const value : Integer);
begin
  if FInputStream <> nil
  then FInputStream.CheckReadBytesAvailable( value)
  else raise TTransportExceptionNotOpen.Create('No request has been sent');
end;

function TWinHTTPClientImpl.Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer;
begin
  if FInputStream = nil then begin
    raise TTransportExceptionNotOpen.Create('No request has been sent');
  end;

  try
    Result := FInputStream.Read( pBuf, buflen, off, len);
    ConsumeReadBytes( result);
  except
    on E: Exception
    do raise TTransportExceptionUnknown.Create(E.Message);
  end;
end;

procedure TWinHTTPClientImpl.SendRequest;
var
  http  : IWinHTTPRequest;
  ctrl  : ITransportControl;
  pData : PByte;
  len   : Integer;
  error : Cardinal;
  sMsg  : string;
begin
  http := CreateRequest;

  pData := FOutputMemoryStream.Memory;
  len   := FOutputMemoryStream.Size;

  // send all data immediately, since we have it in memory
  if not http.SendRequest( pData, len, 0) then begin
    error := Cardinal( GetLastError);
    sMsg  := 'WinHTTP send error '+IntToStr(Int64(error))+' '+WinHttpSysErrorMessage(error);
    raise TTransportExceptionUnknown.Create(sMsg);
  end;

  // end request and start receiving
  if not http.FlushAndReceiveResponse then begin
    error := Cardinal( GetLastError);
    sMsg  := 'WinHTTP recv error '+IntToStr(Int64(error))+' '+WinHttpSysErrorMessage(error);
    if error = ERROR_WINHTTP_TIMEOUT
    then raise TTransportExceptionTimedOut.Create( sMsg)
    else raise TTransportExceptionInterrupted.Create( sMsg);
  end;

  ctrl := TTransportControlImpl.Create( TransportControl.MaxAllowedMessageSize);
  FInputStream := THTTPResponseStream.Create( http, ctrl);
end;

procedure TWinHTTPClientImpl.Write( const pBuf : Pointer; off, len : Integer);
var pTmp : PByte;
begin
  pTmp := pBuf;
  Inc(pTmp,off);
  FOutputMemoryStream.Write( pTmp^, len);
end;


{ TWinHTTPClientImpl.THTTPResponseStream }

constructor TWinHTTPClientImpl.THTTPResponseStream.Create( const aRequest : IWinHTTPRequest; const aTransportCtl : ITransportControl);
begin
  inherited Create;
  FRequest := aRequest;
  FTransportControl := aTransportCtl;
  ASSERT( FTransportControl <> nil);
end;

destructor TWinHTTPClientImpl.THTTPResponseStream.Destroy;
begin
  try
    Close;
  finally
    inherited Destroy;
  end;
end;

procedure TWinHTTPClientImpl.THTTPResponseStream.Close;
begin
  FRequest := nil;
end;

procedure TWinHTTPClientImpl.THTTPResponseStream.Flush;
begin
  raise ENotImplemented(ClassName+'.Flush');
end;

function TWinHTTPClientImpl.THTTPResponseStream.IsOpen: Boolean;
begin
  Result := FRequest <> nil;
end;

procedure TWinHTTPClientImpl.THTTPResponseStream.Open;
begin
  // nothing to do
end;

procedure TWinHTTPClientImpl.THTTPResponseStream.Write(const pBuf : Pointer; offset, count: Integer);
begin
  inherited;  // check pointers
  raise ENotImplemented(ClassName+'.Write');
end;

function TWinHTTPClientImpl.THTTPResponseStream.Read(const pBuf : Pointer; const buflen : Integer; offset, count: Integer): Integer;
var pTmp : PByte;
begin
  inherited;  // check pointers

  if count >= buflen-offset
  then count := buflen-offset;

  CheckReadBytesAvailable(count);

  if count > 0 then begin
    pTmp   := pBuf;
    Inc( pTmp, offset);
    Result := FRequest.ReadData( pTmp, count);
    ASSERT( Result >= 0);
  end
  else Result := 0;

  ConsumeReadBytes( result);
end;

procedure TWinHTTPClientImpl.THTTPResponseStream.ConsumeReadBytes( const count : Integer);
begin
  if FTransportControl <> nil
  then FTransportControl.ConsumeReadBytes( count);
end;

procedure TWinHTTPClientImpl.THTTPResponseStream.CheckReadBytesAvailable( const value : Integer);
begin
  if Int64(value) > Int64(FRequest.QueryDataAvailable)
  then raise TTransportExceptionEndOfFile.Create('Not enough input data');
end;

function TWinHTTPClientImpl.THTTPResponseStream.ToArray: TBytes;
begin
  raise ENotImplemented(ClassName+'.ToArray');
end;


end.