ceph/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.WinHTTP.pas

   1 (*
   2  * Licensed to the Apache Software Foundation (ASF) under one
   3  * or more contributor license agreements. See the NOTICE file
   4  * distributed with this work for additional information
   5  * regarding copyright ownership. The ASF licenses this file
   6  * to you under the Apache License, Version 2.0 (the
   7  * "License"); you may not use this file except in compliance
   8  * with the License. You may obtain a copy of the License at
   9  *
  10  *   http://www.apache.org/licenses/LICENSE-2.0
  11  *
  12  * Unless required by applicable law or agreed to in writing,
  13  * software distributed under the License is distributed on an
  14  * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
  15  * KIND, either express or implied. See the License for the
  16  * specific language governing permissions and limitations
  17  * under the License.
  18  *)
  19 unit Thrift.Transport.WinHTTP;
  20
  21 {$I Thrift.Defines.inc}
  22 {$SCOPEDENUMS ON}
  23
  24 interface
  25
  26 uses
  27   Classes,
  28   SysUtils,
  29   Math,
  30   Generics.Collections,
  31   Thrift.Collections,
  32   Thrift.Transport,
  33   Thrift.Exception,
  34   Thrift.Utils,
  35   Thrift.WinHTTP,
  36   Thrift.Stream;
  37
  38 type
  39   TWinHTTPClientImpl = class( TTransportImpl, IHTTPClient)
  40   private
  41     FUri : string;
  42     FInputStream : IThriftStream;
  43     FOutputMemoryStream : TMemoryStream;
  44     FDnsResolveTimeout : Integer;
  45     FConnectionTimeout : Integer;
  46     FSendTimeout : Integer;
  47     FReadTimeout : Integer;
  48     FCustomHeaders : IThriftDictionary<string,string>;
  49     FSecureProtocols : TSecureProtocols;
  50
  51     function CreateRequest: IWinHTTPRequest;
  52     function SecureProtocolsAsWinHTTPFlags : Cardinal;
  53
  54   private
  55     type
  56       TErrorInfo = ( SplitUrl, WinHTTPSession, WinHTTPConnection, WinHTTPRequest, RequestSetup, AutoProxy );
  57
  58       THTTPResponseStream = class( TThriftStreamImpl)
  59       private
  60         FRequest : IWinHTTPRequest;
  61       protected
  62         procedure Write( const pBuf : Pointer; offset: Integer; count: Integer); override;
  63         function Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; override;
  64         procedure Open; override;
  65         procedure Close; override;
  66         procedure Flush; override;
  67         function IsOpen: Boolean; override;
  68         function ToArray: TBytes; override;
  69       public
  70         constructor Create( const aRequest : IWinHTTPRequest);
  71         destructor Destroy; override;
  72       end;
  73
  74   protected
  75     function GetIsOpen: Boolean; override;
  76     procedure Open(); override;
  77     procedure Close(); override;
  78     function  Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; override;
  79     procedure Write( const pBuf : Pointer; off, len : Integer); override;
  80     procedure Flush; override;
  81
  82     procedure SetDnsResolveTimeout(const Value: Integer);
  83     function GetDnsResolveTimeout: Integer;
  84     procedure SetConnectionTimeout(const Value: Integer);
  85     function GetConnectionTimeout: Integer;
  86     procedure SetSendTimeout(const Value: Integer);
  87     function GetSendTimeout: Integer;
  88     procedure SetReadTimeout(const Value: Integer);
  89     function GetReadTimeout: Integer;
  90     function GetSecureProtocols : TSecureProtocols;
  91     procedure SetSecureProtocols( const value : TSecureProtocols);
  92
  93     function GetCustomHeaders: IThriftDictionary<string,string>;
  94     procedure SendRequest;
  95
  96     property DnsResolveTimeout: Integer read GetDnsResolveTimeout write SetDnsResolveTimeout;
  97     property ConnectionTimeout: Integer read GetConnectionTimeout write SetConnectionTimeout;
  98     property SendTimeout: Integer read GetSendTimeout write SetSendTimeout;
  99     property ReadTimeout: Integer read GetReadTimeout write SetReadTimeout;
 100     property CustomHeaders: IThriftDictionary<string,string> read GetCustomHeaders;
 101   public
 102     constructor Create( const AUri: string);
 103     destructor Destroy; override;
 104   end;
 105
 106 implementation
 107
 108
 109 { TWinHTTPClientImpl }
 110
 111 constructor TWinHTTPClientImpl.Create(const AUri: string);
 112 begin
 113   inherited Create;
 114   FUri := AUri;
 115
 116   // defaults according to MSDN
 117   FDnsResolveTimeout := 0; // no timeout
 118   FConnectionTimeout := 60 * 1000;
 119   FSendTimeout       := 30 * 1000;
 120   FReadTimeout       := 30 * 1000;
 121
 122   FSecureProtocols := DEFAULT_THRIFT_SECUREPROTOCOLS;
 123
 124   FCustomHeaders := TThriftDictionaryImpl<string,string>.Create;
 125   FOutputMemoryStream := TMemoryStream.Create;
 126 end;
 127
 128 destructor TWinHTTPClientImpl.Destroy;
 129 begin
 130   Close;
 131   FreeAndNil( FOutputMemoryStream);
 132   inherited;
 133 end;
 134
 135 function TWinHTTPClientImpl.CreateRequest: IWinHTTPRequest;
 136 var
 137   pair    : TPair<string,string>;
 138   session : IWinHTTPSession;
 139   connect : IWinHTTPConnection;
 140   url     : IWinHTTPUrl;
 141   sPath   : string;
 142   info    : TErrorInfo;
 143 begin
 144   info := TErrorInfo.SplitUrl;
 145   try
 146     url := TWinHTTPUrlImpl.Create( FUri);
 147
 148     info := TErrorInfo.WinHTTPSession;
 149     session := TWinHTTPSessionImpl.Create('Apache Thrift Delphi WinHTTP');
 150     session.EnableSecureProtocols( SecureProtocolsAsWinHTTPFlags);
 151
 152     info := TErrorInfo.WinHTTPConnection;
 153     connect := session.Connect( url.HostName, url.Port);
 154
 155     info := TErrorInfo.WinHTTPRequest;
 156     sPath   := url.UrlPath + url.ExtraInfo;
 157     result  := connect.OpenRequest( (url.Scheme = 'https'), 'POST', sPath, THRIFT_MIMETYPE);
 158
 159     // setting a timeout value to 0 (zero) means "no timeout" for that setting
 160     info := TErrorInfo.RequestSetup;
 161     result.SetTimeouts( DnsResolveTimeout, ConnectionTimeout, SendTimeout, ReadTimeout);
 162
 163     // headers
 164     result.AddRequestHeader( 'Content-Type: '+THRIFT_MIMETYPE, WINHTTP_ADDREQ_FLAG_ADD);
 165     for pair in FCustomHeaders do begin
 166       Result.AddRequestHeader( pair.Key +': '+ pair.Value, WINHTTP_ADDREQ_FLAG_ADD);
 167     end;
 168
 169     // enable automatic gzip,deflate decompression
 170     result.EnableAutomaticContentDecompression(TRUE);
 171
 172     // AutoProxy support
 173     info := TErrorInfo.AutoProxy;
 174     result.TryAutoProxy( FUri);
 175   except
 176     on e:TException do raise;
 177     on e:Exception do raise TTransportExceptionUnknown.Create( e.Message+' (at '+EnumUtils<TErrorInfo>.ToString(Ord(info))+')');
 178   end;
 179 end;
 180
 181
 182 function TWinHTTPClientImpl.SecureProtocolsAsWinHTTPFlags : Cardinal;
 183 const
 184   PROTOCOL_MAPPING : array[TSecureProtocol] of Cardinal = (
 185     WINHTTP_FLAG_SECURE_PROTOCOL_SSL2,
 186     WINHTTP_FLAG_SECURE_PROTOCOL_SSL3,
 187     WINHTTP_FLAG_SECURE_PROTOCOL_TLS1,
 188     WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1,
 189     WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2
 190   );
 191 var
 192   prot : TSecureProtocol;
 193   protos : TSecureProtocols;
 194 begin
 195   result := 0;
 196   protos := GetSecureProtocols;
 197   for prot := Low(TSecureProtocol) to High(TSecureProtocol) do begin
 198     if prot in protos
 199     then result := result or PROTOCOL_MAPPING[prot];
 200   end;
 201 end;
 202
 203
 204 function TWinHTTPClientImpl.GetDnsResolveTimeout: Integer;
 205 begin
 206   Result := FDnsResolveTimeout;
 207 end;
 208
 209 procedure TWinHTTPClientImpl.SetDnsResolveTimeout(const Value: Integer);
 210 begin
 211   FDnsResolveTimeout := Value;
 212 end;
 213
 214 function TWinHTTPClientImpl.GetConnectionTimeout: Integer;
 215 begin
 216   Result := FConnectionTimeout;
 217 end;
 218
 219 procedure TWinHTTPClientImpl.SetConnectionTimeout(const Value: Integer);
 220 begin
 221   FConnectionTimeout := Value;
 222 end;
 223
 224 function TWinHTTPClientImpl.GetSendTimeout: Integer;
 225 begin
 226   Result := FSendTimeout;
 227 end;
 228
 229 procedure TWinHTTPClientImpl.SetSendTimeout(const Value: Integer);
 230 begin
 231   FSendTimeout := Value;
 232 end;
 233
 234 function TWinHTTPClientImpl.GetReadTimeout: Integer;
 235 begin
 236   Result := FReadTimeout;
 237 end;
 238
 239 procedure TWinHTTPClientImpl.SetReadTimeout(const Value: Integer);
 240 begin
 241   FReadTimeout := Value;
 242 end;
 243
 244 function TWinHTTPClientImpl.GetSecureProtocols : TSecureProtocols;
 245 begin
 246   Result := FSecureProtocols;
 247 end;
 248
 249 procedure TWinHTTPClientImpl.SetSecureProtocols( const value : TSecureProtocols);
 250 begin
 251   FSecureProtocols := Value;
 252 end;
 253
 254 function TWinHTTPClientImpl.GetCustomHeaders: IThriftDictionary<string,string>;
 255 begin
 256   Result := FCustomHeaders;
 257 end;
 258
 259 function TWinHTTPClientImpl.GetIsOpen: Boolean;
 260 begin
 261   Result := True;
 262 end;
 263
 264 procedure TWinHTTPClientImpl.Open;
 265 begin
 266   FreeAndNil( FOutputMemoryStream);
 267   FOutputMemoryStream := TMemoryStream.Create;
 268 end;
 269
 270 procedure TWinHTTPClientImpl.Close;
 271 begin
 272   FInputStream := nil;
 273   FreeAndNil( FOutputMemoryStream);
 274 end;
 275
 276 procedure TWinHTTPClientImpl.Flush;
 277 begin
 278   try
 279     SendRequest;
 280   finally
 281     FreeAndNil( FOutputMemoryStream);
 282     FOutputMemoryStream := TMemoryStream.Create;
 283     ASSERT( FOutputMemoryStream <> nil);
 284   end;
 285 end;
 286
 287 function TWinHTTPClientImpl.Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer;
 288 begin
 289   if FInputStream = nil then begin
 290     raise TTransportExceptionNotOpen.Create('No request has been sent');
 291   end;
 292
 293   try
 294     Result := FInputStream.Read( pBuf, buflen, off, len)
 295   except
 296     on E: Exception
 297     do raise TTransportExceptionUnknown.Create(E.Message);
 298   end;
 299 end;
 300
 301 procedure TWinHTTPClientImpl.SendRequest;
 302 var
 303   http  : IWinHTTPRequest;
 304   pData : PByte;
 305   len   : Integer;
 306   error : Cardinal;
 307   sMsg  : string;
 308 begin
 309   http := CreateRequest;
 310
 311   pData := FOutputMemoryStream.Memory;
 312   len   := FOutputMemoryStream.Size;
 313
 314   // send all data immediately, since we have it in memory
 315   if not http.SendRequest( pData, len, 0) then begin
 316     error := Cardinal( GetLastError);
 317     sMsg  := 'WinHTTP send error '+IntToStr(Int64(error))+' '+WinHttpSysErrorMessage(error);
 318     raise TTransportExceptionUnknown.Create(sMsg);
 319   end;
 320
 321   // end request and start receiving
 322   if not http.FlushAndReceiveResponse then begin
 323     error := Cardinal( GetLastError);
 324     sMsg  := 'WinHTTP recv error '+IntToStr(Int64(error))+' '+WinHttpSysErrorMessage(error);
 325     if error = ERROR_WINHTTP_TIMEOUT
 326     then raise TTransportExceptionTimedOut.Create( sMsg)
 327     else raise TTransportExceptionInterrupted.Create( sMsg);
 328   end;
 329
 330   FInputStream := THTTPResponseStream.Create(http);
 331 end;
 332
 333 procedure TWinHTTPClientImpl.Write( const pBuf : Pointer; off, len : Integer);
 334 var pTmp : PByte;
 335 begin
 336   pTmp := pBuf;
 337   Inc(pTmp,off);
 338   FOutputMemoryStream.Write( pTmp^, len);
 339 end;
 340
 341
 342 { TWinHTTPClientImpl.THTTPResponseStream }
 343
 344 constructor TWinHTTPClientImpl.THTTPResponseStream.Create( const aRequest : IWinHTTPRequest);
 345 begin
 346   inherited Create;
 347   FRequest := aRequest;
 348 end;
 349
 350 destructor TWinHTTPClientImpl.THTTPResponseStream.Destroy;
 351 begin
 352   try
 353     Close;
 354   finally
 355     inherited Destroy;
 356   end;
 357 end;
 358
 359 procedure TWinHTTPClientImpl.THTTPResponseStream.Close;
 360 begin
 361   FRequest := nil;
 362 end;
 363
 364 procedure TWinHTTPClientImpl.THTTPResponseStream.Flush;
 365 begin
 366   raise ENotImplemented(ClassName+'.Flush');
 367 end;
 368
 369 function TWinHTTPClientImpl.THTTPResponseStream.IsOpen: Boolean;
 370 begin
 371   Result := FRequest <> nil;
 372 end;
 373
 374 procedure TWinHTTPClientImpl.THTTPResponseStream.Open;
 375 begin
 376   // nothing to do
 377 end;
 378
 379 procedure TWinHTTPClientImpl.THTTPResponseStream.Write(const pBuf : Pointer; offset, count: Integer);
 380 begin
 381   inherited;  // check pointers
 382   raise ENotImplemented(ClassName+'.Write');
 383 end;
 384
 385 function TWinHTTPClientImpl.THTTPResponseStream.Read(const pBuf : Pointer; const buflen : Integer; offset, count: Integer): Integer;
 386 var pTmp : PByte;
 387 begin
 388   inherited;  // check pointers
 389
 390   if count >= buflen-offset
 391   then count := buflen-offset;
 392
 393   if count > 0 then begin
 394     pTmp   := pBuf;
 395     Inc( pTmp, offset);
 396     Result := FRequest.ReadData( pTmp, count);
 397     ASSERT( Result >= 0);
 398   end
 399   else Result := 0;
 400 end;
 401
 402 function TWinHTTPClientImpl.THTTPResponseStream.ToArray: TBytes;
 403 begin
 404   raise ENotImplemented(ClassName+'.ToArray');
 405 end;
 406
 407
 408 end.