diff options
Diffstat (limited to 'src/jaegertracing/thrift/lib/delphi')
52 files changed, 18291 insertions, 0 deletions
diff --git a/src/jaegertracing/thrift/lib/delphi/DelphiThrift.groupproj b/src/jaegertracing/thrift/lib/delphi/DelphiThrift.groupproj new file mode 100644 index 000000000..a172e496c --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/DelphiThrift.groupproj @@ -0,0 +1,156 @@ + <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{6BD327A5-7688-4263-B6A8-B15207CF4EC5}</ProjectGuid> + </PropertyGroup> + <ItemGroup> + <Projects Include="test\client.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\server.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\multiplexed\Multiplex.Test.Client.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\multiplexed\Multiplex.Test.Server.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\serializer\TestSerializer.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\skip\skiptest_version1.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\skip\skiptest_version2.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\typeregistry\TestTypeRegistry.dproj"> + <Dependencies/> + </Projects> + <Projects Include="..\..\tutorial\delphi\DelphiServer\DelphiServer.dproj"> + <Dependencies/> + </Projects> + <Projects Include="..\..\tutorial\delphi\DelphiClient\DelphiClient.dproj"> + <Dependencies/> + </Projects> + <Projects Include="test\keywords\ReservedKeywords.dproj"> + <Dependencies/> + </Projects> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Default.Personality.12</Borland.Personality> + <Borland.ProjectType/> + <BorlandProject> + <Default.Personality/> + </BorlandProject> + </ProjectExtensions> + <Target Name="client"> + <MSBuild Projects="test\client.dproj"/> + </Target> + <Target Name="client:Clean"> + <MSBuild Projects="test\client.dproj" Targets="Clean"/> + </Target> + <Target Name="client:Make"> + <MSBuild Projects="test\client.dproj" Targets="Make"/> + </Target> + <Target Name="server"> + <MSBuild Projects="test\server.dproj"/> + </Target> + <Target Name="server:Clean"> + <MSBuild Projects="test\server.dproj" Targets="Clean"/> + </Target> + <Target Name="server:Make"> + <MSBuild Projects="test\server.dproj" Targets="Make"/> + </Target> + <Target Name="Multiplex_Test_Client"> + <MSBuild Projects="test\multiplexed\Multiplex.Test.Client.dproj"/> + </Target> + <Target Name="Multiplex_Test_Client:Clean"> + <MSBuild Projects="test\multiplexed\Multiplex.Test.Client.dproj" Targets="Clean"/> + </Target> + <Target Name="Multiplex_Test_Client:Make"> + <MSBuild Projects="test\multiplexed\Multiplex.Test.Client.dproj" Targets="Make"/> + </Target> + <Target Name="Multiplex_Test_Server"> + <MSBuild Projects="test\multiplexed\Multiplex.Test.Server.dproj"/> + </Target> + <Target Name="Multiplex_Test_Server:Clean"> + <MSBuild Projects="test\multiplexed\Multiplex.Test.Server.dproj" Targets="Clean"/> + </Target> + <Target Name="Multiplex_Test_Server:Make"> + <MSBuild Projects="test\multiplexed\Multiplex.Test.Server.dproj" Targets="Make"/> + </Target> + <Target Name="TestSerializer"> + <MSBuild Projects="test\serializer\TestSerializer.dproj"/> + </Target> + <Target Name="TestSerializer:Clean"> + <MSBuild Projects="test\serializer\TestSerializer.dproj" Targets="Clean"/> + </Target> + <Target Name="TestSerializer:Make"> + <MSBuild Projects="test\serializer\TestSerializer.dproj" Targets="Make"/> + </Target> + <Target Name="skiptest_version1"> + <MSBuild Projects="test\skip\skiptest_version1.dproj"/> + </Target> + <Target Name="skiptest_version1:Clean"> + <MSBuild Projects="test\skip\skiptest_version1.dproj" Targets="Clean"/> + </Target> + <Target Name="skiptest_version1:Make"> + <MSBuild Projects="test\skip\skiptest_version1.dproj" Targets="Make"/> + </Target> + <Target Name="skiptest_version2"> + <MSBuild Projects="test\skip\skiptest_version2.dproj"/> + </Target> + <Target Name="skiptest_version2:Clean"> + <MSBuild Projects="test\skip\skiptest_version2.dproj" Targets="Clean"/> + </Target> + <Target Name="skiptest_version2:Make"> + <MSBuild Projects="test\skip\skiptest_version2.dproj" Targets="Make"/> + </Target> + <Target Name="TestTypeRegistry"> + <MSBuild Projects="test\typeregistry\TestTypeRegistry.dproj"/> + </Target> + <Target Name="TestTypeRegistry:Clean"> + <MSBuild Projects="test\typeregistry\TestTypeRegistry.dproj" Targets="Clean"/> + </Target> + <Target Name="TestTypeRegistry:Make"> + <MSBuild Projects="test\typeregistry\TestTypeRegistry.dproj" Targets="Make"/> + </Target> + <Target Name="DelphiServer"> + <MSBuild Projects="..\..\tutorial\delphi\DelphiServer\DelphiServer.dproj"/> + </Target> + <Target Name="DelphiServer:Clean"> + <MSBuild Projects="..\..\tutorial\delphi\DelphiServer\DelphiServer.dproj" Targets="Clean"/> + </Target> + <Target Name="DelphiServer:Make"> + <MSBuild Projects="..\..\tutorial\delphi\DelphiServer\DelphiServer.dproj" Targets="Make"/> + </Target> + <Target Name="DelphiClient"> + <MSBuild Projects="..\..\tutorial\delphi\DelphiClient\DelphiClient.dproj"/> + </Target> + <Target Name="DelphiClient:Clean"> + <MSBuild Projects="..\..\tutorial\delphi\DelphiClient\DelphiClient.dproj" Targets="Clean"/> + </Target> + <Target Name="DelphiClient:Make"> + <MSBuild Projects="..\..\tutorial\delphi\DelphiClient\DelphiClient.dproj" Targets="Make"/> + </Target> + <Target Name="ReservedKeywords"> + <MSBuild Projects="test\keywords\ReservedKeywords.dproj"/> + </Target> + <Target Name="ReservedKeywords:Clean"> + <MSBuild Projects="test\keywords\ReservedKeywords.dproj" Targets="Clean"/> + </Target> + <Target Name="ReservedKeywords:Make"> + <MSBuild Projects="test\keywords\ReservedKeywords.dproj" Targets="Make"/> + </Target> + <Target Name="Build"> + <CallTarget Targets="client;server;Multiplex_Test_Client;Multiplex_Test_Server;TestSerializer;skiptest_version1;skiptest_version2;TestTypeRegistry;DelphiServer;DelphiClient;ReservedKeywords"/> + </Target> + <Target Name="Clean"> + <CallTarget Targets="client:Clean;server:Clean;Multiplex_Test_Client:Clean;Multiplex_Test_Server:Clean;TestSerializer:Clean;skiptest_version1:Clean;skiptest_version2:Clean;TestTypeRegistry:Clean;DelphiServer:Clean;DelphiClient:Clean;ReservedKeywords:Clean"/> + </Target> + <Target Name="Make"> + <CallTarget Targets="client:Make;server:Make;Multiplex_Test_Client:Make;Multiplex_Test_Server:Make;TestSerializer:Make;skiptest_version1:Make;skiptest_version2:Make;TestTypeRegistry:Make;DelphiServer:Make;DelphiClient:Make;ReservedKeywords:Make"/> + </Target> + <Import Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')" Project="$(BDS)\Bin\CodeGear.Group.Targets"/> + </Project> diff --git a/src/jaegertracing/thrift/lib/delphi/README.md b/src/jaegertracing/thrift/lib/delphi/README.md new file mode 100644 index 000000000..91799d04d --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/README.md @@ -0,0 +1,30 @@ +Thrift Delphi Software Library + +License +======= + +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. + +Using Thrift with Delphi +==================== + +The Thrift Delphi Library requires at least Delphi 2010. + +Because the Library heavily relies on generics, using it +with earlier versions (such as Delphi 7) will *not* work. + diff --git a/src/jaegertracing/thrift/lib/delphi/coding_standards.md b/src/jaegertracing/thrift/lib/delphi/coding_standards.md new file mode 100644 index 000000000..fa0390bb5 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/coding_standards.md @@ -0,0 +1 @@ +Please follow [General Coding Standards](/doc/coding_standards.md) diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Collections.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Collections.pas new file mode 100644 index 000000000..3b56fe205 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Collections.pas @@ -0,0 +1,692 @@ +(* + * 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.Collections; + +interface + +uses + SysUtils, Generics.Collections, Generics.Defaults, Thrift.Utils; + +type + +{$IF CompilerVersion < 21.0} + TArray<T> = array of T; +{$IFEND} + + IThriftContainer = interface( ISupportsToString) + ['{E05C0F9D-A4F5-491D-AADA-C926B4BDB6E4}'] + end; + + + IThriftDictionary<TKey,TValue> = interface(IThriftContainer) + ['{25EDD506-F9D1-4008-A40F-5940364B7E46}'] + function GetEnumerator: TEnumerator<TPair<TKey,TValue>>; + + function GetKeys: TDictionary<TKey,TValue>.TKeyCollection; + function GetValues: TDictionary<TKey,TValue>.TValueCollection; + function GetItem(const Key: TKey): TValue; + procedure SetItem(const Key: TKey; const Value: TValue); + function GetCount: Integer; + + procedure Add(const Key: TKey; const Value: TValue); + procedure Remove(const Key: TKey); +{$IF CompilerVersion >= 21.0} + function ExtractPair(const Key: TKey): TPair<TKey,TValue>; +{$IFEND} + procedure Clear; + procedure TrimExcess; + function TryGetValue(const Key: TKey; out Value: TValue): Boolean; + procedure AddOrSetValue(const Key: TKey; const Value: TValue); + function ContainsKey(const Key: TKey): Boolean; + function ContainsValue(const Value: TValue): Boolean; + function ToArray: TArray<TPair<TKey,TValue>>; + + property Items[const Key: TKey]: TValue read GetItem write SetItem; default; + property Count: Integer read GetCount; + property Keys: TDictionary<TKey,TValue>.TKeyCollection read GetKeys; + property Values: TDictionary<TKey,TValue>.TValueCollection read GetValues; + end; + + TThriftDictionaryImpl<TKey,TValue> = class( TInterfacedObject, IThriftDictionary<TKey,TValue>, IThriftContainer, ISupportsToString) + private + FDictionaly : TDictionary<TKey,TValue>; + protected + function GetEnumerator: TEnumerator<TPair<TKey,TValue>>; + + function GetKeys: TDictionary<TKey,TValue>.TKeyCollection; + function GetValues: TDictionary<TKey,TValue>.TValueCollection; + function GetItem(const Key: TKey): TValue; + procedure SetItem(const Key: TKey; const Value: TValue); + function GetCount: Integer; + + procedure Add(const Key: TKey; const Value: TValue); + procedure Remove(const Key: TKey); +{$IF CompilerVersion >= 21.0} + function ExtractPair(const Key: TKey): TPair<TKey,TValue>; +{$IFEND} + procedure Clear; + procedure TrimExcess; + function TryGetValue(const Key: TKey; out Value: TValue): Boolean; + procedure AddOrSetValue(const Key: TKey; const Value: TValue); + function ContainsKey(const Key: TKey): Boolean; + function ContainsValue(const Value: TValue): Boolean; + function ToArray: TArray<TPair<TKey,TValue>>; + property Items[const Key: TKey]: TValue read GetItem write SetItem; default; + property Count: Integer read GetCount; + property Keys: TDictionary<TKey,TValue>.TKeyCollection read GetKeys; + property Values: TDictionary<TKey,TValue>.TValueCollection read GetValues; + public + constructor Create(ACapacity: Integer = 0); + destructor Destroy; override; + function ToString : string; override; + end; + + IThriftList<T> = interface(IThriftContainer) + ['{29BEEE31-9CB4-401B-AA04-5148A75F473B}'] + function GetEnumerator: TEnumerator<T>; + function GetCapacity: Integer; + procedure SetCapacity(Value: Integer); + function GetCount: Integer; + procedure SetCount(Value: Integer); + function GetItem(Index: Integer): T; + procedure SetItem(Index: Integer; const Value: T); + function Add(const Value: T): Integer; + procedure AddRange(const Values: array of T); overload; + procedure AddRange(const Collection: IEnumerable<T>); overload; + procedure AddRange(Collection: TEnumerable<T>); overload; + procedure Insert(Index: Integer; const Value: T); + procedure InsertRange(Index: Integer; const Values: array of T); overload; + procedure InsertRange(Index: Integer; const Collection: IEnumerable<T>); overload; + procedure InsertRange(Index: Integer; const Collection: TEnumerable<T>); overload; + function Remove(const Value: T): Integer; + procedure Delete(Index: Integer); + procedure DeleteRange(AIndex, ACount: Integer); + function Extract(const Value: T): T; +{$IF CompilerVersion >= 21.0} + procedure Exchange(Index1, Index2: Integer); + procedure Move(CurIndex, NewIndex: Integer); + function First: T; + function Last: T; +{$IFEND} + procedure Clear; + function Contains(const Value: T): Boolean; + function IndexOf(const Value: T): Integer; + function LastIndexOf(const Value: T): Integer; + procedure Reverse; + procedure Sort; overload; + procedure Sort(const AComparer: IComparer<T>); overload; + function BinarySearch(const Item: T; out Index: Integer): Boolean; overload; + function BinarySearch(const Item: T; out Index: Integer; const AComparer: IComparer<T>): Boolean; overload; + procedure TrimExcess; + function ToArray: TArray<T>; + property Capacity: Integer read GetCapacity write SetCapacity; + property Count: Integer read GetCount write SetCount; + property Items[Index: Integer]: T read GetItem write SetItem; default; + end; + + TThriftListImpl<T> = class( TInterfacedObject, IThriftList<T>, IThriftContainer, ISupportsToString) + private + FList : TList<T>; + protected + function GetEnumerator: TEnumerator<T>; + function GetCapacity: Integer; + procedure SetCapacity(Value: Integer); + function GetCount: Integer; + procedure SetCount(Value: Integer); + function GetItem(Index: Integer): T; + procedure SetItem(Index: Integer; const Value: T); + function Add(const Value: T): Integer; + procedure AddRange(const Values: array of T); overload; + procedure AddRange(const Collection: IEnumerable<T>); overload; + procedure AddRange(Collection: TEnumerable<T>); overload; + procedure Insert(Index: Integer; const Value: T); + procedure InsertRange(Index: Integer; const Values: array of T); overload; + procedure InsertRange(Index: Integer; const Collection: IEnumerable<T>); overload; + procedure InsertRange(Index: Integer; const Collection: TEnumerable<T>); overload; + function Remove(const Value: T): Integer; + procedure Delete(Index: Integer); + procedure DeleteRange(AIndex, ACount: Integer); + function Extract(const Value: T): T; +{$IF CompilerVersion >= 21.0} + procedure Exchange(Index1, Index2: Integer); + procedure Move(CurIndex, NewIndex: Integer); + function First: T; + function Last: T; +{$IFEND} + procedure Clear; + function Contains(const Value: T): Boolean; + function IndexOf(const Value: T): Integer; + function LastIndexOf(const Value: T): Integer; + procedure Reverse; + procedure Sort; overload; + procedure Sort(const AComparer: IComparer<T>); overload; + function BinarySearch(const Item: T; out Index: Integer): Boolean; overload; + function BinarySearch(const Item: T; out Index: Integer; const AComparer: IComparer<T>): Boolean; overload; + procedure TrimExcess; + function ToArray: TArray<T>; + property Capacity: Integer read GetCapacity write SetCapacity; + property Count: Integer read GetCount write SetCount; + property Items[Index: Integer]: T read GetItem write SetItem; default; + public + constructor Create; + destructor Destroy; override; + function ToString : string; override; + end; + + IHashSet<TValue> = interface(IThriftContainer) + ['{0923A3B5-D4D4-48A8-91AD-40238E2EAD66}'] + function GetEnumerator: TEnumerator<TValue>; + function GetIsReadOnly: Boolean; + function GetCount: Integer; + property Count: Integer read GetCount; + property IsReadOnly: Boolean read GetIsReadOnly; + procedure Add( const item: TValue); + procedure Clear; + function Contains( const item: TValue): Boolean; + procedure CopyTo(var A: TArray<TValue>; arrayIndex: Integer); + function Remove( const item: TValue ): Boolean; + end; + + THashSetImpl<TValue> = class( TInterfacedObject, IHashSet<TValue>, IThriftContainer, ISupportsToString) + private + FDictionary : IThriftDictionary<TValue,Integer>; + FIsReadOnly: Boolean; + protected + function GetEnumerator: TEnumerator<TValue>; + function GetIsReadOnly: Boolean; + function GetCount: Integer; + property Count: Integer read GetCount; + property IsReadOnly: Boolean read FIsReadOnly; + procedure Add( const item: TValue); + procedure Clear; + function Contains( const item: TValue): Boolean; + procedure CopyTo(var A: TArray<TValue>; arrayIndex: Integer); + function Remove( const item: TValue ): Boolean; + public + constructor Create; + function ToString : string; override; + end; + +implementation + +{ THashSetImpl<TValue> } + +procedure THashSetImpl<TValue>.Add( const item: TValue); +begin + if not FDictionary.ContainsKey(item) then + begin + FDictionary.Add( item, 0); + end; +end; + +procedure THashSetImpl<TValue>.Clear; +begin + FDictionary.Clear; +end; + +function THashSetImpl<TValue>.Contains( const item: TValue): Boolean; +begin + Result := FDictionary.ContainsKey(item); +end; + +procedure THashSetImpl<TValue>.CopyTo(var A: TArray<TValue>; arrayIndex: Integer); +var + i : Integer; + Enumlator : TEnumerator<TValue>; +begin + Enumlator := GetEnumerator; + while Enumlator.MoveNext do + begin + A[arrayIndex] := Enumlator.Current; + Inc(arrayIndex); + end; +end; + +constructor THashSetImpl<TValue>.Create; +begin + inherited; + FDictionary := TThriftDictionaryImpl<TValue,Integer>.Create; +end; + +function THashSetImpl<TValue>.GetCount: Integer; +begin + Result := FDictionary.Count; +end; + +function THashSetImpl<TValue>.GetEnumerator: TEnumerator<TValue>; +begin + Result := FDictionary.Keys.GetEnumerator; +end; + +function THashSetImpl<TValue>.GetIsReadOnly: Boolean; +begin + Result := FIsReadOnly; +end; + +function THashSetImpl<TValue>.Remove( const item: TValue): Boolean; +begin + Result := False; + if FDictionary.ContainsKey( item ) then + begin + FDictionary.Remove( item ); + Result := not FDictionary.ContainsKey( item ); + end; +end; + +function THashSetImpl<TValue>.ToString : string; +var elm : TValue; + sb : TThriftStringBuilder; + first : Boolean; +begin + sb := TThriftStringBuilder.Create('{'); + try + first := TRUE; + for elm in FDictionary.Keys do begin + if first + then first := FALSE + else sb.Append(', '); + + sb.Append( StringUtils<TValue>.ToString(elm)); + end; + sb.Append('}'); + Result := sb.ToString; + finally + sb.Free; + end; +end; + +{ TThriftDictionaryImpl<TKey, TValue> } + +procedure TThriftDictionaryImpl<TKey, TValue>.Add(const Key: TKey; + const Value: TValue); +begin + FDictionaly.Add( Key, Value); +end; + +procedure TThriftDictionaryImpl<TKey, TValue>.AddOrSetValue(const Key: TKey; + const Value: TValue); +begin + FDictionaly.AddOrSetValue( Key, Value); +end; + +procedure TThriftDictionaryImpl<TKey, TValue>.Clear; +begin + FDictionaly.Clear; +end; + +function TThriftDictionaryImpl<TKey, TValue>.ContainsKey( + const Key: TKey): Boolean; +begin + Result := FDictionaly.ContainsKey( Key ); +end; + +function TThriftDictionaryImpl<TKey, TValue>.ContainsValue( + const Value: TValue): Boolean; +begin + Result := FDictionaly.ContainsValue( Value ); +end; + +constructor TThriftDictionaryImpl<TKey, TValue>.Create(ACapacity: Integer); +begin + inherited Create; + FDictionaly := TDictionary<TKey,TValue>.Create( ACapacity ); +end; + +destructor TThriftDictionaryImpl<TKey, TValue>.Destroy; +begin + FDictionaly.Free; + inherited; +end; + +{$IF CompilerVersion >= 21.0} +function TThriftDictionaryImpl<TKey, TValue>.ExtractPair( const Key: TKey): TPair<TKey, TValue>; +begin + Result := FDictionaly.ExtractPair( Key); +end; +{$IFEND} + +function TThriftDictionaryImpl<TKey, TValue>.GetCount: Integer; +begin + Result := FDictionaly.Count; +end; + +function TThriftDictionaryImpl<TKey, TValue>.GetEnumerator: TEnumerator<TPair<TKey, TValue>>; +begin + Result := FDictionaly.GetEnumerator; +end; + +function TThriftDictionaryImpl<TKey, TValue>.GetItem(const Key: TKey): TValue; +begin + Result := FDictionaly.Items[Key]; +end; + +function TThriftDictionaryImpl<TKey, TValue>.GetKeys: TDictionary<TKey, TValue>.TKeyCollection; +begin + Result := FDictionaly.Keys; +end; + +function TThriftDictionaryImpl<TKey, TValue>.GetValues: TDictionary<TKey, TValue>.TValueCollection; +begin + Result := FDictionaly.Values; +end; + +procedure TThriftDictionaryImpl<TKey, TValue>.Remove(const Key: TKey); +begin + FDictionaly.Remove( Key ); +end; + +procedure TThriftDictionaryImpl<TKey, TValue>.SetItem(const Key: TKey; + const Value: TValue); +begin + FDictionaly.AddOrSetValue( Key, Value); +end; + +function TThriftDictionaryImpl<TKey, TValue>.ToArray: TArray<TPair<TKey, TValue>>; +{$IF CompilerVersion < 22.0} +var + x : TPair<TKey, TValue>; + i : Integer; +{$IFEND} +begin +{$IF CompilerVersion < 22.0} + SetLength(Result, Count); + i := 0; + for x in FDictionaly do + begin + Result[i] := x; + Inc( i ); + end; +{$ELSE} + Result := FDictionaly.ToArray; +{$IFEND} +end; + +function TThriftDictionaryImpl<TKey, TValue>.ToString : string; +var pair : TPair<TKey, TValue>; + sb : TThriftStringBuilder; + first : Boolean; +begin + sb := TThriftStringBuilder.Create('{'); + try + first := TRUE; + for pair in FDictionaly do begin + if first + then first := FALSE + else sb.Append(', '); + + sb.Append( '('); + sb.Append( StringUtils<TKey>.ToString(pair.Key)); + sb.Append(' => '); + sb.Append( StringUtils<TValue>.ToString(pair.Value)); + sb.Append(')'); + end; + sb.Append('}'); + Result := sb.ToString; + finally + sb.Free; + end; +end; + +procedure TThriftDictionaryImpl<TKey, TValue>.TrimExcess; +begin + FDictionaly.TrimExcess; +end; + +function TThriftDictionaryImpl<TKey, TValue>.TryGetValue(const Key: TKey; + out Value: TValue): Boolean; +begin + Result := FDictionaly.TryGetValue( Key, Value); +end; + +{ TThriftListImpl<T> } + +function TThriftListImpl<T>.Add(const Value: T): Integer; +begin + Result := FList.Add( Value ); +end; + +procedure TThriftListImpl<T>.AddRange(Collection: TEnumerable<T>); +begin + FList.AddRange( Collection ); +end; + +procedure TThriftListImpl<T>.AddRange(const Collection: IEnumerable<T>); +begin + FList.AddRange( Collection ); +end; + +procedure TThriftListImpl<T>.AddRange(const Values: array of T); +begin + FList.AddRange( Values ); +end; + +function TThriftListImpl<T>.BinarySearch(const Item: T; + out Index: Integer): Boolean; +begin + Result := FList.BinarySearch( Item, Index); +end; + +function TThriftListImpl<T>.BinarySearch(const Item: T; out Index: Integer; + const AComparer: IComparer<T>): Boolean; +begin + Result := FList.BinarySearch( Item, Index, AComparer); +end; + +procedure TThriftListImpl<T>.Clear; +begin + FList.Clear; +end; + +function TThriftListImpl<T>.Contains(const Value: T): Boolean; +begin + Result := FList.Contains( Value ); +end; + +constructor TThriftListImpl<T>.Create; +begin + inherited; + FList := TList<T>.Create; +end; + +procedure TThriftListImpl<T>.Delete(Index: Integer); +begin + FList.Delete( Index ) +end; + +procedure TThriftListImpl<T>.DeleteRange(AIndex, ACount: Integer); +begin + FList.DeleteRange( AIndex, ACount) +end; + +destructor TThriftListImpl<T>.Destroy; +begin + FList.Free; + inherited; +end; + +{$IF CompilerVersion >= 21.0} +procedure TThriftListImpl<T>.Exchange(Index1, Index2: Integer); +begin + FList.Exchange( Index1, Index2 ) +end; +{$IFEND} + +function TThriftListImpl<T>.Extract(const Value: T): T; +begin + Result := FList.Extract( Value ) +end; + +{$IF CompilerVersion >= 21.0} +function TThriftListImpl<T>.First: T; +begin + Result := FList.First; +end; +{$IFEND} + +function TThriftListImpl<T>.GetCapacity: Integer; +begin + Result := FList.Capacity; +end; + +function TThriftListImpl<T>.GetCount: Integer; +begin + Result := FList.Count; +end; + +function TThriftListImpl<T>.GetEnumerator: TEnumerator<T>; +begin + Result := FList.GetEnumerator; +end; + +function TThriftListImpl<T>.GetItem(Index: Integer): T; +begin + Result := FList[Index]; +end; + +function TThriftListImpl<T>.IndexOf(const Value: T): Integer; +begin + Result := FList.IndexOf( Value ); +end; + +procedure TThriftListImpl<T>.Insert(Index: Integer; const Value: T); +begin + FList.Insert( Index, Value); +end; + +procedure TThriftListImpl<T>.InsertRange(Index: Integer; + const Collection: TEnumerable<T>); +begin + FList.InsertRange( Index, Collection ); +end; + +procedure TThriftListImpl<T>.InsertRange(Index: Integer; + const Values: array of T); +begin + FList.InsertRange( Index, Values); +end; + +procedure TThriftListImpl<T>.InsertRange(Index: Integer; + const Collection: IEnumerable<T>); +begin + FList.InsertRange( Index, Collection ); +end; + +{$IF CompilerVersion >= 21.0} +function TThriftListImpl<T>.Last: T; +begin + Result := FList.Last; +end; +{$IFEND} + +function TThriftListImpl<T>.LastIndexOf(const Value: T): Integer; +begin + Result := FList.LastIndexOf( Value ); +end; + +{$IF CompilerVersion >= 21.0} +procedure TThriftListImpl<T>.Move(CurIndex, NewIndex: Integer); +begin + FList.Move( CurIndex, NewIndex); +end; +{$IFEND} + +function TThriftListImpl<T>.Remove(const Value: T): Integer; +begin + Result := FList.Remove( Value ); +end; + +procedure TThriftListImpl<T>.Reverse; +begin + FList.Reverse; +end; + +procedure TThriftListImpl<T>.SetCapacity(Value: Integer); +begin + FList.Capacity := Value; +end; + +procedure TThriftListImpl<T>.SetCount(Value: Integer); +begin + FList.Count := Value; +end; + +procedure TThriftListImpl<T>.SetItem(Index: Integer; const Value: T); +begin + FList[Index] := Value; +end; + +procedure TThriftListImpl<T>.Sort; +begin + FList.Sort; +end; + +procedure TThriftListImpl<T>.Sort(const AComparer: IComparer<T>); +begin + FList.Sort(AComparer); +end; + +function TThriftListImpl<T>.ToArray: TArray<T>; +{$IF CompilerVersion < 22.0} +var + x : T; + i : Integer; +{$IFEND} +begin +{$IF CompilerVersion < 22.0} + SetLength(Result, Count); + i := 0; + for x in FList do + begin + Result[i] := x; + Inc( i ); + end; +{$ELSE} + Result := FList.ToArray; +{$IFEND} +end; + +function TThriftListImpl<T>.ToString : string; +var elm : T; + sb : TThriftStringBuilder; + first : Boolean; +begin + sb := TThriftStringBuilder.Create('{'); + try + first := TRUE; + for elm in FList do begin + if first + then first := FALSE + else sb.Append(', '); + + sb.Append( StringUtils<T>.ToString(elm)); + end; + sb.Append('}'); + Result := sb.ToString; + finally + sb.Free; + end; +end; + +procedure TThriftListImpl<T>.TrimExcess; +begin + FList.TrimExcess; +end; + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Defines.inc b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Defines.inc new file mode 100644 index 000000000..499ccae12 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Defines.inc @@ -0,0 +1,50 @@ +(* + * 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. + *) + + +// Good lists of Delphi version numbers +// https://github.com/project-jedi/jedi/blob/master/jedi.inc +// http://docwiki.embarcadero.com/RADStudio/Seattle/en/Compiler_Versions + + +// start with most backwards compatible defaults + +{$DEFINE OLD_UNIT_NAMES} +{$DEFINE OLD_SOCKETS} // TODO: add socket support for CompilerVersion >= 28.0 +{$UNDEF HAVE_CLASS_CTOR} + + +// enable features as they are available + +{$IF CompilerVersion >= 21.0} // Delphi 2010 + {$DEFINE HAVE_CLASS_CTOR} +{$IFEND} + +{$IF CompilerVersion >= 23.0} // Delphi XE2 + {$UNDEF OLD_UNIT_NAMES} +{$IFEND} + +{$IF CompilerVersion >= 28.0} // Delphi XE7 + {$UNDEF OLD_SOCKETS} +{$IFEND} + + +// EOF + + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Exception.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Exception.pas new file mode 100644 index 000000000..5d15c3656 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Exception.pas @@ -0,0 +1,62 @@ +(* + * 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. + *) + +{$SCOPEDENUMS ON} + +unit Thrift.Exception; + +interface + +uses + Classes, SysUtils; + +type + // base class for all Thrift exceptions + TException = class( SysUtils.Exception) + public + function Message : string; // hide inherited property: allow read, but prevent accidental writes + procedure UpdateMessageProperty; // update inherited message property with toString() + end; + + + + +implementation + +{ TException } + +function TException.Message; +// allow read (exception summary), but prevent accidental writes +// read will return the exception summary +begin + result := Self.ToString; +end; + +procedure TException.UpdateMessageProperty; +// Update the inherited Message property to better conform to standard behaviour. +// Nice benefit: The IDE is now able to show the exception message again. +begin + inherited Message := Self.ToString; // produces a summary text +end; + + + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Processor.Multiplex.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Processor.Multiplex.pas new file mode 100644 index 000000000..8cf23db07 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Processor.Multiplex.pas @@ -0,0 +1,231 @@ +(* + * 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.Processor.Multiplex; + + +interface + +uses + SysUtils, + Generics.Collections, + Thrift, + Thrift.Protocol, + Thrift.Protocol.Multiplex; + +{ TMultiplexedProcessor is a TProcessor allowing a single TServer to provide multiple services. + To do so, you instantiate the processor and then register additional processors with it, + as shown in the following example: + + + TMultiplexedProcessor processor = new TMultiplexedProcessor(); + + processor.registerProcessor( + "Calculator", + new Calculator.Processor(new CalculatorHandler())); + + processor.registerProcessor( + "WeatherReport", + new WeatherReport.Processor(new WeatherReportHandler())); + + TServerTransport t = new TServerSocket(9090); + TSimpleServer server = new TSimpleServer(processor, t); + + server.serve(); +} + + +type + IMultiplexedProcessor = interface( IProcessor) + ['{807F9D19-6CF4-4789-840E-93E87A12EB63}'] + // Register a service with this TMultiplexedProcessor. This allows us + // to broker requests to individual services by using the service name + // to select them at request time. + procedure RegisterProcessor( const serviceName : String; const processor : IProcessor; const asDefault : Boolean = FALSE); + end; + + + TMultiplexedProcessorImpl = class( TInterfacedObject, IMultiplexedProcessor, IProcessor) + private type + // Our goal was to work with any protocol. In order to do that, we needed + // to allow them to call readMessageBegin() and get a TMessage in exactly + // the standard format, without the service name prepended to TMessage.name. + TStoredMessageProtocol = class( TProtocolDecorator) + private + FMessageBegin : TThriftMessage; + public + constructor Create( const protocol : IProtocol; const aMsgBegin : TThriftMessage); + function ReadMessageBegin: TThriftMessage; override; + end; + + private + FServiceProcessorMap : TDictionary<String, IProcessor>; + FDefaultProcessor : IProcessor; + + procedure Error( const oprot : IProtocol; const msg : TThriftMessage; + extype : TApplicationExceptionSpecializedClass; const etxt : string); + + public + constructor Create; + destructor Destroy; override; + + // Register a service with this TMultiplexedProcessorImpl. This allows us + // to broker requests to individual services by using the service name + // to select them at request time. + procedure RegisterProcessor( const serviceName : String; const processor : IProcessor; const asDefault : Boolean = FALSE); + + { This implementation of process performs the following steps: + - Read the beginning of the message. + - Extract the service name from the message. + - Using the service name to locate the appropriate processor. + - Dispatch to the processor, with a decorated instance of TProtocol + that allows readMessageBegin() to return the original TMessage. + + An exception is thrown if the message type is not CALL or ONEWAY + or if the service is unknown (or not properly registered). + } + function Process( const iprot, oprot: IProtocol; const events : IProcessorEvents = nil): Boolean; + end; + + +implementation + +constructor TMultiplexedProcessorImpl.TStoredMessageProtocol.Create( const protocol : IProtocol; const aMsgBegin : TThriftMessage); +begin + inherited Create( protocol); + FMessageBegin := aMsgBegin; +end; + + +function TMultiplexedProcessorImpl.TStoredMessageProtocol.ReadMessageBegin: TThriftMessage; +begin + result := FMessageBegin; +end; + + +constructor TMultiplexedProcessorImpl.Create; +begin + inherited Create; + FServiceProcessorMap := TDictionary<string,IProcessor>.Create; +end; + + +destructor TMultiplexedProcessorImpl.Destroy; +begin + try + FreeAndNil( FServiceProcessorMap); + finally + inherited Destroy; + end; +end; + + +procedure TMultiplexedProcessorImpl.RegisterProcessor( const serviceName : String; const processor : IProcessor; const asDefault : Boolean); +begin + FServiceProcessorMap.Add( serviceName, processor); + + if asDefault then begin + if FDefaultProcessor = nil + then FDefaultProcessor := processor + else raise TApplicationExceptionInternalError.Create('Only one default service allowed'); + end; +end; + + +procedure TMultiplexedProcessorImpl.Error( const oprot : IProtocol; const msg : TThriftMessage; + extype : TApplicationExceptionSpecializedClass; + const etxt : string); +var appex : TApplicationException; + newMsg : TThriftMessage; +begin + appex := extype.Create(etxt); + try + Init( newMsg, msg.Name, TMessageType.Exception, msg.SeqID); + + oprot.WriteMessageBegin(newMsg); + appex.Write(oprot); + oprot.WriteMessageEnd(); + oprot.Transport.Flush(); + + finally + appex.Free; + end; +end; + + +function TMultiplexedProcessorImpl.Process(const iprot, oprot : IProtocol; const events : IProcessorEvents = nil): Boolean; +var msg, newMsg : TThriftMessage; + idx : Integer; + sService : string; + processor : IProcessor; + protocol : IProtocol; +const + ERROR_INVALID_MSGTYPE = 'Message must be "call" or "oneway"'; + ERROR_INCOMPATIBLE_PROT = 'No service name found in "%s". Client is expected to use TMultiplexProtocol.'; + ERROR_UNKNOWN_SERVICE = 'Service "%s" is not registered with MultiplexedProcessor'; +begin + // Use the actual underlying protocol (e.g. TBinaryProtocol) to read the message header. + // This pulls the message "off the wire", which we'll deal with at the end of this method. + msg := iprot.readMessageBegin(); + if not (msg.Type_ in [TMessageType.Call, TMessageType.Oneway]) then begin + Error( oprot, msg, + TApplicationExceptionInvalidMessageType, + ERROR_INVALID_MSGTYPE); + Exit( FALSE); + end; + + // Extract the service name + // use FDefaultProcessor as fallback if there is no separator + idx := Pos( TMultiplexedProtocol.SEPARATOR, msg.Name); + if idx > 0 then begin + + // Create a new TMessage, something that can be consumed by any TProtocol + sService := Copy( msg.Name, 1, idx-1); + if not FServiceProcessorMap.TryGetValue( sService, processor) + then begin + Error( oprot, msg, + TApplicationExceptionInternalError, + Format(ERROR_UNKNOWN_SERVICE,[sService])); + Exit( FALSE); + end; + + // Create a new TMessage, removing the service name + Inc( idx, Length(TMultiplexedProtocol.SEPARATOR)); + Init( newMsg, Copy( msg.Name, idx, MAXINT), msg.Type_, msg.SeqID); + + end + else if FDefaultProcessor <> nil then begin + processor := FDefaultProcessor; + newMsg := msg; // no need to change + + end + else begin + Error( oprot, msg, + TApplicationExceptionInvalidProtocol, + Format(ERROR_INCOMPATIBLE_PROT,[msg.Name])); + Exit( FALSE); + end; + + // Dispatch processing to the stored processor + protocol := TStoredMessageProtocol.Create( iprot, newMsg); + result := processor.process( protocol, oprot, events); +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.Compact.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.Compact.pas new file mode 100644 index 000000000..07cab9a05 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.Compact.pas @@ -0,0 +1,1118 @@ +(* + * 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. + *) + +{$SCOPEDENUMS ON} + +unit Thrift.Protocol.Compact; + +interface + +uses + Classes, + SysUtils, + Math, + Generics.Collections, + Thrift.Transport, + Thrift.Protocol, + Thrift.Utils; + +type + ICompactProtocol = interface( IProtocol) + ['{C01927EC-021A-45F7-93B1-23D6A5420EDD}'] + end; + + // Compact protocol implementation for thrift. + // Adapted from the C# version. + TCompactProtocolImpl = class( TProtocolImpl, ICompactProtocol) + public + type + TFactory = class( TInterfacedObject, IProtocolFactory) + public + function GetProtocol( const trans: ITransport): IProtocol; + end; + + private const + + { TODO + static TStruct ANONYMOUS_STRUCT = new TStruct(""); + static TField TSTOP = new TField("", TType.Stop, (short)0); + } + + PROTOCOL_ID = Byte( $82); + VERSION = Byte( 1); + VERSION_MASK = Byte( $1F); // 0001 1111 + TYPE_MASK = Byte( $E0); // 1110 0000 + TYPE_BITS = Byte( $07); // 0000 0111 + TYPE_SHIFT_AMOUNT = Byte( 5); + + private type + // All of the on-wire type codes. + Types = ( + STOP = $00, + BOOLEAN_TRUE = $01, + BOOLEAN_FALSE = $02, + BYTE_ = $03, + I16 = $04, + I32 = $05, + I64 = $06, + DOUBLE_ = $07, + BINARY = $08, + LIST = $09, + SET_ = $0A, + MAP = $0B, + STRUCT = $0C + ); + + private const + ttypeToCompactType : array[TType] of Types = ( + Types.STOP, // Stop = 0, + Types(-1), // Void = 1, + Types.BOOLEAN_TRUE, // Bool_ = 2, + Types.BYTE_, // Byte_ = 3, + Types.DOUBLE_, // Double_ = 4, + Types(-5), // unused + Types.I16, // I16 = 6, + Types(-7), // unused + Types.I32, // I32 = 8, + Types(-9), // unused + Types.I64, // I64 = 10, + Types.BINARY, // String_ = 11, + Types.STRUCT, // Struct = 12, + Types.MAP, // Map = 13, + Types.SET_, // Set_ = 14, + Types.LIST // List = 15, + ); + + tcompactTypeToType : array[Types] of TType = ( + TType.Stop, // STOP + TType.Bool_, // BOOLEAN_TRUE + TType.Bool_, // BOOLEAN_FALSE + TType.Byte_, // BYTE_ + TType.I16, // I16 + TType.I32, // I32 + TType.I64, // I64 + TType.Double_, // DOUBLE_ + TType.String_, // BINARY + TType.List, // LIST + TType.Set_, // SET_ + TType.Map, // MAP + TType.Struct // STRUCT + ); + + private + // Used to keep track of the last field for the current and previous structs, + // so we can do the delta stuff. + lastField_ : TStack<Integer>; + lastFieldId_ : Integer; + + // If we encounter a boolean field begin, save the TField here so it can + // have the value incorporated. + private booleanField_ : TThriftField; + + // If we Read a field header, and it's a boolean field, save the boolean + // value here so that ReadBool can use it. + private boolValue_ : ( unused, bool_true, bool_false); + + public + constructor Create(const trans : ITransport); + destructor Destroy; override; + + procedure Reset; + + private + procedure WriteByteDirect( const b : Byte); overload; + + // Writes a byte without any possibility of all that field header nonsense. + procedure WriteByteDirect( const n : Integer); overload; + + // Write an i32 as a varint. Results in 1-5 bytes on the wire. + // TODO: make a permanent buffer like WriteVarint64? + procedure WriteVarint32( n : Cardinal); + + private + // The workhorse of WriteFieldBegin. It has the option of doing a 'type override' + // of the type header. This is used specifically in the boolean field case. + procedure WriteFieldBeginInternal( const field : TThriftField; typeOverride : Byte); + + public + procedure WriteMessageBegin( const msg: TThriftMessage); override; + procedure WriteMessageEnd; override; + procedure WriteStructBegin( const struc: TThriftStruct); override; + procedure WriteStructEnd; override; + procedure WriteFieldBegin( const field: TThriftField); override; + procedure WriteFieldEnd; override; + procedure WriteFieldStop; override; + procedure WriteMapBegin( const map: TThriftMap); override; + procedure WriteMapEnd; override; + procedure WriteListBegin( const list: TThriftList); override; + procedure WriteListEnd(); override; + procedure WriteSetBegin( const set_: TThriftSet ); override; + procedure WriteSetEnd(); override; + procedure WriteBool( b: Boolean); override; + procedure WriteByte( b: ShortInt); override; + procedure WriteI16( i16: SmallInt); override; + procedure WriteI32( i32: Integer); override; + procedure WriteI64( const i64: Int64); override; + procedure WriteDouble( const dub: Double); override; + procedure WriteBinary( const b: TBytes); overload; override; + + private + class function DoubleToInt64Bits( const db : Double) : Int64; + class function Int64BitsToDouble( const i64 : Int64) : Double; + + // Abstract method for writing the start of lists and sets. List and sets on + // the wire differ only by the type indicator. + procedure WriteCollectionBegin( const elemType : TType; size : Integer); + + procedure WriteVarint64( n : UInt64); + + // Convert l into a zigzag long. This allows negative numbers to be + // represented compactly as a varint. + class function longToZigzag( const n : Int64) : UInt64; + + // Convert n into a zigzag int. This allows negative numbers to be + // represented compactly as a varint. + class function intToZigZag( const n : Integer) : Cardinal; + + //Convert a Int64 into little-endian bytes in buf starting at off and going until off+7. + class procedure fixedLongToBytes( const n : Int64; var buf : TBytes); + + public + function ReadMessageBegin: TThriftMessage; override; + procedure ReadMessageEnd(); override; + function ReadStructBegin: TThriftStruct; override; + procedure ReadStructEnd; override; + function ReadFieldBegin: TThriftField; override; + procedure ReadFieldEnd(); override; + function ReadMapBegin: TThriftMap; override; + procedure ReadMapEnd(); override; + function ReadListBegin: TThriftList; override; + procedure ReadListEnd(); override; + function ReadSetBegin: TThriftSet; override; + procedure ReadSetEnd(); override; + function ReadBool: Boolean; override; + function ReadByte: ShortInt; override; + function ReadI16: SmallInt; override; + function ReadI32: Integer; override; + function ReadI64: Int64; override; + function ReadDouble:Double; override; + function ReadBinary: TBytes; overload; override; + + private + // Internal Reading methods + + // Read an i32 from the wire as a varint. The MSB of each byte is set + // if there is another byte to follow. This can Read up to 5 bytes. + function ReadVarint32 : Cardinal; + + // Read an i64 from the wire as a proper varint. The MSB of each byte is set + // if there is another byte to follow. This can Read up to 10 bytes. + function ReadVarint64 : UInt64; + + + // encoding helpers + + // Convert from zigzag Integer to Integer. + class function zigzagToInt( const n : Cardinal ) : Integer; + + // Convert from zigzag Int64 to Int64. + class function zigzagToLong( const n : UInt64) : Int64; + + // Note that it's important that the mask bytes are Int64 literals, + // otherwise they'll default to ints, and when you shift an Integer left 56 bits, + // you just get a messed up Integer. + class function bytesToLong( const bytes : TBytes) : Int64; + + // type testing and converting + class function isBoolType( const b : byte) : Boolean; + + // Given a TCompactProtocol.Types constant, convert it to its corresponding TType value. + class function getTType( const type_ : byte) : TType; + + // Given a TType value, find the appropriate TCompactProtocol.Types constant. + class function getCompactType( const ttype : TType) : Byte; + end; + + +implementation + + + +//--- TCompactProtocolImpl.TFactory ---------------------------------------- + + +function TCompactProtocolImpl.TFactory.GetProtocol( const trans: ITransport): IProtocol; +begin + result := TCompactProtocolImpl.Create( trans); +end; + + +//--- TCompactProtocolImpl ------------------------------------------------- + + +constructor TCompactProtocolImpl.Create(const trans: ITransport); +begin + inherited Create( trans); + + lastFieldId_ := 0; + lastField_ := TStack<Integer>.Create; + + Init( booleanField_, '', TType.Stop, 0); + boolValue_ := unused; +end; + + +destructor TCompactProtocolImpl.Destroy; +begin + try + FreeAndNil( lastField_); + finally + inherited Destroy; + end; +end; + + + +procedure TCompactProtocolImpl.Reset; +begin + lastField_.Clear(); + lastFieldId_ := 0; + Init( booleanField_, '', TType.Stop, 0); + boolValue_ := unused; +end; + + +// Writes a byte without any possibility of all that field header nonsense. +// Used internally by other writing methods that know they need to Write a byte. +procedure TCompactProtocolImpl.WriteByteDirect( const b : Byte); +begin + Transport.Write( @b, SizeOf(b)); +end; + + +// Writes a byte without any possibility of all that field header nonsense. +procedure TCompactProtocolImpl.WriteByteDirect( const n : Integer); +begin + WriteByteDirect( Byte(n)); +end; + + +// Write an i32 as a varint. Results in 1-5 bytes on the wire. +procedure TCompactProtocolImpl.WriteVarint32( n : Cardinal); +var i32buf : TBytes; + idx : Integer; +begin + SetLength( i32buf, 5); + idx := 0; + while TRUE do begin + ASSERT( idx < Length(i32buf)); + + // last part? + if ((n and not $7F) = 0) then begin + i32buf[idx] := Byte(n); + Inc(idx); + Break; + end; + + i32buf[idx] := Byte((n and $7F) or $80); + Inc(idx); + n := n shr 7; + end; + + Transport.Write( i32buf, 0, idx); +end; + + +// Write a message header to the wire. Compact Protocol messages contain the +// protocol version so we can migrate forwards in the future if need be. +procedure TCompactProtocolImpl.WriteMessageBegin( const msg: TThriftMessage); +var versionAndType : Byte; +begin + Reset; + + versionAndType := Byte( VERSION and VERSION_MASK) + or Byte( (Cardinal(msg.Type_) shl TYPE_SHIFT_AMOUNT) and TYPE_MASK); + + WriteByteDirect( PROTOCOL_ID); + WriteByteDirect( versionAndType); + WriteVarint32( Cardinal(msg.SeqID)); + WriteString( msg.Name); +end; + + +// Write a struct begin. This doesn't actually put anything on the wire. We use it as an +// opportunity to put special placeholder markers on the field stack so we can get the +// field id deltas correct. +procedure TCompactProtocolImpl.WriteStructBegin( const struc: TThriftStruct); +begin + lastField_.Push(lastFieldId_); + lastFieldId_ := 0; +end; + + +// Write a struct end. This doesn't actually put anything on the wire. We use this as an +// opportunity to pop the last field from the current struct off of the field stack. +procedure TCompactProtocolImpl.WriteStructEnd; +begin + lastFieldId_ := lastField_.Pop(); +end; + + +// Write a field header containing the field id and field type. If the difference between the +// current field id and the last one is small (< 15), then the field id will be encoded in +// the 4 MSB as a delta. Otherwise, the field id will follow the type header as a zigzag varint. +procedure TCompactProtocolImpl.WriteFieldBegin( const field: TThriftField); +begin + case field.Type_ of + TType.Bool_ : booleanField_ := field; // we want to possibly include the value, so we'll wait. + else + WriteFieldBeginInternal(field, $FF); + end; +end; + + +// The workhorse of WriteFieldBegin. It has the option of doing a 'type override' +// of the type header. This is used specifically in the boolean field case. +procedure TCompactProtocolImpl.WriteFieldBeginInternal( const field : TThriftField; typeOverride : Byte); +var typeToWrite : Byte; +begin + // if there's a type override, use that. + if typeOverride = $FF + then typeToWrite := getCompactType( field.Type_) + else typeToWrite := typeOverride; + + // check if we can use delta encoding for the field id + if (field.ID > lastFieldId_) and ((field.ID - lastFieldId_) <= 15) + then begin + // Write them together + WriteByteDirect( ((field.ID - lastFieldId_) shl 4) or typeToWrite); + end + else begin + // Write them separate + WriteByteDirect( typeToWrite); + WriteI16( field.ID); + end; + + lastFieldId_ := field.ID; +end; + + +// Write the STOP symbol so we know there are no more fields in this struct. +procedure TCompactProtocolImpl.WriteFieldStop; +begin + WriteByteDirect( Byte( Types.STOP)); +end; + + +// Write a map header. If the map is empty, omit the key and value type +// headers, as we don't need any additional information to skip it. +procedure TCompactProtocolImpl.WriteMapBegin( const map: TThriftMap); +var key, val : Byte; +begin + if (map.Count = 0) + then WriteByteDirect( 0) + else begin + WriteVarint32( Cardinal( map.Count)); + key := getCompactType(map.KeyType); + val := getCompactType(map.ValueType); + WriteByteDirect( (key shl 4) or val); + end; +end; + + +// Write a list header. +procedure TCompactProtocolImpl.WriteListBegin( const list: TThriftList); +begin + WriteCollectionBegin( list.ElementType, list.Count); +end; + + +// Write a set header. +procedure TCompactProtocolImpl.WriteSetBegin( const set_: TThriftSet ); +begin + WriteCollectionBegin( set_.ElementType, set_.Count); +end; + + +// Write a boolean value. Potentially, this could be a boolean field, in +// which case the field header info isn't written yet. If so, decide what the +// right type header is for the value and then Write the field header. +// Otherwise, Write a single byte. +procedure TCompactProtocolImpl.WriteBool( b: Boolean); +var bt : Types; +begin + if b + then bt := Types.BOOLEAN_TRUE + else bt := Types.BOOLEAN_FALSE; + + if booleanField_.Type_ = TType.Bool_ then begin + // we haven't written the field header yet + WriteFieldBeginInternal( booleanField_, Byte(bt)); + booleanField_.Type_ := TType.Stop; + end + else begin + // we're not part of a field, so just Write the value. + WriteByteDirect( Byte(bt)); + end; +end; + + +// Write a byte. Nothing to see here! +procedure TCompactProtocolImpl.WriteByte( b: ShortInt); +begin + WriteByteDirect( Byte(b)); +end; + + +// Write an I16 as a zigzag varint. +procedure TCompactProtocolImpl.WriteI16( i16: SmallInt); +begin + WriteVarint32( intToZigZag( i16)); +end; + + +// Write an i32 as a zigzag varint. +procedure TCompactProtocolImpl.WriteI32( i32: Integer); +begin + WriteVarint32( intToZigZag( i32)); +end; + + +// Write an i64 as a zigzag varint. +procedure TCompactProtocolImpl.WriteI64( const i64: Int64); +begin + WriteVarint64( longToZigzag( i64)); +end; + + +class function TCompactProtocolImpl.DoubleToInt64Bits( const db : Double) : Int64; +begin + ASSERT( SizeOf(db) = SizeOf(result)); + Move( db, result, SizeOf(result)); +end; + + +class function TCompactProtocolImpl.Int64BitsToDouble( const i64 : Int64) : Double; +begin + ASSERT( SizeOf(i64) = SizeOf(result)); + Move( i64, result, SizeOf(result)); +end; + + +// Write a double to the wire as 8 bytes. +procedure TCompactProtocolImpl.WriteDouble( const dub: Double); +var data : TBytes; +begin + fixedLongToBytes( DoubleToInt64Bits(dub), data); + Transport.Write( data); +end; + + +// Write a byte array, using a varint for the size. +procedure TCompactProtocolImpl.WriteBinary( const b: TBytes); +begin + WriteVarint32( Cardinal(Length(b))); + Transport.Write( b); +end; + +procedure TCompactProtocolImpl.WriteMessageEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.WriteMapEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.WriteListEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.WriteSetEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.WriteFieldEnd; +begin + // nothing to do +end; + + +// Abstract method for writing the start of lists and sets. List and sets on +// the wire differ only by the type indicator. +procedure TCompactProtocolImpl.WriteCollectionBegin( const elemType : TType; size : Integer); +begin + if size <= 14 + then WriteByteDirect( (size shl 4) or getCompactType(elemType)) + else begin + WriteByteDirect( $F0 or getCompactType(elemType)); + WriteVarint32( Cardinal(size)); + end; +end; + + +// Write an i64 as a varint. Results in 1-10 bytes on the wire. +procedure TCompactProtocolImpl.WriteVarint64( n : UInt64); +var varint64out : TBytes; + idx : Integer; +begin + SetLength( varint64out, 10); + idx := 0; + while TRUE do begin + ASSERT( idx < Length(varint64out)); + + // last one? + if (n and not UInt64($7F)) = 0 then begin + varint64out[idx] := Byte(n); + Inc(idx); + Break; + end; + + varint64out[idx] := Byte((n and $7F) or $80); + Inc(idx); + n := n shr 7; + end; + + Transport.Write( varint64out, 0, idx); +end; + + +// Convert l into a zigzag Int64. This allows negative numbers to be +// represented compactly as a varint. +class function TCompactProtocolImpl.longToZigzag( const n : Int64) : UInt64; +begin + // there is no arithmetic right shift in Delphi + if n >= 0 + then result := UInt64(n shl 1) + else result := UInt64(n shl 1) xor $FFFFFFFFFFFFFFFF; +end; + + +// Convert n into a zigzag Integer. This allows negative numbers to be +// represented compactly as a varint. +class function TCompactProtocolImpl.intToZigZag( const n : Integer) : Cardinal; +begin + // there is no arithmetic right shift in Delphi + if n >= 0 + then result := Cardinal(n shl 1) + else result := Cardinal(n shl 1) xor $FFFFFFFF; +end; + + +// Convert a Int64 into 8 little-endian bytes in buf +class procedure TCompactProtocolImpl.fixedLongToBytes( const n : Int64; var buf : TBytes); +begin + SetLength( buf, 8); + buf[0] := Byte( n and $FF); + buf[1] := Byte((n shr 8) and $FF); + buf[2] := Byte((n shr 16) and $FF); + buf[3] := Byte((n shr 24) and $FF); + buf[4] := Byte((n shr 32) and $FF); + buf[5] := Byte((n shr 40) and $FF); + buf[6] := Byte((n shr 48) and $FF); + buf[7] := Byte((n shr 56) and $FF); +end; + + + +// Read a message header. +function TCompactProtocolImpl.ReadMessageBegin : TThriftMessage; +var protocolId, versionAndType, version, type_ : Byte; + seqid : Integer; + msgNm : String; +begin + Reset; + + protocolId := Byte( ReadByte); + if (protocolId <> PROTOCOL_ID) + then raise TProtocolExceptionBadVersion.Create( 'Expected protocol id ' + IntToHex(PROTOCOL_ID,2) + + ' but got ' + IntToHex(protocolId,2)); + + versionAndType := Byte( ReadByte); + version := Byte( versionAndType and VERSION_MASK); + if (version <> VERSION) + then raise TProtocolExceptionBadVersion.Create( 'Expected version ' +IntToStr(VERSION) + + ' but got ' + IntToStr(version)); + + type_ := Byte( (versionAndType shr TYPE_SHIFT_AMOUNT) and TYPE_BITS); + seqid := Integer( ReadVarint32); + msgNm := ReadString; + Init( result, msgNm, TMessageType(type_), seqid); +end; + + +// Read a struct begin. There's nothing on the wire for this, but it is our +// opportunity to push a new struct begin marker onto the field stack. +function TCompactProtocolImpl.ReadStructBegin: TThriftStruct; +begin + lastField_.Push( lastFieldId_); + lastFieldId_ := 0; + Init( result); +end; + + +// Doesn't actually consume any wire data, just removes the last field for +// this struct from the field stack. +procedure TCompactProtocolImpl.ReadStructEnd; +begin + // consume the last field we Read off the wire. + lastFieldId_ := lastField_.Pop(); +end; + + +// Read a field header off the wire. +function TCompactProtocolImpl.ReadFieldBegin: TThriftField; +var type_ : Byte; + modifier : ShortInt; + fieldId : SmallInt; +begin + type_ := Byte( ReadByte); + + // if it's a stop, then we can return immediately, as the struct is over. + if type_ = Byte(Types.STOP) then begin + Init( result, '', TType.Stop, 0); + Exit; + end; + + // mask off the 4 MSB of the type header. it could contain a field id delta. + modifier := ShortInt( (type_ and $F0) shr 4); + if (modifier = 0) + then fieldId := ReadI16 // not a delta. look ahead for the zigzag varint field id. + else fieldId := SmallInt( lastFieldId_ + modifier); // add the delta to the last Read field id. + + Init( result, '', getTType(Byte(type_ and $0F)), fieldId); + + // if this happens to be a boolean field, the value is encoded in the type + // save the boolean value in a special instance variable. + if isBoolType(type_) then begin + if Byte(type_ and $0F) = Byte(Types.BOOLEAN_TRUE) + then boolValue_ := bool_true + else boolValue_ := bool_false; + end; + + // push the new field onto the field stack so we can keep the deltas going. + lastFieldId_ := result.ID; +end; + + +// Read a map header off the wire. If the size is zero, skip Reading the key +// and value type. This means that 0-length maps will yield TMaps without the +// "correct" types. +function TCompactProtocolImpl.ReadMapBegin: TThriftMap; +var size : Integer; + keyAndValueType : Byte; + key, val : TType; +begin + size := Integer( ReadVarint32); + if size = 0 + then keyAndValueType := 0 + else keyAndValueType := Byte( ReadByte); + + key := getTType( Byte( keyAndValueType shr 4)); + val := getTType( Byte( keyAndValueType and $F)); + Init( result, key, val, size); + ASSERT( (result.KeyType = key) and (result.ValueType = val)); +end; + + +// Read a list header off the wire. If the list size is 0-14, the size will +// be packed into the element type header. If it's a longer list, the 4 MSB +// of the element type header will be $F, and a varint will follow with the +// true size. +function TCompactProtocolImpl.ReadListBegin: TThriftList; +var size_and_type : Byte; + size : Integer; + type_ : TType; +begin + size_and_type := Byte( ReadByte); + + size := (size_and_type shr 4) and $0F; + if (size = 15) + then size := Integer( ReadVarint32); + + type_ := getTType( size_and_type); + Init( result, type_, size); +end; + + +// Read a set header off the wire. If the set size is 0-14, the size will +// be packed into the element type header. If it's a longer set, the 4 MSB +// of the element type header will be $F, and a varint will follow with the +// true size. +function TCompactProtocolImpl.ReadSetBegin: TThriftSet; +var size_and_type : Byte; + size : Integer; + type_ : TType; +begin + size_and_type := Byte( ReadByte); + + size := (size_and_type shr 4) and $0F; + if (size = 15) + then size := Integer( ReadVarint32); + + type_ := getTType( size_and_type); + Init( result, type_, size); +end; + + +// Read a boolean off the wire. If this is a boolean field, the value should +// already have been Read during ReadFieldBegin, so we'll just consume the +// pre-stored value. Otherwise, Read a byte. +function TCompactProtocolImpl.ReadBool: Boolean; +begin + if boolValue_ <> unused then begin + result := (boolValue_ = bool_true); + boolValue_ := unused; + Exit; + end; + + result := (Byte(ReadByte) = Byte(Types.BOOLEAN_TRUE)); +end; + + +// Read a single byte off the wire. Nothing interesting here. +function TCompactProtocolImpl.ReadByte: ShortInt; +begin + Transport.ReadAll( @result, SizeOf(result), 0, 1); +end; + + +// Read an i16 from the wire as a zigzag varint. +function TCompactProtocolImpl.ReadI16: SmallInt; +begin + result := SmallInt( zigzagToInt( ReadVarint32)); +end; + + +// Read an i32 from the wire as a zigzag varint. +function TCompactProtocolImpl.ReadI32: Integer; +begin + result := zigzagToInt( ReadVarint32); +end; + + +// Read an i64 from the wire as a zigzag varint. +function TCompactProtocolImpl.ReadI64: Int64; +begin + result := zigzagToLong( ReadVarint64); +end; + + +// No magic here - just Read a double off the wire. +function TCompactProtocolImpl.ReadDouble:Double; +var longBits : TBytes; +begin + SetLength( longBits, 8); + Transport.ReadAll( longBits, 0, 8); + result := Int64BitsToDouble( bytesToLong( longBits)); +end; + + +// Read a byte[] from the wire. +function TCompactProtocolImpl.ReadBinary: TBytes; +var length : Integer; +begin + length := Integer( ReadVarint32); + SetLength( result, length); + if (length > 0) + then Transport.ReadAll( result, 0, length); +end; + + +procedure TCompactProtocolImpl.ReadMessageEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.ReadFieldEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.ReadMapEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.ReadListEnd; +begin + // nothing to do +end; + + +procedure TCompactProtocolImpl.ReadSetEnd; +begin + // nothing to do +end; + + + +// Read an i32 from the wire as a varint. The MSB of each byte is set +// if there is another byte to follow. This can Read up to 5 bytes. +function TCompactProtocolImpl.ReadVarint32 : Cardinal; +var shift : Integer; + b : Byte; +begin + result := 0; + shift := 0; + while TRUE do begin + b := Byte( ReadByte); + result := result or (Cardinal(b and $7F) shl shift); + if ((b and $80) <> $80) + then Break; + Inc( shift, 7); + end; +end; + + +// Read an i64 from the wire as a proper varint. The MSB of each byte is set +// if there is another byte to follow. This can Read up to 10 bytes. +function TCompactProtocolImpl.ReadVarint64 : UInt64; +var shift : Integer; + b : Byte; +begin + result := 0; + shift := 0; + while TRUE do begin + b := Byte( ReadByte); + result := result or (UInt64(b and $7F) shl shift); + if ((b and $80) <> $80) + then Break; + Inc( shift, 7); + end; +end; + + +// Convert from zigzag Integer to Integer. +class function TCompactProtocolImpl.zigzagToInt( const n : Cardinal ) : Integer; +begin + result := Integer(n shr 1) xor (-Integer(n and 1)); +end; + + +// Convert from zigzag Int64 to Int64. +class function TCompactProtocolImpl.zigzagToLong( const n : UInt64) : Int64; +begin + result := Int64(n shr 1) xor (-Int64(n and 1)); +end; + + +// Note that it's important that the mask bytes are Int64 literals, +// otherwise they'll default to ints, and when you shift an Integer left 56 bits, +// you just get a messed up Integer. +class function TCompactProtocolImpl.bytesToLong( const bytes : TBytes) : Int64; +begin + ASSERT( Length(bytes) >= 8); + result := (Int64(bytes[7] and $FF) shl 56) or + (Int64(bytes[6] and $FF) shl 48) or + (Int64(bytes[5] and $FF) shl 40) or + (Int64(bytes[4] and $FF) shl 32) or + (Int64(bytes[3] and $FF) shl 24) or + (Int64(bytes[2] and $FF) shl 16) or + (Int64(bytes[1] and $FF) shl 8) or + (Int64(bytes[0] and $FF)); +end; + + +class function TCompactProtocolImpl.isBoolType( const b : byte) : Boolean; +var lowerNibble : Byte; +begin + lowerNibble := b and $0f; + result := (Types(lowerNibble) in [Types.BOOLEAN_TRUE, Types.BOOLEAN_FALSE]); +end; + + +// Given a TCompactProtocol.Types constant, convert it to its corresponding TType value. +class function TCompactProtocolImpl.getTType( const type_ : byte) : TType; +var tct : Types; +begin + tct := Types( type_ and $0F); + if tct in [Low(Types)..High(Types)] + then result := tcompactTypeToType[tct] + else raise TProtocolExceptionInvalidData.Create('don''t know what type: '+IntToStr(Ord(tct))); +end; + + +// Given a TType value, find the appropriate TCompactProtocol.Types constant. +class function TCompactProtocolImpl.getCompactType( const ttype : TType) : Byte; +begin + if ttype in VALID_TTYPES + then result := Byte( ttypeToCompactType[ttype]) + else raise TProtocolExceptionInvalidData.Create('don''t know what type: '+IntToStr(Ord(ttype))); +end; + + +//--- unit tests ------------------------------------------- + +{$IFDEF Debug} +procedure TestDoubleToInt64Bits; + + procedure TestPair( const a : Double; const b : Int64); + begin + ASSERT( TCompactProtocolImpl.DoubleToInt64Bits(a) = b); + ASSERT( TCompactProtocolImpl.Int64BitsToDouble(b) = a); + end; + +begin + TestPair( 1.0000000000000000E+000, Int64($3FF0000000000000)); + TestPair( 1.5000000000000000E+001, Int64($402E000000000000)); + TestPair( 2.5500000000000000E+002, Int64($406FE00000000000)); + TestPair( 4.2949672950000000E+009, Int64($41EFFFFFFFE00000)); + TestPair( 3.9062500000000000E-003, Int64($3F70000000000000)); + TestPair( 2.3283064365386963E-010, Int64($3DF0000000000000)); + TestPair( 1.2345678901230000E-300, Int64($01AA74FE1C1E7E45)); + TestPair( 1.2345678901234500E-150, Int64($20D02A36586DB4BB)); + TestPair( 1.2345678901234565E+000, Int64($3FF3C0CA428C59FA)); + TestPair( 1.2345678901234567E+000, Int64($3FF3C0CA428C59FB)); + TestPair( 1.2345678901234569E+000, Int64($3FF3C0CA428C59FC)); + TestPair( 1.2345678901234569E+150, Int64($5F182344CD3CDF9F)); + TestPair( 1.2345678901234569E+300, Int64($7E3D7EE8BCBBD352)); + TestPair( -1.7976931348623157E+308, Int64($FFEFFFFFFFFFFFFF)); + TestPair( 1.7976931348623157E+308, Int64($7FEFFFFFFFFFFFFF)); + TestPair( 4.9406564584124654E-324, Int64($0000000000000001)); + TestPair( 0.0000000000000000E+000, Int64($0000000000000000)); + TestPair( 4.94065645841247E-324, Int64($0000000000000001)); + TestPair( 3.2378592100206092E-319, Int64($000000000000FFFF)); + TestPair( 1.3906711615669959E-309, Int64($0000FFFFFFFFFFFF)); + TestPair( NegInfinity, Int64($FFF0000000000000)); + TestPair( Infinity, Int64($7FF0000000000000)); + + // NaN is special + ASSERT( TCompactProtocolImpl.DoubleToInt64Bits( NaN) = Int64($FFF8000000000000)); + ASSERT( IsNan( TCompactProtocolImpl.Int64BitsToDouble( Int64($FFF8000000000000)))); +end; +{$ENDIF} + + +{$IFDEF Debug} +procedure TestZigZag; + + procedure Test32( const test : Integer); + var zz : Cardinal; + begin + zz := TCompactProtocolImpl.intToZigZag(test); + ASSERT( TCompactProtocolImpl.zigzagToInt(zz) = test, IntToStr(test)); + end; + + procedure Test64( const test : Int64); + var zz : UInt64; + begin + zz := TCompactProtocolImpl.longToZigzag(test); + ASSERT( TCompactProtocolImpl.zigzagToLong(zz) = test, IntToStr(test)); + end; + +var i : Integer; +begin + // protobuf testcases + ASSERT( TCompactProtocolImpl.intToZigZag(0) = 0, 'pb #1 to ZigZag'); + ASSERT( TCompactProtocolImpl.intToZigZag(-1) = 1, 'pb #2 to ZigZag'); + ASSERT( TCompactProtocolImpl.intToZigZag(1) = 2, 'pb #3 to ZigZag'); + ASSERT( TCompactProtocolImpl.intToZigZag(-2) = 3, 'pb #4 to ZigZag'); + ASSERT( TCompactProtocolImpl.intToZigZag(+2147483647) = 4294967294, 'pb #5 to ZigZag'); + ASSERT( TCompactProtocolImpl.intToZigZag(-2147483648) = 4294967295, 'pb #6 to ZigZag'); + + // protobuf testcases + ASSERT( TCompactProtocolImpl.zigzagToInt(0) = 0, 'pb #1 from ZigZag'); + ASSERT( TCompactProtocolImpl.zigzagToInt(1) = -1, 'pb #2 from ZigZag'); + ASSERT( TCompactProtocolImpl.zigzagToInt(2) = 1, 'pb #3 from ZigZag'); + ASSERT( TCompactProtocolImpl.zigzagToInt(3) = -2, 'pb #4 from ZigZag'); + ASSERT( TCompactProtocolImpl.zigzagToInt(4294967294) = +2147483647, 'pb #5 from ZigZag'); + ASSERT( TCompactProtocolImpl.zigzagToInt(4294967295) = -2147483648, 'pb #6 from ZigZag'); + + // back and forth 32 + Test32( 0); + for i := 0 to 30 do begin + Test32( +(Integer(1) shl i)); + Test32( -(Integer(1) shl i)); + end; + Test32( Integer($7FFFFFFF)); + Test32( Integer($80000000)); + + // back and forth 64 + Test64( 0); + for i := 0 to 62 do begin + Test64( +(Int64(1) shl i)); + Test64( -(Int64(1) shl i)); + end; + Test64( Int64($7FFFFFFFFFFFFFFF)); + Test64( Int64($8000000000000000)); +end; +{$ENDIF} + + +{$IFDEF Debug} +procedure TestLongBytes; + + procedure Test( const test : Int64); + var buf : TBytes; + begin + TCompactProtocolImpl.fixedLongToBytes( test, buf); + ASSERT( TCompactProtocolImpl.bytesToLong( buf) = test, IntToStr(test)); + end; + +var i : Integer; +begin + Test( 0); + for i := 0 to 62 do begin + Test( +(Int64(1) shl i)); + Test( -(Int64(1) shl i)); + end; + Test( Int64($7FFFFFFFFFFFFFFF)); + Test( Int64($8000000000000000)); +end; +{$ENDIF} + + +{$IFDEF Debug} +procedure UnitTest; +var w : WORD; +const FPU_CW_DENORMALIZED = $0002; +begin + w := Get8087CW; + try + Set8087CW( w or FPU_CW_DENORMALIZED); + + TestDoubleToInt64Bits; + TestZigZag; + TestLongBytes; + + finally + Set8087CW( w); + end; +end; +{$ENDIF} + + +initialization + {$IFDEF Debug} + UnitTest; + {$ENDIF} + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.JSON.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.JSON.pas new file mode 100644 index 000000000..30600aa80 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.JSON.pas @@ -0,0 +1,1237 @@ +(* + * 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. + *) + +{$SCOPEDENUMS ON} + +unit Thrift.Protocol.JSON; + +interface + +uses + Character, + Classes, + SysUtils, + Math, + Generics.Collections, + Thrift.Transport, + Thrift.Protocol, + Thrift.Utils; + +type + IJSONProtocol = interface( IProtocol) + ['{F0DAFDBD-692A-4B71-9736-F5D485A2178F}'] + // Read a byte that must match b; otherwise an exception is thrown. + procedure ReadJSONSyntaxChar( b : Byte); + end; + + // JSON protocol implementation for thrift. + // This is a full-featured protocol supporting Write and Read. + // Please see the C++ class header for a detailed description of the protocol's wire format. + // Adapted from the C# version. + TJSONProtocolImpl = class( TProtocolImpl, IJSONProtocol) + public + type + TFactory = class( TInterfacedObject, IProtocolFactory) + public + function GetProtocol( const trans: ITransport): IProtocol; + end; + + private + class function GetTypeNameForTypeID(typeID : TType) : string; + class function GetTypeIDForTypeName( const name : string) : TType; + + protected + type + // Base class for tracking JSON contexts that may require + // inserting/Reading additional JSON syntax characters. + // This base context does nothing. + TJSONBaseContext = class + protected + FProto : Pointer; // weak IJSONProtocol; + public + constructor Create( const aProto : IJSONProtocol); + procedure Write; virtual; + procedure Read; virtual; + function EscapeNumbers : Boolean; virtual; + end; + + // Context for JSON lists. + // Will insert/Read commas before each item except for the first one. + TJSONListContext = class( TJSONBaseContext) + private + FFirst : Boolean; + public + constructor Create( const aProto : IJSONProtocol); + procedure Write; override; + procedure Read; override; + end; + + // Context for JSON records. Will insert/Read colons before the value portion of each record + // pair, and commas before each key except the first. In addition, will indicate that numbers + // in the key position need to be escaped in quotes (since JSON keys must be strings). + TJSONPairContext = class( TJSONBaseContext) + private + FFirst, FColon : Boolean; + public + constructor Create( const aProto : IJSONProtocol); + procedure Write; override; + procedure Read; override; + function EscapeNumbers : Boolean; override; + end; + + // Holds up to one byte from the transport + TLookaheadReader = class + protected + FProto : Pointer; // weak IJSONProtocol; + constructor Create( const aProto : IJSONProtocol); + + private + FHasData : Boolean; + FData : Byte; + + public + // Return and consume the next byte to be Read, either taking it from the + // data buffer if present or getting it from the transport otherwise. + function Read : Byte; + + // Return the next byte to be Read without consuming, filling the data + // buffer if it has not been filled alReady. + function Peek : Byte; + end; + + protected + // Stack of nested contexts that we may be in + FContextStack : TStack<TJSONBaseContext>; + + // Current context that we are in + FContext : TJSONBaseContext; + + // Reader that manages a 1-byte buffer + FReader : TLookaheadReader; + + // Push/pop a new JSON context onto/from the stack. + procedure ResetContextStack; + procedure PushContext( const aCtx : TJSONBaseContext); + procedure PopContext; + + public + // TJSONProtocolImpl Constructor + constructor Create( const aTrans : ITransport); + destructor Destroy; override; + + protected + // IJSONProtocol + // Read a byte that must match b; otherwise an exception is thrown. + procedure ReadJSONSyntaxChar( b : Byte); + + private + // Convert a byte containing a hex char ('0'-'9' or 'a'-'f') into its corresponding hex value + class function HexVal( ch : Byte) : Byte; + + // Convert a byte containing a hex value to its corresponding hex character + class function HexChar( val : Byte) : Byte; + + // Write the bytes in array buf as a JSON characters, escaping as needed + procedure WriteJSONString( const b : TBytes); overload; + procedure WriteJSONString( const str : string); overload; + + // Write out number as a JSON value. If the context dictates so, it will be + // wrapped in quotes to output as a JSON string. + procedure WriteJSONInteger( const num : Int64); + + // Write out a double as a JSON value. If it is NaN or infinity or if the + // context dictates escaping, Write out as JSON string. + procedure WriteJSONDouble( const num : Double); + + // Write out contents of byte array b as a JSON string with base-64 encoded data + procedure WriteJSONBase64( const b : TBytes); + + procedure WriteJSONObjectStart; + procedure WriteJSONObjectEnd; + procedure WriteJSONArrayStart; + procedure WriteJSONArrayEnd; + + public + // IProtocol + procedure WriteMessageBegin( const aMsg : TThriftMessage); override; + procedure WriteMessageEnd; override; + procedure WriteStructBegin( const struc: TThriftStruct); override; + procedure WriteStructEnd; override; + procedure WriteFieldBegin( const field: TThriftField); override; + procedure WriteFieldEnd; override; + procedure WriteFieldStop; override; + procedure WriteMapBegin( const map: TThriftMap); override; + procedure WriteMapEnd; override; + procedure WriteListBegin( const list: TThriftList); override; + procedure WriteListEnd(); override; + procedure WriteSetBegin( const set_: TThriftSet ); override; + procedure WriteSetEnd(); override; + procedure WriteBool( b: Boolean); override; + procedure WriteByte( b: ShortInt); override; + procedure WriteI16( i16: SmallInt); override; + procedure WriteI32( i32: Integer); override; + procedure WriteI64( const i64: Int64); override; + procedure WriteDouble( const d: Double); override; + procedure WriteString( const s: string ); override; + procedure WriteBinary( const b: TBytes); override; + // + function ReadMessageBegin: TThriftMessage; override; + procedure ReadMessageEnd(); override; + function ReadStructBegin: TThriftStruct; override; + procedure ReadStructEnd; override; + function ReadFieldBegin: TThriftField; override; + procedure ReadFieldEnd(); override; + function ReadMapBegin: TThriftMap; override; + procedure ReadMapEnd(); override; + function ReadListBegin: TThriftList; override; + procedure ReadListEnd(); override; + function ReadSetBegin: TThriftSet; override; + procedure ReadSetEnd(); override; + function ReadBool: Boolean; override; + function ReadByte: ShortInt; override; + function ReadI16: SmallInt; override; + function ReadI32: Integer; override; + function ReadI64: Int64; override; + function ReadDouble:Double; override; + function ReadString : string; override; + function ReadBinary: TBytes; override; + + + private + // Reading methods. + + // Read in a JSON string, unescaping as appropriate. + // Skip Reading from the context if skipContext is true. + function ReadJSONString( skipContext : Boolean) : TBytes; + + // Return true if the given byte could be a valid part of a JSON number. + function IsJSONNumeric( b : Byte) : Boolean; + + // Read in a sequence of characters that are all valid in JSON numbers. Does + // not do a complete regex check to validate that this is actually a number. + function ReadJSONNumericChars : String; + + // Read in a JSON number. If the context dictates, Read in enclosing quotes. + function ReadJSONInteger : Int64; + + // Read in a JSON double value. Throw if the value is not wrapped in quotes + // when expected or if wrapped in quotes when not expected. + function ReadJSONDouble : Double; + + // Read in a JSON string containing base-64 encoded data and decode it. + function ReadJSONBase64 : TBytes; + + procedure ReadJSONObjectStart; + procedure ReadJSONObjectEnd; + procedure ReadJSONArrayStart; + procedure ReadJSONArrayEnd; + end; + + +implementation + +var + COMMA : TBytes; + COLON : TBytes; + LBRACE : TBytes; + RBRACE : TBytes; + LBRACKET : TBytes; + RBRACKET : TBytes; + QUOTE : TBytes; + BACKSLASH : TBytes; + ESCSEQ : TBytes; + +const + VERSION = 1; + JSON_CHAR_TABLE : array[0..$2F] of Byte + = (0,0,0,0, 0,0,0,0, Byte('b'),Byte('t'),Byte('n'),0, Byte('f'),Byte('r'),0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 1,1,Byte('"'),1, 1,1,1,1, 1,1,1,1, 1,1,1,1); + + ESCAPE_CHARS = '"\/btnfr'; + ESCAPE_CHAR_VALS = '"\/'#8#9#10#12#13; + + DEF_STRING_SIZE = 16; + + NAME_BOOL = 'tf'; + NAME_BYTE = 'i8'; + NAME_I16 = 'i16'; + NAME_I32 = 'i32'; + NAME_I64 = 'i64'; + NAME_DOUBLE = 'dbl'; + NAME_STRUCT = 'rec'; + NAME_STRING = 'str'; + NAME_MAP = 'map'; + NAME_LIST = 'lst'; + NAME_SET = 'set'; + + INVARIANT_CULTURE : TFormatSettings + = ( ThousandSeparator: ','; + DecimalSeparator: '.'); + + + +//--- TJSONProtocolImpl ---------------------- + + +function TJSONProtocolImpl.TFactory.GetProtocol( const trans: ITransport): IProtocol; +begin + result := TJSONProtocolImpl.Create(trans); +end; + +class function TJSONProtocolImpl.GetTypeNameForTypeID(typeID : TType) : string; +begin + case typeID of + TType.Bool_: result := NAME_BOOL; + TType.Byte_: result := NAME_BYTE; + TType.I16: result := NAME_I16; + TType.I32: result := NAME_I32; + TType.I64: result := NAME_I64; + TType.Double_: result := NAME_DOUBLE; + TType.String_: result := NAME_STRING; + TType.Struct: result := NAME_STRUCT; + TType.Map: result := NAME_MAP; + TType.Set_: result := NAME_SET; + TType.List: result := NAME_LIST; + else + raise TProtocolExceptionNotImplemented.Create('Unrecognized type ('+IntToStr(Ord(typeID))+')'); + end; +end; + + +class function TJSONProtocolImpl.GetTypeIDForTypeName( const name : string) : TType; +begin + if name = NAME_BOOL then result := TType.Bool_ + else if name = NAME_BYTE then result := TType.Byte_ + else if name = NAME_I16 then result := TType.I16 + else if name = NAME_I32 then result := TType.I32 + else if name = NAME_I64 then result := TType.I64 + else if name = NAME_DOUBLE then result := TType.Double_ + else if name = NAME_STRUCT then result := TType.Struct + else if name = NAME_STRING then result := TType.String_ + else if name = NAME_MAP then result := TType.Map + else if name = NAME_LIST then result := TType.List + else if name = NAME_SET then result := TType.Set_ + else raise TProtocolExceptionNotImplemented.Create('Unrecognized type ('+name+')'); +end; + + +constructor TJSONProtocolImpl.TJSONBaseContext.Create( const aProto : IJSONProtocol); +begin + inherited Create; + FProto := Pointer(aProto); +end; + + +procedure TJSONProtocolImpl.TJSONBaseContext.Write; +begin + // nothing +end; + + +procedure TJSONProtocolImpl.TJSONBaseContext.Read; +begin + // nothing +end; + + +function TJSONProtocolImpl.TJSONBaseContext.EscapeNumbers : Boolean; +begin + result := FALSE; +end; + + +constructor TJSONProtocolImpl.TJSONListContext.Create( const aProto : IJSONProtocol); +begin + inherited Create( aProto); + FFirst := TRUE; +end; + + +procedure TJSONProtocolImpl.TJSONListContext.Write; +begin + if FFirst + then FFirst := FALSE + else IJSONProtocol(FProto).Transport.Write( COMMA); +end; + + +procedure TJSONProtocolImpl.TJSONListContext.Read; +begin + if FFirst + then FFirst := FALSE + else IJSONProtocol(FProto).ReadJSONSyntaxChar( COMMA[0]); +end; + + +constructor TJSONProtocolImpl.TJSONPairContext.Create( const aProto : IJSONProtocol); +begin + inherited Create( aProto); + FFirst := TRUE; + FColon := TRUE; +end; + + +procedure TJSONProtocolImpl.TJSONPairContext.Write; +begin + if FFirst then begin + FFirst := FALSE; + FColon := TRUE; + end + else begin + if FColon + then IJSONProtocol(FProto).Transport.Write( COLON) + else IJSONProtocol(FProto).Transport.Write( COMMA); + FColon := not FColon; + end; +end; + + +procedure TJSONProtocolImpl.TJSONPairContext.Read; +begin + if FFirst then begin + FFirst := FALSE; + FColon := TRUE; + end + else begin + if FColon + then IJSONProtocol(FProto).ReadJSONSyntaxChar( COLON[0]) + else IJSONProtocol(FProto).ReadJSONSyntaxChar( COMMA[0]); + FColon := not FColon; + end; +end; + + +function TJSONProtocolImpl.TJSONPairContext.EscapeNumbers : Boolean; +begin + result := FColon; +end; + + +constructor TJSONProtocolImpl.TLookaheadReader.Create( const aProto : IJSONProtocol); +begin + inherited Create; + FProto := Pointer(aProto); + FHasData := FALSE; +end; + + +function TJSONProtocolImpl.TLookaheadReader.Read : Byte; +begin + if FHasData + then FHasData := FALSE + else begin + IJSONProtocol(FProto).Transport.ReadAll( @FData, SizeOf(FData), 0, 1); + end; + result := FData; +end; + + +function TJSONProtocolImpl.TLookaheadReader.Peek : Byte; +begin + if not FHasData then begin + IJSONProtocol(FProto).Transport.ReadAll( @FData, SizeOf(FData), 0, 1); + FHasData := TRUE; + end; + result := FData; +end; + + +constructor TJSONProtocolImpl.Create( const aTrans : ITransport); +begin + inherited Create( aTrans); + + // Stack of nested contexts that we may be in + FContextStack := TStack<TJSONBaseContext>.Create; + + FContext := TJSONBaseContext.Create( Self); + FReader := TLookaheadReader.Create( Self); +end; + + +destructor TJSONProtocolImpl.Destroy; +begin + try + ResetContextStack; // free any contents + FreeAndNil( FReader); + FreeAndNil( FContext); + FreeAndNil( FContextStack); + finally + inherited Destroy; + end; +end; + + +procedure TJSONProtocolImpl.ResetContextStack; +begin + while FContextStack.Count > 0 + do PopContext; +end; + + +procedure TJSONProtocolImpl.PushContext( const aCtx : TJSONBaseContext); +begin + FContextStack.Push( FContext); + FContext := aCtx; +end; + + +procedure TJSONProtocolImpl.PopContext; +begin + FreeAndNil(FContext); + FContext := FContextStack.Pop; +end; + + +procedure TJSONProtocolImpl.ReadJSONSyntaxChar( b : Byte); +var ch : Byte; +begin + ch := FReader.Read; + if (ch <> b) + then raise TProtocolExceptionInvalidData.Create('Unexpected character ('+Char(ch)+')'); +end; + + +class function TJSONProtocolImpl.HexVal( ch : Byte) : Byte; +var i : Integer; +begin + i := StrToIntDef( '$0'+Char(ch), -1); + if (0 <= i) and (i < $10) + then result := i + else raise TProtocolExceptionInvalidData.Create('Expected hex character ('+Char(ch)+')'); +end; + + +class function TJSONProtocolImpl.HexChar( val : Byte) : Byte; +const HEXCHARS = '0123456789ABCDEF'; +begin + result := Byte( PChar(HEXCHARS)[val and $0F]); + ASSERT( Pos( Char(result), HEXCHARS) > 0); +end; + + +procedure TJSONProtocolImpl.WriteJSONString( const str : string); +begin + WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( str)); +end; + + +procedure TJSONProtocolImpl.WriteJSONString( const b : TBytes); +var i : Integer; + tmp : TBytes; +begin + FContext.Write; + Transport.Write( QUOTE); + for i := 0 to Length(b)-1 do begin + + if (b[i] and $00FF) >= $30 then begin + + if (b[i] = BACKSLASH[0]) then begin + Transport.Write( BACKSLASH); + Transport.Write( BACKSLASH); + end + else begin + Transport.Write( b, i, 1); + end; + + end + else begin + SetLength( tmp, 2); + tmp[0] := JSON_CHAR_TABLE[b[i]]; + if (tmp[0] = 1) then begin + Transport.Write( b, i, 1) + end + else if (tmp[0] > 1) then begin + Transport.Write( BACKSLASH); + Transport.Write( tmp, 0, 1); + end + else begin + Transport.Write( ESCSEQ); + tmp[0] := HexChar( b[i] div $10); + tmp[1] := HexChar( b[i]); + Transport.Write( tmp, 0, 2); + end; + end; + end; + Transport.Write( QUOTE); +end; + + +procedure TJSONProtocolImpl.WriteJSONInteger( const num : Int64); +var str : String; + escapeNum : Boolean; +begin + FContext.Write; + str := IntToStr(num); + + escapeNum := FContext.EscapeNumbers; + if escapeNum + then Transport.Write( QUOTE); + + Transport.Write( SysUtils.TEncoding.UTF8.GetBytes( str)); + + if escapeNum + then Transport.Write( QUOTE); +end; + + +procedure TJSONProtocolImpl.WriteJSONDouble( const num : Double); +var str : string; + special : Boolean; + escapeNum : Boolean; +begin + FContext.Write; + + str := FloatToStr( num, INVARIANT_CULTURE); + special := FALSE; + + case UpCase(str[1]) of + 'N' : special := TRUE; // NaN + 'I' : special := TRUE; // Infinity + '-' : special := (UpCase(str[2]) = 'I'); // -Infinity + end; + + escapeNum := special or FContext.EscapeNumbers; + + + if escapeNum + then Transport.Write( QUOTE); + + Transport.Write( SysUtils.TEncoding.UTF8.GetBytes( str)); + + if escapeNum + then Transport.Write( QUOTE); +end; + + +procedure TJSONProtocolImpl.WriteJSONBase64( const b : TBytes); +var len, off, cnt : Integer; + tmpBuf : TBytes; +begin + FContext.Write; + Transport.Write( QUOTE); + + len := Length(b); + off := 0; + SetLength( tmpBuf, 4); + + while len >= 3 do begin + // Encode 3 bytes at a time + Base64Utils.Encode( b, off, 3, tmpBuf, 0); + Transport.Write( tmpBuf, 0, 4); + Inc( off, 3); + Dec( len, 3); + end; + + // Encode remainder, if any + if len > 0 then begin + cnt := Base64Utils.Encode( b, off, len, tmpBuf, 0); + Transport.Write( tmpBuf, 0, cnt); + end; + + Transport.Write( QUOTE); +end; + + +procedure TJSONProtocolImpl.WriteJSONObjectStart; +begin + FContext.Write; + Transport.Write( LBRACE); + PushContext( TJSONPairContext.Create( Self)); +end; + + +procedure TJSONProtocolImpl.WriteJSONObjectEnd; +begin + PopContext; + Transport.Write( RBRACE); +end; + + +procedure TJSONProtocolImpl.WriteJSONArrayStart; +begin + FContext.Write; + Transport.Write( LBRACKET); + PushContext( TJSONListContext.Create( Self)); +end; + + +procedure TJSONProtocolImpl.WriteJSONArrayEnd; +begin + PopContext; + Transport.Write( RBRACKET); +end; + + +procedure TJSONProtocolImpl.WriteMessageBegin( const aMsg : TThriftMessage); +begin + ResetContextStack; // THRIFT-1473 + + WriteJSONArrayStart; + WriteJSONInteger(VERSION); + + WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( aMsg.Name)); + + WriteJSONInteger( LongInt( aMsg.Type_)); + WriteJSONInteger( aMsg.SeqID); +end; + +procedure TJSONProtocolImpl.WriteMessageEnd; +begin + WriteJSONArrayEnd; +end; + + +procedure TJSONProtocolImpl.WriteStructBegin( const struc: TThriftStruct); +begin + WriteJSONObjectStart; +end; + + +procedure TJSONProtocolImpl.WriteStructEnd; +begin + WriteJSONObjectEnd; +end; + + +procedure TJSONProtocolImpl.WriteFieldBegin( const field : TThriftField); +begin + WriteJSONInteger(field.ID); + WriteJSONObjectStart; + WriteJSONString( GetTypeNameForTypeID(field.Type_)); +end; + + +procedure TJSONProtocolImpl.WriteFieldEnd; +begin + WriteJSONObjectEnd; +end; + + +procedure TJSONProtocolImpl.WriteFieldStop; +begin + // nothing to do +end; + +procedure TJSONProtocolImpl.WriteMapBegin( const map: TThriftMap); +begin + WriteJSONArrayStart; + WriteJSONString( GetTypeNameForTypeID( map.KeyType)); + WriteJSONString( GetTypeNameForTypeID( map.ValueType)); + WriteJSONInteger( map.Count); + WriteJSONObjectStart; +end; + + +procedure TJSONProtocolImpl.WriteMapEnd; +begin + WriteJSONObjectEnd; + WriteJSONArrayEnd; +end; + + +procedure TJSONProtocolImpl.WriteListBegin( const list: TThriftList); +begin + WriteJSONArrayStart; + WriteJSONString( GetTypeNameForTypeID( list.ElementType)); + WriteJSONInteger(list.Count); +end; + + +procedure TJSONProtocolImpl.WriteListEnd; +begin + WriteJSONArrayEnd; +end; + + +procedure TJSONProtocolImpl.WriteSetBegin( const set_: TThriftSet); +begin + WriteJSONArrayStart; + WriteJSONString( GetTypeNameForTypeID( set_.ElementType)); + WriteJSONInteger( set_.Count); +end; + + +procedure TJSONProtocolImpl.WriteSetEnd; +begin + WriteJSONArrayEnd; +end; + +procedure TJSONProtocolImpl.WriteBool( b: Boolean); +begin + if b + then WriteJSONInteger( 1) + else WriteJSONInteger( 0); +end; + +procedure TJSONProtocolImpl.WriteByte( b: ShortInt); +begin + WriteJSONInteger( b); +end; + +procedure TJSONProtocolImpl.WriteI16( i16: SmallInt); +begin + WriteJSONInteger( i16); +end; + +procedure TJSONProtocolImpl.WriteI32( i32: Integer); +begin + WriteJSONInteger( i32); +end; + +procedure TJSONProtocolImpl.WriteI64( const i64: Int64); +begin + WriteJSONInteger(i64); +end; + +procedure TJSONProtocolImpl.WriteDouble( const d: Double); +begin + WriteJSONDouble( d); +end; + +procedure TJSONProtocolImpl.WriteString( const s: string ); +begin + WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( s)); +end; + +procedure TJSONProtocolImpl.WriteBinary( const b: TBytes); +begin + WriteJSONBase64( b); +end; + + +function TJSONProtocolImpl.ReadJSONString( skipContext : Boolean) : TBytes; +var buffer : TMemoryStream; + ch : Byte; + wch : Word; + highSurogate: Char; + surrogatePairs: Array[0..1] of Char; + off : Integer; + tmp : TBytes; +begin + highSurogate := #0; + buffer := TMemoryStream.Create; + try + if not skipContext + then FContext.Read; + + ReadJSONSyntaxChar( QUOTE[0]); + + while TRUE do begin + ch := FReader.Read; + + if (ch = QUOTE[0]) + then Break; + + // check for escapes + if (ch <> ESCSEQ[0]) then begin + buffer.Write( ch, 1); + Continue; + end; + + // distuinguish between \uNNNN and \? + ch := FReader.Read; + if (ch <> ESCSEQ[1]) + then begin + off := Pos( Char(ch), ESCAPE_CHARS); + if off < 1 + then raise TProtocolExceptionInvalidData.Create('Expected control char'); + ch := Byte( ESCAPE_CHAR_VALS[off]); + buffer.Write( ch, 1); + Continue; + end; + + // it is \uXXXX + SetLength( tmp, 4); + Transport.ReadAll( tmp, 0, 4); + wch := (HexVal(tmp[0]) shl 12) + + (HexVal(tmp[1]) shl 8) + + (HexVal(tmp[2]) shl 4) + + HexVal(tmp[3]); + + // we need to make UTF8 bytes from it, to be decoded later + if CharUtils.IsHighSurrogate(char(wch)) then begin + if highSurogate <> #0 + then raise TProtocolExceptionInvalidData.Create('Expected low surrogate char'); + highSurogate := char(wch); + end + else if CharUtils.IsLowSurrogate(char(wch)) then begin + if highSurogate = #0 + then TProtocolExceptionInvalidData.Create('Expected high surrogate char'); + surrogatePairs[0] := highSurogate; + surrogatePairs[1] := char(wch); + tmp := TEncoding.UTF8.GetBytes(surrogatePairs); + buffer.Write( tmp[0], Length(tmp)); + highSurogate := #0; + end + else begin + tmp := SysUtils.TEncoding.UTF8.GetBytes(Char(wch)); + buffer.Write( tmp[0], Length(tmp)); + end; + end; + + if highSurogate <> #0 + then raise TProtocolExceptionInvalidData.Create('Expected low surrogate char'); + + SetLength( result, buffer.Size); + if buffer.Size > 0 then Move( buffer.Memory^, result[0], Length(result)); + + finally + buffer.Free; + end; +end; + + +function TJSONProtocolImpl.IsJSONNumeric( b : Byte) : Boolean; +const NUMCHARS = ['+','-','.','0','1','2','3','4','5','6','7','8','9','E','e']; +begin + result := CharInSet( Char(b), NUMCHARS); +end; + + +function TJSONProtocolImpl.ReadJSONNumericChars : string; +var strbld : TThriftStringBuilder; + ch : Byte; +begin + strbld := TThriftStringBuilder.Create; + try + while TRUE do begin + ch := FReader.Peek; + if IsJSONNumeric(ch) + then strbld.Append( Char(FReader.Read)) + else Break; + end; + result := strbld.ToString; + + finally + strbld.Free; + end; +end; + + +function TJSONProtocolImpl.ReadJSONInteger : Int64; +var str : string; +begin + FContext.Read; + if FContext.EscapeNumbers + then ReadJSONSyntaxChar( QUOTE[0]); + + str := ReadJSONNumericChars; + + if FContext.EscapeNumbers + then ReadJSONSyntaxChar( QUOTE[0]); + + try + result := StrToInt64(str); + except + on e:Exception do begin + raise TProtocolExceptionInvalidData.Create('Bad data encounted in numeric data ('+str+') ('+e.Message+')'); + end; + end; +end; + + +function TJSONProtocolImpl.ReadJSONDouble : Double; +var dub : Double; + str : string; +begin + FContext.Read; + + if FReader.Peek = QUOTE[0] + then begin + str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( TRUE)); + dub := StrToFloat( str, INVARIANT_CULTURE); + + if not FContext.EscapeNumbers() + and not Math.IsNaN(dub) + and not Math.IsInfinite(dub) + then begin + // Throw exception -- we should not be in a string in Self case + raise TProtocolExceptionInvalidData.Create('Numeric data unexpectedly quoted'); + end; + result := dub; + Exit; + end; + + // will throw - we should have had a quote if escapeNum == true + if FContext.EscapeNumbers + then ReadJSONSyntaxChar( QUOTE[0]); + + try + str := ReadJSONNumericChars; + result := StrToFloat( str, INVARIANT_CULTURE); + except + on e:Exception + do raise TProtocolExceptionInvalidData.Create('Bad data encounted in numeric data ('+str+') ('+e.Message+')'); + end; +end; + + +function TJSONProtocolImpl.ReadJSONBase64 : TBytes; +var b : TBytes; + len, off, size : Integer; +begin + b := ReadJSONString(false); + + len := Length(b); + off := 0; + size := 0; + + // reduce len to ignore fill bytes + Dec(len); + while (len >= 0) and (b[len] = Byte('=')) do Dec(len); + Inc(len); + + // read & decode full byte triplets = 4 source bytes + while (len >= 4) do begin + // Decode 4 bytes at a time + Inc( size, Base64Utils.Decode( b, off, 4, b, size)); // decoded in place + Inc( off, 4); + Dec( len, 4); + end; + + // Don't decode if we hit the end or got a single leftover byte (invalid + // base64 but legal for skip of regular string type) + if len > 1 then begin + // Decode remainder + Inc( size, Base64Utils.Decode( b, off, len, b, size)); // decoded in place + end; + + // resize to final size and return the data + SetLength( b, size); + result := b; +end; + + +procedure TJSONProtocolImpl.ReadJSONObjectStart; +begin + FContext.Read; + ReadJSONSyntaxChar( LBRACE[0]); + PushContext( TJSONPairContext.Create( Self)); +end; + + +procedure TJSONProtocolImpl.ReadJSONObjectEnd; +begin + ReadJSONSyntaxChar( RBRACE[0]); + PopContext; +end; + + +procedure TJSONProtocolImpl.ReadJSONArrayStart; +begin + FContext.Read; + ReadJSONSyntaxChar( LBRACKET[0]); + PushContext( TJSONListContext.Create( Self)); +end; + + +procedure TJSONProtocolImpl.ReadJSONArrayEnd; +begin + ReadJSONSyntaxChar( RBRACKET[0]); + PopContext; +end; + + +function TJSONProtocolImpl.ReadMessageBegin: TThriftMessage; +begin + ResetContextStack; // THRIFT-1473 + + Init( result); + ReadJSONArrayStart; + + if ReadJSONInteger <> VERSION + then raise TProtocolExceptionBadVersion.Create('Message contained bad version.'); + + result.Name := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE)); + result.Type_ := TMessageType( ReadJSONInteger); + result.SeqID := ReadJSONInteger; +end; + + +procedure TJSONProtocolImpl.ReadMessageEnd; +begin + ReadJSONArrayEnd; +end; + + +function TJSONProtocolImpl.ReadStructBegin : TThriftStruct ; +begin + ReadJSONObjectStart; + Init( result); +end; + + +procedure TJSONProtocolImpl.ReadStructEnd; +begin + ReadJSONObjectEnd; +end; + + +function TJSONProtocolImpl.ReadFieldBegin : TThriftField; +var ch : Byte; + str : string; +begin + Init( result); + ch := FReader.Peek; + if ch = RBRACE[0] + then result.Type_ := TType.Stop + else begin + result.ID := ReadJSONInteger; + ReadJSONObjectStart; + + str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE)); + result.Type_ := GetTypeIDForTypeName( str); + end; +end; + + +procedure TJSONProtocolImpl.ReadFieldEnd; +begin + ReadJSONObjectEnd; +end; + + +function TJSONProtocolImpl.ReadMapBegin : TThriftMap; +var str : string; +begin + Init( result); + ReadJSONArrayStart; + + str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE)); + result.KeyType := GetTypeIDForTypeName( str); + + str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE)); + result.ValueType := GetTypeIDForTypeName( str); + + result.Count := ReadJSONInteger; + ReadJSONObjectStart; +end; + + +procedure TJSONProtocolImpl.ReadMapEnd; +begin + ReadJSONObjectEnd; + ReadJSONArrayEnd; +end; + + +function TJSONProtocolImpl.ReadListBegin : TThriftList; +var str : string; +begin + Init( result); + ReadJSONArrayStart; + + str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE)); + result.ElementType := GetTypeIDForTypeName( str); + result.Count := ReadJSONInteger; +end; + + +procedure TJSONProtocolImpl.ReadListEnd; +begin + ReadJSONArrayEnd; +end; + + +function TJSONProtocolImpl.ReadSetBegin : TThriftSet; +var str : string; +begin + Init( result); + ReadJSONArrayStart; + + str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE)); + result.ElementType := GetTypeIDForTypeName( str); + result.Count := ReadJSONInteger; +end; + + +procedure TJSONProtocolImpl.ReadSetEnd; +begin + ReadJSONArrayEnd; +end; + + +function TJSONProtocolImpl.ReadBool : Boolean; +begin + result := (ReadJSONInteger <> 0); +end; + + +function TJSONProtocolImpl.ReadByte : ShortInt; +begin + result := ReadJSONInteger; +end; + + +function TJSONProtocolImpl.ReadI16 : SmallInt; +begin + result := ReadJSONInteger; +end; + + +function TJSONProtocolImpl.ReadI32 : LongInt; +begin + result := ReadJSONInteger; +end; + + +function TJSONProtocolImpl.ReadI64 : Int64; +begin + result := ReadJSONInteger; +end; + + +function TJSONProtocolImpl.ReadDouble : Double; +begin + result := ReadJSONDouble; +end; + + +function TJSONProtocolImpl.ReadString : string; +begin + result := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE)); +end; + + +function TJSONProtocolImpl.ReadBinary : TBytes; +begin + result := ReadJSONBase64; +end; + + +//--- init code --- + +procedure InitBytes( var b : TBytes; aData : array of Byte); +begin + SetLength( b, Length(aData)); + Move( aData, b[0], Length(b)); +end; + +initialization + InitBytes( COMMA, [Byte(',')]); + InitBytes( COLON, [Byte(':')]); + InitBytes( LBRACE, [Byte('{')]); + InitBytes( RBRACE, [Byte('}')]); + InitBytes( LBRACKET, [Byte('[')]); + InitBytes( RBRACKET, [Byte(']')]); + InitBytes( QUOTE, [Byte('"')]); + InitBytes( BACKSLASH, [Byte('\')]); + InitBytes( ESCSEQ, [Byte('\'),Byte('u'),Byte('0'),Byte('0')]); +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.Multiplex.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.Multiplex.pas new file mode 100644 index 000000000..93a38380d --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.Multiplex.pas @@ -0,0 +1,107 @@ +(* + * 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.Protocol.Multiplex; + +interface + +uses Thrift.Protocol; + +{ TMultiplexedProtocol is a protocol-independent concrete decorator + that allows a Thrift client to communicate with a multiplexing Thrift server, + by prepending the service name to the function name during function calls. + + NOTE: THIS IS NOT USED BY SERVERS. + On the server, use TMultiplexedProcessor to handle requests from a multiplexing client. + + This example uses a single socket transport to invoke two services: + + TSocket transport = new TSocket("localhost", 9090); + transport.open(); + + TBinaryProtocol protocol = new TBinaryProtocol(transport); + + TMultiplexedProtocol mp = new TMultiplexedProtocol(protocol, "Calculator"); + Calculator.Client service = new Calculator.Client(mp); + + TMultiplexedProtocol mp2 = new TMultiplexedProtocol(protocol, "WeatherReport"); + WeatherReport.Client service2 = new WeatherReport.Client(mp2); + + System.out.println(service.add(2,2)); + System.out.println(service2.getTemperature()); + +} + +type + TMultiplexedProtocol = class( TProtocolDecorator) + public const + { Used to delimit the service name from the function name } + SEPARATOR = ':'; + + private + FServiceName : String; + + public + { Wrap the specified protocol, allowing it to be used to communicate with a multiplexing server. + The serviceName is required as it is prepended to the message header so that the multiplexing + server can broker the function call to the proper service. + + Args: + protocol ....... Your communication protocol of choice, e.g. TBinaryProtocol. + serviceName .... The service name of the service communicating via this protocol. + } + constructor Create( const aProtocol : IProtocol; const aServiceName : string); + + { Prepends the service name to the function name, separated by SEPARATOR. + Args: The original message. + } + procedure WriteMessageBegin( const msg: TThriftMessage); override; + end; + + +implementation + + +constructor TMultiplexedProtocol.Create(const aProtocol: IProtocol; const aServiceName: string); +begin + ASSERT( aServiceName <> ''); + inherited Create(aProtocol); + FServiceName := aServiceName; +end; + + +procedure TMultiplexedProtocol.WriteMessageBegin( const msg: TThriftMessage); +// Prepends the service name to the function name, separated by TMultiplexedProtocol.SEPARATOR. +var newMsg : TThriftMessage; +begin + case msg.Type_ of + TMessageType.Call, + TMessageType.Oneway : begin + Init( newMsg, FServiceName + SEPARATOR + msg.Name, msg.Type_, msg.SeqID); + inherited WriteMessageBegin( newMsg); + end; + + else + inherited WriteMessageBegin( msg); + end; +end; + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.pas new file mode 100644 index 000000000..609dfc605 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.pas @@ -0,0 +1,1370 @@ +(* + * 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. + *) + +{$SCOPEDENUMS ON} + +unit Thrift.Protocol; + +interface + +uses + Classes, + SysUtils, + Contnrs, + Thrift.Exception, + Thrift.Stream, + Thrift.Utils, + Thrift.Collections, + Thrift.Transport; + +type + + TType = ( + Stop = 0, + Void = 1, + Bool_ = 2, + Byte_ = 3, + Double_ = 4, + I16 = 6, + I32 = 8, + I64 = 10, + String_ = 11, + Struct = 12, + Map = 13, + Set_ = 14, + List = 15 + ); + + TMessageType = ( + Call = 1, + Reply = 2, + Exception = 3, + Oneway = 4 + ); + +const + VALID_TTYPES = [ + TType.Stop, TType.Void, + TType.Bool_, TType.Byte_, TType.Double_, TType.I16, TType.I32, TType.I64, TType.String_, + TType.Struct, TType.Map, TType.Set_, TType.List + ]; + + VALID_MESSAGETYPES = [Low(TMessageType)..High(TMessageType)]; + +const + DEFAULT_RECURSION_LIMIT = 64; + +type + IProtocol = interface; + + TThriftMessage = record + Name: string; + Type_: TMessageType; + SeqID: Integer; + end; + + TThriftStruct = record + Name: string; + end; + + TThriftField = record + Name: string; + Type_: TType; + Id: SmallInt; + end; + + TThriftList = record + ElementType: TType; + Count: Integer; + end; + + TThriftMap = record + KeyType: TType; + ValueType: TType; + Count: Integer; + end; + + TThriftSet = record + ElementType: TType; + Count: Integer; + end; + + + + IProtocolFactory = interface + ['{7CD64A10-4E9F-4E99-93BF-708A31F4A67B}'] + function GetProtocol( const trans: ITransport): IProtocol; + end; + + TProtocolException = class( TException) + public + const // TODO(jensg): change into enum + UNKNOWN = 0; + INVALID_DATA = 1; + NEGATIVE_SIZE = 2; + SIZE_LIMIT = 3; + BAD_VERSION = 4; + NOT_IMPLEMENTED = 5; + DEPTH_LIMIT = 6; + protected + constructor HiddenCreate(const Msg: string); + public + // purposefully hide inherited constructor + class function Create(const Msg: string): TProtocolException; overload; deprecated 'Use specialized TProtocolException types (or regenerate from IDL)'; + class function Create: TProtocolException; overload; deprecated 'Use specialized TProtocolException types (or regenerate from IDL)'; + class function Create( type_: Integer): TProtocolException; overload; deprecated 'Use specialized TProtocolException types (or regenerate from IDL)'; + class function Create( type_: Integer; const msg: string): TProtocolException; overload; deprecated 'Use specialized TProtocolException types (or regenerate from IDL)'; + end; + + // Needed to remove deprecation warning + TProtocolExceptionSpecialized = class abstract (TProtocolException) + public + constructor Create(const Msg: string); + end; + + TProtocolExceptionUnknown = class (TProtocolExceptionSpecialized); + TProtocolExceptionInvalidData = class (TProtocolExceptionSpecialized); + TProtocolExceptionNegativeSize = class (TProtocolExceptionSpecialized); + TProtocolExceptionSizeLimit = class (TProtocolExceptionSpecialized); + TProtocolExceptionBadVersion = class (TProtocolExceptionSpecialized); + TProtocolExceptionNotImplemented = class (TProtocolExceptionSpecialized); + TProtocolExceptionDepthLimit = class (TProtocolExceptionSpecialized); + + + TProtocolUtil = class + public + class procedure Skip( prot: IProtocol; type_: TType); + end; + + IProtocolRecursionTracker = interface + ['{29CA033F-BB56-49B1-9EE3-31B1E82FC7A5}'] + // no members yet + end; + + TProtocolRecursionTrackerImpl = class abstract( TInterfacedObject, IProtocolRecursionTracker) + protected + FProtocol : IProtocol; + public + constructor Create( prot : IProtocol); + destructor Destroy; override; + end; + + IProtocol = interface + ['{602A7FFB-0D9E-4CD8-8D7F-E5076660588A}'] + function GetTransport: ITransport; + procedure WriteMessageBegin( const msg: TThriftMessage); + procedure WriteMessageEnd; + procedure WriteStructBegin( const struc: TThriftStruct); + procedure WriteStructEnd; + procedure WriteFieldBegin( const field: TThriftField); + procedure WriteFieldEnd; + procedure WriteFieldStop; + procedure WriteMapBegin( const map: TThriftMap); + procedure WriteMapEnd; + procedure WriteListBegin( const list: TThriftList); + procedure WriteListEnd(); + procedure WriteSetBegin( const set_: TThriftSet ); + procedure WriteSetEnd(); + procedure WriteBool( b: Boolean); + procedure WriteByte( b: ShortInt); + procedure WriteI16( i16: SmallInt); + procedure WriteI32( i32: Integer); + procedure WriteI64( const i64: Int64); + procedure WriteDouble( const d: Double); + procedure WriteString( const s: string ); + procedure WriteAnsiString( const s: AnsiString); + procedure WriteBinary( const b: TBytes); + + function ReadMessageBegin: TThriftMessage; + procedure ReadMessageEnd(); + function ReadStructBegin: TThriftStruct; + procedure ReadStructEnd; + function ReadFieldBegin: TThriftField; + procedure ReadFieldEnd(); + function ReadMapBegin: TThriftMap; + procedure ReadMapEnd(); + function ReadListBegin: TThriftList; + procedure ReadListEnd(); + function ReadSetBegin: TThriftSet; + procedure ReadSetEnd(); + function ReadBool: Boolean; + function ReadByte: ShortInt; + function ReadI16: SmallInt; + function ReadI32: Integer; + function ReadI64: Int64; + function ReadDouble:Double; + function ReadBinary: TBytes; + function ReadString: string; + function ReadAnsiString: AnsiString; + + procedure SetRecursionLimit( value : Integer); + function GetRecursionLimit : Integer; + function NextRecursionLevel : IProtocolRecursionTracker; + procedure IncrementRecursionDepth; + procedure DecrementRecursionDepth; + + property Transport: ITransport read GetTransport; + property RecursionLimit : Integer read GetRecursionLimit write SetRecursionLimit; + end; + + TProtocolImpl = class abstract( TInterfacedObject, IProtocol) + protected + FTrans : ITransport; + FRecursionLimit : Integer; + FRecursionDepth : Integer; + + procedure SetRecursionLimit( value : Integer); + function GetRecursionLimit : Integer; + function NextRecursionLevel : IProtocolRecursionTracker; + procedure IncrementRecursionDepth; + procedure DecrementRecursionDepth; + + function GetTransport: ITransport; + public + procedure WriteMessageBegin( const msg: TThriftMessage); virtual; abstract; + procedure WriteMessageEnd; virtual; abstract; + procedure WriteStructBegin( const struc: TThriftStruct); virtual; abstract; + procedure WriteStructEnd; virtual; abstract; + procedure WriteFieldBegin( const field: TThriftField); virtual; abstract; + procedure WriteFieldEnd; virtual; abstract; + procedure WriteFieldStop; virtual; abstract; + procedure WriteMapBegin( const map: TThriftMap); virtual; abstract; + procedure WriteMapEnd; virtual; abstract; + procedure WriteListBegin( const list: TThriftList); virtual; abstract; + procedure WriteListEnd(); virtual; abstract; + procedure WriteSetBegin( const set_: TThriftSet ); virtual; abstract; + procedure WriteSetEnd(); virtual; abstract; + procedure WriteBool( b: Boolean); virtual; abstract; + procedure WriteByte( b: ShortInt); virtual; abstract; + procedure WriteI16( i16: SmallInt); virtual; abstract; + procedure WriteI32( i32: Integer); virtual; abstract; + procedure WriteI64( const i64: Int64); virtual; abstract; + procedure WriteDouble( const d: Double); virtual; abstract; + procedure WriteString( const s: string ); virtual; + procedure WriteAnsiString( const s: AnsiString); virtual; + procedure WriteBinary( const b: TBytes); virtual; abstract; + + function ReadMessageBegin: TThriftMessage; virtual; abstract; + procedure ReadMessageEnd(); virtual; abstract; + function ReadStructBegin: TThriftStruct; virtual; abstract; + procedure ReadStructEnd; virtual; abstract; + function ReadFieldBegin: TThriftField; virtual; abstract; + procedure ReadFieldEnd(); virtual; abstract; + function ReadMapBegin: TThriftMap; virtual; abstract; + procedure ReadMapEnd(); virtual; abstract; + function ReadListBegin: TThriftList; virtual; abstract; + procedure ReadListEnd(); virtual; abstract; + function ReadSetBegin: TThriftSet; virtual; abstract; + procedure ReadSetEnd(); virtual; abstract; + function ReadBool: Boolean; virtual; abstract; + function ReadByte: ShortInt; virtual; abstract; + function ReadI16: SmallInt; virtual; abstract; + function ReadI32: Integer; virtual; abstract; + function ReadI64: Int64; virtual; abstract; + function ReadDouble:Double; virtual; abstract; + function ReadBinary: TBytes; virtual; abstract; + function ReadString: string; virtual; + function ReadAnsiString: AnsiString; virtual; + + property Transport: ITransport read GetTransport; + + constructor Create( trans: ITransport ); + end; + + IBase = interface( ISupportsToString) + ['{AFF6CECA-5200-4540-950E-9B89E0C1C00C}'] + procedure Read( const iprot: IProtocol); + procedure Write( const iprot: IProtocol); + end; + + + TBinaryProtocolImpl = class( TProtocolImpl ) + protected + const + VERSION_MASK : Cardinal = $ffff0000; + VERSION_1 : Cardinal = $80010000; + protected + FStrictRead : Boolean; + FStrictWrite : Boolean; + + private + function ReadAll( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer ): Integer; inline; + function ReadStringBody( size: Integer): string; + + public + + type + TFactory = class( TInterfacedObject, IProtocolFactory) + protected + FStrictRead : Boolean; + FStrictWrite : Boolean; + public + function GetProtocol( const trans: ITransport): IProtocol; + constructor Create( AStrictRead, AStrictWrite: Boolean ); overload; + constructor Create; overload; + end; + + constructor Create( const trans: ITransport); overload; + constructor Create( const trans: ITransport; strictRead: Boolean; strictWrite: Boolean); overload; + + procedure WriteMessageBegin( const msg: TThriftMessage); override; + procedure WriteMessageEnd; override; + procedure WriteStructBegin( const struc: TThriftStruct); override; + procedure WriteStructEnd; override; + procedure WriteFieldBegin( const field: TThriftField); override; + procedure WriteFieldEnd; override; + procedure WriteFieldStop; override; + procedure WriteMapBegin( const map: TThriftMap); override; + procedure WriteMapEnd; override; + procedure WriteListBegin( const list: TThriftList); override; + procedure WriteListEnd(); override; + procedure WriteSetBegin( const set_: TThriftSet ); override; + procedure WriteSetEnd(); override; + procedure WriteBool( b: Boolean); override; + procedure WriteByte( b: ShortInt); override; + procedure WriteI16( i16: SmallInt); override; + procedure WriteI32( i32: Integer); override; + procedure WriteI64( const i64: Int64); override; + procedure WriteDouble( const d: Double); override; + procedure WriteBinary( const b: TBytes); override; + + function ReadMessageBegin: TThriftMessage; override; + procedure ReadMessageEnd(); override; + function ReadStructBegin: TThriftStruct; override; + procedure ReadStructEnd; override; + function ReadFieldBegin: TThriftField; override; + procedure ReadFieldEnd(); override; + function ReadMapBegin: TThriftMap; override; + procedure ReadMapEnd(); override; + function ReadListBegin: TThriftList; override; + procedure ReadListEnd(); override; + function ReadSetBegin: TThriftSet; override; + procedure ReadSetEnd(); override; + function ReadBool: Boolean; override; + function ReadByte: ShortInt; override; + function ReadI16: SmallInt; override; + function ReadI32: Integer; override; + function ReadI64: Int64; override; + function ReadDouble:Double; override; + function ReadBinary: TBytes; override; + + end; + + + { TProtocolDecorator forwards all requests to an enclosed TProtocol instance, + providing a way to author concise concrete decorator subclasses. The decorator + does not (and should not) modify the behaviour of the enclosed TProtocol + + See p.175 of Design Patterns (by Gamma et al.) + } + TProtocolDecorator = class( TProtocolImpl) + private + FWrappedProtocol : IProtocol; + + public + // Encloses the specified protocol. + // All operations will be forward to the given protocol. Must be non-null. + constructor Create( const aProtocol : IProtocol); + + procedure WriteMessageBegin( const msg: TThriftMessage); override; + procedure WriteMessageEnd; override; + procedure WriteStructBegin( const struc: TThriftStruct); override; + procedure WriteStructEnd; override; + procedure WriteFieldBegin( const field: TThriftField); override; + procedure WriteFieldEnd; override; + procedure WriteFieldStop; override; + procedure WriteMapBegin( const map: TThriftMap); override; + procedure WriteMapEnd; override; + procedure WriteListBegin( const list: TThriftList); override; + procedure WriteListEnd(); override; + procedure WriteSetBegin( const set_: TThriftSet ); override; + procedure WriteSetEnd(); override; + procedure WriteBool( b: Boolean); override; + procedure WriteByte( b: ShortInt); override; + procedure WriteI16( i16: SmallInt); override; + procedure WriteI32( i32: Integer); override; + procedure WriteI64( const i64: Int64); override; + procedure WriteDouble( const d: Double); override; + procedure WriteString( const s: string ); override; + procedure WriteAnsiString( const s: AnsiString); override; + procedure WriteBinary( const b: TBytes); override; + + function ReadMessageBegin: TThriftMessage; override; + procedure ReadMessageEnd(); override; + function ReadStructBegin: TThriftStruct; override; + procedure ReadStructEnd; override; + function ReadFieldBegin: TThriftField; override; + procedure ReadFieldEnd(); override; + function ReadMapBegin: TThriftMap; override; + procedure ReadMapEnd(); override; + function ReadListBegin: TThriftList; override; + procedure ReadListEnd(); override; + function ReadSetBegin: TThriftSet; override; + procedure ReadSetEnd(); override; + function ReadBool: Boolean; override; + function ReadByte: ShortInt; override; + function ReadI16: SmallInt; override; + function ReadI32: Integer; override; + function ReadI64: Int64; override; + function ReadDouble:Double; override; + function ReadBinary: TBytes; override; + function ReadString: string; override; + function ReadAnsiString: AnsiString; override; + end; + + +type + IRequestEvents = interface + ['{F926A26A-5B00-4560-86FA-2CAE3BA73DAF}'] + // Called before reading arguments. + procedure PreRead; + // Called between reading arguments and calling the handler. + procedure PostRead; + // Called between calling the handler and writing the response. + procedure PreWrite; + // Called after writing the response. + procedure PostWrite; + // Called when an oneway (async) function call completes successfully. + procedure OnewayComplete; + // Called if the handler throws an undeclared exception. + procedure UnhandledError( const e : Exception); + // Called when a client has finished request-handling to clean up + procedure CleanupContext; + end; + + + IProcessorEvents = interface + ['{A8661119-657C-447D-93C5-512E36162A45}'] + // Called when a client is about to call the processor. + procedure Processing( const transport : ITransport); + // Called on any service function invocation + function CreateRequestContext( const aFunctionName : string) : IRequestEvents; + // Called when a client has finished request-handling to clean up + procedure CleanupContext; + end; + + + IProcessor = interface + ['{7BAE92A5-46DA-4F13-B6EA-0EABE233EE5F}'] + function Process( const iprot :IProtocol; const oprot: IProtocol; const events : IProcessorEvents = nil): Boolean; + end; + + +procedure Init( var rec : TThriftMessage; const AName: string = ''; const AMessageType: TMessageType = Low(TMessageType); const ASeqID: Integer = 0); overload; inline; +procedure Init( var rec : TThriftStruct; const AName: string = ''); overload; inline; +procedure Init( var rec : TThriftField; const AName: string = ''; const AType: TType = Low(TType); const AID: SmallInt = 0); overload; inline; +procedure Init( var rec : TThriftMap; const AKeyType: TType = Low(TType); const AValueType: TType = Low(TType); const ACount: Integer = 0); overload; inline; +procedure Init( var rec : TThriftSet; const AElementType: TType = Low(TType); const ACount: Integer = 0); overload; inline; +procedure Init( var rec : TThriftList; const AElementType: TType = Low(TType); const ACount: Integer = 0); overload; inline; + + +implementation + +function ConvertInt64ToDouble( const n: Int64): Double; +begin + ASSERT( SizeOf(n) = SizeOf(Result)); + System.Move( n, Result, SizeOf(Result)); +end; + +function ConvertDoubleToInt64( const d: Double): Int64; +begin + ASSERT( SizeOf(d) = SizeOf(Result)); + System.Move( d, Result, SizeOf(Result)); +end; + + + +{ TProtocolRecursionTrackerImpl } + +constructor TProtocolRecursionTrackerImpl.Create( prot : IProtocol); +begin + inherited Create; + + // storing the pointer *after* the (successful) increment is important here + prot.IncrementRecursionDepth; + FProtocol := prot; +end; + +destructor TProtocolRecursionTrackerImpl.Destroy; +begin + try + // we have to release the reference iff the pointer has been stored + if FProtocol <> nil then begin + FProtocol.DecrementRecursionDepth; + FProtocol := nil; + end; + finally + inherited Destroy; + end; +end; + +{ TProtocolImpl } + +constructor TProtocolImpl.Create(trans: ITransport); +begin + inherited Create; + FTrans := trans; + FRecursionLimit := DEFAULT_RECURSION_LIMIT; + FRecursionDepth := 0; +end; + +procedure TProtocolImpl.SetRecursionLimit( value : Integer); +begin + FRecursionLimit := value; +end; + +function TProtocolImpl.GetRecursionLimit : Integer; +begin + result := FRecursionLimit; +end; + +function TProtocolImpl.NextRecursionLevel : IProtocolRecursionTracker; +begin + result := TProtocolRecursionTrackerImpl.Create(Self); +end; + +procedure TProtocolImpl.IncrementRecursionDepth; +begin + if FRecursionDepth < FRecursionLimit + then Inc(FRecursionDepth) + else raise TProtocolExceptionDepthLimit.Create('Depth limit exceeded'); +end; + +procedure TProtocolImpl.DecrementRecursionDepth; +begin + Dec(FRecursionDepth) +end; + +function TProtocolImpl.GetTransport: ITransport; +begin + Result := FTrans; +end; + +function TProtocolImpl.ReadAnsiString: AnsiString; +var + b : TBytes; + len : Integer; +begin + Result := ''; + b := ReadBinary; + len := Length( b ); + if len > 0 then + begin + SetLength( Result, len); + System.Move( b[0], Pointer(Result)^, len ); + end; +end; + +function TProtocolImpl.ReadString: string; +begin + Result := TEncoding.UTF8.GetString( ReadBinary ); +end; + +procedure TProtocolImpl.WriteAnsiString(const s: AnsiString); +var + b : TBytes; + len : Integer; +begin + len := Length(s); + SetLength( b, len); + if len > 0 then + begin + System.Move( Pointer(s)^, b[0], len ); + end; + WriteBinary( b ); +end; + +procedure TProtocolImpl.WriteString(const s: string); +var + b : TBytes; +begin + b := TEncoding.UTF8.GetBytes(s); + WriteBinary( b ); +end; + +{ TProtocolUtil } + +class procedure TProtocolUtil.Skip( prot: IProtocol; type_: TType); +var field : TThriftField; + map : TThriftMap; + set_ : TThriftSet; + list : TThriftList; + i : Integer; + tracker : IProtocolRecursionTracker; +begin + tracker := prot.NextRecursionLevel; + case type_ of + // simple types + TType.Bool_ : prot.ReadBool(); + TType.Byte_ : prot.ReadByte(); + TType.I16 : prot.ReadI16(); + TType.I32 : prot.ReadI32(); + TType.I64 : prot.ReadI64(); + TType.Double_ : prot.ReadDouble(); + TType.String_ : prot.ReadBinary();// Don't try to decode the string, just skip it. + + // structured types + TType.Struct : begin + prot.ReadStructBegin(); + while TRUE do begin + field := prot.ReadFieldBegin(); + if (field.Type_ = TType.Stop) then Break; + Skip(prot, field.Type_); + prot.ReadFieldEnd(); + end; + prot.ReadStructEnd(); + end; + + TType.Map : begin + map := prot.ReadMapBegin(); + for i := 0 to map.Count-1 do begin + Skip(prot, map.KeyType); + Skip(prot, map.ValueType); + end; + prot.ReadMapEnd(); + end; + + TType.Set_ : begin + set_ := prot.ReadSetBegin(); + for i := 0 to set_.Count-1 + do Skip( prot, set_.ElementType); + prot.ReadSetEnd(); + end; + + TType.List : begin + list := prot.ReadListBegin(); + for i := 0 to list.Count-1 + do Skip( prot, list.ElementType); + prot.ReadListEnd(); + end; + + else + raise TProtocolExceptionInvalidData.Create('Unexpected type '+IntToStr(Ord(type_))); + end; +end; + + +{ TBinaryProtocolImpl } + +constructor TBinaryProtocolImpl.Create( const trans: ITransport); +begin + //no inherited + Create( trans, False, True); +end; + +constructor TBinaryProtocolImpl.Create( const trans: ITransport; strictRead, + strictWrite: Boolean); +begin + inherited Create( trans ); + FStrictRead := strictRead; + FStrictWrite := strictWrite; +end; + +function TBinaryProtocolImpl.ReadAll( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer ): Integer; +begin + Result := FTrans.ReadAll( pBuf, buflen, off, len ); +end; + +function TBinaryProtocolImpl.ReadBinary: TBytes; +var + size : Integer; + buf : TBytes; +begin + size := ReadI32; + SetLength( buf, size ); + FTrans.ReadAll( buf, 0, size); + Result := buf; +end; + +function TBinaryProtocolImpl.ReadBool: Boolean; +begin + Result := (ReadByte = 1); +end; + +function TBinaryProtocolImpl.ReadByte: ShortInt; +begin + ReadAll( @result, SizeOf(result), 0, 1); +end; + +function TBinaryProtocolImpl.ReadDouble: Double; +begin + Result := ConvertInt64ToDouble( ReadI64 ) +end; + +function TBinaryProtocolImpl.ReadFieldBegin: TThriftField; +begin + Init( result, '', TType( ReadByte), 0); + if ( result.Type_ <> TType.Stop ) then begin + result.Id := ReadI16; + end; +end; + +procedure TBinaryProtocolImpl.ReadFieldEnd; +begin + +end; + +function TBinaryProtocolImpl.ReadI16: SmallInt; +var i16in : packed array[0..1] of Byte; +begin + ReadAll( @i16in, Sizeof(i16in), 0, 2); + Result := SmallInt(((i16in[0] and $FF) shl 8) or (i16in[1] and $FF)); +end; + +function TBinaryProtocolImpl.ReadI32: Integer; +var i32in : packed array[0..3] of Byte; +begin + ReadAll( @i32in, SizeOf(i32in), 0, 4); + + Result := Integer( + ((i32in[0] and $FF) shl 24) or + ((i32in[1] and $FF) shl 16) or + ((i32in[2] and $FF) shl 8) or + (i32in[3] and $FF)); + +end; + +function TBinaryProtocolImpl.ReadI64: Int64; +var i64in : packed array[0..7] of Byte; +begin + ReadAll( @i64in, SizeOf(i64in), 0, 8); + Result := + (Int64( i64in[0] and $FF) shl 56) or + (Int64( i64in[1] and $FF) shl 48) or + (Int64( i64in[2] and $FF) shl 40) or + (Int64( i64in[3] and $FF) shl 32) or + (Int64( i64in[4] and $FF) shl 24) or + (Int64( i64in[5] and $FF) shl 16) or + (Int64( i64in[6] and $FF) shl 8) or + (Int64( i64in[7] and $FF)); +end; + +function TBinaryProtocolImpl.ReadListBegin: TThriftList; +begin + result.ElementType := TType(ReadByte); + result.Count := ReadI32; +end; + +procedure TBinaryProtocolImpl.ReadListEnd; +begin + +end; + +function TBinaryProtocolImpl.ReadMapBegin: TThriftMap; +begin + result.KeyType := TType(ReadByte); + result.ValueType := TType(ReadByte); + result.Count := ReadI32; +end; + +procedure TBinaryProtocolImpl.ReadMapEnd; +begin + +end; + +function TBinaryProtocolImpl.ReadMessageBegin: TThriftMessage; +var + size : Integer; + version : Integer; +begin + Init( result); + size := ReadI32; + if (size < 0) then begin + version := size and Integer( VERSION_MASK); + if ( version <> Integer( VERSION_1)) then begin + raise TProtocolExceptionBadVersion.Create('Bad version in ReadMessageBegin: ' + IntToStr(version) ); + end; + result.Type_ := TMessageType( size and $000000ff); + result.Name := ReadString; + result.SeqID := ReadI32; + end + else begin + if FStrictRead then begin + raise TProtocolExceptionBadVersion.Create('Missing version in readMessageBegin, old client?' ); + end; + result.Name := ReadStringBody( size ); + result.Type_ := TMessageType( ReadByte ); + result.SeqID := ReadI32; + end; +end; + +procedure TBinaryProtocolImpl.ReadMessageEnd; +begin + inherited; + +end; + +function TBinaryProtocolImpl.ReadSetBegin: TThriftSet; +begin + result.ElementType := TType(ReadByte); + result.Count := ReadI32; +end; + +procedure TBinaryProtocolImpl.ReadSetEnd; +begin + +end; + +function TBinaryProtocolImpl.ReadStringBody( size: Integer): string; +var + buf : TBytes; +begin + SetLength( buf, size ); + FTrans.ReadAll( buf, 0, size ); + Result := TEncoding.UTF8.GetString( buf); +end; + +function TBinaryProtocolImpl.ReadStructBegin: TThriftStruct; +begin + Init( Result); +end; + +procedure TBinaryProtocolImpl.ReadStructEnd; +begin + inherited; + +end; + +procedure TBinaryProtocolImpl.WriteBinary( const b: TBytes); +var iLen : Integer; +begin + iLen := Length(b); + WriteI32( iLen); + if iLen > 0 then FTrans.Write(b, 0, iLen); +end; + +procedure TBinaryProtocolImpl.WriteBool(b: Boolean); +begin + if b then begin + WriteByte( 1 ); + end else begin + WriteByte( 0 ); + end; +end; + +procedure TBinaryProtocolImpl.WriteByte(b: ShortInt); +begin + FTrans.Write( @b, 0, 1); +end; + +procedure TBinaryProtocolImpl.WriteDouble( const d: Double); +begin + WriteI64(ConvertDoubleToInt64(d)); +end; + +procedure TBinaryProtocolImpl.WriteFieldBegin( const field: TThriftField); +begin + WriteByte(ShortInt(field.Type_)); + WriteI16(field.ID); +end; + +procedure TBinaryProtocolImpl.WriteFieldEnd; +begin + +end; + +procedure TBinaryProtocolImpl.WriteFieldStop; +begin + WriteByte(ShortInt(TType.Stop)); +end; + +procedure TBinaryProtocolImpl.WriteI16(i16: SmallInt); +var i16out : packed array[0..1] of Byte; +begin + i16out[0] := Byte($FF and (i16 shr 8)); + i16out[1] := Byte($FF and i16); + FTrans.Write( @i16out, 0, 2); +end; + +procedure TBinaryProtocolImpl.WriteI32(i32: Integer); +var i32out : packed array[0..3] of Byte; +begin + i32out[0] := Byte($FF and (i32 shr 24)); + i32out[1] := Byte($FF and (i32 shr 16)); + i32out[2] := Byte($FF and (i32 shr 8)); + i32out[3] := Byte($FF and i32); + FTrans.Write( @i32out, 0, 4); +end; + +procedure TBinaryProtocolImpl.WriteI64( const i64: Int64); +var i64out : packed array[0..7] of Byte; +begin + i64out[0] := Byte($FF and (i64 shr 56)); + i64out[1] := Byte($FF and (i64 shr 48)); + i64out[2] := Byte($FF and (i64 shr 40)); + i64out[3] := Byte($FF and (i64 shr 32)); + i64out[4] := Byte($FF and (i64 shr 24)); + i64out[5] := Byte($FF and (i64 shr 16)); + i64out[6] := Byte($FF and (i64 shr 8)); + i64out[7] := Byte($FF and i64); + FTrans.Write( @i64out, 0, 8); +end; + +procedure TBinaryProtocolImpl.WriteListBegin( const list: TThriftList); +begin + WriteByte(ShortInt(list.ElementType)); + WriteI32(list.Count); +end; + +procedure TBinaryProtocolImpl.WriteListEnd; +begin + +end; + +procedure TBinaryProtocolImpl.WriteMapBegin( const map: TThriftMap); +begin + WriteByte(ShortInt(map.KeyType)); + WriteByte(ShortInt(map.ValueType)); + WriteI32(map.Count); +end; + +procedure TBinaryProtocolImpl.WriteMapEnd; +begin + +end; + +procedure TBinaryProtocolImpl.WriteMessageBegin( const msg: TThriftMessage); +var + version : Cardinal; +begin + if FStrictWrite then + begin + version := VERSION_1 or Cardinal( msg.Type_); + WriteI32( Integer( version) ); + WriteString( msg.Name); + WriteI32( msg.SeqID); + end else + begin + WriteString( msg.Name); + WriteByte(ShortInt( msg.Type_)); + WriteI32( msg.SeqID); + end; +end; + +procedure TBinaryProtocolImpl.WriteMessageEnd; +begin + +end; + +procedure TBinaryProtocolImpl.WriteSetBegin( const set_: TThriftSet); +begin + WriteByte(ShortInt(set_.ElementType)); + WriteI32(set_.Count); +end; + +procedure TBinaryProtocolImpl.WriteSetEnd; +begin + +end; + +procedure TBinaryProtocolImpl.WriteStructBegin( const struc: TThriftStruct); +begin + +end; + +procedure TBinaryProtocolImpl.WriteStructEnd; +begin + +end; + +{ TProtocolException } + +constructor TProtocolException.HiddenCreate(const Msg: string); +begin + inherited Create(Msg); +end; + +class function TProtocolException.Create(const Msg: string): TProtocolException; +begin + Result := TProtocolExceptionUnknown.Create(Msg); +end; + +class function TProtocolException.Create: TProtocolException; +begin + Result := TProtocolExceptionUnknown.Create(''); +end; + +class function TProtocolException.Create(type_: Integer): TProtocolException; +begin +{$WARN SYMBOL_DEPRECATED OFF} + Result := Create(type_, ''); +{$WARN SYMBOL_DEPRECATED DEFAULT} +end; + +class function TProtocolException.Create(type_: Integer; const msg: string): TProtocolException; +begin + case type_ of + INVALID_DATA: Result := TProtocolExceptionInvalidData.Create(msg); + NEGATIVE_SIZE: Result := TProtocolExceptionNegativeSize.Create(msg); + SIZE_LIMIT: Result := TProtocolExceptionSizeLimit.Create(msg); + BAD_VERSION: Result := TProtocolExceptionBadVersion.Create(msg); + NOT_IMPLEMENTED: Result := TProtocolExceptionNotImplemented.Create(msg); + DEPTH_LIMIT: Result := TProtocolExceptionDepthLimit.Create(msg); + else + Result := TProtocolExceptionUnknown.Create(msg); + end; +end; + +{ TProtocolExceptionSpecialized } + +constructor TProtocolExceptionSpecialized.Create(const Msg: string); +begin + inherited HiddenCreate(Msg); +end; + +{ TBinaryProtocolImpl.TFactory } + +constructor TBinaryProtocolImpl.TFactory.Create(AStrictRead, AStrictWrite: Boolean); +begin + inherited Create; + FStrictRead := AStrictRead; + FStrictWrite := AStrictWrite; +end; + +constructor TBinaryProtocolImpl.TFactory.Create; +begin + //no inherited; + Create( False, True ) +end; + +function TBinaryProtocolImpl.TFactory.GetProtocol( const trans: ITransport): IProtocol; +begin + Result := TBinaryProtocolImpl.Create( trans, FStrictRead, FStrictWrite); +end; + + +{ TProtocolDecorator } + +constructor TProtocolDecorator.Create( const aProtocol : IProtocol); +begin + ASSERT( aProtocol <> nil); + inherited Create( aProtocol.Transport); + FWrappedProtocol := aProtocol; +end; + + +procedure TProtocolDecorator.WriteMessageBegin( const msg: TThriftMessage); +begin + FWrappedProtocol.WriteMessageBegin( msg); +end; + + +procedure TProtocolDecorator.WriteMessageEnd; +begin + FWrappedProtocol.WriteMessageEnd; +end; + + +procedure TProtocolDecorator.WriteStructBegin( const struc: TThriftStruct); +begin + FWrappedProtocol.WriteStructBegin( struc); +end; + + +procedure TProtocolDecorator.WriteStructEnd; +begin + FWrappedProtocol.WriteStructEnd; +end; + + +procedure TProtocolDecorator.WriteFieldBegin( const field: TThriftField); +begin + FWrappedProtocol.WriteFieldBegin( field); +end; + + +procedure TProtocolDecorator.WriteFieldEnd; +begin + FWrappedProtocol.WriteFieldEnd; +end; + + +procedure TProtocolDecorator.WriteFieldStop; +begin + FWrappedProtocol.WriteFieldStop; +end; + + +procedure TProtocolDecorator.WriteMapBegin( const map: TThriftMap); +begin + FWrappedProtocol.WriteMapBegin( map); +end; + + +procedure TProtocolDecorator.WriteMapEnd; +begin + FWrappedProtocol.WriteMapEnd; +end; + + +procedure TProtocolDecorator.WriteListBegin( const list: TThriftList); +begin + FWrappedProtocol.WriteListBegin( list); +end; + + +procedure TProtocolDecorator.WriteListEnd(); +begin + FWrappedProtocol.WriteListEnd(); +end; + + +procedure TProtocolDecorator.WriteSetBegin( const set_: TThriftSet ); +begin + FWrappedProtocol.WriteSetBegin( set_); +end; + + +procedure TProtocolDecorator.WriteSetEnd(); +begin + FWrappedProtocol.WriteSetEnd(); +end; + + +procedure TProtocolDecorator.WriteBool( b: Boolean); +begin + FWrappedProtocol.WriteBool( b); +end; + + +procedure TProtocolDecorator.WriteByte( b: ShortInt); +begin + FWrappedProtocol.WriteByte( b); +end; + + +procedure TProtocolDecorator.WriteI16( i16: SmallInt); +begin + FWrappedProtocol.WriteI16( i16); +end; + + +procedure TProtocolDecorator.WriteI32( i32: Integer); +begin + FWrappedProtocol.WriteI32( i32); +end; + + +procedure TProtocolDecorator.WriteI64( const i64: Int64); +begin + FWrappedProtocol.WriteI64( i64); +end; + + +procedure TProtocolDecorator.WriteDouble( const d: Double); +begin + FWrappedProtocol.WriteDouble( d); +end; + + +procedure TProtocolDecorator.WriteString( const s: string ); +begin + FWrappedProtocol.WriteString( s); +end; + + +procedure TProtocolDecorator.WriteAnsiString( const s: AnsiString); +begin + FWrappedProtocol.WriteAnsiString( s); +end; + + +procedure TProtocolDecorator.WriteBinary( const b: TBytes); +begin + FWrappedProtocol.WriteBinary( b); +end; + + +function TProtocolDecorator.ReadMessageBegin: TThriftMessage; +begin + result := FWrappedProtocol.ReadMessageBegin; +end; + + +procedure TProtocolDecorator.ReadMessageEnd(); +begin + FWrappedProtocol.ReadMessageEnd(); +end; + + +function TProtocolDecorator.ReadStructBegin: TThriftStruct; +begin + result := FWrappedProtocol.ReadStructBegin; +end; + + +procedure TProtocolDecorator.ReadStructEnd; +begin + FWrappedProtocol.ReadStructEnd; +end; + + +function TProtocolDecorator.ReadFieldBegin: TThriftField; +begin + result := FWrappedProtocol.ReadFieldBegin; +end; + + +procedure TProtocolDecorator.ReadFieldEnd(); +begin + FWrappedProtocol.ReadFieldEnd(); +end; + + +function TProtocolDecorator.ReadMapBegin: TThriftMap; +begin + result := FWrappedProtocol.ReadMapBegin; +end; + + +procedure TProtocolDecorator.ReadMapEnd(); +begin + FWrappedProtocol.ReadMapEnd(); +end; + + +function TProtocolDecorator.ReadListBegin: TThriftList; +begin + result := FWrappedProtocol.ReadListBegin; +end; + + +procedure TProtocolDecorator.ReadListEnd(); +begin + FWrappedProtocol.ReadListEnd(); +end; + + +function TProtocolDecorator.ReadSetBegin: TThriftSet; +begin + result := FWrappedProtocol.ReadSetBegin; +end; + + +procedure TProtocolDecorator.ReadSetEnd(); +begin + FWrappedProtocol.ReadSetEnd(); +end; + + +function TProtocolDecorator.ReadBool: Boolean; +begin + result := FWrappedProtocol.ReadBool; +end; + + +function TProtocolDecorator.ReadByte: ShortInt; +begin + result := FWrappedProtocol.ReadByte; +end; + + +function TProtocolDecorator.ReadI16: SmallInt; +begin + result := FWrappedProtocol.ReadI16; +end; + + +function TProtocolDecorator.ReadI32: Integer; +begin + result := FWrappedProtocol.ReadI32; +end; + + +function TProtocolDecorator.ReadI64: Int64; +begin + result := FWrappedProtocol.ReadI64; +end; + + +function TProtocolDecorator.ReadDouble:Double; +begin + result := FWrappedProtocol.ReadDouble; +end; + + +function TProtocolDecorator.ReadBinary: TBytes; +begin + result := FWrappedProtocol.ReadBinary; +end; + + +function TProtocolDecorator.ReadString: string; +begin + result := FWrappedProtocol.ReadString; +end; + + +function TProtocolDecorator.ReadAnsiString: AnsiString; +begin + result := FWrappedProtocol.ReadAnsiString; +end; + + +{ Init helper functions } + +procedure Init( var rec : TThriftMessage; const AName: string; const AMessageType: TMessageType; const ASeqID: Integer); +begin + rec.Name := AName; + rec.Type_ := AMessageType; + rec.SeqID := ASeqID; +end; + + +procedure Init( var rec : TThriftStruct; const AName: string = ''); +begin + rec.Name := AName; +end; + + +procedure Init( var rec : TThriftField; const AName: string; const AType: TType; const AID: SmallInt); +begin + rec.Name := AName; + rec.Type_ := AType; + rec.Id := AId; +end; + + +procedure Init( var rec : TThriftMap; const AKeyType, AValueType: TType; const ACount: Integer); +begin + rec.ValueType := AValueType; + rec.KeyType := AKeyType; + rec.Count := ACount; +end; + + +procedure Init( var rec : TThriftSet; const AElementType: TType; const ACount: Integer); +begin + rec.Count := ACount; + rec.ElementType := AElementType; +end; + + +procedure Init( var rec : TThriftList; const AElementType: TType; const ACount: Integer); +begin + rec.Count := ACount; + rec.ElementType := AElementType; +end; + + + + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Serializer.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Serializer.pas new file mode 100644 index 000000000..5f2905a97 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Serializer.pas @@ -0,0 +1,230 @@ +(* + * 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.Serializer; + +{$I Thrift.Defines.inc} + +interface + +uses + {$IFDEF OLD_UNIT_NAMES} + Classes, Windows, SysUtils, + {$ELSE} + System.Classes, Winapi.Windows, System.SysUtils, + {$ENDIF} + Thrift.Protocol, + Thrift.Transport, + Thrift.Stream; + + +type + // Generic utility for easily serializing objects into a byte array or Stream. + TSerializer = class + private + FStream : TMemoryStream; + FTransport : ITransport; + FProtocol : IProtocol; + + public + // Create a new TSerializer that uses the TBinaryProtocol by default. + constructor Create; overload; + + // Create a new TSerializer. + // It will use the TProtocol specified by the factory that is passed in. + constructor Create( const factory : IProtocolFactory); overload; + + // DTOR + destructor Destroy; override; + + // Serialize the Thrift object. + function Serialize( const input : IBase) : TBytes; overload; + procedure Serialize( const input : IBase; const aStm : TStream); overload; + end; + + + // Generic utility for easily deserializing objects from byte array or Stream. + TDeserializer = class + private + FStream : TMemoryStream; + FTransport : ITransport; + FProtocol : IProtocol; + + public + // Create a new TDeserializer that uses the TBinaryProtocol by default. + constructor Create; overload; + + // Create a new TDeserializer. + // It will use the TProtocol specified by the factory that is passed in. + constructor Create( const factory : IProtocolFactory); overload; + + // DTOR + destructor Destroy; override; + + // Deserialize the Thrift object data. + procedure Deserialize( const input : TBytes; const target : IBase); overload; + procedure Deserialize( const input : TStream; const target : IBase); overload; + end; + + + +implementation + + +{ TSerializer } + + +constructor TSerializer.Create(); +// Create a new TSerializer that uses the TBinaryProtocol by default. +begin + //no inherited; + Create( TBinaryProtocolImpl.TFactory.Create); +end; + + +constructor TSerializer.Create( const factory : IProtocolFactory); +// Create a new TSerializer. +// It will use the TProtocol specified by the factory that is passed in. +var adapter : IThriftStream; +begin + inherited Create; + FStream := TMemoryStream.Create; + adapter := TThriftStreamAdapterDelphi.Create( FStream, FALSE); + FTransport := TStreamTransportImpl.Create( nil, adapter); + FProtocol := factory.GetProtocol( FTransport); +end; + + +destructor TSerializer.Destroy; +begin + try + FProtocol := nil; + FTransport := nil; + FreeAndNil( FStream); + finally + inherited Destroy; + end; +end; + + +function TSerializer.Serialize( const input : IBase) : TBytes; +// Serialize the Thrift object into a byte array. The process is simple, +// just clear the byte array output, write the object into it, and grab the +// raw bytes. +var iBytes : Int64; +begin + try + FStream.Size := 0; + input.Write( FProtocol); + SetLength( result, FStream.Size); + iBytes := Length(result); + if iBytes > 0 + then Move( FStream.Memory^, result[0], iBytes); + finally + FStream.Size := 0; // free any allocated memory + end; +end; + + +procedure TSerializer.Serialize( const input : IBase; const aStm : TStream); +// Serialize the Thrift object into a byte array. The process is simple, +// just clear the byte array output, write the object into it, and grab the +// raw bytes. +const COPY_ENTIRE_STREAM = 0; +begin + try + FStream.Size := 0; + input.Write( FProtocol); + aStm.CopyFrom( FStream, COPY_ENTIRE_STREAM); + finally + FStream.Size := 0; // free any allocated memory + end; +end; + + +{ TDeserializer } + + +constructor TDeserializer.Create(); +// Create a new TDeserializer that uses the TBinaryProtocol by default. +begin + //no inherited; + Create( TBinaryProtocolImpl.TFactory.Create); +end; + + +constructor TDeserializer.Create( const factory : IProtocolFactory); +// Create a new TDeserializer. +// It will use the TProtocol specified by the factory that is passed in. +var adapter : IThriftStream; +begin + inherited Create; + FStream := TMemoryStream.Create; + adapter := TThriftStreamAdapterDelphi.Create( FStream, FALSE); + FTransport := TStreamTransportImpl.Create( adapter, nil); + FProtocol := factory.GetProtocol( FTransport); +end; + + +destructor TDeserializer.Destroy; +begin + try + FProtocol := nil; + FTransport := nil; + FreeAndNil( FStream); + finally + inherited Destroy; + end; +end; + + +procedure TDeserializer.Deserialize( const input : TBytes; const target : IBase); +// Deserialize the Thrift object data from the byte array. +var iBytes : Int64; +begin + try + iBytes := Length(input); + FStream.Size := iBytes; + if iBytes > 0 + then Move( input[0], FStream.Memory^, iBytes); + + target.Read( FProtocol); + finally + FStream.Size := 0; // free any allocated memory + end; +end; + + +procedure TDeserializer.Deserialize( const input : TStream; const target : IBase); +// Deserialize the Thrift object data from the byte array. +const COPY_ENTIRE_STREAM = 0; +var before : Int64; +begin + try + before := FStream.Position; + FStream.CopyFrom( input, COPY_ENTIRE_STREAM); + FStream.Position := before; + target.Read( FProtocol); + finally + FStream.Size := 0; // free any allocated memory + end; +end; + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Server.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Server.pas new file mode 100644 index 000000000..13c5762cf --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Server.pas @@ -0,0 +1,423 @@ +(* + * 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.Server; + +{$I Thrift.Defines.inc} +{$I-} // prevent annoying errors with default log delegate and no console + +interface + +uses + {$IFDEF OLD_UNIT_NAMES} + Windows, SysUtils, + {$ELSE} + Winapi.Windows, System.SysUtils, + {$ENDIF} + Thrift, + Thrift.Protocol, + Thrift.Transport; + +type + IServerEvents = interface + ['{9E2A99C5-EE85-40B2-9A52-2D1722B18176}'] + // Called before the server begins. + procedure PreServe; + // Called when the server transport is ready to accept requests + procedure PreAccept; + // Called when a new client has connected and the server is about to being processing. + function CreateProcessingContext( const input, output : IProtocol) : IProcessorEvents; + end; + + + IServer = interface + ['{ADC46F2D-8199-4D1C-96D2-87FD54351723}'] + procedure Serve; + procedure Stop; + + function GetServerEvents : IServerEvents; + procedure SetServerEvents( const value : IServerEvents); + + property ServerEvents : IServerEvents read GetServerEvents write SetServerEvents; + end; + + TServerImpl = class abstract( TInterfacedObject, IServer ) + public + type + TLogDelegate = reference to procedure( const str: string); + protected + FProcessor : IProcessor; + FServerTransport : IServerTransport; + FInputTransportFactory : ITransportFactory; + FOutputTransportFactory : ITransportFactory; + FInputProtocolFactory : IProtocolFactory; + FOutputProtocolFactory : IProtocolFactory; + FLogDelegate : TLogDelegate; + FServerEvents : IServerEvents; + + class procedure DefaultLogDelegate( const str: string); + + function GetServerEvents : IServerEvents; + procedure SetServerEvents( const value : IServerEvents); + + procedure Serve; virtual; abstract; + procedure Stop; virtual; abstract; + public + constructor Create( + const AProcessor :IProcessor; + const AServerTransport: IServerTransport; + const AInputTransportFactory : ITransportFactory; + const AOutputTransportFactory : ITransportFactory; + const AInputProtocolFactory : IProtocolFactory; + const AOutputProtocolFactory : IProtocolFactory; + const ALogDelegate : TLogDelegate + ); overload; + + constructor Create( + const AProcessor :IProcessor; + const AServerTransport: IServerTransport + ); overload; + + constructor Create( + const AProcessor :IProcessor; + const AServerTransport: IServerTransport; + const ALogDelegate: TLogDelegate + ); overload; + + constructor Create( + const AProcessor :IProcessor; + const AServerTransport: IServerTransport; + const ATransportFactory : ITransportFactory + ); overload; + + constructor Create( + const AProcessor :IProcessor; + const AServerTransport: IServerTransport; + const ATransportFactory : ITransportFactory; + const AProtocolFactory : IProtocolFactory + ); overload; + end; + + TSimpleServer = class( TServerImpl) + private + FStop : Boolean; + public + constructor Create( const AProcessor: IProcessor; const AServerTransport: IServerTransport); overload; + constructor Create( const AProcessor: IProcessor; const AServerTransport: IServerTransport; + ALogDel: TServerImpl.TLogDelegate); overload; + constructor Create( const AProcessor: IProcessor; const AServerTransport: IServerTransport; + const ATransportFactory: ITransportFactory); overload; + constructor Create( const AProcessor: IProcessor; const AServerTransport: IServerTransport; + const ATransportFactory: ITransportFactory; const AProtocolFactory: IProtocolFactory); overload; + + procedure Serve; override; + procedure Stop; override; + end; + + +implementation + +{ TServerImpl } + +constructor TServerImpl.Create( const AProcessor: IProcessor; + const AServerTransport: IServerTransport; const ALogDelegate: TLogDelegate); +var + InputFactory, OutputFactory : IProtocolFactory; + InputTransFactory, OutputTransFactory : ITransportFactory; + +begin + InputFactory := TBinaryProtocolImpl.TFactory.Create; + OutputFactory := TBinaryProtocolImpl.TFactory.Create; + InputTransFactory := TTransportFactoryImpl.Create; + OutputTransFactory := TTransportFactoryImpl.Create; + + //no inherited; + Create( + AProcessor, + AServerTransport, + InputTransFactory, + OutputTransFactory, + InputFactory, + OutputFactory, + ALogDelegate + ); +end; + +constructor TServerImpl.Create(const AProcessor: IProcessor; + const AServerTransport: IServerTransport); +var + InputFactory, OutputFactory : IProtocolFactory; + InputTransFactory, OutputTransFactory : ITransportFactory; + +begin + InputFactory := TBinaryProtocolImpl.TFactory.Create; + OutputFactory := TBinaryProtocolImpl.TFactory.Create; + InputTransFactory := TTransportFactoryImpl.Create; + OutputTransFactory := TTransportFactoryImpl.Create; + + //no inherited; + Create( + AProcessor, + AServerTransport, + InputTransFactory, + OutputTransFactory, + InputFactory, + OutputFactory, + DefaultLogDelegate + ); +end; + +constructor TServerImpl.Create(const AProcessor: IProcessor; + const AServerTransport: IServerTransport; const ATransportFactory: ITransportFactory); +var + InputProtocolFactory : IProtocolFactory; + OutputProtocolFactory : IProtocolFactory; +begin + InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create; + OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create; + + //no inherited; + Create( AProcessor, AServerTransport, ATransportFactory, ATransportFactory, + InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate); +end; + +constructor TServerImpl.Create(const AProcessor: IProcessor; + const AServerTransport: IServerTransport; + const AInputTransportFactory, AOutputTransportFactory: ITransportFactory; + const AInputProtocolFactory, AOutputProtocolFactory: IProtocolFactory; + const ALogDelegate : TLogDelegate); +begin + inherited Create; + FProcessor := AProcessor; + FServerTransport := AServerTransport; + FInputTransportFactory := AInputTransportFactory; + FOutputTransportFactory := AOutputTransportFactory; + FInputProtocolFactory := AInputProtocolFactory; + FOutputProtocolFactory := AOutputProtocolFactory; + FLogDelegate := ALogDelegate; +end; + +class procedure TServerImpl.DefaultLogDelegate( const str: string); +begin + try + Writeln( str); + if IoResult <> 0 then OutputDebugString(PChar(str)); + except + OutputDebugString(PChar(str)); + end; +end; + +constructor TServerImpl.Create( const AProcessor: IProcessor; + const AServerTransport: IServerTransport; const ATransportFactory: ITransportFactory; + const AProtocolFactory: IProtocolFactory); +begin + //no inherited; + Create( AProcessor, AServerTransport, + ATransportFactory, ATransportFactory, + AProtocolFactory, AProtocolFactory, + DefaultLogDelegate); +end; + + +function TServerImpl.GetServerEvents : IServerEvents; +begin + result := FServerEvents; +end; + + +procedure TServerImpl.SetServerEvents( const value : IServerEvents); +begin + // if you need more than one, provide a specialized IServerEvents implementation + FServerEvents := value; +end; + + +{ TSimpleServer } + +constructor TSimpleServer.Create( const AProcessor: IProcessor; + const AServerTransport: IServerTransport); +var + InputProtocolFactory : IProtocolFactory; + OutputProtocolFactory : IProtocolFactory; + InputTransportFactory : ITransportFactory; + OutputTransportFactory : ITransportFactory; +begin + InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create; + OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create; + InputTransportFactory := TTransportFactoryImpl.Create; + OutputTransportFactory := TTransportFactoryImpl.Create; + + inherited Create( AProcessor, AServerTransport, InputTransportFactory, + OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate); +end; + +constructor TSimpleServer.Create( const AProcessor: IProcessor; + const AServerTransport: IServerTransport; ALogDel: TServerImpl.TLogDelegate); +var + InputProtocolFactory : IProtocolFactory; + OutputProtocolFactory : IProtocolFactory; + InputTransportFactory : ITransportFactory; + OutputTransportFactory : ITransportFactory; +begin + InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create; + OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create; + InputTransportFactory := TTransportFactoryImpl.Create; + OutputTransportFactory := TTransportFactoryImpl.Create; + + inherited Create( AProcessor, AServerTransport, InputTransportFactory, + OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, ALogDel); +end; + +constructor TSimpleServer.Create( const AProcessor: IProcessor; + const AServerTransport: IServerTransport; const ATransportFactory: ITransportFactory); +begin + inherited Create( AProcessor, AServerTransport, ATransportFactory, + ATransportFactory, TBinaryProtocolImpl.TFactory.Create, TBinaryProtocolImpl.TFactory.Create, DefaultLogDelegate); +end; + +constructor TSimpleServer.Create( const AProcessor: IProcessor; + const AServerTransport: IServerTransport; const ATransportFactory: ITransportFactory; + const AProtocolFactory: IProtocolFactory); +begin + inherited Create( AProcessor, AServerTransport, ATransportFactory, + ATransportFactory, AProtocolFactory, AProtocolFactory, DefaultLogDelegate); +end; + +procedure TSimpleServer.Serve; +var + client : ITransport; + InputTransport : ITransport; + OutputTransport : ITransport; + InputProtocol : IProtocol; + OutputProtocol : IProtocol; + context : IProcessorEvents; +begin + try + FServerTransport.Listen; + except + on E: Exception do + begin + FLogDelegate( E.ToString); + end; + end; + + if FServerEvents <> nil + then FServerEvents.PreServe; + + client := nil; + while (not FStop) do + begin + try + // clean up any old instances before waiting for clients + InputTransport := nil; + OutputTransport := nil; + InputProtocol := nil; + OutputProtocol := nil; + + // close any old connections before before waiting for new clients + if client <> nil then try + try + client.Close; + finally + client := nil; + end; + except + // catch all, we can't do much about it at this point + end; + + client := FServerTransport.Accept( procedure + begin + if FServerEvents <> nil + then FServerEvents.PreAccept; + end); + + if client = nil then begin + if FStop + then Abort // silent exception + else raise TTransportExceptionUnknown.Create('ServerTransport.Accept() may not return NULL'); + end; + + FLogDelegate( 'Client Connected!'); + + InputTransport := FInputTransportFactory.GetTransport( client ); + OutputTransport := FOutputTransportFactory.GetTransport( client ); + InputProtocol := FInputProtocolFactory.GetProtocol( InputTransport ); + OutputProtocol := FOutputProtocolFactory.GetProtocol( OutputTransport ); + + if FServerEvents <> nil + then context := FServerEvents.CreateProcessingContext( InputProtocol, OutputProtocol) + else context := nil; + + while not FStop do begin + if context <> nil + then context.Processing( client); + if not FProcessor.Process( InputProtocol, OutputProtocol, context) + then Break; + end; + + except + on E: TTransportException do + begin + if FStop + then FLogDelegate('TSimpleServer was shutting down, caught ' + E.ToString) + else FLogDelegate( E.ToString); + end; + on E: Exception do + begin + FLogDelegate( E.ToString); + end; + end; + + if context <> nil + then begin + context.CleanupContext; + context := nil; + end; + + if InputTransport <> nil then + begin + InputTransport.Close; + end; + if OutputTransport <> nil then + begin + OutputTransport.Close; + end; + end; + + if FStop then + begin + try + FServerTransport.Close; + except + on E: TTransportException do + begin + FLogDelegate('TServerTranport failed on close: ' + E.Message); + end; + end; + FStop := False; + end; +end; + +procedure TSimpleServer.Stop; +begin + FStop := True; + FServerTransport.Close; +end; + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Socket.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Socket.pas new file mode 100644 index 000000000..f0cab79db --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Socket.pas @@ -0,0 +1,1617 @@ +(* + * 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.Socket; + +{$I Thrift.Defines.inc} +{$I-} // prevent annoying errors with default log delegate and no console + +interface +{$IFNDEF OLD_SOCKETS} // not for OLD_SOCKETS + +uses + Winapi.Windows, Winapi.Winsock2; + +const + AI_PASSIVE = $00000001; // Socket address will be used in bind() call + AI_CANONNAME = $00000002; // Return canonical name in first ai_canonname + AI_NUMERICHOST = $00000004; // Nodename must be a numeric address string + AI_NUMERICSERV = $00000008; // Servicename must be a numeric port number + + AI_ALL = $00000100; // Query both IP6 and IP4 with AI_V4MAPPED + AI_ADDRCONFIG = $00000400; // Resolution only if global address configured + AI_V4MAPPED = $00000800; // On v6 failure, query v4 and convert to V4MAPPED format + + AI_NON_AUTHORITATIVE = $00004000; // LUP_NON_AUTHORITATIVE + AI_SECURE = $00008000; // LUP_SECURE + AI_RETURN_PREFERRED_NAMES = $00010000; // LUP_RETURN_PREFERRED_NAMES + + AI_FQDN = $00020000; // Return the FQDN in ai_canonname + AI_FILESERVER = $00040000; // Resolving fileserver name resolution + +type + PAddrInfoA = ^TAddrInfoA; + TAddrInfoA = record + ai_flags: Integer; + ai_family: Integer; + ai_socktype: Integer; + ai_protocol: Integer; + ai_addrlen: NativeUInt; + ai_canonname: PAnsiChar; + ai_addr: PSockAddr; + ai_next: PAddrInfoA; + end; + + PAddrInfoW = ^TAddrInfoW; + TAddrInfoW = record + ai_flags: Integer; + ai_family: Integer; + ai_socktype: Integer; + ai_protocol: Integer; + ai_addrlen: NativeUInt; + ai_canonname: PChar; + ai_addr: PSockAddr; + ai_next: PAddrInfoW; + end; + + TAddressFamily = USHORT; + + TIn6Addr = record + case Integer of + 0: (_Byte: array[0..15] of UCHAR); + 1: (_Word: array[0..7] of USHORT); + end; + + TScopeId = record + public + Value: ULONG; + private + function GetBitField(Loc: Integer): Integer; inline; + procedure SetBitField(Loc: Integer; const aValue: Integer); inline; + public + property Zone: Integer index $0028 read GetBitField write SetBitField; + property Level: Integer index $2804 read GetBitField write SetBitField; + end; + + TSockAddrIn6 = record + sin6_family: TAddressFamily; + sin6_port: USHORT; + sin6_flowinfo: ULONG; + sin6_addr: TIn6Addr; + case Integer of + 0: (sin6_scope_id: ULONG); + 1: (sin6_scope_struct: TScopeId); + end; + PSockAddrIn6 = ^TSockAddrIn6; + +const + NI_NOFQDN = $01; // Only return nodename portion for local hosts + NI_NUMERICHOST = $02; // Return numeric form of the host's address + NI_NAMEREQD = $04; // Error if the host's name not in DNS + NI_NUMERICSERV = $08; // Return numeric form of the service (port #) + NI_DGRAM = $10; // Service is a datagram service + + NI_MAXHOST = 1025; // Max size of a fully-qualified domain name + NI_MAXSERV = 32; // Max size of a service name + +function getaddrinfo(pNodeName, pServiceName: PAnsiChar; const pHints: TAddrInfoA; var ppResult: PAddrInfoA): Integer; stdcall; +function GetAddrInfoW(pNodeName, pServiceName: PWideChar; const pHints: TAddrInfoW; var ppResult: PAddrInfoW): Integer; stdcall; +procedure freeaddrinfo(pAddrInfo: PAddrInfoA); stdcall; +procedure FreeAddrInfoW(pAddrInfo: PAddrInfoW); stdcall; +function getnameinfo(const pSockaddr: TSockAddr; SockaddrLength: Integer; pNodeBuffer: PAnsiChar; NodeBufferSize: DWORD; pServiceBuffer: PAnsiChar; + ServiceBufferSize: DWORD; Flags: Integer): Integer; stdcall; +function GetNameInfoW(const pSockaddr: TSockAddr; SockaddrLength: Integer; pNodeBuffer: PWideChar; NodeBufferSize: DWORD; pServiceBuffer: PWideChar; + ServiceBufferSize: DWORD; Flags: Integer): Integer; stdcall; + +type + TSmartPointerDestroyer<T> = reference to procedure(Value: T); + + ISmartPointer<T> = reference to function: T; + + TSmartPointer<T> = class(TInterfacedObject, ISmartPointer<T>) + private + FValue: T; + FDestroyer: TSmartPointerDestroyer<T>; + public + constructor Create(AValue: T; ADestroyer: TSmartPointerDestroyer<T>); + destructor Destroy; override; + function Invoke: T; + end; + + TBaseSocket = class abstract + public type + TLogDelegate = reference to procedure( const str: string); + strict private + FPort: Integer; + FSocket: Winapi.Winsock2.TSocket; + FSendTimeout, + FRecvTimeout: Longword; + FKeepAlive: Boolean; + FLogDelegate: TLogDelegate; + class constructor Create; + class destructor Destroy; + class procedure DefaultLogDelegate(const Str: string); + protected type + IGetAddrInfoWrapper = interface + function Init: Integer; + function GetRes: PAddrInfoW; + property Res: PAddrInfoW read GetRes; + end; + TGetAddrInfoWrapper = class(TInterfacedObject, IGetAddrInfoWrapper) + strict private + FNode: string; + FService: string; + FHints, + FRes: PAddrInfoW; + public + constructor Create(ANode, AService: string; AHints: PAddrInfoW); + destructor Destroy; override; + function Init: Integer; + function GetRes: PAddrInfoW; + property Res: PAddrInfoW read GetRes; + end; + strict protected + procedure CommonInit; virtual; + function CreateSocket(AAddress: string; APort: Integer): IGetAddrInfoWrapper; + procedure SetRecvTimeout(ARecvTimeout: Longword); virtual; + procedure SetSendTimeout(ASendTimeout: Longword); virtual; + procedure SetKeepAlive(AKeepAlive: Boolean); virtual; + procedure SetSocket(ASocket: Winapi.Winsock2.TSocket); + property LogDelegate: TLogDelegate read FLogDelegate; + public + // + // Constructs a new socket. Note that this does NOT actually connect the + // socket. + // + constructor Create(ALogDelegate: TLogDelegate = nil); overload; + constructor Create(APort: Integer; ALogDelegate: TLogDelegate = nil); overload; + + // + // Destroys the socket object, closing it if necessary. + // + destructor Destroy; override; + + // + // Shuts down communications on the socket + // + procedure Close; virtual; + + // The port that the socket is connected to + property Port: Integer read FPort write FPort; + + // The receive timeout + property RecvTimeout: Longword read FRecvTimeout write SetRecvTimeout; + + // The send timeout + property SendTimeout: Longword read FSendTimeout write SetSendTimeout; + + // Set SO_KEEPALIVE + property KeepAlive: Boolean read FKeepAlive write SetKeepAlive; + + // The underlying socket descriptor + property Socket: Winapi.Winsock2.TSocket read FSocket write SetSocket; + end; + + TSocket = class(TBaseSocket) + strict private type + TCachedPeerAddr = record + case Integer of + 0: (ipv4: TSockAddrIn); + 1: (ipv6: TSockAddrIn6); + end; + strict private + FHost: string; + FPeerHost: string; + FPeerAddress: string; + FPeerPort: Integer; + FInterruptListener: ISmartPointer<Winapi.Winsock2.TSocket>; + FConnTimeout: Longword; + FLingerOn: Boolean; + FLingerVal: Integer; + FNoDelay: Boolean; + FMaxRecvRetries: Longword; + FCachedPeerAddr: TCachedPeerAddr; + procedure InitPeerInfo; + procedure OpenConnection(Res: TBaseSocket.IGetAddrInfoWrapper); + procedure LocalOpen; + procedure SetGenericTimeout(S: Winapi.Winsock2.TSocket; Timeout: Longword; OptName: Integer); + function GetIsOpen: Boolean; + procedure SetNoDelay(ANoDelay: Boolean); + function GetSocketInfo: string; + function GetPeerHost: string; + function GetPeerAddress: string; + function GetPeerPort: Integer; + function GetOrigin: string; + strict protected + procedure CommonInit; override; + procedure SetRecvTimeout(ARecvTimeout: Longword); override; + procedure SetSendTimeout(ASendTimeout: Longword); override; + procedure SetKeepAlive(AKeepAlive: Boolean); override; + public + // + // Constructs a new socket. Note that this does NOT actually connect the + // socket. + // + constructor Create(ALogDelegate: TBaseSocket.TLogDelegate = nil); overload; + + // + // Constructs a new socket. Note that this does NOT actually connect the + // socket. + // + // @param host An IP address or hostname to connect to + // @param port The port to connect on + // + constructor Create(AHost: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload; + + // + // Constructor to create socket from socket descriptor. + // + constructor Create(ASocket: Winapi.Winsock2.TSocket; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload; + + // + // Constructor to create socket from socket descriptor that + // can be interrupted safely. + // + constructor Create(ASocket: Winapi.Winsock2.TSocket; AInterruptListener: ISmartPointer<Winapi.Winsock2.TSocket>; + ALogDelegate: TBaseSocket.TLogDelegate = nil); overload; + + // + // Creates and opens the socket + // + // @throws ETransportationException If the socket could not connect + // + procedure Open; + + // + // Shuts down communications on the socket + // + procedure Close; override; + + // + // Reads from the underlying socket. + // \returns the number of bytes read or 0 indicates EOF + // \throws TTransportException of types: + // Interrupted means the socket was interrupted + // out of a blocking call + // NotOpen means the socket has been closed + // TimedOut means the receive timeout expired + // Unknown means something unexpected happened + // + function Read(var Buf; Len: Integer): Integer; + + // + // Writes to the underlying socket. Loops until done or fail. + // + procedure Write(const Buf; Len: Integer); + + // + // Writes to the underlying socket. Does single send() and returns result. + // + function WritePartial(const Buf; Len: Integer): Integer; + + // + // Returns a cached copy of the peer address. + // + function GetCachedAddress(out Len: Integer): PSockAddr; + + // + // Set a cache of the peer address (used when trivially available: e.g. + // accept() or connect()). Only caches IPV4 and IPV6; unset for others. + // + procedure SetCachedAddress(const Addr: TSockAddr; Len: Integer); + + // + // Controls whether the linger option is set on the socket. + // + // @param on Whether SO_LINGER is on + // @param linger If linger is active, the number of seconds to linger for + // + procedure SetLinger(LingerOn: Boolean; LingerVal: Integer); + + // + // Calls select() on the socket to see if there is more data available. + // + function Peek: Boolean; + + // Whether the socket is alive + property IsOpen: Boolean read GetIsOpen; + + // The host that the socket is connected to + property Host: string read FHost write FHost; + + // Whether to enable or disable Nagle's algorithm + property NoDelay: Boolean read FNoDelay write SetNoDelay; + + // Connect timeout + property ConnTimeout: Longword read FConnTimeout write FConnTimeout; + + // The max number of recv retries in the case of a WSAEWOULDBLOCK + property MaxRecvRetries: Longword read FMaxRecvRetries write FMaxRecvRetries; + + // Socket information formatted as a string <Host: x Port: x> + property SocketInfo: string read GetSocketInfo; + + // The DNS name of the host to which the socket is connected + property PeerHost: string read GetPeerHost; + + // The address of the host to which the socket is connected + property PeerAddress: string read GetPeerAddress; + + // The port of the host to which the socket is connected + property PeerPort: Integer read GetPeerPort; + + // The origin the socket is connected to + property Origin: string read GetOrigin; + end; + + TServerSocketFunc = reference to procedure(sock: Winapi.Winsock2.TSocket); + + TServerSocket = class(TBaseSocket) + strict private + FAddress: string; + FAcceptBacklog, + FRetryLimit, + FRetryDelay, + FTcpSendBuffer, + FTcpRecvBuffer: Integer; + FAcceptTimeout: Longword; + FListening, + FInterruptableChildren: Boolean; + FInterruptSockWriter, // is notified on Interrupt() + FInterruptSockReader, // is used in select with FSocket for interruptability + FChildInterruptSockWriter: Winapi.Winsock2.TSocket; // is notified on InterruptChildren() + FChildInterruptSockReader: ISmartPointer<Winapi.Winsock2.TSocket>; // if FnterruptableChildren this is shared with child TSockets + FListenCallback, + FAcceptCallback: TServerSocketFunc; + function CreateSocketObj(Client: Winapi.Winsock2.TSocket): TSocket; + procedure Notify(NotifySocket: Winapi.Winsock2.TSocket); + procedure SetInterruptableChildren(AValue: Boolean); + strict protected + procedure CommonInit; override; + public const + DEFAULT_BACKLOG = 1024; + public + // + // Constructor. + // + // @param port Port number to bind to + // + constructor Create(APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload; + + // + // Constructor. + // + // @param port Port number to bind to + // @param sendTimeout Socket send timeout + // @param recvTimeout Socket receive timeout + // + constructor Create(APort: Integer; ASendTimeout, ARecvTimeout: Longword; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload; + + // + // Constructor. + // + // @param address Address to bind to + // @param port Port number to bind to + // + constructor Create(AAddress: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload; + + procedure Listen; + function Accept: TSocket; + procedure Interrupt; + procedure InterruptChildren; + procedure Close; override; + + property AcceptBacklog: Integer read FAcceptBacklog write FAcceptBacklog; + property AcceptTimeout: Longword read FAcceptTimeout write FAcceptTimeout; + property RetryLimit: Integer read FRetryLimit write FRetryLimit; + property RetryDelay: Integer read FRetryDelay write FRetryDelay; + property TcpSendBuffer: Integer read FTcpSendBuffer write FTcpSendBuffer; + property TcpRecvBuffer: Integer read FTcpRecvBuffer write FTcpRecvBuffer; + + // When enabled (the default), new children TSockets will be constructed so + // they can be interrupted by TServerTransport.InterruptChildren(). + // This is more expensive in terms of system calls (poll + recv) however + // ensures a connected client cannot interfere with TServer.Stop(). + // + // When disabled, TSocket children do not incur an additional poll() call. + // Server-side reads are more efficient, however a client can interfere with + // the server's ability to shutdown properly by staying connected. + // + // Must be called before listen(); mode cannot be switched after that. + // \throws EPropertyError if listen() has been called + property InterruptableChildren: Boolean read FInterruptableChildren write SetInterruptableChildren; + + // listenCallback gets called just before listen, and after all Thrift + // setsockopt calls have been made. If you have custom setsockopt + // things that need to happen on the listening socket, this is the place to do it. + property ListenCallback: TServerSocketFunc read FListenCallback write FListenCallback; + + // acceptCallback gets called after each accept call, on the newly created socket. + // It is called after all Thrift setsockopt calls have been made. If you have + // custom setsockopt things that need to happen on the accepted + // socket, this is the place to do it. + property AcceptCallback: TServerSocketFunc read FAcceptCallback write FAcceptCallback; + end; + +{$ENDIF} // not for OLD_SOCKETS +implementation +{$IFNDEF OLD_SOCKETS} // not for OLD_SOCKETS + +uses + System.SysUtils, System.Math, System.DateUtils, Thrift.Transport; + +constructor TBaseSocket.TGetAddrInfoWrapper.Create(ANode, AService: string; AHints: PAddrInfoW); +begin + inherited Create; + FNode := ANode; + FService := AService; + FHints := AHints; + FRes := nil; +end; + +destructor TBaseSocket.TGetAddrInfoWrapper.Destroy; +begin + if Assigned(FRes) then + FreeAddrInfoW(FRes); + inherited Destroy; +end; + +function TBaseSocket.TGetAddrInfoWrapper.Init: Integer; +begin + if FRes = nil then + Exit(GetAddrInfoW(@FNode[1], @FService[1], FHints^, FRes)); + Result := 0; +end; + +function TBaseSocket.TGetAddrInfoWrapper.GetRes: PAddrInfoW; +begin + Result := FRes; +end; + +procedure DestroyerOfFineSockets(ssock: Winapi.Winsock2.TSocket); +begin + closesocket(ssock); +end; + +function TScopeId.GetBitField(Loc: Integer): Integer; +begin + Result := (Value shr (Loc shr 8)) and ((1 shl (Loc and $FF)) - 1); +end; + +procedure TScopeId.SetBitField(Loc: Integer; const aValue: Integer); +begin + Value := (Value and ULONG((not ((1 shl (Loc and $FF)) - 1)))) or ULONG(aValue shl (Loc shr 8)); +end; + +function getaddrinfo; external 'ws2_32.dll' name 'getaddrinfo'; +function GetAddrInfoW; external 'ws2_32.dll' name 'GetAddrInfoW'; +procedure freeaddrinfo; external 'ws2_32.dll' name 'freeaddrinfo'; +procedure FreeAddrInfoW; external 'ws2_32.dll' name 'FreeAddrInfoW'; +function getnameinfo; external 'ws2_32.dll' name 'getnameinfo'; +function GetNameInfoW; external 'ws2_32.dll' name 'GetNameInfoW'; + +constructor TSmartPointer<T>.Create(AValue: T; ADestroyer: TSmartPointerDestroyer<T>); +begin + inherited Create; + FValue := AValue; + FDestroyer := ADestroyer; +end; + +destructor TSmartPointer<T>.Destroy; +begin + if Assigned(FDestroyer) then FDestroyer(FValue); + inherited Destroy; +end; + +function TSmartPointer<T>.Invoke: T; +begin + Result := FValue; +end; + +class constructor TBaseSocket.Create; +var + Version: WORD; + Data: WSAData; + Error: Integer; +begin + Version := $0202; + FillChar(Data, SizeOf(Data), 0); + Error := WSAStartup(Version, Data); + if Error <> 0 then + raise Exception.Create('Failed to initialize Winsock.'); +end; + +class destructor TBaseSocket.Destroy; +begin + WSACleanup; +end; + +class procedure TBaseSocket.DefaultLogDelegate(const Str: string); +var + OutStr: string; +begin + OutStr := Format('Thrift: %s %s', [DateTimeToStr(Now, TFormatSettings.Create), Str]); + try + Writeln(OutStr); + if IoResult <> 0 then OutputDebugString(PChar(OutStr)); + except + OutputDebugString(PChar(OutStr)); + end; +end; + +procedure TBaseSocket.CommonInit; +begin + FSocket := INVALID_SOCKET; + FPort := 0; + FSendTimeout := 0; + FRecvTimeout := 0; + FKeepAlive := False; + FLogDelegate := DefaultLogDelegate; +end; + +function TBaseSocket.CreateSocket(AAddress: string; APort: Integer): IGetAddrInfoWrapper; +var + Hints: TAddrInfoW; + Res: PAddrInfoW; + ThePort: array[0..5] of Char; + Error: Integer; +begin + FillChar(Hints, SizeOf(Hints), 0); + Hints.ai_family := PF_UNSPEC; + Hints.ai_socktype := SOCK_STREAM; + Hints.ai_flags := AI_PASSIVE or AI_ADDRCONFIG; + StrFmt(ThePort, '%d', [FPort]); + + Result := TGetAddrInfoWrapper.Create(AAddress, ThePort, @Hints); + Error := Result.Init; + if Error <> 0 then begin + LogDelegate(Format('GetAddrInfoW %d: %s', [Error, SysErrorMessage(Error)])); + Close; + raise TTransportExceptionNotOpen.Create('Could not resolve host for server socket.'); + end; + + // Pick the ipv6 address first since ipv4 addresses can be mapped + // into ipv6 space. + Res := Result.Res; + while Assigned(Res) do begin + if (Res^.ai_family = AF_INET6) or (not Assigned(Res^.ai_next)) then + Break; + Res := Res^.ai_next; + end; + + FSocket := Winapi.Winsock2.socket(Res^.ai_family, Res^.ai_socktype, Res^.ai_protocol); + if FSocket = INVALID_SOCKET then begin + Error := WSAGetLastError; + LogDelegate(Format('TBaseSocket.CreateSocket() socket() %s', [SysErrorMessage(Error)])); + Close; + raise TTransportExceptionNotOpen.Create(Format('socket(): %s', [SysErrorMessage(Error)])); + end; +end; + +procedure TBaseSocket.SetRecvTimeout(ARecvTimeout: Longword); +begin + FRecvTimeout := ARecvTimeout; +end; + +procedure TBaseSocket.SetSendTimeout(ASendTimeout: Longword); +begin + FSendTimeout := ASendTimeout; +end; + +procedure TBaseSocket.SetKeepAlive(AKeepAlive: Boolean); +begin + FKeepAlive := AKeepAlive; +end; + +procedure TBaseSocket.SetSocket(ASocket: Winapi.Winsock2.TSocket); +begin + if FSocket <> INVALID_SOCKET then + Close; + FSocket := ASocket; +end; + +constructor TBaseSocket.Create(ALogDelegate: TLogDelegate); +begin + inherited Create; + CommonInit; + if Assigned(ALogDelegate) then FLogDelegate := ALogDelegate; +end; + +constructor TBaseSocket.Create(APort: Integer; ALogDelegate: TLogDelegate); +begin + inherited Create; + CommonInit; + FPort := APort; + if Assigned(ALogDelegate) then FLogDelegate := ALogDelegate; +end; + +destructor TBaseSocket.Destroy; +begin + Close; + inherited Destroy; +end; + +procedure TBaseSocket.Close; +begin + if FSocket <> INVALID_SOCKET then begin + shutdown(FSocket, SD_BOTH); + closesocket(FSocket); + end; + FSocket := INVALID_SOCKET; +end; + +procedure TSocket.InitPeerInfo; +begin + FCachedPeerAddr.ipv4.sin_family := AF_UNSPEC; + FPeerHost := ''; + FPeerAddress := ''; + FPeerPort := 0; +end; + +procedure TSocket.CommonInit; +begin + inherited CommonInit; + FHost := ''; + FInterruptListener := nil; + FConnTimeout := 0; + FLingerOn := True; + FLingerVal := 0; + FNoDelay := True; + FMaxRecvRetries := 5; + InitPeerInfo; +end; + +procedure TSocket.OpenConnection(Res: TBaseSocket.IGetAddrInfoWrapper); +label + Done; +var + ErrnoCopy: Integer; + Ret, + Ret2: Integer; + Fds: TFdSet; + TVal: TTimeVal; + PTVal: PTimeVal; + Val, + Lon: Integer; + One, + Zero: Cardinal; +begin + if SendTimeout > 0 then SetSendTimeout(SendTimeout); + if RecvTimeout > 0 then SetRecvTimeout(RecvTimeout); + if KeepAlive then SetKeepAlive(KeepAlive); + SetLinger(FLingerOn, FLingerVal); + SetNoDelay(FNoDelay); + + // Set the socket to be non blocking for connect if a timeout exists + Zero := 0; + if FConnTimeout > 0 then begin + One := 1; + if ioctlsocket(Socket, Integer(FIONBIO), One) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TSocket.OpenConnection() ioctlsocket() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('ioctlsocket() failed: %s', [SysErrorMessage(ErrnoCopy)])); + end; + end + else begin + if ioctlsocket(Socket, Integer(FIONBIO), Zero) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TSocket.OpenConnection() ioctlsocket() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('ioctlsocket() failed: %s', [SysErrorMessage(ErrnoCopy)])); + end; + end; + + Ret := connect(Socket, Res.Res^.ai_addr^, Res.Res^.ai_addrlen); + if Ret = 0 then goto Done; + + ErrnoCopy := WSAGetLastError; + if (ErrnoCopy <> WSAEINPROGRESS) and (ErrnoCopy <> WSAEWOULDBLOCK) then begin + LogDelegate(Format('TSocket.OpenConnection() connect() ', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('connect() failed: %s', [SysErrorMessage(ErrnoCopy)])); + end; + + FD_ZERO(Fds); + _FD_SET(Socket, Fds); + if FConnTimeout > 0 then begin + TVal.tv_sec := FConnTimeout div 1000; + TVal.tv_usec := (FConnTimeout mod 1000) * 1000; + PTVal := @TVal; + end + else + PTVal := nil; + Ret := select(1, nil, @Fds, nil, PTVal); + + if Ret > 0 then begin + // Ensure the socket is connected and that there are no errors set + Lon := SizeOf(Val); + Ret2 := getsockopt(Socket, SOL_SOCKET, SO_ERROR, @Val, Lon); + if Ret2 = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TSocket.OpenConnection() getsockopt() ', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('getsockopt(): %s', [SysErrorMessage(ErrnoCopy)])); + end; + // no errors on socket, go to town + if Val = 0 then goto Done; + LogDelegate(Format('TSocket.OpenConnection() error on socket (after select()) ', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('socket OpenConnection() error: %s', [SysErrorMessage(Val)])); + end + else if Ret = 0 then begin + // socket timed out + LogDelegate(Format('TSocket.OpenConnection() timed out ', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create('OpenConnection() timed out'); + end + else begin + // error on select() + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TSocket.OpenConnection() select() ', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('select() failed: %s', [SysErrorMessage(ErrnoCopy)])); + end; + +Done: + // Set socket back to normal mode (blocking) + ioctlsocket(Socket, Integer(FIONBIO), Zero); + SetCachedAddress(Res.Res^.ai_addr^, Res.Res^.ai_addrlen); +end; + +procedure TSocket.LocalOpen; +var + Res: TBaseSocket.IGetAddrInfoWrapper; +begin + if IsOpen then Exit; + + // Validate port number + if (Port < 0) or (Port > $FFFF) then + raise TTransportExceptionBadArgs.Create('Specified port is invalid'); + + Res := CreateSocket(Host, Port); + + OpenConnection(Res); +end; + +procedure TSocket.SetGenericTimeout(S: Winapi.Winsock2.TSocket; Timeout: Longword; OptName: Integer); +var + Time: DWORD; +begin + if S = INVALID_SOCKET then + Exit; + + Time := Timeout; + + if setsockopt(S, SOL_SOCKET, OptName, @Time, SizeOf(Time)) = SOCKET_ERROR then + LogDelegate(Format('SetGenericTimeout() setsockopt() %s', [SysErrorMessage(WSAGetLastError)])); +end; + +function TSocket.GetIsOpen: Boolean; +begin + Result := Socket <> INVALID_SOCKET; +end; + +procedure TSocket.SetNoDelay(ANoDelay: Boolean); +var + V: Integer; +begin + FNoDelay := ANoDelay; + if Socket = INVALID_SOCKET then + Exit; + + V := IfThen(FNoDelay, 1, 0); + if setsockopt(Socket, IPPROTO_TCP, TCP_NODELAY, @V, SizeOf(V)) = SOCKET_ERROR then + LogDelegate(Format('TSocket.SetNoDelay() setsockopt() %s %s', [SocketInfo, SysErrorMessage(WSAGetLastError)])); +end; + +function TSocket.GetSocketInfo: string; +begin + if (FHost = '') or (Port = 0) then + Result := '<Host: ' + GetPeerAddress + ' Port: ' + GetPeerPort.ToString + '>' + else + Result := '<Host: ' + FHost + ' Port: ' + Port.ToString + '>'; +end; + +function TSocket.GetPeerHost: string; +var + Addr: TSockAddrStorage; + AddrPtr: PSockAddr; + AddrLen: Integer; + ClientHost: array[0..NI_MAXHOST-1] of Char; + ClientService: array[0..NI_MAXSERV-1] of Char; +begin + if FPeerHost = '' then begin + if Socket = INVALID_SOCKET then + Exit(FPeerHost); + + AddrPtr := GetCachedAddress(AddrLen); + if AddrPtr = nil then begin + AddrLen := SizeOf(Addr); + if getpeername(Socket, PSockAddr(@Addr)^, AddrLen) <> 0 then + Exit(FPeerHost); + AddrPtr := PSockAddr(@Addr); + SetCachedAddress(AddrPtr^, AddrLen); + end; + + GetNameInfoW(AddrPtr^, AddrLen, ClientHost, NI_MAXHOST, ClientService, NI_MAXSERV, 0); + FPeerHost := ClientHost; + end; + Result := FPeerHost; +end; + +function TSocket.GetPeerAddress: string; +var + Addr: TSockAddrStorage; + AddrPtr: PSockAddr; + AddrLen: Integer; + ClientHost: array[0..NI_MAXHOST-1] of Char; + ClientService: array[0..NI_MAXSERV-1] of Char; +begin + if FPeerAddress = '' then begin + if Socket = INVALID_SOCKET then + Exit(FPeerAddress); + + AddrPtr := GetCachedAddress(AddrLen); + if AddrPtr = nil then begin + AddrLen := SizeOf(Addr); + if getpeername(Socket, PSockAddr(@Addr)^, AddrLen) <> 0 then + Exit(FPeerHost); + AddrPtr := PSockAddr(@Addr); + SetCachedAddress(AddrPtr^, AddrLen); + end; + + GetNameInfoW(AddrPtr^, AddrLen, ClientHost, NI_MAXHOST, ClientService, NI_MAXSERV, NI_NUMERICHOST or NI_NUMERICSERV); + FPeerAddress := ClientHost; + TryStrToInt(ClientService, FPeerPort); + end; + Result := FPeerAddress +end; + +function TSocket.GetPeerPort: Integer; +begin + GetPeerAddress; + Result := FPeerPort; +end; + +function TSocket.GetOrigin: string; +begin + Result := GetPeerHost + ':' + GetPeerPort.ToString; +end; + +procedure TSocket.SetRecvTimeout(ARecvTimeout: Longword); +begin + inherited SetRecvTimeout(ARecvTimeout); + SetGenericTimeout(Socket, ARecvTimeout, SO_RCVTIMEO); +end; + +procedure TSocket.SetSendTimeout(ASendTimeout: Longword); +begin + inherited SetSendTimeout(ASendTimeout); + SetGenericTimeout(Socket, ASendTimeout, SO_SNDTIMEO); +end; + +procedure TSocket.SetKeepAlive(AKeepAlive: Boolean); +var + Value: Integer; +begin + inherited SetKeepAlive(AKeepAlive); + + Value := IfThen(KeepAlive, 1, 0); + if setsockopt(Socket, SOL_SOCKET, SO_KEEPALIVE, @Value, SizeOf(Value)) = SOCKET_ERROR then + LogDelegate(Format('TSocket.SetKeepAlive() setsockopt() %s %s', [SocketInfo, SysErrorMessage(WSAGetLastError)])); +end; + +constructor TSocket.Create(ALogDelegate: TBaseSocket.TLogDelegate = nil); +begin + // Not needed, but just a placeholder + inherited Create(ALogDelegate); +end; + +constructor TSocket.Create(AHost: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate); +begin + inherited Create(APort, ALogDelegate); + FHost := AHost; +end; + +constructor TSocket.Create(ASocket: Winapi.Winsock2.TSocket; ALogDelegate: TBaseSocket.TLogDelegate); +begin + inherited Create(ALogDelegate); + Socket := ASocket; +end; + +constructor TSocket.Create(ASocket: Winapi.Winsock2.TSocket; AInterruptListener: ISmartPointer<Winapi.Winsock2.TSocket>; + ALogDelegate: TBaseSocket.TLogDelegate); +begin + inherited Create(ALogDelegate); + Socket := ASocket; + FInterruptListener := AInterruptListener; +end; + +procedure TSocket.Open; +begin + if IsOpen then Exit; + LocalOpen; +end; + +procedure TSocket.Close; +begin + inherited Close; + InitPeerInfo; +end; + +function TSocket.Read(var Buf; Len: Integer): Integer; +label + TryAgain; +var + Retries: Longword; + EAgainThreshold, + ReadElapsed: UInt64; + Start: TDateTime; + Got: Integer; + Fds: TFdSet; + ErrnoCopy: Integer; + TVal: TTimeVal; + PTVal: PTimeVal; + Ret: Integer; +begin + if Socket = INVALID_SOCKET then + raise TTransportExceptionNotOpen.Create('Called read on non-open socket'); + + Retries := 0; + + // THRIFT_EAGAIN can be signalled both when a timeout has occurred and when + // the system is out of resources (an awesome undocumented feature). + // The following is an approximation of the time interval under which + // THRIFT_EAGAIN is taken to indicate an out of resources error. + EAgainThreshold := 0; + if RecvTimeout <> 0 then + // if a readTimeout is specified along with a max number of recv retries, then + // the threshold will ensure that the read timeout is not exceeded even in the + // case of resource errors + EAgainThreshold := RecvTimeout div IfThen(FMaxRecvRetries > 0, FMaxRecvRetries, 2); + +TryAgain: + // Read from the socket + if RecvTimeout > 0 then + Start := Now + else + // if there is no read timeout we don't need the TOD to determine whether + // an THRIFT_EAGAIN is due to a timeout or an out-of-resource condition. + Start := 0; + + if Assigned(FInterruptListener) then begin + FD_ZERO(Fds); + _FD_SET(Socket, Fds); + _FD_SET(FInterruptListener, Fds); + if RecvTimeout > 0 then begin + TVal.tv_sec := RecvTimeout div 1000; + TVal.tv_usec := (RecvTimeout mod 1000) * 1000; + PTVal := @TVal; + end + else + PTVal := nil; + + Ret := select(2, @Fds, nil, nil, PTVal); + ErrnoCopy := WSAGetLastError; + if Ret < 0 then begin + // error cases + if (ErrnoCopy = WSAEINTR) and (Retries < FMaxRecvRetries) then begin + Inc(Retries); + goto TryAgain; + end; + LogDelegate(Format('TSocket.Read() select() %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)])); + end + else if Ret > 0 then begin + // Check the interruptListener + if FD_ISSET(FInterruptListener, Fds) then + raise TTransportExceptionInterrupted.Create('Interrupted'); + end + else // Ret = 0 + raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (timed out)'); + + // falling through means there is something to recv and it cannot block + end; + + Got := recv(Socket, Buf, Len, 0); + ErrnoCopy := WSAGetLastError; + // Check for error on read + if Got < 0 then begin + if ErrnoCopy = WSAEWOULDBLOCK then begin + // if no timeout we can assume that resource exhaustion has occurred. + if RecvTimeout = 0 then + raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (unavailable resources)'); + // check if this is the lack of resources or timeout case + ReadElapsed := MilliSecondsBetween(Now, Start); + if (EAgainThreshold = 0) or (ReadElapsed < EAgainThreshold) then begin + if Retries < FMaxRecvRetries then begin + Inc(Retries); + Sleep(1); + goto TryAgain; + end + else + raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (unavailable resources)'); + end + else + // infer that timeout has been hit + raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (timed out)'); + end; + + // If interrupted, try again + if (ErrnoCopy = WSAEINTR) and (Retries < FMaxRecvRetries) then begin + Inc(Retries); + goto TryAgain; + end; + + if ErrnoCopy = WSAECONNRESET then + Exit(0); + + // This ish isn't open + if ErrnoCopy = WSAENOTCONN then + raise TTransportExceptionNotOpen.Create('WSAENOTCONN'); + + // Timed out! + if ErrnoCopy = WSAETIMEDOUT then + raise TTransportExceptionNotOpen.Create('WSAETIMEDOUT'); + + // Now it's not a try again case, but a real probblez + LogDelegate(Format('TSocket.Read() recv() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + + // Some other error, whatevz + raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)])); + end; + + Result := Got; +end; + +procedure TSocket.Write(const Buf; Len: Integer); +var + Sent, B: Integer; +begin + Sent := 0; + while Sent < Len do begin + B := WritePartial((PByte(@Buf) + Sent)^, Len - Sent); + if B = 0 then + // This should only happen if the timeout set with SO_SNDTIMEO expired. + // Raise an exception. + raise TTransportExceptionTimedOut.Create('send timeout expired'); + Inc(Sent, B); + end; +end; + +function TSocket.WritePartial(const Buf; Len: Integer): Integer; +var + B: Integer; + ErrnoCopy: Integer; +begin + if Socket = INVALID_SOCKET then + raise TTransportExceptionNotOpen.Create('Called write on non-open socket'); + + B := send(Socket, Buf, Len, 0); + + if B < 0 then begin + // Fail on a send error + ErrnoCopy := WSAGetLastError; + if ErrnoCopy = WSAEWOULDBLOCK then + Exit(0); + + LogDelegate(Format('TSocket.WritePartial() send() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + + if (ErrnoCopy = WSAECONNRESET) or (ErrnoCopy = WSAENOTCONN) then begin + Close; + raise TTransportExceptionNotOpen.Create(Format('write() send(): %s', [SysErrorMessage(ErrnoCopy)])); + end; + + raise TTransportExceptionUnknown.Create(Format('write() send(): %s', [SysErrorMessage(ErrnoCopy)])); + end; + + // Fail on blocked send + if B = 0 then + raise TTransportExceptionNotOpen.Create('Socket send returned 0.'); + + Result := B; +end; + +function TSocket.GetCachedAddress(out Len: Integer): PSockAddr; +begin + case FCachedPeerAddr.ipv4.sin_family of + AF_INET: begin + Len := SizeOf(TSockAddrIn); + Result := PSockAddr(@FCachedPeerAddr.ipv4); + end; + AF_INET6: begin + Len := SizeOf(TSockAddrIn6); + Result := PSockAddr(@FCachedPeerAddr.ipv6); + end; + else + Len := 0; + Result := nil; + end; +end; + +procedure TSocket.SetCachedAddress(const Addr: TSockAddr; Len: Integer); +begin + case Addr.sa_family of + AF_INET: if Len = SizeOf(TSockAddrIn) then FCachedPeerAddr.ipv4 := PSockAddrIn(@Addr)^; + AF_INET6: if Len = SizeOf(TSockAddrIn6) then FCachedPeerAddr.ipv6 := PSockAddrIn6(@Addr)^; + end; + FPeerAddress := ''; + FPeerHost := ''; + FPeerPort := 0; +end; + +procedure TSocket.SetLinger(LingerOn: Boolean; LingerVal: Integer); +var + L: TLinger; +begin + FLingerOn := LingerOn; + FLingerVal := LingerVal; + if Socket = INVALID_SOCKET then + Exit; + + L.l_onoff := IfThen(FLingerOn, 1, 0); + L.l_linger := LingerVal; + + if setsockopt(Socket, SOL_SOCKET, SO_LINGER, @L, SizeOf(L)) = SOCKET_ERROR then + LogDelegate(Format('TSocket.SetLinger() setsockopt() %s %s', [SocketInfo, SysErrorMessage(WSAGetLastError)])); +end; + +function TSocket.Peek: Boolean; +var + Retries: Longword; + Fds: TFdSet; + TVal: TTimeVal; + PTVal: PTimeVal; + Ret: Integer; + ErrnoCopy: Integer; + Buf: Byte; +begin + if not IsOpen then Exit(False); + + if Assigned(FInterruptListener) then begin + Retries := 0; + while true do begin + FD_ZERO(Fds); + _FD_SET(Socket, Fds); + _FD_SET(FInterruptListener, Fds); + if RecvTimeout > 0 then begin + TVal.tv_sec := RecvTimeout div 1000; + TVal.tv_usec := (RecvTimeout mod 1000) * 1000; + PTVal := @TVal; + end + else + PTVal := nil; + + Ret := select(2, @Fds, nil, nil, PTVal); + ErrnoCopy := WSAGetLastError; + if Ret < 0 then begin + // error cases + if (ErrnoCopy = WSAEINTR) and (Retries < FMaxRecvRetries) then begin + Inc(Retries); + Continue; + end; + LogDelegate(Format('TSocket.Peek() select() %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)])); + end + else if Ret > 0 then begin + // Check the interruptListener + if FD_ISSET(FInterruptListener, Fds) then + Exit(False); + // There must be data or a disconnection, fall through to the PEEK + Break; + end + else + // timeout + Exit(False); + end; + end; + + // Check to see if data is available or if the remote side closed + Ret := recv(Socket, Buf, 1, MSG_PEEK); + if Ret = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + if ErrnoCopy = WSAECONNRESET then begin + Close; + Exit(False); + end; + LogDelegate(Format('TSocket.Peek() recv() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionUnknown.Create(Format('recv(): %s', [SysErrorMessage(ErrnoCopy)])); + end; + Result := Ret > 0; +end; + +function TServerSocket.CreateSocketObj(Client: Winapi.Winsock2.TSocket): TSocket; +begin + if FInterruptableChildren then + Result := TSocket.Create(Client, FChildInterruptSockReader) + else + Result := TSocket.Create(Client); +end; + +procedure TServerSocket.Notify(NotifySocket: Winapi.Winsock2.TSocket); +var + Byt: Byte; +begin + if NotifySocket <> INVALID_SOCKET then begin + Byt := 0; + if send(NotifySocket, Byt, SizeOf(Byt), 0) = SOCKET_ERROR then + LogDelegate(Format('TServerSocket.Notify() send() %s', [SysErrorMessage(WSAGetLastError)])); + end; +end; + +procedure TServerSocket.SetInterruptableChildren(AValue: Boolean); +begin + if FListening then + raise Exception.Create('InterruptableChildren cannot be set after listen()'); + FInterruptableChildren := AValue; +end; + +procedure TServerSocket.CommonInit; +begin + inherited CommonInit; + FInterruptableChildren := True; + FAcceptBacklog := DEFAULT_BACKLOG; + FAcceptTimeout := 0; + FRetryLimit := 0; + FRetryDelay := 0; + FTcpSendBuffer := 0; + FTcpRecvBuffer := 0; + FListening := False; + FInterruptSockWriter := INVALID_SOCKET; + FInterruptSockReader := INVALID_SOCKET; + FChildInterruptSockWriter := INVALID_SOCKET; +end; + +constructor TServerSocket.Create(APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil); +begin + // Unnecessary, but here for documentation purposes + inherited Create(APort, ALogDelegate); +end; + +constructor TServerSocket.Create(APort: Integer; ASendTimeout, ARecvTimeout: Longword; ALogDelegate: TBaseSocket.TLogDelegate); +begin + inherited Create(APort, ALogDelegate); + SendTimeout := ASendTimeout; + RecvTimeout := ARecvTimeout; +end; + +constructor TServerSocket.Create(AAddress: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate); +begin + inherited Create(APort, ALogDelegate); + FAddress := AAddress; +end; + +procedure TServerSocket.Listen; + + function CreateSocketPair(var Reader, Writer: Winapi.Winsock2.TSocket): Integer; + label + Error; + type + TSAUnion = record + case Integer of + 0: (inaddr: TSockAddrIn); + 1: (addr: TSockAddr); + end; + var + a: TSAUnion; + listener: Winapi.Winsock2.TSocket; + e: Integer; + addrlen: Integer; + flags: DWORD; + reuse: Integer; + begin + addrlen := SizeOf(a.inaddr); + flags := 0; + reuse := 1; + + listener := Winapi.Winsock2.socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); + if listener = INVALID_SOCKET then + Exit(SOCKET_ERROR); + + FillChar(a, SizeOf(a), 0); + a.inaddr.sin_family := AF_INET; + a.inaddr.sin_addr.s_addr := htonl(INADDR_LOOPBACK); + a.inaddr.sin_port := 0; + Reader := INVALID_SOCKET; + Writer := INVALID_SOCKET; + + // ignore errors coming out of this setsockopt. This is because + // SO_EXCLUSIVEADDRUSE requires admin privileges on WinXP, but we don't + // want to force socket pairs to be an admin. + setsockopt(listener, SOL_SOCKET, Integer(SO_EXCLUSIVEADDRUSE), @reuse, SizeOf(reuse)); + if bind(listener, a.addr, SizeOf(a.inaddr)) = SOCKET_ERROR then + goto Error; + + if getsockname(listener, a.addr, addrlen) = SOCKET_ERROR then + goto Error; + + if Winapi.Winsock2.listen(listener, 1) = SOCKET_ERROR then + goto Error; + + Reader := WSASocket(AF_INET, SOCK_STREAM, 0, nil, 0, flags); + if Reader = INVALID_SOCKET then + goto Error; + + if connect(Reader, a.addr, SizeOf(a.inaddr)) = SOCKET_ERROR then + goto Error; + + Writer := Winapi.Winsock2.accept(listener, nil, nil); + if Writer = INVALID_SOCKET then + goto Error; + + closesocket(listener); + Exit(0); + + Error: + e := WSAGetLastError; + closesocket(listener); + closesocket(Reader); + closesocket(Writer); + WSASetLastError(e); + Result := SOCKET_ERROR; + end; + +var + TempIntReader, + TempIntWriter: Winapi.Winsock2.TSocket; + One: Cardinal; + ErrnoCopy: Integer; + Ling: TLinger; + Retries: Integer; + AddrInfo: IGetAddrInfoWrapper; + SA: TSockAddrStorage; + Len: Integer; +begin + // Create the socket pair used to interrupt + if CreateSocketPair(TempIntReader, TempIntWriter) = SOCKET_ERROR then begin + LogDelegate(Format('TServerSocket.Listen() CreateSocketPair() Interrupt %s', [SysErrorMessage(WSAGetLastError)])); + FInterruptSockReader := INVALID_SOCKET; + FInterruptSockWriter := INVALID_SOCKET; + end + else begin + FInterruptSockReader := TempIntReader; + FInterruptSockWriter := TempIntWriter; + end; + + // Create the socket pair used to interrupt all clients + if CreateSocketPair(TempIntReader, TempIntWriter) = SOCKET_ERROR then begin + LogDelegate(Format('TServerSocket.Listen() CreateSocketPair() ChildInterrupt %s', [SysErrorMessage(WSAGetLastError)])); + FChildInterruptSockReader := TSmartPointer<Winapi.Winsock2.TSocket>.Create(INVALID_SOCKET, nil); + FChildInterruptSockWriter := INVALID_SOCKET; + end + else begin + FChildInterruptSockReader := TSmartPointer<Winapi.Winsock2.TSocket>.Create(TempIntReader, DestroyerOfFineSockets); + FChildInterruptSockWriter := TempIntWriter; + end; + + if (Port < 0) or (Port > $FFFF) then + raise TTransportExceptionBadArgs.Create('Specified port is invalid'); + + AddrInfo := CreateSocket(FAddress, Port); + + // Set SO_EXCLUSIVEADDRUSE to prevent 2MSL delay on accept + One := 1; + setsockopt(Socket, SOL_SOCKET, Integer(SO_EXCLUSIVEADDRUSE), @one, SizeOf(One)); + // ignore errors coming out of this setsockopt on Windows. This is because + // SO_EXCLUSIVEADDRUSE requires admin privileges on WinXP, but we don't + // want to force servers to be an admin. + + // Set TCP buffer sizes + if FTcpSendBuffer > 0 then begin + if setsockopt(Socket, SOL_SOCKET, SO_SNDBUF, @FTcpSendBuffer, SizeOf(FTcpSendBuffer)) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Listen() setsockopt() SO_SNDBUF %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('Could not set SO_SNDBUF: %s', [SysErrorMessage(ErrnoCopy)])); + end; + end; + + if FTcpRecvBuffer > 0 then begin + if setsockopt(Socket, SOL_SOCKET, SO_RCVBUF, @FTcpRecvBuffer, SizeOf(FTcpRecvBuffer)) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Listen() setsockopt() SO_RCVBUF %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('Could not set SO_RCVBUF: %s', [SysErrorMessage(ErrnoCopy)])); + end; + end; + + // Turn linger off, don't want to block on calls to close + Ling.l_onoff := 0; + Ling.l_linger := 0; + if setsockopt(Socket, SOL_SOCKET, SO_LINGER, @Ling, SizeOf(Ling)) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Listen() setsockopt() SO_LINGER %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('Could not set SO_LINGER: %s', [SysErrorMessage(ErrnoCopy)])); + end; + + // TCP Nodelay, speed over bandwidth + if setsockopt(Socket, IPPROTO_TCP, TCP_NODELAY, @One, SizeOf(One)) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Listen() setsockopt() TCP_NODELAY %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('Could not set TCP_NODELAY: %s', [SysErrorMessage(ErrnoCopy)])); + end; + + // Set NONBLOCK on the accept socket + if ioctlsocket(Socket, Integer(FIONBIO), One) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Listen() ioctlsocket() FIONBIO %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('ioctlsocket() FIONBIO: %s', [SysErrorMessage(ErrnoCopy)])); + end; + + // prepare the port information + // we may want to try to bind more than once, since THRIFT_NO_SOCKET_CACHING doesn't + // always seem to work. The client can configure the retry variables. + Retries := 0; + while True do begin + if bind(Socket, AddrInfo.Res^.ai_addr^, AddrInfo.Res^.ai_addrlen) = 0 then + Break; + Inc(Retries); + if Retries > FRetryLimit then + Break; + Sleep(FRetryDelay * 1000); + end; + + // retrieve bind info + if (Port = 0) and (Retries < FRetryLimit) then begin + Len := SizeOf(SA); + FillChar(SA, Len, 0); + if getsockname(Socket, PSockAddr(@SA)^, Len) = SOCKET_ERROR then + LogDelegate(Format('TServerSocket.Listen() getsockname() %s', [SysErrorMessage(WSAGetLastError)])) + else begin + if SA.ss_family = AF_INET6 then + Port := ntohs(PSockAddrIn6(@SA)^.sin6_port) + else + Port := ntohs(PSockAddrIn(@SA)^.sin_port); + end; + end; + + // throw an error if we failed to bind properly + if (Retries > FRetryLimit) then begin + LogDelegate(Format('TServerSocket.Listen() BIND %d', [Port])); + Close; + raise TTransportExceptionNotOpen.Create(Format('Could not bind: %s', [SysErrorMessage(WSAGetLastError)])); + end; + + if Assigned(FListenCallback) then + FListenCallback(Socket); + + // Call listen + if Winapi.Winsock2.listen(Socket, FAcceptBacklog) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Listen() listen() %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionNotOpen.Create(Format('Could not listen: %s', [SysErrorMessage(ErrnoCopy)])); + end; + + // The socket is now listening! +end; + +function TServerSocket.Accept: TSocket; +var + Fds: TFdSet; + MaxEInters, + NumEInters: Integer; + TVal: TTimeVal; + PTVal: PTimeVal; + ErrnoCopy: Integer; + Buf: Byte; + ClientAddress: TSockAddrStorage; + Size: Integer; + ClientSocket: Winapi.Winsock2.TSocket; + Zero: Cardinal; + Client: TSocket; + Ret: Integer; +begin + MaxEInters := 5; + NumEInters := 0; + + while True do begin + FD_ZERO(Fds); + _FD_SET(Socket, Fds); + _FD_SET(FInterruptSockReader, Fds); + if FAcceptTimeout > 0 then begin + TVal.tv_sec := FAcceptTimeout div 1000; + TVal.tv_usec := (FAcceptTimeout mod 1000) * 1000; + PTVal := @TVal; + end + else + PTVal := nil; + + // TODO: if WSAEINTR is received, we'll restart the timeout. + // To be accurate, we need to fix this in the future. + Ret := select(2, @Fds, nil, nil, PTVal); + + if Ret < 0 then begin + // error cases + if (WSAGetLastError = WSAEINTR) and (NumEInters < MaxEInters) then begin + // THRIFT_EINTR needs to be handled manually and we can tolerate + // a certain number + Inc(NumEInters); + Continue; + end; + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Accept() select() %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)])); + end + else if Ret > 0 then begin + // Check for an interrupt signal + if (FInterruptSockReader <> INVALID_SOCKET) and FD_ISSET(FInterruptSockReader, Fds) then begin + if recv(FInterruptSockReader, Buf, SizeOf(Buf), 0) = SOCKET_ERROR then + LogDelegate(Format('TServerSocket.Accept() recv() interrupt %s', [SysErrorMessage(WSAGetLastError)])); + raise TTransportExceptionInterrupted.Create('interrupted'); + end; + + // Check for the actual server socket being ready + if FD_ISSET(Socket, Fds) then + Break; + end + else begin + LogDelegate('TServerSocket.Accept() select() 0'); + raise TTransportExceptionUnknown.Create('unknown error'); + end; + end; + + Size := SizeOf(ClientAddress); + ClientSocket := Winapi.Winsock2.accept(Socket, @ClientAddress, @Size); + if ClientSocket = INVALID_SOCKET then begin + ErrnoCopy := WSAGetLastError; + LogDelegate(Format('TServerSocket.Accept() accept() %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionUnknown.Create(Format('accept(): %s', [SysErrorMessage(ErrnoCopy)])); + end; + + // Make sure client socket is blocking + Zero := 0; + if ioctlsocket(ClientSocket, Integer(FIONBIO), Zero) = SOCKET_ERROR then begin + ErrnoCopy := WSAGetLastError; + closesocket(ClientSocket); + LogDelegate(Format('TServerSocket.Accept() ioctlsocket() FIONBIO %s', [SysErrorMessage(ErrnoCopy)])); + raise TTransportExceptionUnknown.Create(Format('ioctlsocket(): %s', [SysErrorMessage(ErrnoCopy)])); + end; + + Client := CreateSocketObj(ClientSocket); + if SendTimeout > 0 then + Client.SendTimeout := SendTimeout; + if RecvTimeout > 0 then + Client.RecvTimeout := RecvTimeout; + if KeepAlive then + Client.KeepAlive := KeepAlive; + Client.SetCachedAddress(PSockAddr(@ClientAddress)^, Size); + + if Assigned(FAcceptCallback) then + FAcceptCallback(ClientSocket); + + Result := Client; +end; + +procedure TServerSocket.Interrupt; +begin + Notify(FInterruptSockWriter); +end; + +procedure TServerSocket.InterruptChildren; +begin + Notify(FChildInterruptSockWriter); +end; + +procedure TServerSocket.Close; +begin + inherited Close; + if FInterruptSockWriter <> INVALID_SOCKET then + closesocket(FInterruptSockWriter); + if FInterruptSockReader <> INVALID_SOCKET then + closesocket(FInterruptSockReader); + if FChildInterruptSockWriter <> INVALID_SOCKET then + closesocket(FChildInterruptSockWriter); + FChildInterruptSockReader := TSmartPointer<Winapi.Winsock2.TSocket>.Create(INVALID_SOCKET, nil); + FListening := False; +end; + +{$ENDIF} // not for OLD_SOCKETS +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Stream.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Stream.pas new file mode 100644 index 000000000..3308c53a5 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Stream.pas @@ -0,0 +1,319 @@ +(* + * 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.Stream; + +{$I Thrift.Defines.inc} + +interface + +uses + Classes, + SysUtils, + SysConst, + RTLConsts, + {$IFDEF OLD_UNIT_NAMES} + ActiveX, + {$ELSE} + Winapi.ActiveX, + {$ENDIF} + Thrift.Utils; + +type + + IThriftStream = interface + ['{2A77D916-7446-46C1-8545-0AEC0008DBCA}'] + procedure Write( const buffer: TBytes; offset: Integer; count: Integer); overload; + procedure Write( const pBuf : Pointer; offset: Integer; count: Integer); overload; + function Read( var buffer: TBytes; offset: Integer; count: Integer): Integer; overload; + function Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; overload; + procedure Open; + procedure Close; + procedure Flush; + function IsOpen: Boolean; + function ToArray: TBytes; + end; + + TThriftStreamImpl = class( TInterfacedObject, IThriftStream) + private + procedure CheckSizeAndOffset( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer); overload; + protected + procedure Write( const buffer: TBytes; offset: Integer; count: Integer); overload; inline; + procedure Write( const pBuf : Pointer; offset: Integer; count: Integer); overload; virtual; + function Read( var buffer: TBytes; offset: Integer; count: Integer): Integer; overload; inline; + function Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; overload; virtual; + procedure Open; virtual; abstract; + procedure Close; virtual; abstract; + procedure Flush; virtual; abstract; + function IsOpen: Boolean; virtual; abstract; + function ToArray: TBytes; virtual; abstract; + end; + + TThriftStreamAdapterDelphi = class( TThriftStreamImpl ) + private + FStream : TStream; + FOwnsStream : Boolean; + 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 Open; override; + procedure Close; override; + procedure Flush; override; + function IsOpen: Boolean; override; + function ToArray: TBytes; override; + public + constructor Create( const AStream: TStream; AOwnsStream : Boolean); + destructor Destroy; override; + end; + + TThriftStreamAdapterCOM = class( TThriftStreamImpl) + private + FStream : IStream; + 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 Open; override; + procedure Close; override; + procedure Flush; override; + function IsOpen: Boolean; override; + function ToArray: TBytes; override; + public + constructor Create( const AStream: IStream); + end; + +implementation + +{ TThriftStreamAdapterCOM } + +procedure TThriftStreamAdapterCOM.Close; +begin + FStream := nil; +end; + +constructor TThriftStreamAdapterCOM.Create( const AStream: IStream); +begin + inherited Create; + FStream := AStream; +end; + +procedure TThriftStreamAdapterCOM.Flush; +begin + if IsOpen then begin + if FStream <> nil then begin + FStream.Commit( STGC_DEFAULT ); + end; + end; +end; + +function TThriftStreamAdapterCOM.IsOpen: Boolean; +begin + Result := FStream <> nil; +end; + +procedure TThriftStreamAdapterCOM.Open; +begin + // nothing to do +end; + +function TThriftStreamAdapterCOM.Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +var pTmp : PByte; +begin + inherited; + + if count >= buflen-offset + then count := buflen-offset; + + Result := 0; + if FStream <> nil then begin + if count > 0 then begin + pTmp := pBuf; + Inc( pTmp, offset); + FStream.Read( pTmp, count, @Result); + end; + end; +end; + +function TThriftStreamAdapterCOM.ToArray: TBytes; +var + statstg: TStatStg; + len : Integer; + NewPos : {$IF CompilerVersion >= 29.0} UInt64 {$ELSE} Int64 {$IFEND}; + cbRead : Integer; +begin + FillChar( statstg, SizeOf( statstg), 0); + len := 0; + if IsOpen then begin + if Succeeded( FStream.Stat( statstg, STATFLAG_NONAME )) then begin + len := statstg.cbSize; + end; + end; + + SetLength( Result, len ); + + if len > 0 then begin + if Succeeded( FStream.Seek( 0, STREAM_SEEK_SET, NewPos) ) then begin + FStream.Read( @Result[0], len, @cbRead); + end; + end; +end; + +procedure TThriftStreamAdapterCOM.Write( const pBuf: Pointer; offset: Integer; count: Integer); +var nWritten : Integer; + pTmp : PByte; +begin + inherited; + if IsOpen then begin + if count > 0 then begin + pTmp := pBuf; + Inc( pTmp, offset); + FStream.Write( pTmp, count, @nWritten); + end; + end; +end; + +{ TThriftStreamImpl } + +procedure TThriftStreamImpl.CheckSizeAndOffset( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer); +begin + if count > 0 then begin + if (offset < 0) or ( offset >= buflen) then begin + raise ERangeError.Create( SBitsIndexError ); + end; + if count > buflen then begin + raise ERangeError.Create( SBitsIndexError ); + end; + end; +end; + +function TThriftStreamImpl.Read(var buffer: TBytes; offset, count: Integer): Integer; +begin + if Length(buffer) > 0 + then Result := Read( @buffer[0], Length(buffer), offset, count) + else Result := 0; +end; + +function TThriftStreamImpl.Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +begin + Result := 0; + CheckSizeAndOffset( pBuf, buflen, offset, count ); +end; + +procedure TThriftStreamImpl.Write(const buffer: TBytes; offset, count: Integer); +begin + if Length(buffer) > 0 + then Write( @buffer[0], offset, count); +end; + +procedure TThriftStreamImpl.Write( const pBuf : Pointer; offset: Integer; count: Integer); +begin + CheckSizeAndOffset( pBuf, offset+count, offset, count); +end; + +{ TThriftStreamAdapterDelphi } + +procedure TThriftStreamAdapterDelphi.Close; +begin + FStream.Free; + FStream := nil; + FOwnsStream := False; +end; + +constructor TThriftStreamAdapterDelphi.Create( const AStream: TStream; AOwnsStream: Boolean); +begin + inherited Create; + FStream := AStream; + FOwnsStream := AOwnsStream; +end; + +destructor TThriftStreamAdapterDelphi.Destroy; +begin + if FOwnsStream + then Close; + + inherited; +end; + +procedure TThriftStreamAdapterDelphi.Flush; +begin + // nothing to do +end; + +function TThriftStreamAdapterDelphi.IsOpen: Boolean; +begin + Result := FStream <> nil; +end; + +procedure TThriftStreamAdapterDelphi.Open; +begin + // nothing to do +end; + +function TThriftStreamAdapterDelphi.Read(const pBuf : Pointer; const buflen : Integer; offset, count: Integer): Integer; +var pTmp : PByte; +begin + inherited; + + if count >= buflen-offset + then count := buflen-offset; + + if count > 0 then begin + pTmp := pBuf; + Inc( pTmp, offset); + Result := FStream.Read( pTmp^, count) + end + else Result := 0; +end; + +function TThriftStreamAdapterDelphi.ToArray: TBytes; +var + OrgPos : Integer; + len : Integer; +begin + len := 0; + if FStream <> nil then + begin + len := FStream.Size; + end; + + SetLength( Result, len ); + + if len > 0 then + begin + OrgPos := FStream.Position; + try + FStream.Position := 0; + FStream.ReadBuffer( Pointer(@Result[0])^, len ); + finally + FStream.Position := OrgPos; + end; + end +end; + +procedure TThriftStreamAdapterDelphi.Write(const pBuf : Pointer; offset, count: Integer); +var pTmp : PByte; +begin + inherited; + if count > 0 then begin + pTmp := pBuf; + Inc( pTmp, offset); + FStream.Write( pTmp^, count) + end; +end; + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.MsxmlHTTP.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.MsxmlHTTP.pas new file mode 100644 index 000000000..c666e7fed --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.MsxmlHTTP.pas @@ -0,0 +1,268 @@ +(* + * 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.MsxmlHTTP; + +{$I Thrift.Defines.inc} +{$SCOPEDENUMS ON} + +interface + +uses + Classes, + SysUtils, + Math, + Generics.Collections, + {$IFDEF OLD_UNIT_NAMES} + ActiveX, msxml, + {$ELSE} + Winapi.ActiveX, Winapi.msxml, + {$ENDIF} + Thrift.Collections, + Thrift.Transport, + Thrift.Exception, + Thrift.Utils, + Thrift.Stream; + +type + TMsxmlHTTPClientImpl = class( TTransportImpl, IHTTPClient) + private + FUri : string; + FInputStream : IThriftStream; + FOutputStream : IThriftStream; + FDnsResolveTimeout : Integer; + FConnectionTimeout : Integer; + FSendTimeout : Integer; + FReadTimeout : Integer; + FCustomHeaders : IThriftDictionary<string,string>; + + function CreateRequest: IXMLHTTPRequest; + 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 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); + destructor Destroy; override; + end; + + +implementation + + +{ TMsxmlHTTPClientImpl } + +constructor TMsxmlHTTPClientImpl.Create(const AUri: string); +begin + inherited Create; + FUri := AUri; + + // defaults according to MSDN + FDnsResolveTimeout := 0; // no timeout + FConnectionTimeout := 60 * 1000; + FSendTimeout := 30 * 1000; + FReadTimeout := 30 * 1000; + + FCustomHeaders := TThriftDictionaryImpl<string,string>.Create; + FOutputStream := TThriftStreamAdapterDelphi.Create( TMemoryStream.Create, True); +end; + +function TMsxmlHTTPClientImpl.CreateRequest: IXMLHTTPRequest; +var + pair : TPair<string,string>; + srvHttp : IServerXMLHTTPRequest; +begin + {$IF CompilerVersion >= 21.0} + Result := CoServerXMLHTTP.Create; + {$ELSE} + Result := CoXMLHTTPRequest.Create; + {$IFEND} + + // setting a timeout value to 0 (zero) means "no timeout" for that setting + if Supports( result, IServerXMLHTTPRequest, srvHttp) + then srvHttp.setTimeouts( DnsResolveTimeout, ConnectionTimeout, SendTimeout, ReadTimeout); + + Result.open('POST', FUri, False, '', ''); + Result.setRequestHeader( 'Content-Type', THRIFT_MIMETYPE); + Result.setRequestHeader( 'Accept', THRIFT_MIMETYPE); + Result.setRequestHeader( 'User-Agent', 'Delphi/IHTTPClient'); + + for pair in FCustomHeaders do begin + Result.setRequestHeader( pair.Key, pair.Value ); + end; +end; + +destructor TMsxmlHTTPClientImpl.Destroy; +begin + Close; + inherited; +end; + +function TMsxmlHTTPClientImpl.GetDnsResolveTimeout: Integer; +begin + Result := FDnsResolveTimeout; +end; + +procedure TMsxmlHTTPClientImpl.SetDnsResolveTimeout(const Value: Integer); +begin + FDnsResolveTimeout := Value; +end; + +function TMsxmlHTTPClientImpl.GetConnectionTimeout: Integer; +begin + Result := FConnectionTimeout; +end; + +procedure TMsxmlHTTPClientImpl.SetConnectionTimeout(const Value: Integer); +begin + FConnectionTimeout := Value; +end; + +function TMsxmlHTTPClientImpl.GetSendTimeout: Integer; +begin + Result := FSendTimeout; +end; + +procedure TMsxmlHTTPClientImpl.SetSendTimeout(const Value: Integer); +begin + FSendTimeout := Value; +end; + +function TMsxmlHTTPClientImpl.GetReadTimeout: Integer; +begin + Result := FReadTimeout; +end; + +procedure TMsxmlHTTPClientImpl.SetReadTimeout(const Value: Integer); +begin + FReadTimeout := Value; +end; + +function TMsxmlHTTPClientImpl.GetSecureProtocols : TSecureProtocols; +begin + Result := []; +end; + +procedure TMsxmlHTTPClientImpl.SetSecureProtocols( const value : TSecureProtocols); +begin + raise TTransportExceptionBadArgs.Create('SetSecureProtocols: Not supported with '+ClassName); +end; + +function TMsxmlHTTPClientImpl.GetCustomHeaders: IThriftDictionary<string,string>; +begin + Result := FCustomHeaders; +end; + +function TMsxmlHTTPClientImpl.GetIsOpen: Boolean; +begin + Result := True; +end; + +procedure TMsxmlHTTPClientImpl.Open; +begin + FOutputStream := TThriftStreamAdapterDelphi.Create( TMemoryStream.Create, True); +end; + +procedure TMsxmlHTTPClientImpl.Close; +begin + FInputStream := nil; + FOutputStream := nil; +end; + +procedure TMsxmlHTTPClientImpl.Flush; +begin + try + SendRequest; + finally + FOutputStream := nil; + FOutputStream := TThriftStreamAdapterDelphi.Create( TMemoryStream.Create, True); + ASSERT( FOutputStream <> nil); + end; +end; + +function TMsxmlHTTPClientImpl.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) + except + on E: Exception + do raise TTransportExceptionUnknown.Create(E.Message); + end; +end; + +procedure TMsxmlHTTPClientImpl.SendRequest; +var + xmlhttp : IXMLHTTPRequest; + ms : TMemoryStream; + a : TBytes; + len : Integer; +begin + xmlhttp := CreateRequest; + + ms := TMemoryStream.Create; + try + a := FOutputStream.ToArray; + len := Length(a); + if len > 0 then begin + ms.WriteBuffer( Pointer(@a[0])^, len); + end; + ms.Position := 0; + xmlhttp.send( IUnknown( TStreamAdapter.Create( ms, soReference ))); + FInputStream := nil; + FInputStream := TThriftStreamAdapterCOM.Create( IUnknown( xmlhttp.responseStream) as IStream); + finally + ms.Free; + end; +end; + +procedure TMsxmlHTTPClientImpl.Write( const pBuf : Pointer; off, len : Integer); +begin + FOutputStream.Write( pBuf, off, len); +end; + + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.Pipes.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.Pipes.pas new file mode 100644 index 000000000..77a343b0c --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.Pipes.pas @@ -0,0 +1,1044 @@ +(* + * 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.Pipes; + +{$WARN SYMBOL_PLATFORM OFF} +{$I Thrift.Defines.inc} + +interface + +uses + {$IFDEF OLD_UNIT_NAMES} + Windows, SysUtils, Math, AccCtrl, AclAPI, SyncObjs, + {$ELSE} + Winapi.Windows, System.SysUtils, System.Math, Winapi.AccCtrl, Winapi.AclAPI, System.SyncObjs, + {$ENDIF} + Thrift.Transport, + Thrift.Utils, + Thrift.Stream; + +const + DEFAULT_THRIFT_PIPE_OPEN_TIMEOUT = 10; // default: fail fast on open + + +type + //--- Pipe Streams --- + + + TPipeStreamBase = class( TThriftStreamImpl) + strict protected + FPipe : THandle; + FTimeout : DWORD; + FOpenTimeOut : DWORD; // separate value to allow for fail-fast-on-open scenarios + FOverlapped : Boolean; + + procedure Write( const pBuf : Pointer; offset, count : Integer); override; + function Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; override; + //procedure Open; override; - see derived classes + procedure Close; override; + procedure Flush; override; + + function ReadDirect( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; overload; + function ReadOverlapped( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; overload; + procedure WriteDirect( const pBuf : Pointer; offset: Integer; count: Integer); overload; + procedure WriteOverlapped( const pBuf : Pointer; offset: Integer; count: Integer); overload; + + function IsOpen: Boolean; override; + function ToArray: TBytes; override; + public + constructor Create( aEnableOverlapped : Boolean; + const aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT; + const aOpenTimeOut : DWORD = DEFAULT_THRIFT_PIPE_OPEN_TIMEOUT); + destructor Destroy; override; + end; + + + TNamedPipeStreamImpl = class sealed( TPipeStreamBase) + strict private + FPipeName : string; + FShareMode : DWORD; + FSecurityAttribs : PSecurityAttributes; + + strict protected + procedure Open; override; + + public + constructor Create( const aPipeName : string; + const aEnableOverlapped : Boolean; + const aShareMode: DWORD = 0; + const aSecurityAttributes: PSecurityAttributes = nil; + const aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT; + const aOpenTimeOut : DWORD = DEFAULT_THRIFT_PIPE_OPEN_TIMEOUT); overload; + end; + + + THandlePipeStreamImpl = class sealed( TPipeStreamBase) + strict private + FSrcHandle : THandle; + + strict protected + procedure Open; override; + + public + constructor Create( const aPipeHandle : THandle; + const aOwnsHandle, aEnableOverlapped : Boolean; + const aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT); overload; + destructor Destroy; override; + end; + + + //--- Pipe Transports --- + + + IPipeTransport = interface( IStreamTransport) + ['{5E05CC85-434F-428F-BFB2-856A168B5558}'] + end; + + + TPipeTransportBase = class( TStreamTransportImpl, IPipeTransport) + public + // ITransport + function GetIsOpen: Boolean; override; + procedure Open; override; + procedure Close; override; + end; + + + TNamedPipeTransportClientEndImpl = class( TPipeTransportBase) + public + // Named pipe constructors + constructor Create( aPipe : THandle; aOwnsHandle : Boolean; + const aTimeOut : DWORD); overload; + constructor Create( const aPipeName : string; + const aShareMode: DWORD = 0; + const aSecurityAttributes: PSecurityAttributes = nil; + const aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT; + const aOpenTimeOut : DWORD = DEFAULT_THRIFT_PIPE_OPEN_TIMEOUT); overload; + end; + + + TNamedPipeTransportServerEndImpl = class( TNamedPipeTransportClientEndImpl) + strict private + FHandle : THandle; + public + // ITransport + procedure Close; override; + constructor Create( aPipe : THandle; aOwnsHandle : Boolean; + const aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT); reintroduce; + end; + + + TAnonymousPipeTransportImpl = class( TPipeTransportBase) + public + // Anonymous pipe constructor + constructor Create(const aPipeRead, aPipeWrite : THandle; + aOwnsHandles : Boolean; + const aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT); overload; + end; + + + //--- Server Transports --- + + + IAnonymousPipeServerTransport = interface( IServerTransport) + ['{7AEE6793-47B9-4E49-981A-C39E9108E9AD}'] + // Server side anonymous pipe ends + function ReadHandle : THandle; + function WriteHandle : THandle; + // Client side anonymous pipe ends + function ClientAnonRead : THandle; + function ClientAnonWrite : THandle; + end; + + + INamedPipeServerTransport = interface( IServerTransport) + ['{9DF9EE48-D065-40AF-8F67-D33037D3D960}'] + function Handle : THandle; + end; + + + TPipeServerTransportBase = class( TServerTransportImpl) + strict protected + FStopServer : TEvent; + procedure InternalClose; virtual; abstract; + function QueryStopServer : Boolean; + public + constructor Create; + destructor Destroy; override; + procedure Listen; override; + procedure Close; override; + end; + + + TAnonymousPipeServerTransportImpl = class( TPipeServerTransportBase, IAnonymousPipeServerTransport) + strict private + FBufSize : DWORD; + + // Server side anonymous pipe handles + FReadHandle, + FWriteHandle : THandle; + + //Client side anonymous pipe handles + FClientAnonRead, + FClientAnonWrite : THandle; + + FTimeOut: DWORD; + protected + function Accept(const fnAccepting: TProc): ITransport; override; + + function CreateAnonPipe : Boolean; + + // IAnonymousPipeServerTransport + function ReadHandle : THandle; + function WriteHandle : THandle; + function ClientAnonRead : THandle; + function ClientAnonWrite : THandle; + + procedure InternalClose; override; + + public + constructor Create(aBufsize : Cardinal = 4096; aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT); + end; + + + TNamedPipeServerTransportImpl = class( TPipeServerTransportBase, INamedPipeServerTransport) + strict private + FPipeName : string; + FMaxConns : DWORD; + FBufSize : DWORD; + FTimeout : DWORD; + FHandle : THandle; + FConnected : Boolean; + + + strict protected + function Accept(const fnAccepting: TProc): ITransport; override; + function CreateNamedPipe : THandle; + function CreateTransportInstance : ITransport; + + // INamedPipeServerTransport + function Handle : THandle; + procedure InternalClose; override; + + public + constructor Create( aPipename : string; aBufsize : Cardinal = 4096; + aMaxConns : Cardinal = PIPE_UNLIMITED_INSTANCES; + aTimeOut : Cardinal = INFINITE); + end; + + +implementation + + +procedure ClosePipeHandle( var hPipe : THandle); +begin + if hPipe <> INVALID_HANDLE_VALUE + then try + CloseHandle( hPipe); + finally + hPipe := INVALID_HANDLE_VALUE; + end; +end; + + +function DuplicatePipeHandle( const hSource : THandle) : THandle; +begin + if not DuplicateHandle( GetCurrentProcess, hSource, + GetCurrentProcess, @result, + 0, FALSE, DUPLICATE_SAME_ACCESS) + then raise TTransportExceptionNotOpen.Create('DuplicateHandle: '+SysErrorMessage(GetLastError)); +end; + + + +{ TPipeStreamBase } + + +constructor TPipeStreamBase.Create( aEnableOverlapped : Boolean; + const aTimeOut, aOpenTimeOut : DWORD); +begin + inherited Create; + ASSERT( aTimeout > 0); // aOpenTimeout may be 0 + FPipe := INVALID_HANDLE_VALUE; + FTimeout := aTimeOut; + FOpenTimeOut := aOpenTimeOut; + FOverlapped := aEnableOverlapped; +end; + + +destructor TPipeStreamBase.Destroy; +begin + try + Close; + finally + inherited Destroy; + end; +end; + + +procedure TPipeStreamBase.Close; +begin + ClosePipeHandle( FPipe); +end; + + +procedure TPipeStreamBase.Flush; +begin + FlushFileBuffers( FPipe); +end; + + +function TPipeStreamBase.IsOpen: Boolean; +begin + result := (FPipe <> INVALID_HANDLE_VALUE); +end; + + +procedure TPipeStreamBase.Write( const pBuf : Pointer; offset, count : Integer); +begin + if FOverlapped + then WriteOverlapped( pBuf, offset, count) + else WriteDirect( pBuf, offset, count); +end; + + +function TPipeStreamBase.Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +begin + if FOverlapped + then result := ReadOverlapped( pBuf, buflen, offset, count) + else result := ReadDirect( pBuf, buflen, offset, count); +end; + + +procedure TPipeStreamBase.WriteDirect( const pBuf : Pointer; offset: Integer; count: Integer); +var cbWritten, nBytes : DWORD; + pData : PByte; +begin + if not IsOpen + then raise TTransportExceptionNotOpen.Create('Called write on non-open pipe'); + + // if necessary, send the data in chunks + // there's a system limit around 0x10000 bytes that we hit otherwise + // MSDN: "Pipe write operations across a network are limited to 65,535 bytes per write. For more information regarding pipes, see the Remarks section." + nBytes := Min( 15*4096, count); // 16 would exceed the limit + pData := pBuf; + Inc( pData, offset); + while nBytes > 0 do begin + if not WriteFile( FPipe, pData^, nBytes, cbWritten, nil) + then raise TTransportExceptionNotOpen.Create('Write to pipe failed'); + + Inc( pData, cbWritten); + Dec( count, cbWritten); + nBytes := Min( nBytes, count); + end; +end; + + +procedure TPipeStreamBase.WriteOverlapped( const pBuf : Pointer; offset: Integer; count: Integer); +var cbWritten, dwWait, dwError, nBytes : DWORD; + overlapped : IOverlappedHelper; + pData : PByte; +begin + if not IsOpen + then raise TTransportExceptionNotOpen.Create('Called write on non-open pipe'); + + // if necessary, send the data in chunks + // there's a system limit around 0x10000 bytes that we hit otherwise + // MSDN: "Pipe write operations across a network are limited to 65,535 bytes per write. For more information regarding pipes, see the Remarks section." + nBytes := Min( 15*4096, count); // 16 would exceed the limit + pData := pBuf; + Inc( pData, offset); + while nBytes > 0 do begin + overlapped := TOverlappedHelperImpl.Create; + if not WriteFile( FPipe, pData^, nBytes, cbWritten, overlapped.OverlappedPtr) + then begin + dwError := GetLastError; + case dwError of + ERROR_IO_PENDING : begin + dwWait := overlapped.WaitFor(FTimeout); + + if (dwWait = WAIT_TIMEOUT) then begin + CancelIo( FPipe); // prevents possible AV on invalid overlapped ptr + raise TTransportExceptionTimedOut.Create('Pipe write timed out'); + end; + + if (dwWait <> WAIT_OBJECT_0) + or not GetOverlappedResult( FPipe, overlapped.Overlapped, cbWritten, TRUE) + then raise TTransportExceptionUnknown.Create('Pipe write error'); + end; + + else + raise TTransportExceptionUnknown.Create(SysErrorMessage(dwError)); + end; + end; + + ASSERT( DWORD(nBytes) = cbWritten); + + Inc( pData, cbWritten); + Dec( count, cbWritten); + nBytes := Min( nBytes, count); + end; +end; + + +function TPipeStreamBase.ReadDirect( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +var cbRead, dwErr, nRemaining : DWORD; + bytes, retries : LongInt; + bOk : Boolean; + pData : PByte; +const INTERVAL = 10; // ms +begin + if not IsOpen + then raise TTransportExceptionNotOpen.Create('Called read on non-open pipe'); + + // MSDN: Handle can be a handle to a named pipe instance, + // or it can be a handle to the read end of an anonymous pipe, + // The handle must have GENERIC_READ access to the pipe. + if FTimeOut <> INFINITE then begin + retries := Max( 1, Round( 1.0 * FTimeOut / INTERVAL)); + while TRUE do begin + if not PeekNamedPipe( FPipe, nil, 0, nil, @bytes, nil) then begin + dwErr := GetLastError; + if (dwErr = ERROR_INVALID_HANDLE) + or (dwErr = ERROR_BROKEN_PIPE) + or (dwErr = ERROR_PIPE_NOT_CONNECTED) + then begin + result := 0; // other side closed the pipe + Exit; + end; + end + else if bytes > 0 then begin + Break; // there are data + end; + + Dec( retries); + if retries > 0 + then Sleep( INTERVAL) + else raise TTransportExceptionTimedOut.Create('Pipe read timed out'); + end; + end; + + result := 0; + nRemaining := count; + pData := pBuf; + Inc( pData, offset); + while nRemaining > 0 do begin + // read the data (or block INFINITE-ly) + bOk := ReadFile( FPipe, pData^, nRemaining, cbRead, nil); + if (not bOk) and (GetLastError() <> ERROR_MORE_DATA) + then Break; // No more data, possibly because client disconnected. + + Dec( nRemaining, cbRead); + Inc( pData, cbRead); + Inc( result, cbRead); + end; +end; + + +function TPipeStreamBase.ReadOverlapped( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +var cbRead, dwWait, dwError, nRemaining : DWORD; + bOk : Boolean; + overlapped : IOverlappedHelper; + pData : PByte; +begin + if not IsOpen + then raise TTransportExceptionNotOpen.Create('Called read on non-open pipe'); + + result := 0; + nRemaining := count; + pData := pBuf; + Inc( pData, offset); + while nRemaining > 0 do begin + overlapped := TOverlappedHelperImpl.Create; + + // read the data + bOk := ReadFile( FPipe, pData^, nRemaining, cbRead, overlapped.OverlappedPtr); + if not bOk then begin + dwError := GetLastError; + case dwError of + ERROR_IO_PENDING : begin + dwWait := overlapped.WaitFor(FTimeout); + + if (dwWait = WAIT_TIMEOUT) then begin + CancelIo( FPipe); // prevents possible AV on invalid overlapped ptr + raise TTransportExceptionTimedOut.Create('Pipe read timed out'); + end; + + if (dwWait <> WAIT_OBJECT_0) + or not GetOverlappedResult( FPipe, overlapped.Overlapped, cbRead, TRUE) + then raise TTransportExceptionUnknown.Create('Pipe read error'); + end; + + else + raise TTransportExceptionUnknown.Create(SysErrorMessage(dwError)); + end; + end; + + ASSERT( cbRead > 0); // see TTransportImpl.ReadAll() + ASSERT( cbRead <= DWORD(nRemaining)); + Dec( nRemaining, cbRead); + Inc( pData, cbRead); + Inc( result, cbRead); + end; +end; + + +function TPipeStreamBase.ToArray: TBytes; +var bytes : LongInt; +begin + SetLength( result, 0); + bytes := 0; + + if IsOpen + and PeekNamedPipe( FPipe, nil, 0, nil, @bytes, nil) + and (bytes > 0) + then begin + SetLength( result, bytes); + Read( result, 0, bytes); + end; +end; + + +{ TNamedPipeStreamImpl } + + +constructor TNamedPipeStreamImpl.Create( const aPipeName : string; + const aEnableOverlapped : Boolean; + const aShareMode: DWORD; + const aSecurityAttributes: PSecurityAttributes; + const aTimeOut, aOpenTimeOut : DWORD); +begin + inherited Create( aEnableOverlapped, aTimeout, aOpenTimeOut); + + FPipeName := aPipeName; + FShareMode := aShareMode; + FSecurityAttribs := aSecurityAttributes; + + if Copy(FPipeName,1,2) <> '\\' + then FPipeName := '\\.\pipe\' + FPipeName; // assume localhost +end; + + +procedure TNamedPipeStreamImpl.Open; +var hPipe : THandle; + retries, timeout, dwErr : DWORD; +const INTERVAL = 10; // ms +begin + if IsOpen then Exit; + + retries := Max( 1, Round( 1.0 * FOpenTimeOut / INTERVAL)); + timeout := FOpenTimeOut; + + // if the server hasn't gotten to the point where the pipe has been created, at least wait the timeout + // According to MSDN, if no instances of the specified named pipe exist, the WaitNamedPipe function + // returns IMMEDIATELY, regardless of the time-out value. + // Always use INTERVAL, since WaitNamedPipe(0) defaults to some other value + while not WaitNamedPipe( PChar(FPipeName), INTERVAL) do begin + dwErr := GetLastError; + if dwErr <> ERROR_FILE_NOT_FOUND + then raise TTransportExceptionNotOpen.Create('Unable to open pipe, '+SysErrorMessage(dwErr)); + + if timeout <> INFINITE then begin + if (retries > 0) + then Dec(retries) + else raise TTransportExceptionNotOpen.Create('Unable to open pipe, timed out'); + end; + + Sleep(INTERVAL) + end; + + // open that thingy + hPipe := CreateFile( PChar( FPipeName), + GENERIC_READ or GENERIC_WRITE, + FShareMode, // sharing + FSecurityAttribs, // security attributes + OPEN_EXISTING, // opens existing pipe + FILE_FLAG_OVERLAPPED or FILE_FLAG_WRITE_THROUGH, // async+fast, please + 0); // no template file + + if hPipe = INVALID_HANDLE_VALUE + then raise TTransportExceptionNotOpen.Create('Unable to open pipe, '+SysErrorMessage(GetLastError)); + + // everything fine + FPipe := hPipe; +end; + + +{ THandlePipeStreamImpl } + + +constructor THandlePipeStreamImpl.Create( const aPipeHandle : THandle; + const aOwnsHandle, aEnableOverlapped : Boolean; + const aTimeOut : DWORD); +begin + inherited Create( aEnableOverlapped, aTimeOut); + + if aOwnsHandle + then FSrcHandle := aPipeHandle + else FSrcHandle := DuplicatePipeHandle( aPipeHandle); + + Open; +end; + + +destructor THandlePipeStreamImpl.Destroy; +begin + try + ClosePipeHandle( FSrcHandle); + finally + inherited Destroy; + end; +end; + + +procedure THandlePipeStreamImpl.Open; +begin + if not IsOpen + then FPipe := DuplicatePipeHandle( FSrcHandle); +end; + + +{ TPipeTransportBase } + + +function TPipeTransportBase.GetIsOpen: Boolean; +begin + result := (FInputStream <> nil) and (FInputStream.IsOpen) + and (FOutputStream <> nil) and (FOutputStream.IsOpen); +end; + + +procedure TPipeTransportBase.Open; +begin + FInputStream.Open; + FOutputStream.Open; +end; + + +procedure TPipeTransportBase.Close; +begin + FInputStream.Close; + FOutputStream.Close; +end; + + +{ TNamedPipeTransportClientEndImpl } + + +constructor TNamedPipeTransportClientEndImpl.Create( const aPipeName : string; const aShareMode: DWORD; + const aSecurityAttributes: PSecurityAttributes; + const aTimeOut, aOpenTimeOut : DWORD); +// Named pipe constructor +begin + inherited Create( nil, nil); + FInputStream := TNamedPipeStreamImpl.Create( aPipeName, TRUE, aShareMode, aSecurityAttributes, aTimeOut, aOpenTimeOut); + FOutputStream := FInputStream; // true for named pipes +end; + + +constructor TNamedPipeTransportClientEndImpl.Create( aPipe : THandle; aOwnsHandle : Boolean; + const aTimeOut : DWORD); +// Named pipe constructor +begin + inherited Create( nil, nil); + FInputStream := THandlePipeStreamImpl.Create( aPipe, TRUE, aOwnsHandle, aTimeOut); + FOutputStream := FInputStream; // true for named pipes +end; + + +{ TNamedPipeTransportServerEndImpl } + + +constructor TNamedPipeTransportServerEndImpl.Create( aPipe : THandle; aOwnsHandle : Boolean; + const aTimeOut : DWORD); +// Named pipe constructor +begin + FHandle := DuplicatePipeHandle( aPipe); + inherited Create( aPipe, aOwnsHandle, aTimeOut); +end; + + +procedure TNamedPipeTransportServerEndImpl.Close; +begin + FlushFileBuffers( FHandle); + DisconnectNamedPipe( FHandle); // force client off the pipe + ClosePipeHandle( FHandle); + + inherited Close; +end; + + +{ TAnonymousPipeTransportImpl } + + +constructor TAnonymousPipeTransportImpl.Create( const aPipeRead, aPipeWrite : THandle; + aOwnsHandles : Boolean; + const aTimeOut : DWORD = DEFAULT_THRIFT_TIMEOUT); +// Anonymous pipe constructor +begin + inherited Create( nil, nil); + // overlapped is not supported with AnonPipes, see MSDN + FInputStream := THandlePipeStreamImpl.Create( aPipeRead, aOwnsHandles, FALSE, aTimeOut); + FOutputStream := THandlePipeStreamImpl.Create( aPipeWrite, aOwnsHandles, FALSE, aTimeOut); +end; + + +{ TPipeServerTransportBase } + + +constructor TPipeServerTransportBase.Create; +begin + inherited Create; + FStopServer := TEvent.Create(nil,TRUE,FALSE,''); // manual reset +end; + + +destructor TPipeServerTransportBase.Destroy; +begin + try + FreeAndNil( FStopServer); + finally + inherited Destroy; + end; +end; + + +function TPipeServerTransportBase.QueryStopServer : Boolean; +begin + result := (FStopServer = nil) + or (FStopServer.WaitFor(0) <> wrTimeout); +end; + + +procedure TPipeServerTransportBase.Listen; +begin + FStopServer.ResetEvent; +end; + + +procedure TPipeServerTransportBase.Close; +begin + FStopServer.SetEvent; + InternalClose; +end; + + +{ TAnonymousPipeServerTransportImpl } + + +constructor TAnonymousPipeServerTransportImpl.Create(aBufsize : Cardinal; aTimeOut : DWORD); +// Anonymous pipe CTOR +begin + inherited Create; + FBufsize := aBufSize; + FReadHandle := INVALID_HANDLE_VALUE; + FWriteHandle := INVALID_HANDLE_VALUE; + FClientAnonRead := INVALID_HANDLE_VALUE; + FClientAnonWrite := INVALID_HANDLE_VALUE; + FTimeOut := aTimeOut; + + // The anonymous pipe needs to be created first so that the server can + // pass the handles on to the client before the serve (acceptImpl) + // blocking call. + if not CreateAnonPipe + then raise TTransportExceptionNotOpen.Create(ClassName+'.Create() failed'); +end; + + +function TAnonymousPipeServerTransportImpl.Accept(const fnAccepting: TProc): ITransport; +var buf : Byte; + br : DWORD; +begin + if Assigned(fnAccepting) + then fnAccepting(); + + // This 0-byte read serves merely as a blocking call. + if not ReadFile( FReadHandle, buf, 0, br, nil) + and (GetLastError() <> ERROR_MORE_DATA) + then raise TTransportExceptionNotOpen.Create('TServerPipe unable to initiate pipe communication'); + + // create the transport impl + result := TAnonymousPipeTransportImpl.Create( FReadHandle, FWriteHandle, FALSE, FTimeOut); +end; + + +procedure TAnonymousPipeServerTransportImpl.InternalClose; +begin + ClosePipeHandle( FReadHandle); + ClosePipeHandle( FWriteHandle); + ClosePipeHandle( FClientAnonRead); + ClosePipeHandle( FClientAnonWrite); +end; + + +function TAnonymousPipeServerTransportImpl.ReadHandle : THandle; +begin + result := FReadHandle; +end; + + +function TAnonymousPipeServerTransportImpl.WriteHandle : THandle; +begin + result := FWriteHandle; +end; + + +function TAnonymousPipeServerTransportImpl.ClientAnonRead : THandle; +begin + result := FClientAnonRead; +end; + + +function TAnonymousPipeServerTransportImpl.ClientAnonWrite : THandle; +begin + result := FClientAnonWrite; +end; + + +function TAnonymousPipeServerTransportImpl.CreateAnonPipe : Boolean; +var sd : PSECURITY_DESCRIPTOR; + sa : SECURITY_ATTRIBUTES; //TSecurityAttributes; + hCAR, hPipeW, hCAW, hPipe : THandle; +begin + sd := PSECURITY_DESCRIPTOR( LocalAlloc( LPTR,SECURITY_DESCRIPTOR_MIN_LENGTH)); + try + Win32Check( InitializeSecurityDescriptor( sd, SECURITY_DESCRIPTOR_REVISION)); + Win32Check( SetSecurityDescriptorDacl( sd, TRUE, nil, FALSE)); + + sa.nLength := sizeof( sa); + sa.lpSecurityDescriptor := sd; + sa.bInheritHandle := TRUE; //allow passing handle to child + + Result := CreatePipe( hCAR, hPipeW, @sa, FBufSize); //create stdin pipe + if not Result then begin //create stdin pipe + raise TTransportExceptionNotOpen.Create('TServerPipe CreatePipe (anon) failed, '+SysErrorMessage(GetLastError)); + Exit; + end; + + Result := CreatePipe( hPipe, hCAW, @sa, FBufSize); //create stdout pipe + if not Result then begin //create stdout pipe + CloseHandle( hCAR); + CloseHandle( hPipeW); + raise TTransportExceptionNotOpen.Create('TServerPipe CreatePipe (anon) failed, '+SysErrorMessage(GetLastError)); + Exit; + end; + + FClientAnonRead := hCAR; + FClientAnonWrite := hCAW; + FReadHandle := hPipe; + FWriteHandle := hPipeW; + finally + if sd <> nil then LocalFree( Cardinal(sd)); + end; +end; + + +{ TNamedPipeServerTransportImpl } + + +constructor TNamedPipeServerTransportImpl.Create( aPipename : string; aBufsize, aMaxConns, aTimeOut : Cardinal); +// Named Pipe CTOR +begin + inherited Create; + ASSERT( aTimeout > 0); + FPipeName := aPipename; + FBufsize := aBufSize; + FMaxConns := Max( 1, Min( PIPE_UNLIMITED_INSTANCES, aMaxConns)); + FHandle := INVALID_HANDLE_VALUE; + FTimeout := aTimeOut; + FConnected := FALSE; + + if Copy(FPipeName,1,2) <> '\\' + then FPipeName := '\\.\pipe\' + FPipeName; // assume localhost +end; + + +function TNamedPipeServerTransportImpl.Accept(const fnAccepting: TProc): ITransport; +var dwError, dwWait, dwDummy : DWORD; + overlapped : IOverlappedHelper; + handles : array[0..1] of THandle; +begin + overlapped := TOverlappedHelperImpl.Create; + + ASSERT( not FConnected); + CreateNamedPipe; + while not FConnected do begin + + if QueryStopServer then begin + InternalClose; + Abort; + end; + + if Assigned(fnAccepting) + then fnAccepting(); + + // Wait for the client to connect; if it succeeds, the + // function returns a nonzero value. If the function returns + // zero, GetLastError should return ERROR_PIPE_CONNECTED. + if ConnectNamedPipe( Handle, overlapped.OverlappedPtr) then begin + FConnected := TRUE; + Break; + end; + + // ConnectNamedPipe() returns FALSE for OverlappedIO, even if connected. + // We have to check GetLastError() explicitly to find out + dwError := GetLastError; + case dwError of + ERROR_PIPE_CONNECTED : begin + FConnected := not QueryStopServer; // special case: pipe immediately connected + end; + + ERROR_IO_PENDING : begin + handles[0] := overlapped.WaitHandle; + handles[1] := FStopServer.Handle; + dwWait := WaitForMultipleObjects( 2, @handles, FALSE, FTimeout); + FConnected := (dwWait = WAIT_OBJECT_0) + and GetOverlappedResult( Handle, overlapped.Overlapped, dwDummy, TRUE) + and not QueryStopServer; + end; + + else + InternalClose; + raise TTransportExceptionNotOpen.Create('Client connection failed'); + end; + end; + + // create the transport impl + result := CreateTransportInstance; +end; + + +function TNamedPipeServerTransportImpl.CreateTransportInstance : ITransport; +// create the transport impl +var hPipe : THandle; +begin + hPipe := THandle( InterlockedExchangePointer( Pointer(FHandle), Pointer(INVALID_HANDLE_VALUE))); + try + FConnected := FALSE; + result := TNamedPipeTransportServerEndImpl.Create( hPipe, TRUE, FTimeout); + except + ClosePipeHandle(hPipe); + raise; + end; +end; + + +procedure TNamedPipeServerTransportImpl.InternalClose; +var hPipe : THandle; +begin + hPipe := THandle( InterlockedExchangePointer( Pointer(FHandle), Pointer(INVALID_HANDLE_VALUE))); + if hPipe = INVALID_HANDLE_VALUE then Exit; + + try + if FConnected + then FlushFileBuffers( hPipe) + else CancelIo( hPipe); + DisconnectNamedPipe( hPipe); + finally + ClosePipeHandle( hPipe); + FConnected := FALSE; + end; +end; + + +function TNamedPipeServerTransportImpl.Handle : THandle; +begin + {$IFDEF WIN64} + result := THandle( InterlockedExchangeAdd64( Int64(FHandle), 0)); + {$ELSE} + result := THandle( InterlockedExchangeAdd( Integer(FHandle), 0)); + {$ENDIF} +end; + + +function TNamedPipeServerTransportImpl.CreateNamedPipe : THandle; +var SIDAuthWorld : SID_IDENTIFIER_AUTHORITY ; + everyone_sid : PSID; + ea : EXPLICIT_ACCESS; + acl : PACL; + sd : PSECURITY_DESCRIPTOR; + sa : SECURITY_ATTRIBUTES; +const + SECURITY_WORLD_SID_AUTHORITY : TSIDIdentifierAuthority = (Value : (0,0,0,0,0,1)); + SECURITY_WORLD_RID = $00000000; +begin + sd := nil; + everyone_sid := nil; + try + ASSERT( (FHandle = INVALID_HANDLE_VALUE) and not FConnected); + + // Windows - set security to allow non-elevated apps + // to access pipes created by elevated apps. + SIDAuthWorld := SECURITY_WORLD_SID_AUTHORITY; + AllocateAndInitializeSid( SIDAuthWorld, 1, SECURITY_WORLD_RID, 0, 0, 0, 0, 0, 0, 0, everyone_sid); + + ZeroMemory( @ea, SizeOf(ea)); + ea.grfAccessPermissions := GENERIC_ALL; //SPECIFIC_RIGHTS_ALL or STANDARD_RIGHTS_ALL; + ea.grfAccessMode := SET_ACCESS; + ea.grfInheritance := NO_INHERITANCE; + ea.Trustee.TrusteeForm := TRUSTEE_IS_SID; + ea.Trustee.TrusteeType := TRUSTEE_IS_WELL_KNOWN_GROUP; + ea.Trustee.ptstrName := PChar(everyone_sid); + + acl := nil; + SetEntriesInAcl( 1, @ea, nil, acl); + + sd := PSECURITY_DESCRIPTOR( LocalAlloc( LPTR,SECURITY_DESCRIPTOR_MIN_LENGTH)); + Win32Check( InitializeSecurityDescriptor( sd, SECURITY_DESCRIPTOR_REVISION)); + Win32Check( SetSecurityDescriptorDacl( sd, TRUE, acl, FALSE)); + + sa.nLength := SizeOf(sa); + sa.lpSecurityDescriptor := sd; + sa.bInheritHandle := FALSE; + + // Create an instance of the named pipe + {$IFDEF OLD_UNIT_NAMES} + result := Windows.CreateNamedPipe( + {$ELSE} + result := Winapi.Windows.CreateNamedPipe( + {$ENDIF} + PChar( FPipeName), // pipe name + PIPE_ACCESS_DUPLEX or // read/write access + FILE_FLAG_OVERLAPPED, // async mode + PIPE_TYPE_BYTE or // byte type pipe + PIPE_READMODE_BYTE, // byte read mode + FMaxConns, // max. instances + FBufSize, // output buffer size + FBufSize, // input buffer size + FTimeout, // time-out, see MSDN + @sa // default security attribute + ); + + if( result <> INVALID_HANDLE_VALUE) + then InterlockedExchangePointer( Pointer(FHandle), Pointer(result)) + else raise TTransportExceptionNotOpen.Create('CreateNamedPipe() failed ' + IntToStr(GetLastError)); + + finally + if sd <> nil then LocalFree( Cardinal( sd)); + if acl <> nil then LocalFree( Cardinal( acl)); + if everyone_sid <> nil then FreeSid(everyone_sid); + end; +end; + + + +end. + + + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.WinHTTP.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.WinHTTP.pas new file mode 100644 index 000000000..262e38fb1 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.WinHTTP.pas @@ -0,0 +1,408 @@ +(* + * 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) + 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; + + private + type + TErrorInfo = ( SplitUrl, WinHTTPSession, WinHTTPConnection, WinHTTPRequest, RequestSetup, AutoProxy ); + + THTTPResponseStream = class( TThriftStreamImpl) + private + FRequest : IWinHTTPRequest; + 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 Open; override; + procedure Close; override; + procedure Flush; override; + function IsOpen: Boolean; override; + function ToArray: TBytes; override; + public + constructor Create( const aRequest : IWinHTTPRequest); + destructor Destroy; override; + end; + + 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 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); + destructor Destroy; override; + end; + +implementation + + +{ TWinHTTPClientImpl } + +constructor TWinHTTPClientImpl.Create(const AUri: string); +begin + inherited Create; + 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; + +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) + except + on E: Exception + do raise TTransportExceptionUnknown.Create(E.Message); + end; +end; + +procedure TWinHTTPClientImpl.SendRequest; +var + http : IWinHTTPRequest; + 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; + + FInputStream := THTTPResponseStream.Create(http); +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); +begin + inherited Create; + FRequest := aRequest; +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; + + if count > 0 then begin + pTmp := pBuf; + Inc( pTmp, offset); + Result := FRequest.ReadData( pTmp, count); + ASSERT( Result >= 0); + end + else Result := 0; +end; + +function TWinHTTPClientImpl.THTTPResponseStream.ToArray: TBytes; +begin + raise ENotImplemented(ClassName+'.ToArray'); +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.pas new file mode 100644 index 000000000..c2071df89 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Transport.pas @@ -0,0 +1,1523 @@ +(* + * 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; + +{$I Thrift.Defines.inc} +{$SCOPEDENUMS ON} + +interface + +uses + Classes, + SysUtils, + Math, + Generics.Collections, + {$IFDEF OLD_UNIT_NAMES} + WinSock, Sockets, + {$ELSE} + Winapi.WinSock, + {$IFDEF OLD_SOCKETS} + Web.Win.Sockets, + {$ELSE} + Thrift.Socket, + {$ENDIF} + {$ENDIF} + Thrift.Collections, + Thrift.Exception, + Thrift.Utils, + Thrift.WinHTTP, + Thrift.Stream; + +type + ITransport = interface + ['{DB84961E-8BB3-4532-99E1-A8C7AC2300F7}'] + function GetIsOpen: Boolean; + property IsOpen: Boolean read GetIsOpen; + function Peek: Boolean; + procedure Open; + procedure Close; + function Read(var buf: TBytes; off: Integer; len: Integer): Integer; overload; + function Read(const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; overload; + function ReadAll(var buf: TBytes; off: Integer; len: Integer): Integer; overload; + function ReadAll(const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; overload; + procedure Write( const buf: TBytes); overload; + procedure Write( const buf: TBytes; off: Integer; len: Integer); overload; + procedure Write( const pBuf : Pointer; off, len : Integer); overload; + procedure Write( const pBuf : Pointer; len : Integer); overload; + procedure Flush; + end; + + TTransportImpl = class( TInterfacedObject, ITransport) + protected + function GetIsOpen: Boolean; virtual; abstract; + property IsOpen: Boolean read GetIsOpen; + function Peek: Boolean; virtual; + procedure Open(); virtual; abstract; + procedure Close(); virtual; abstract; + function Read(var buf: TBytes; off: Integer; len: Integer): Integer; overload; inline; + function Read(const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; overload; virtual; abstract; + function ReadAll(var buf: TBytes; off: Integer; len: Integer): Integer; overload; inline; + function ReadAll(const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; overload; virtual; + procedure Write( const buf: TBytes); overload; inline; + procedure Write( const buf: TBytes; off: Integer; len: Integer); overload; inline; + procedure Write( const pBuf : Pointer; len : Integer); overload; inline; + procedure Write( const pBuf : Pointer; off, len : Integer); overload; virtual; abstract; + procedure Flush; virtual; + end; + + TTransportException = class( TException) + public + type + TExceptionType = ( + Unknown, + NotOpen, + AlreadyOpen, + TimedOut, + EndOfFile, + BadArgs, + Interrupted + ); + private + function GetType: TExceptionType; + protected + constructor HiddenCreate(const Msg: string); + public + class function Create( AType: TExceptionType): TTransportException; overload; deprecated 'Use specialized TTransportException types (or regenerate from IDL)'; + class function Create( const msg: string): TTransportException; reintroduce; overload; deprecated 'Use specialized TTransportException types (or regenerate from IDL)'; + class function Create( AType: TExceptionType; const msg: string): TTransportException; overload; deprecated 'Use specialized TTransportException types (or regenerate from IDL)'; + property Type_: TExceptionType read GetType; + end; + + // Needed to remove deprecation warning + TTransportExceptionSpecialized = class abstract (TTransportException) + public + constructor Create(const Msg: string); + end; + + TTransportExceptionUnknown = class (TTransportExceptionSpecialized); + TTransportExceptionNotOpen = class (TTransportExceptionSpecialized); + TTransportExceptionAlreadyOpen = class (TTransportExceptionSpecialized); + TTransportExceptionTimedOut = class (TTransportExceptionSpecialized); + TTransportExceptionEndOfFile = class (TTransportExceptionSpecialized); + TTransportExceptionBadArgs = class (TTransportExceptionSpecialized); + TTransportExceptionInterrupted = class (TTransportExceptionSpecialized); + + TSecureProtocol = ( + SSL_2, SSL_3, TLS_1, // outdated, for compatibilty only + TLS_1_1, TLS_1_2 // secure (as of today) + ); + + TSecureProtocols = set of TSecureProtocol; + + IHTTPClient = interface( ITransport ) + ['{7BF615DD-8680-4004-A5B2-88947BA3BA3D}'] + 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 GetCustomHeaders: IThriftDictionary<string,string>; + procedure SendRequest; + function GetSecureProtocols : TSecureProtocols; + procedure SetSecureProtocols( const value : TSecureProtocols); + + 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; + property SecureProtocols : TSecureProtocols read GetSecureProtocols write SetSecureProtocols; + end; + + IServerTransport = interface + ['{C43B87ED-69EA-47C4-B77C-15E288252900}'] + procedure Listen; + procedure Close; + function Accept( const fnAccepting: TProc): ITransport; + end; + + TServerTransportImpl = class( TInterfacedObject, IServerTransport) + protected + procedure Listen; virtual; abstract; + procedure Close; virtual; abstract; + function Accept( const fnAccepting: TProc): ITransport; virtual; abstract; + end; + + ITransportFactory = interface + ['{DD809446-000F-49E1-9BFF-E0D0DC76A9D7}'] + function GetTransport( const ATrans: ITransport): ITransport; + end; + + TTransportFactoryImpl = class( TInterfacedObject, ITransportFactory) + function GetTransport( const ATrans: ITransport): ITransport; virtual; + end; + + TTcpSocketStreamImpl = class( TThriftStreamImpl ) +{$IFDEF OLD_SOCKETS} + private type + TWaitForData = ( wfd_HaveData, wfd_Timeout, wfd_Error); + private + FTcpClient : TCustomIpClient; + FTimeout : Integer; + function Select( ReadReady, WriteReady, ExceptFlag: PBoolean; + TimeOut: Integer; var wsaError : Integer): Integer; + function WaitForData( TimeOut : Integer; pBuf : Pointer; DesiredBytes: Integer; + var wsaError, bytesReady : Integer): TWaitForData; +{$ELSE} + FTcpClient: TSocket; + protected const + SLEEP_TIME = 200; +{$ENDIF} + protected + procedure Write( const pBuf : Pointer; offset, count: Integer); override; + function Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; override; + procedure Open; override; + procedure Close; override; + procedure Flush; override; + + function IsOpen: Boolean; override; + function ToArray: TBytes; override; + public +{$IFDEF OLD_SOCKETS} + constructor Create( const ATcpClient: TCustomIpClient; const aTimeout : Integer = 0); +{$ELSE} + constructor Create( const ATcpClient: TSocket; const aTimeout : Longword = 0); +{$ENDIF} + end; + + IStreamTransport = interface( ITransport ) + ['{A8479B47-2A3E-4421-A9A0-D5A9EDCC634A}'] + function GetInputStream: IThriftStream; + function GetOutputStream: IThriftStream; + property InputStream : IThriftStream read GetInputStream; + property OutputStream : IThriftStream read GetOutputStream; + end; + + TStreamTransportImpl = class( TTransportImpl, IStreamTransport) + protected + FInputStream : IThriftStream; + FOutputStream : IThriftStream; + protected + function GetIsOpen: Boolean; override; + + function GetInputStream: IThriftStream; + function GetOutputStream: IThriftStream; + public + property InputStream : IThriftStream read GetInputStream; + property OutputStream : IThriftStream read GetOutputStream; + + procedure Open; override; + procedure Close; override; + procedure Flush; override; + function Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; override; + procedure Write( const pBuf : Pointer; off, len : Integer); override; + constructor Create( const AInputStream : IThriftStream; const AOutputStream : IThriftStream); + destructor Destroy; override; + end; + + TBufferedStreamImpl = class( TThriftStreamImpl) + private + FStream : IThriftStream; + FBufSize : Integer; + FReadBuffer : TMemoryStream; + FWriteBuffer : TMemoryStream; + 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 Open; override; + procedure Close; override; + procedure Flush; override; + function IsOpen: Boolean; override; + function ToArray: TBytes; override; + public + constructor Create( const AStream: IThriftStream; ABufSize: Integer); + destructor Destroy; override; + end; + + TServerSocketImpl = class( TServerTransportImpl) + private +{$IFDEF OLD_SOCKETS} + FServer : TTcpServer; + FPort : Integer; + FClientTimeout : Integer; +{$ELSE} + FServer: TServerSocket; +{$ENDIF} + FUseBufferedSocket : Boolean; + FOwnsServer : Boolean; + protected + function Accept( const fnAccepting: TProc) : ITransport; override; + public +{$IFDEF OLD_SOCKETS} + constructor Create( const AServer: TTcpServer; AClientTimeout: Integer = 0); overload; + constructor Create( APort: Integer; AClientTimeout: Integer = 0; AUseBufferedSockets: Boolean = FALSE); overload; +{$ELSE} + constructor Create( const AServer: TServerSocket; AClientTimeout: Longword = 0); overload; + constructor Create( APort: Integer; AClientTimeout: Longword = 0; AUseBufferedSockets: Boolean = FALSE); overload; +{$ENDIF} + destructor Destroy; override; + procedure Listen; override; + procedure Close; override; + end; + + TBufferedTransportImpl = class( TTransportImpl ) + private + FInputBuffer : IThriftStream; + FOutputBuffer : IThriftStream; + FTransport : IStreamTransport; + FBufSize : Integer; + + procedure InitBuffers; + function GetUnderlyingTransport: ITransport; + protected + function GetIsOpen: Boolean; override; + procedure Flush; override; + public + 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; + constructor Create( const ATransport : IStreamTransport ); overload; + constructor Create( const ATransport : IStreamTransport; ABufSize: Integer); overload; + property UnderlyingTransport: ITransport read GetUnderlyingTransport; + property IsOpen: Boolean read GetIsOpen; + end; + + TSocketImpl = class(TStreamTransportImpl) + private +{$IFDEF OLD_SOCKETS} + FClient : TCustomIpClient; +{$ELSE} + FClient: TSocket; +{$ENDIF} + FOwnsClient : Boolean; + FHost : string; + FPort : Integer; +{$IFDEF OLD_SOCKETS} + FTimeout : Integer; +{$ELSE} + FTimeout : Longword; +{$ENDIF} + + procedure InitSocket; + protected + function GetIsOpen: Boolean; override; + public + procedure Open; override; +{$IFDEF OLD_SOCKETS} + constructor Create( const AClient : TCustomIpClient; aOwnsClient : Boolean; ATimeout: Integer = 0); overload; + constructor Create( const AHost: string; APort: Integer; ATimeout: Integer = 0); overload; +{$ELSE} + constructor Create(const AClient: TSocket; aOwnsClient: Boolean); overload; + constructor Create( const AHost: string; APort: Integer; ATimeout: Longword = 0); overload; +{$ENDIF} + destructor Destroy; override; + procedure Close; override; +{$IFDEF OLD_SOCKETS} + property TcpClient: TCustomIpClient read FClient; +{$ELSE} + property TcpClient: TSocket read FClient; +{$ENDIF} + property Host : string read FHost; + property Port: Integer read FPort; + end; + + TFramedTransportImpl = class( TTransportImpl) + private const + FHeaderSize : Integer = 4; + private class var + FHeader_Dummy : array of Byte; + protected + FTransport : ITransport; + FWriteBuffer : TMemoryStream; + FReadBuffer : TMemoryStream; + + procedure InitWriteBuffer; + procedure ReadFrame; + public + type + TFactory = class( TTransportFactoryImpl ) + public + function GetTransport( const ATrans: ITransport): ITransport; override; + end; + + {$IFDEF HAVE_CLASS_CTOR} + class constructor Create; + {$ENDIF} + + constructor Create; overload; + constructor Create( const ATrans: ITransport); overload; + destructor Destroy; override; + + procedure Open(); override; + function GetIsOpen: Boolean; 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; + end; + +{$IFNDEF HAVE_CLASS_CTOR} +procedure TFramedTransportImpl_Initialize; +{$ENDIF} + +const + DEFAULT_THRIFT_TIMEOUT = 5 * 1000; // ms + DEFAULT_THRIFT_SECUREPROTOCOLS = [ TSecureProtocol.TLS_1_1, TSecureProtocol.TLS_1_2]; + + + +implementation + +{ TTransportImpl } + +procedure TTransportImpl.Flush; +begin + // nothing to do +end; + +function TTransportImpl.Peek: Boolean; +begin + Result := IsOpen; +end; + +function TTransportImpl.Read(var buf: TBytes; off: Integer; len: Integer): Integer; +begin + if Length(buf) > 0 + then result := Read( @buf[0], Length(buf), off, len) + else result := 0; +end; + +function TTransportImpl.ReadAll(var buf: TBytes; off: Integer; len: Integer): Integer; +begin + if Length(buf) > 0 + then result := ReadAll( @buf[0], Length(buf), off, len) + else result := 0; +end; + +procedure TTransportImpl.Write( const buf: TBytes); +begin + if Length(buf) > 0 + then Write( @buf[0], 0, Length(buf)); +end; + +procedure TTransportImpl.Write( const buf: TBytes; off: Integer; len: Integer); +begin + if Length(buf) > 0 + then Write( @buf[0], off, len); +end; + +function TTransportImpl.ReadAll(const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; +var ret : Integer; +begin + result := 0; + while result < len do begin + ret := Read( pBuf, buflen, off + result, len - result); + if ret > 0 + then Inc( result, ret) + else raise TTransportExceptionNotOpen.Create( 'Cannot read, Remote side has closed' ); + end; +end; + +procedure TTransportImpl.Write( const pBuf : Pointer; len : Integer); +begin + Self.Write( pBuf, 0, len); +end; + +{ TTransportException } + +function TTransportException.GetType: TExceptionType; +begin + if Self is TTransportExceptionNotOpen then Result := TExceptionType.NotOpen + else if Self is TTransportExceptionAlreadyOpen then Result := TExceptionType.AlreadyOpen + else if Self is TTransportExceptionTimedOut then Result := TExceptionType.TimedOut + else if Self is TTransportExceptionEndOfFile then Result := TExceptionType.EndOfFile + else if Self is TTransportExceptionBadArgs then Result := TExceptionType.BadArgs + else if Self is TTransportExceptionInterrupted then Result := TExceptionType.Interrupted + else Result := TExceptionType.Unknown; +end; + +constructor TTransportException.HiddenCreate(const Msg: string); +begin + inherited Create(Msg); +end; + +class function TTransportException.Create(AType: TExceptionType): TTransportException; +begin + //no inherited; +{$WARN SYMBOL_DEPRECATED OFF} + Result := Create(AType, '') +{$WARN SYMBOL_DEPRECATED DEFAULT} +end; + +class function TTransportException.Create(AType: TExceptionType; + const msg: string): TTransportException; +begin + case AType of + TExceptionType.NotOpen: Result := TTransportExceptionNotOpen.Create(msg); + TExceptionType.AlreadyOpen: Result := TTransportExceptionAlreadyOpen.Create(msg); + TExceptionType.TimedOut: Result := TTransportExceptionTimedOut.Create(msg); + TExceptionType.EndOfFile: Result := TTransportExceptionEndOfFile.Create(msg); + TExceptionType.BadArgs: Result := TTransportExceptionBadArgs.Create(msg); + TExceptionType.Interrupted: Result := TTransportExceptionInterrupted.Create(msg); + else + Result := TTransportExceptionUnknown.Create(msg); + end; +end; + +class function TTransportException.Create(const msg: string): TTransportException; +begin + Result := TTransportExceptionUnknown.Create(Msg); +end; + +{ TTransportExceptionSpecialized } + +constructor TTransportExceptionSpecialized.Create(const Msg: string); +begin + inherited HiddenCreate(Msg); +end; + +{ TTransportFactoryImpl } + +function TTransportFactoryImpl.GetTransport( const ATrans: ITransport): ITransport; +begin + Result := ATrans; +end; + +{ TServerSocket } + +{$IFDEF OLD_SOCKETS} +constructor TServerSocketImpl.Create( const AServer: TTcpServer; AClientTimeout: Integer); +begin + inherited Create; + FServer := AServer; + FClientTimeout := AClientTimeout; +end; +{$ELSE} +constructor TServerSocketImpl.Create( const AServer: TServerSocket; AClientTimeout: Longword); +begin + inherited Create; + FServer := AServer; + FServer.RecvTimeout := AClientTimeout; + FServer.SendTimeout := AClientTimeout; +end; +{$ENDIF} + +{$IFDEF OLD_SOCKETS} +constructor TServerSocketImpl.Create(APort, AClientTimeout: Integer; AUseBufferedSockets: Boolean); +{$ELSE} +constructor TServerSocketImpl.Create(APort: Integer; AClientTimeout: Longword; AUseBufferedSockets: Boolean); +{$ENDIF} +begin + inherited Create; +{$IFDEF OLD_SOCKETS} + FPort := APort; + FClientTimeout := AClientTimeout; + FServer := TTcpServer.Create( nil ); + FServer.BlockMode := bmBlocking; + {$IF CompilerVersion >= 21.0} + FServer.LocalPort := AnsiString( IntToStr( FPort)); + {$ELSE} + FServer.LocalPort := IntToStr( FPort); + {$IFEND} +{$ELSE} + FServer := TServerSocket.Create(APort, AClientTimeout, AClientTimeout); +{$ENDIF} + FUseBufferedSocket := AUseBufferedSockets; + FOwnsServer := True; +end; + +destructor TServerSocketImpl.Destroy; +begin + if FOwnsServer then begin + FServer.Free; + FServer := nil; + end; + inherited; +end; + +function TServerSocketImpl.Accept( const fnAccepting: TProc): ITransport; +var +{$IFDEF OLD_SOCKETS} + client : TCustomIpClient; +{$ELSE} + client: TSocket; +{$ENDIF} + trans : IStreamTransport; +begin + if FServer = nil then begin + raise TTransportExceptionNotOpen.Create('No underlying server socket.'); + end; + +{$IFDEF OLD_SOCKETS} + client := nil; + try + client := TCustomIpClient.Create(nil); + + if Assigned(fnAccepting) + then fnAccepting(); + + if not FServer.Accept( client) then begin + client.Free; + Result := nil; + Exit; + end; + + if client = nil then begin + Result := nil; + Exit; + end; + + trans := TSocketImpl.Create( client, TRUE, FClientTimeout); + client := nil; // trans owns it now + + if FUseBufferedSocket + then result := TBufferedTransportImpl.Create( trans) + else result := trans; + + except + on E: Exception do begin + client.Free; + raise TTransportExceptionUnknown.Create(E.ToString); + end; + end; +{$ELSE} + if Assigned(fnAccepting) then + fnAccepting(); + + client := FServer.Accept; + try + trans := TSocketImpl.Create(client, True); + client := nil; + + if FUseBufferedSocket then + Result := TBufferedTransportImpl.Create(trans) + else + Result := trans; + except + client.Free; + raise; + end; +{$ENDIF} +end; + +procedure TServerSocketImpl.Listen; +begin + if FServer <> nil then + begin +{$IFDEF OLD_SOCKETS} + try + FServer.Active := True; + except + on E: Exception + do raise TTransportExceptionUnknown.Create('Could not accept on listening socket: ' + E.Message); + end; +{$ELSE} + FServer.Listen; +{$ENDIF} + end; +end; + +procedure TServerSocketImpl.Close; +begin + if FServer <> nil then +{$IFDEF OLD_SOCKETS} + try + FServer.Active := False; + except + on E: Exception + do raise TTransportExceptionUnknown.Create('Error on closing socket : ' + E.Message); + end; +{$ELSE} + FServer.Close; +{$ENDIF} +end; + +{ TSocket } + +{$IFDEF OLD_SOCKETS} +constructor TSocketImpl.Create( const AClient : TCustomIpClient; aOwnsClient : Boolean; ATimeout: Integer = 0); +var stream : IThriftStream; +begin + FClient := AClient; + FTimeout := ATimeout; + FOwnsClient := aOwnsClient; + stream := TTcpSocketStreamImpl.Create( FClient, FTimeout); + inherited Create( stream, stream); +end; +{$ELSE} +constructor TSocketImpl.Create(const AClient: TSocket; aOwnsClient: Boolean); +var stream : IThriftStream; +begin + FClient := AClient; + FTimeout := AClient.RecvTimeout; + FOwnsClient := aOwnsClient; + stream := TTcpSocketStreamImpl.Create(FClient, FTimeout); + inherited Create(stream, stream); +end; +{$ENDIF} + +{$IFDEF OLD_SOCKETS} +constructor TSocketImpl.Create(const AHost: string; APort, ATimeout: Integer); +{$ELSE} +constructor TSocketImpl.Create(const AHost: string; APort: Integer; ATimeout: Longword); +{$ENDIF} +begin + inherited Create(nil,nil); + FHost := AHost; + FPort := APort; + FTimeout := ATimeout; + InitSocket; +end; + +destructor TSocketImpl.Destroy; +begin + if FOwnsClient + then FreeAndNil( FClient); + inherited; +end; + +procedure TSocketImpl.Close; +begin + inherited Close; + + FInputStream := nil; + FOutputStream := nil; + + if FOwnsClient + then FreeAndNil( FClient) + else FClient := nil; +end; + +function TSocketImpl.GetIsOpen: Boolean; +begin +{$IFDEF OLD_SOCKETS} + Result := (FClient <> nil) and FClient.Connected; +{$ELSE} + Result := (FClient <> nil) and FClient.IsOpen +{$ENDIF} +end; + +procedure TSocketImpl.InitSocket; +var + stream : IThriftStream; +begin + if FOwnsClient + then FreeAndNil( FClient) + else FClient := nil; + +{$IFDEF OLD_SOCKETS} + FClient := TTcpClient.Create( nil); +{$ELSE} + FClient := TSocket.Create(FHost, FPort); +{$ENDIF} + FOwnsClient := True; + + stream := TTcpSocketStreamImpl.Create( FClient, FTimeout); + FInputStream := stream; + FOutputStream := stream; +end; + +procedure TSocketImpl.Open; +begin + if IsOpen then begin + raise TTransportExceptionAlreadyOpen.Create('Socket already connected'); + end; + + if FHost = '' then begin + raise TTransportExceptionNotOpen.Create('Cannot open null host'); + end; + + if Port <= 0 then begin + raise TTransportExceptionNotOpen.Create('Cannot open without port'); + end; + + if FClient = nil + then InitSocket; + +{$IFDEF OLD_SOCKETS} + FClient.RemoteHost := TSocketHost( Host); + FClient.RemotePort := TSocketPort( IntToStr( Port)); + FClient.Connect; +{$ELSE} + FClient.Open; +{$ENDIF} + + FInputStream := TTcpSocketStreamImpl.Create( FClient, FTimeout); + FOutputStream := FInputStream; +end; + +{ TBufferedStream } + +procedure TBufferedStreamImpl.Close; +begin + Flush; + FStream := nil; + + FReadBuffer.Free; + FReadBuffer := nil; + + FWriteBuffer.Free; + FWriteBuffer := nil; +end; + +constructor TBufferedStreamImpl.Create( const AStream: IThriftStream; ABufSize: Integer); +begin + inherited Create; + FStream := AStream; + FBufSize := ABufSize; + FReadBuffer := TMemoryStream.Create; + FWriteBuffer := TMemoryStream.Create; +end; + +destructor TBufferedStreamImpl.Destroy; +begin + Close; + inherited; +end; + +procedure TBufferedStreamImpl.Flush; +var + buf : TBytes; + len : Integer; +begin + if IsOpen then begin + len := FWriteBuffer.Size; + if len > 0 then begin + SetLength( buf, len ); + FWriteBuffer.Position := 0; + FWriteBuffer.Read( Pointer(@buf[0])^, len ); + FStream.Write( buf, 0, len ); + end; + FWriteBuffer.Clear; + end; +end; + +function TBufferedStreamImpl.IsOpen: Boolean; +begin + Result := (FWriteBuffer <> nil) + and (FReadBuffer <> nil) + and (FStream <> nil) + and FStream.IsOpen; +end; + +procedure TBufferedStreamImpl.Open; +begin + FStream.Open; +end; + +function TBufferedStreamImpl.Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +var + nRead : Integer; + tempbuf : TBytes; + pTmp : PByte; +begin + inherited; + Result := 0; + + if IsOpen then begin + while count > 0 do begin + + if FReadBuffer.Position >= FReadBuffer.Size then begin + FReadBuffer.Clear; + SetLength( tempbuf, FBufSize); + nRead := FStream.Read( tempbuf, 0, FBufSize ); + if nRead = 0 then Break; // avoid infinite loop + + FReadBuffer.WriteBuffer( Pointer(@tempbuf[0])^, nRead ); + FReadBuffer.Position := 0; + end; + + if FReadBuffer.Position < FReadBuffer.Size then begin + nRead := Min( FReadBuffer.Size - FReadBuffer.Position, count); + pTmp := pBuf; + Inc( pTmp, offset); + Inc( Result, FReadBuffer.Read( pTmp^, nRead)); + Dec( count, nRead); + Inc( offset, nRead); + end; + end; + end; +end; + +function TBufferedStreamImpl.ToArray: TBytes; +var len : Integer; +begin + len := 0; + + if IsOpen then begin + len := FReadBuffer.Size; + end; + + SetLength( Result, len); + + if len > 0 then begin + FReadBuffer.Position := 0; + FReadBuffer.Read( Pointer(@Result[0])^, len ); + end; +end; + +procedure TBufferedStreamImpl.Write( const pBuf : Pointer; offset: Integer; count: Integer); +var pTmp : PByte; +begin + inherited; + if count > 0 then begin + if IsOpen then begin + pTmp := pBuf; + Inc( pTmp, offset); + FWriteBuffer.Write( pTmp^, count ); + if FWriteBuffer.Size > FBufSize then begin + Flush; + end; + end; + end; +end; + +{ TStreamTransportImpl } + +constructor TStreamTransportImpl.Create( const AInputStream : IThriftStream; const AOutputStream : IThriftStream); +begin + inherited Create; + FInputStream := AInputStream; + FOutputStream := AOutputStream; +end; + +destructor TStreamTransportImpl.Destroy; +begin + FInputStream := nil; + FOutputStream := nil; + inherited; +end; + +procedure TStreamTransportImpl.Close; +begin + FInputStream := nil; + FOutputStream := nil; +end; + +procedure TStreamTransportImpl.Flush; +begin + if FOutputStream = nil then begin + raise TTransportExceptionNotOpen.Create('Cannot flush null outputstream' ); + end; + + FOutputStream.Flush; +end; + +function TStreamTransportImpl.GetInputStream: IThriftStream; +begin + Result := FInputStream; +end; + +function TStreamTransportImpl.GetIsOpen: Boolean; +begin + Result := True; +end; + +function TStreamTransportImpl.GetOutputStream: IThriftStream; +begin + Result := FOutputStream; +end; + +procedure TStreamTransportImpl.Open; +begin + +end; + +function TStreamTransportImpl.Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; +begin + if FInputStream = nil then begin + raise TTransportExceptionNotOpen.Create('Cannot read from null inputstream' ); + end; + + Result := FInputStream.Read( pBuf,buflen, off, len ); +end; + +procedure TStreamTransportImpl.Write( const pBuf : Pointer; off, len : Integer); +begin + if FOutputStream = nil then begin + raise TTransportExceptionNotOpen.Create('Cannot write to null outputstream' ); + end; + + FOutputStream.Write( pBuf, off, len ); +end; + +{ TBufferedTransportImpl } + +constructor TBufferedTransportImpl.Create( const ATransport: IStreamTransport); +begin + //no inherited; + Create( ATransport, 1024 ); +end; + +constructor TBufferedTransportImpl.Create( const ATransport: IStreamTransport; ABufSize: Integer); +begin + inherited Create; + FTransport := ATransport; + FBufSize := ABufSize; + InitBuffers; +end; + +procedure TBufferedTransportImpl.Close; +begin + FTransport.Close; + FInputBuffer := nil; + FOutputBuffer := nil; +end; + +procedure TBufferedTransportImpl.Flush; +begin + if FOutputBuffer <> nil then begin + FOutputBuffer.Flush; + end; +end; + +function TBufferedTransportImpl.GetIsOpen: Boolean; +begin + Result := FTransport.IsOpen; +end; + +function TBufferedTransportImpl.GetUnderlyingTransport: ITransport; +begin + Result := FTransport; +end; + +procedure TBufferedTransportImpl.InitBuffers; +begin + if FTransport.InputStream <> nil then begin + FInputBuffer := TBufferedStreamImpl.Create( FTransport.InputStream, FBufSize ); + end; + if FTransport.OutputStream <> nil then begin + FOutputBuffer := TBufferedStreamImpl.Create( FTransport.OutputStream, FBufSize ); + end; +end; + +procedure TBufferedTransportImpl.Open; +begin + FTransport.Open; + InitBuffers; // we need to get the buffers to match FTransport substreams again +end; + +function TBufferedTransportImpl.Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; +begin + Result := 0; + if FInputBuffer <> nil then begin + Result := FInputBuffer.Read( pBuf,buflen, off, len ); + end; +end; + +procedure TBufferedTransportImpl.Write( const pBuf : Pointer; off, len : Integer); +begin + if FOutputBuffer <> nil then begin + FOutputBuffer.Write( pBuf, off, len ); + end; +end; + +{ TFramedTransportImpl } + +{$IFDEF HAVE_CLASS_CTOR} +class constructor TFramedTransportImpl.Create; +begin + SetLength( FHeader_Dummy, FHeaderSize); + FillChar( FHeader_Dummy[0], Length( FHeader_Dummy) * SizeOf( Byte ), 0); +end; +{$ELSE} +procedure TFramedTransportImpl_Initialize; +begin + SetLength( TFramedTransportImpl.FHeader_Dummy, TFramedTransportImpl.FHeaderSize); + FillChar( TFramedTransportImpl.FHeader_Dummy[0], + Length( TFramedTransportImpl.FHeader_Dummy) * SizeOf( Byte ), 0); +end; +{$ENDIF} + +constructor TFramedTransportImpl.Create; +begin + inherited Create; + InitWriteBuffer; +end; + +procedure TFramedTransportImpl.Close; +begin + FTransport.Close; +end; + +constructor TFramedTransportImpl.Create( const ATrans: ITransport); +begin + inherited Create; + InitWriteBuffer; + FTransport := ATrans; +end; + +destructor TFramedTransportImpl.Destroy; +begin + FWriteBuffer.Free; + FReadBuffer.Free; + inherited; +end; + +procedure TFramedTransportImpl.Flush; +var + buf : TBytes; + len : Integer; + data_len : Integer; + +begin + len := FWriteBuffer.Size; + SetLength( buf, len); + if len > 0 then begin + System.Move( FWriteBuffer.Memory^, buf[0], len ); + end; + + data_len := len - FHeaderSize; + if (data_len < 0) then begin + raise TTransportExceptionUnknown.Create('TFramedTransport.Flush: data_len < 0' ); + end; + + InitWriteBuffer; + + buf[0] := Byte($FF and (data_len shr 24)); + buf[1] := Byte($FF and (data_len shr 16)); + buf[2] := Byte($FF and (data_len shr 8)); + buf[3] := Byte($FF and data_len); + + FTransport.Write( buf, 0, len ); + FTransport.Flush; +end; + +function TFramedTransportImpl.GetIsOpen: Boolean; +begin + Result := FTransport.IsOpen; +end; + +type + TAccessMemoryStream = class(TMemoryStream) + end; + +procedure TFramedTransportImpl.InitWriteBuffer; +begin + FWriteBuffer.Free; + FWriteBuffer := TMemoryStream.Create; + TAccessMemoryStream(FWriteBuffer).Capacity := 1024; + FWriteBuffer.Write( Pointer(@FHeader_Dummy[0])^, FHeaderSize); +end; + +procedure TFramedTransportImpl.Open; +begin + FTransport.Open; +end; + +function TFramedTransportImpl.Read( const pBuf : Pointer; const buflen : Integer; off: Integer; len: Integer): Integer; +var pTmp : PByte; +begin + if len > (buflen-off) + then len := buflen-off; + + pTmp := pBuf; + Inc( pTmp, off); + + if (FReadBuffer <> nil) and (len > 0) then begin + result := FReadBuffer.Read( pTmp^, len); + if result > 0 then begin + Exit; + end; + end; + + ReadFrame; + if len > 0 + then Result := FReadBuffer.Read( pTmp^, len) + else Result := 0; +end; + +procedure TFramedTransportImpl.ReadFrame; +var + i32rd : TBytes; + size : Integer; + buff : TBytes; +begin + SetLength( i32rd, FHeaderSize ); + FTransport.ReadAll( i32rd, 0, FHeaderSize); + size := + ((i32rd[0] and $FF) shl 24) or + ((i32rd[1] and $FF) shl 16) or + ((i32rd[2] and $FF) shl 8) or + (i32rd[3] and $FF); + SetLength( buff, size ); + FTransport.ReadAll( buff, 0, size ); + FReadBuffer.Free; + FReadBuffer := TMemoryStream.Create; + if Length(buff) > 0 + then FReadBuffer.Write( Pointer(@buff[0])^, size ); + FReadBuffer.Position := 0; +end; + +procedure TFramedTransportImpl.Write( const pBuf : Pointer; off, len : Integer); +var pTmp : PByte; +begin + if len > 0 then begin + pTmp := pBuf; + Inc( pTmp, off); + + FWriteBuffer.Write( pTmp^, len ); + end; +end; + +{ TFramedTransport.TFactory } + +function TFramedTransportImpl.TFactory.GetTransport( const ATrans: ITransport): ITransport; +begin + Result := TFramedTransportImpl.Create( ATrans ); +end; + +{ TTcpSocketStreamImpl } + +procedure TTcpSocketStreamImpl.Close; +begin + FTcpClient.Close; +end; + +{$IFDEF OLD_SOCKETS} +constructor TTcpSocketStreamImpl.Create( const ATcpClient: TCustomIpClient; const aTimeout : Integer); +begin + inherited Create; + FTcpClient := ATcpClient; + FTimeout := aTimeout; +end; +{$ELSE} +constructor TTcpSocketStreamImpl.Create( const ATcpClient: TSocket; const aTimeout : Longword); +begin + inherited Create; + FTcpClient := ATcpClient; + if aTimeout = 0 then + FTcpClient.RecvTimeout := SLEEP_TIME + else + FTcpClient.RecvTimeout := aTimeout; + FTcpClient.SendTimeout := aTimeout; +end; +{$ENDIF} + +procedure TTcpSocketStreamImpl.Flush; +begin + +end; + +function TTcpSocketStreamImpl.IsOpen: Boolean; +begin +{$IFDEF OLD_SOCKETS} + Result := FTcpClient.Active; +{$ELSE} + Result := FTcpClient.IsOpen; +{$ENDIF} +end; + +procedure TTcpSocketStreamImpl.Open; +begin + FTcpClient.Open; +end; + + +{$IFDEF OLD_SOCKETS} +function TTcpSocketStreamImpl.Select( ReadReady, WriteReady, ExceptFlag: PBoolean; + TimeOut: Integer; var wsaError : Integer): Integer; +var + ReadFds: TFDset; + ReadFdsptr: PFDset; + WriteFds: TFDset; + WriteFdsptr: PFDset; + ExceptFds: TFDset; + ExceptFdsptr: PFDset; + tv: timeval; + Timeptr: PTimeval; + socket : TSocket; +begin + if not FTcpClient.Active then begin + wsaError := WSAEINVAL; + Exit( SOCKET_ERROR); + end; + + socket := FTcpClient.Handle; + + if Assigned(ReadReady) then begin + ReadFdsptr := @ReadFds; + FD_ZERO(ReadFds); + FD_SET(socket, ReadFds); + end + else begin + ReadFdsptr := nil; + end; + + if Assigned(WriteReady) then begin + WriteFdsptr := @WriteFds; + FD_ZERO(WriteFds); + FD_SET(socket, WriteFds); + end + else begin + WriteFdsptr := nil; + end; + + if Assigned(ExceptFlag) then begin + ExceptFdsptr := @ExceptFds; + FD_ZERO(ExceptFds); + FD_SET(socket, ExceptFds); + end + else begin + ExceptFdsptr := nil; + end; + + if TimeOut >= 0 then begin + tv.tv_sec := TimeOut div 1000; + tv.tv_usec := 1000 * (TimeOut mod 1000); + Timeptr := @tv; + end + else begin + Timeptr := nil; // wait forever + end; + + wsaError := 0; + try + {$IFDEF MSWINDOWS} + {$IFDEF OLD_UNIT_NAMES} + result := WinSock.select( socket + 1, ReadFdsptr, WriteFdsptr, ExceptFdsptr, Timeptr); + {$ELSE} + result := Winapi.WinSock.select( socket + 1, ReadFdsptr, WriteFdsptr, ExceptFdsptr, Timeptr); + {$ENDIF} + {$ENDIF} + {$IFDEF LINUX} + result := Libc.select( socket + 1, ReadFdsptr, WriteFdsptr, ExceptFdsptr, Timeptr); + {$ENDIF} + + if result = SOCKET_ERROR + then wsaError := WSAGetLastError; + + except + result := SOCKET_ERROR; + end; + + if Assigned(ReadReady) then + ReadReady^ := FD_ISSET(socket, ReadFds); + + if Assigned(WriteReady) then + WriteReady^ := FD_ISSET(socket, WriteFds); + + if Assigned(ExceptFlag) then + ExceptFlag^ := FD_ISSET(socket, ExceptFds); +end; +{$ENDIF} + +{$IFDEF OLD_SOCKETS} +function TTcpSocketStreamImpl.WaitForData( TimeOut : Integer; pBuf : Pointer; + DesiredBytes : Integer; + var wsaError, bytesReady : Integer): TWaitForData; +var bCanRead, bError : Boolean; + retval : Integer; +const + MSG_PEEK = {$IFDEF OLD_UNIT_NAMES} WinSock.MSG_PEEK {$ELSE} Winapi.WinSock.MSG_PEEK {$ENDIF}; +begin + bytesReady := 0; + + // The select function returns the total number of socket handles that are ready + // and contained in the fd_set structures, zero if the time limit expired, + // or SOCKET_ERROR if an error occurred. If the return value is SOCKET_ERROR, + // WSAGetLastError can be used to retrieve a specific error code. + retval := Self.Select( @bCanRead, nil, @bError, TimeOut, wsaError); + if retval = SOCKET_ERROR + then Exit( TWaitForData.wfd_Error); + if (retval = 0) or not bCanRead + then Exit( TWaitForData.wfd_Timeout); + + // recv() returns the number of bytes received, or -1 if an error occurred. + // The return value will be 0 when the peer has performed an orderly shutdown. + + retval := recv( FTcpClient.Handle, pBuf^, DesiredBytes, MSG_PEEK); + if retval <= 0 + then Exit( TWaitForData.wfd_Error); + + // at least we have some data + bytesReady := Min( retval, DesiredBytes); + result := TWaitForData.wfd_HaveData; +end; +{$ENDIF} + +{$IFDEF OLD_SOCKETS} +function TTcpSocketStreamImpl.Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +// old sockets version +var wfd : TWaitForData; + wsaError, + msecs : Integer; + nBytes : Integer; + pTmp : PByte; +begin + inherited; + + if FTimeout > 0 + then msecs := FTimeout + else msecs := DEFAULT_THRIFT_TIMEOUT; + + result := 0; + pTmp := pBuf; + Inc( pTmp, offset); + while count > 0 do begin + + while TRUE do begin + wfd := WaitForData( msecs, pTmp, count, wsaError, nBytes); + case wfd of + TWaitForData.wfd_Error : Exit; + TWaitForData.wfd_HaveData : Break; + TWaitForData.wfd_Timeout : begin + if (FTimeout = 0) + then Exit + else begin + raise TTransportExceptionTimedOut.Create(SysErrorMessage(Cardinal(wsaError))); + + end; + end; + else + ASSERT( FALSE); + end; + end; + + // reduce the timeout once we got data + if FTimeout > 0 + then msecs := FTimeout div 10 + else msecs := DEFAULT_THRIFT_TIMEOUT div 10; + msecs := Max( msecs, 200); + + ASSERT( nBytes <= count); + nBytes := FTcpClient.ReceiveBuf( pTmp^, nBytes); + Inc( pTmp, nBytes); + Dec( count, nBytes); + Inc( result, nBytes); + end; +end; + +function TTcpSocketStreamImpl.ToArray: TBytes; +// old sockets version +var len : Integer; +begin + len := 0; + if IsOpen then begin + len := FTcpClient.BytesReceived; + end; + + SetLength( Result, len ); + + if len > 0 then begin + FTcpClient.ReceiveBuf( Pointer(@Result[0])^, len); + end; +end; + +procedure TTcpSocketStreamImpl.Write( const pBuf : Pointer; offset, count: Integer); +// old sockets version +var bCanWrite, bError : Boolean; + retval, wsaError : Integer; + pTmp : PByte; +begin + inherited; + + if not FTcpClient.Active + then raise TTransportExceptionNotOpen.Create('not open'); + + // The select function returns the total number of socket handles that are ready + // and contained in the fd_set structures, zero if the time limit expired, + // or SOCKET_ERROR if an error occurred. If the return value is SOCKET_ERROR, + // WSAGetLastError can be used to retrieve a specific error code. + retval := Self.Select( nil, @bCanWrite, @bError, FTimeOut, wsaError); + if retval = SOCKET_ERROR + then raise TTransportExceptionUnknown.Create(SysErrorMessage(Cardinal(wsaError))); + + if (retval = 0) + then raise TTransportExceptionTimedOut.Create('timed out'); + + if bError or not bCanWrite + then raise TTransportExceptionUnknown.Create('unknown error'); + + pTmp := pBuf; + Inc( pTmp, offset); + FTcpClient.SendBuf( pTmp^, count); +end; + +{$ELSE} + +function TTcpSocketStreamImpl.Read( const pBuf : Pointer; const buflen : Integer; offset: Integer; count: Integer): Integer; +// new sockets version +var nBytes : Integer; + pTmp : PByte; +begin + inherited; + + result := 0; + pTmp := pBuf; + Inc( pTmp, offset); + while count > 0 do begin + nBytes := FTcpClient.Read( pTmp^, count); + if nBytes = 0 then Exit; + Inc( pTmp, nBytes); + Dec( count, nBytes); + Inc( result, nBytes); + end; +end; + +function TTcpSocketStreamImpl.ToArray: TBytes; +// new sockets version +var len : Integer; +begin + len := 0; + try + if FTcpClient.Peek then + repeat + SetLength(Result, Length(Result) + 1024); + len := FTcpClient.Read(Result[Length(Result) - 1024], 1024); + until len < 1024; + except + on TTransportException do begin { don't allow default exceptions } end; + else raise; + end; + if len > 0 then + SetLength(Result, Length(Result) - 1024 + len); +end; + +procedure TTcpSocketStreamImpl.Write( const pBuf : Pointer; offset, count: Integer); +// new sockets version +var pTmp : PByte; +begin + inherited; + + if not FTcpClient.IsOpen + then raise TTransportExceptionNotOpen.Create('not open'); + + pTmp := pBuf; + Inc( pTmp, offset); + FTcpClient.Write( pTmp^, count); +end; + +{$ENDIF} + + +{$IF CompilerVersion < 21.0} +initialization +begin + TFramedTransportImpl_Initialize; +end; +{$IFEND} + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.TypeRegistry.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.TypeRegistry.pas new file mode 100644 index 000000000..c18e97fe6 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.TypeRegistry.pas @@ -0,0 +1,95 @@ +(* + * 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.TypeRegistry; + +interface + +uses + Generics.Collections, TypInfo, + Thrift.Protocol; + +type + TFactoryMethod<T> = function:T; + + TypeRegistry = class + private + class var FTypeInfoToFactoryLookup : TDictionary<Pointer, Pointer>; + public + class constructor Create; + class destructor Destroy; + class procedure RegisterTypeFactory<F>(const aFactoryMethod: TFactoryMethod<F>); + class function Construct<F>: F; + class function ConstructFromTypeInfo(const aTypeInfo: PTypeInfo): IBase; + end; + +implementation + + +{ TypeRegistration } + +class constructor TypeRegistry.Create; +begin + FTypeInfoToFactoryLookup := TDictionary<Pointer, Pointer>.Create; +end; + +class destructor TypeRegistry.Destroy; +begin + FTypeInfoToFactoryLookup.Free; +end; + +class procedure TypeRegistry.RegisterTypeFactory<F>(const aFactoryMethod: TFactoryMethod<F>); +var + TypeInfo : Pointer; +begin + TypeInfo := System.TypeInfo(F); + + if (TypeInfo <> nil) and (PTypeInfo(TypeInfo).Kind = tkInterface) + then FTypeInfoToFactoryLookup.AddOrSetValue(TypeInfo, @aFactoryMethod); +end; + +class function TypeRegistry.Construct<F>: F; +var + TypeInfo : PTypeInfo; + Factory : Pointer; +begin + Result := default(F); + + TypeInfo := System.TypeInfo(F); + + if Assigned(TypeInfo) and (TypeInfo.Kind = tkInterface) + then begin + if FTypeInfoToFactoryLookup.TryGetValue(TypeInfo, Factory) + then Result := TFactoryMethod<F>(Factory)(); + end; +end; + +class function TypeRegistry.ConstructFromTypeInfo(const aTypeInfo: PTypeInfo): IBase; +var + Factory : Pointer; +begin + Result := nil; + if FTypeInfoToFactoryLookup.TryGetValue(aTypeInfo, Factory) + then Result := IBase(TFactoryMethod<IBase>(Factory)()); +end; + + + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.Utils.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Utils.pas new file mode 100644 index 000000000..ede265646 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.Utils.pas @@ -0,0 +1,336 @@ +(* + * 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.Utils; + +interface + +{$I Thrift.Defines.inc} + +uses + {$IFDEF OLD_UNIT_NAMES} + Classes, Windows, SysUtils, Character, SyncObjs, TypInfo, Rtti; + {$ELSE} + System.Classes, Winapi.Windows, System.SysUtils, System.Character, + System.SyncObjs, System.TypInfo, System.Rtti; + {$ENDIF} + +type + ISupportsToString = interface + ['{AF71C350-E0CD-4E94-B77C-0310DC8227FF}'] + function ToString : string; + end; + + + IOverlappedHelper = interface + ['{A1832EFA-2E02-4884-8F09-F0A0277157FA}'] + function Overlapped : TOverlapped; + function OverlappedPtr : POverlapped; + function WaitHandle : THandle; + function WaitFor(dwTimeout: DWORD) : DWORD; + end; + + TOverlappedHelperImpl = class( TInterfacedObject, IOverlappedHelper) + strict protected + FOverlapped : TOverlapped; + FEvent : TEvent; + + // IOverlappedHelper + function Overlapped : TOverlapped; + function OverlappedPtr : POverlapped; + function WaitHandle : THandle; + function WaitFor(dwTimeout: DWORD) : DWORD; + public + constructor Create; + destructor Destroy; override; + end; + + + TThriftStringBuilder = class( TStringBuilder) + public + function Append(const Value: TBytes): TStringBuilder; overload; + function Append(const Value: ISupportsToString): TStringBuilder; overload; + end; + + + Base64Utils = class sealed + public + class function Encode( const src : TBytes; srcOff, len : Integer; dst : TBytes; dstOff : Integer) : Integer; static; + class function Decode( const src : TBytes; srcOff, len : Integer; dst : TBytes; dstOff : Integer) : Integer; static; + end; + + + CharUtils = class sealed + public + class function IsHighSurrogate( const c : Char) : Boolean; static; inline; + class function IsLowSurrogate( const c : Char) : Boolean; static; inline; + end; + + EnumUtils<T> = class sealed + public + class function ToString(const value : Integer) : string; reintroduce; static; inline; + end; + + StringUtils<T> = class sealed + public + class function ToString(const value : T) : string; reintroduce; static; inline; + end; + + +const + THRIFT_MIMETYPE = 'application/x-thrift'; + +{$IFDEF Win64} +function InterlockedExchangeAdd64( var Addend : Int64; Value : Int64) : Int64; +{$ENDIF} + + +implementation + +{ TOverlappedHelperImpl } + +constructor TOverlappedHelperImpl.Create; +begin + inherited Create; + FillChar( FOverlapped, SizeOf(FOverlapped), 0); + FEvent := TEvent.Create( nil, TRUE, FALSE, ''); // always ManualReset, see MSDN + FOverlapped.hEvent := FEvent.Handle; +end; + + + +destructor TOverlappedHelperImpl.Destroy; +begin + try + FOverlapped.hEvent := 0; + FreeAndNil( FEvent); + + finally + inherited Destroy; + end; + +end; + + +function TOverlappedHelperImpl.Overlapped : TOverlapped; +begin + result := FOverlapped; +end; + + +function TOverlappedHelperImpl.OverlappedPtr : POverlapped; +begin + result := @FOverlapped; +end; + + +function TOverlappedHelperImpl.WaitHandle : THandle; +begin + result := FOverlapped.hEvent; +end; + + +function TOverlappedHelperImpl.WaitFor( dwTimeout : DWORD) : DWORD; +begin + result := WaitForSingleObject( FOverlapped.hEvent, dwTimeout); +end; + + +{ Base64Utils } + +class function Base64Utils.Encode( const src : TBytes; srcOff, len : Integer; dst : TBytes; dstOff : Integer) : Integer; +const ENCODE_TABLE : PAnsiChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; +begin + ASSERT( len in [1..3]); + dst[dstOff] := Byte( ENCODE_TABLE[ (src[srcOff] shr 2) and $3F]); + case len of + 3 : begin + Inc(dstOff); + dst[dstOff] := Byte( ENCODE_TABLE[ ((src[srcOff] shl 4) and $30) or ((src[srcOff + 1] shr 4) and $0F)]); + Inc(dstOff); + dst[dstOff] := Byte( ENCODE_TABLE[ ((src[srcOff + 1] shl 2) and $3C) or ((src[srcOff + 2] shr 6) and $03)]); + Inc(dstOff); + dst[dstOff] := Byte( ENCODE_TABLE[ src[srcOff + 2] and $3F]); + result := 4; + end; + + 2 : begin + Inc(dstOff); + dst[dstOff] := Byte( ENCODE_TABLE[ ((src[srcOff] shl 4) and $30) or ((src[srcOff + 1] shr 4) and $0F)]); + Inc(dstOff); + dst[dstOff] := Byte( ENCODE_TABLE[ (src[srcOff + 1] shl 2) and $3C]); + result := 3; + end; + + 1 : begin + Inc(dstOff); + dst[dstOff] := Byte( ENCODE_TABLE[ (src[srcOff] shl 4) and $30]); + result := 2; + end; + + else + ASSERT( FALSE); + result := 0; // because invalid call + end; +end; + + +class function Base64Utils.Decode( const src : TBytes; srcOff, len : Integer; dst : TBytes; dstOff : Integer) : Integer; +const DECODE_TABLE : array[0..$FF] of Integer + = ( -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,62,-1,-1,-1,63, + 52,53,54,55,56,57,58,59,60,61,-1,-1,-1,-1,-1,-1, + -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, + 15,16,17,18,19,20,21,22,23,24,25,-1,-1,-1,-1,-1, + -1,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, + 41,42,43,44,45,46,47,48,49,50,51,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1 ); +begin + ASSERT( len in [1..4]); + result := 1; + dst[dstOff] := ((DECODE_TABLE[src[srcOff] and $0FF] shl 2) + or (DECODE_TABLE[src[srcOff + 1] and $0FF] shr 4)); + + if (len > 2) then begin + Inc( result); + Inc( dstOff); + dst[dstOff] := (((DECODE_TABLE[src[srcOff + 1] and $0FF] shl 4) and $F0) + or (DECODE_TABLE[src[srcOff + 2] and $0FF] shr 2)); + + if (len > 3) then begin + Inc( result); + Inc( dstOff); + dst[dstOff] := (((DECODE_TABLE[src[srcOff + 2] and $0FF] shl 6) and $C0) + or DECODE_TABLE[src[srcOff + 3] and $0FF]); + end; + end; +end; + + +class function CharUtils.IsHighSurrogate( const c : Char) : Boolean; +begin + {$IF CompilerVersion < 25.0} + {$IFDEF OLD_UNIT_NAMES} + result := Character.IsHighSurrogate(c); + {$ELSE} + result := System.Character.IsHighSurrogate(c); + {$ENDIF} + {$ELSE} + result := c.IsHighSurrogate(); + {$IFEND} +end; + + +class function CharUtils.IsLowSurrogate( const c : Char) : Boolean; +begin + {$IF CompilerVersion < 25.0} + {$IFDEF OLD_UNIT_NAMES} + result := Character.IsLowSurrogate(c); + {$ELSE} + result := System.Character.IsLowSurrogate(c); + {$ENDIF} + {$ELSE} + result := c.IsLowSurrogate(); + {$IFEND} +end; + + +{$IFDEF Win64} + +function InterlockedCompareExchange64( var Target : Int64; Exchange, Comparand : Int64) : Int64; inline; +begin + {$IFDEF OLD_UNIT_NAMES} + result := Windows.InterlockedCompareExchange64( Target, Exchange, Comparand); + {$ELSE} + result := WinApi.Windows.InterlockedCompareExchange64( Target, Exchange, Comparand); + {$ENDIF} +end; + + +function InterlockedExchangeAdd64( var Addend : Int64; Value : Int64) : Int64; +var old : Int64; +begin + repeat + Old := Addend; + until (InterlockedCompareExchange64( Addend, Old + Value, Old) = Old); + result := Old; +end; + +{$ENDIF} + + +{ EnumUtils<T> } + +class function EnumUtils<T>.ToString(const value : Integer) : string; +var pType : PTypeInfo; +begin + pType := PTypeInfo(TypeInfo(T)); + if Assigned(pType) and (pType^.Kind = tkEnumeration) + then result := GetEnumName(pType,value) + else result := IntToStr(Ord(value)); +end; + + +{ StringUtils<T> } + +class function StringUtils<T>.ToString(const value : T) : string; +type PInterface = ^IInterface; +var pType : PTypeInfo; + stos : ISupportsToString; + pIntf : PInterface; // Workaround: Rio does not allow the direct typecast +begin + pType := PTypeInfo(TypeInfo(T)); + if Assigned(pType) then begin + case pType^.Kind of + tkInterface : begin + pIntf := PInterface(@value); + if Supports( pIntf^, ISupportsToString, stos) then begin + result := stos.toString; + Exit; + end; + end; + end; + end; + + result := TValue.From<T>(value).ToString; +end; + + +{ TThriftStringBuilder } + +function TThriftStringBuilder.Append(const Value: TBytes): TStringBuilder; +begin + Result := Append( string( RawByteString(Value)) ); +end; + +function TThriftStringBuilder.Append( const Value: ISupportsToString): TStringBuilder; +begin + Result := Append( Value.ToString ); +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.WinHTTP.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.WinHTTP.pas new file mode 100644 index 000000000..854d7c080 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.WinHTTP.pas @@ -0,0 +1,1273 @@ +(* + * 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.WinHTTP; + +{$I Thrift.Defines.inc} +{$SCOPEDENUMS ON} + +// packing according to winhttp.h +{$IFDEF Win64} {$ALIGN 8} {$ELSE} {$ALIGN 4} {$ENDIF} + +interface + +uses + Windows, + Classes, + SysUtils, + Math, + Generics.Collections; + + +type + HINTERNET = type Pointer; + INTERNET_PORT = type WORD; + INTERNET_SCHEME = type Integer; + LPLPCWSTR = ^LPCWSTR; + + LPURL_COMPONENTS = ^URL_COMPONENTS; + URL_COMPONENTS = record + dwStructSize : DWORD; // set to SizeOf(URL_COMPONENTS) + lpszScheme : LPWSTR; // scheme name + dwSchemeLength : DWORD; + nScheme : INTERNET_SCHEME; // enumerated scheme type + lpszHostName : LPWSTR; // host name + dwHostNameLength : DWORD; + nPort : INTERNET_PORT; // port number + lpszUserName : LPWSTR; // user name + dwUserNameLength : DWORD; + lpszPassword : LPWSTR; // password + dwPasswordLength : DWORD; + lpszUrlPath : LPWSTR; // URL-path + dwUrlPathLength : DWORD; + lpszExtraInfo : LPWSTR; // extra information + dwExtraInfoLength : DWORD; + end; + + URL_COMPONENTSW = URL_COMPONENTS; + LPURL_COMPONENTSW = LPURL_COMPONENTS; + + + // When retrieving proxy data, an application must free the lpszProxy and + // lpszProxyBypass strings contained in this structure (if they are non-NULL) + // using the GlobalFree function. + LPWINHTTP_PROXY_INFO = ^WINHTTP_PROXY_INFO; + WINHTTP_PROXY_INFO = record + dwAccessType : DWORD; // see WINHTTP_ACCESS_* types below + lpszProxy : LPWSTR; // proxy server list + lpszProxyBypass : LPWSTR; // proxy bypass list + end; + + LPWINHTTP_PROXY_INFOW = ^WINHTTP_PROXY_INFOW; + WINHTTP_PROXY_INFOW = WINHTTP_PROXY_INFO; + + + WINHTTP_AUTOPROXY_OPTIONS = record + dwFlags : DWORD; + dwAutoDetectFlags : DWORD; + lpszAutoConfigUrl : LPCWSTR; + lpvReserved : LPVOID; + dwReserved : DWORD; + fAutoLogonIfChallenged : BOOL; + end; + + + WINHTTP_CURRENT_USER_IE_PROXY_CONFIG = record + fAutoDetect : BOOL; + lpszAutoConfigUrl : LPWSTR; + lpszProxy : LPWSTR; + lpszProxyBypass : LPWSTR; + end; + + + + +function WinHttpCloseHandle( aHandle : HINTERNET) : BOOL; stdcall; + +function WinHttpOpen( const pszAgentW : LPCWSTR; + const dwAccessType : DWORD; + const pszProxyW : LPCWSTR; + const pszProxyBypassW : LPCWSTR; + const dwFlags : DWORD + ) : HINTERNET; stdcall; + +function WinHttpConnect( const hSession : HINTERNET; + const pswzServerName : LPCWSTR; + const nServerPort : INTERNET_PORT; + const dwReserved : DWORD + ) : HINTERNET; stdcall; + +function WinHttpOpenRequest( const hConnect : HINTERNET; + const pwszVerb, pwszObjectName, pwszVersion, pwszReferrer : LPCWSTR; + const ppwszAcceptTypes : LPLPCWSTR; + const dwFlags : DWORD + ) : HINTERNET; stdcall; + +function WinHttpQueryOption( const hInternet : HINTERNET; + const dwOption : DWORD; + const pBuffer : Pointer; + var dwBufferLength : DWORD) : BOOL; stdcall; + +function WinHttpSetOption( const hInternet : HINTERNET; + const dwOption : DWORD; + const pBuffer : Pointer; + const dwBufferLength : DWORD) : BOOL; stdcall; + +function WinHttpSetTimeouts( const hRequestOrSession : HINTERNET; + const aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout : Int32 + ) : BOOL; stdcall; + +function WinHttpAddRequestHeaders( const hRequest : HINTERNET; + const pwszHeaders : LPCWSTR; + const dwHeadersLengthInChars : DWORD; + const dwModifiers : DWORD + ) : BOOL; stdcall; + +function WinHttpGetProxyForUrl( const hSession : HINTERNET; + const lpcwszUrl : LPCWSTR; + const options : WINHTTP_AUTOPROXY_OPTIONS; + const info : WINHTTP_PROXY_INFO + ) : BOOL; stdcall; + +function WinHttpGetIEProxyConfigForCurrentUser( var config : WINHTTP_CURRENT_USER_IE_PROXY_CONFIG + ) : BOOL; stdcall; + + +function WinHttpSendRequest( const hRequest : HINTERNET; + const lpszHeaders : LPCWSTR; + const dwHeadersLength : DWORD; + const lpOptional : Pointer; + const dwOptionalLength : DWORD; + const dwTotalLength : DWORD; + const pContext : Pointer + ) : BOOL; stdcall; + +function WinHttpWriteData( const hRequest : HINTERNET; + const pBuf : Pointer; + const dwBytesToWrite : DWORD; + out dwBytesWritten : DWORD + ) : BOOL; stdcall; + +function WinHttpReceiveResponse( const hRequest : HINTERNET; const lpReserved : Pointer) : BOOL; stdcall; + +function WinHttpQueryHeaders( const hRequest : HINTERNET; + const dwInfoLevel : DWORD; + const pwszName : LPCWSTR; + const lpBuffer : Pointer; + var dwBufferLength : DWORD; + var dwIndex : DWORD + ) : BOOL; stdcall; + +function WinHttpQueryDataAvailable( const hRequest : HINTERNET; + var dwNumberOfBytesAvailable : DWORD + ) : BOOL; stdcall; + +function WinHttpReadData( const hRequest : HINTERNET; + const lpBuffer : Pointer; + const dwBytesToRead : DWORD; + out dwBytesRead : DWORD + ) : BOOL; stdcall; + +function WinHttpCrackUrl( const pwszUrl : LPCWSTR; + const dwUrlLength : DWORD; + const dwFlags : DWORD; + var urlComponents : URL_COMPONENTS + ) : BOOL; stdcall; + +function WinHttpCreateUrl( const UrlComponents : URL_COMPONENTS; + const dwFlags : DWORD; + const pwszUrl : LPCWSTR; + var pdwUrlLength : DWORD + ) : BOOL; stdcall; + + +const + // WinHttpOpen dwAccessType values + WINHTTP_ACCESS_TYPE_DEFAULT_PROXY = 0; + WINHTTP_ACCESS_TYPE_NO_PROXY = 1; + WINHTTP_ACCESS_TYPE_NAMED_PROXY = 3; + + // flags for WinHttpOpen(): + WINHTTP_FLAG_ASYNC = $10000000; // want async session, requires WinHttpSetStatusCallback() usage + + // ports + INTERNET_DEFAULT_PORT = 0; // use the protocol-specific default (80 or 443) + + // flags for WinHttpOpenRequest(): + WINHTTP_FLAG_SECURE = $00800000; // use SSL if applicable (HTTPS) + WINHTTP_FLAG_ESCAPE_PERCENT = $00000004; // if escaping enabled, escape percent as well + WINHTTP_FLAG_NULL_CODEPAGE = $00000008; // assume all symbols are ASCII, use fast convertion + WINHTTP_FLAG_BYPASS_PROXY_CACHE = $00000100; // add "pragma: no-cache" request header + WINHTTP_FLAG_REFRESH = WINHTTP_FLAG_BYPASS_PROXY_CACHE; + WINHTTP_FLAG_ESCAPE_DISABLE = $00000040; // disable escaping + WINHTTP_FLAG_ESCAPE_DISABLE_QUERY = $00000080; // if escaping enabled escape path part, but do not escape query + + // flags for WinHttpSendRequest(): + WINHTTP_NO_ADDITIONAL_HEADERS = nil; + WINHTTP_NO_REQUEST_DATA = nil; + + // WinHttpAddRequestHeaders() dwModifiers + WINHTTP_ADDREQ_INDEX_MASK = $0000FFFF; + WINHTTP_ADDREQ_FLAGS_MASK = $FFFF0000; + + WINHTTP_ADDREQ_FLAG_ADD_IF_NEW = $10000000; + WINHTTP_ADDREQ_FLAG_ADD = $20000000; + WINHTTP_ADDREQ_FLAG_COALESCE_WITH_COMMA = $40000000; + WINHTTP_ADDREQ_FLAG_COALESCE_WITH_SEMICOLON = $01000000; + WINHTTP_ADDREQ_FLAG_COALESCE = WINHTTP_ADDREQ_FLAG_COALESCE_WITH_COMMA; + WINHTTP_ADDREQ_FLAG_REPLACE = $80000000; + + // URL functions + ICU_NO_ENCODE = $20000000; // Don't convert unsafe characters to escape sequence + ICU_DECODE = $10000000; // Convert %XX escape sequences to characters + ICU_NO_META = $08000000; // Don't convert .. etc. meta path sequences + ICU_ENCODE_SPACES_ONLY = $04000000; // Encode spaces only + ICU_BROWSER_MODE = $02000000; // Special encode/decode rules for browser + ICU_ENCODE_PERCENT = $00001000; // Encode any percent (ASCII25) + + ICU_ESCAPE = $80000000; // (un)escape URL characters + ICU_ESCAPE_AUTHORITY = $00002000; // causes InternetCreateUrlA to escape chars in authority components (user, pwd, host) + ICU_REJECT_USERPWD = $00004000; // rejects usrls whick have username/pwd sections + + INTERNET_SCHEME_HTTP = INTERNET_SCHEME(1); + INTERNET_SCHEME_HTTPS = INTERNET_SCHEME(2); + + WINHTTP_NO_CLIENT_CERT_CONTEXT = nil; + + // options manifests for WinHttp{Query|Set}Option + WINHTTP_OPTION_CALLBACK = 1; + WINHTTP_OPTION_RESOLVE_TIMEOUT = 2; + WINHTTP_OPTION_CONNECT_TIMEOUT = 3; + WINHTTP_OPTION_CONNECT_RETRIES = 4; + WINHTTP_OPTION_SEND_TIMEOUT = 5; + WINHTTP_OPTION_RECEIVE_TIMEOUT = 6; + WINHTTP_OPTION_RECEIVE_RESPONSE_TIMEOUT = 7; + WINHTTP_OPTION_HANDLE_TYPE = 9; + WINHTTP_OPTION_READ_BUFFER_SIZE = 12; + WINHTTP_OPTION_WRITE_BUFFER_SIZE = 13; + WINHTTP_OPTION_PARENT_HANDLE = 21; + WINHTTP_OPTION_EXTENDED_ERROR = 24; + WINHTTP_OPTION_SECURITY_FLAGS = 31; + WINHTTP_OPTION_SECURITY_CERTIFICATE_STRUCT = 32; + WINHTTP_OPTION_URL = 34; + WINHTTP_OPTION_SECURITY_KEY_BITNESS = 36; + WINHTTP_OPTION_PROXY = 38; + WINHTTP_OPTION_USER_AGENT = 41; + WINHTTP_OPTION_CONTEXT_VALUE = 45; + WINHTTP_OPTION_CLIENT_CERT_CONTEXT = 47; + WINHTTP_OPTION_REQUEST_PRIORITY = 58; + WINHTTP_OPTION_HTTP_VERSION = 59; + WINHTTP_OPTION_DISABLE_FEATURE = 63; + WINHTTP_OPTION_CODEPAGE = 68; + WINHTTP_OPTION_MAX_CONNS_PER_SERVER = 73; + WINHTTP_OPTION_MAX_CONNS_PER_1_0_SERVER = 74; + WINHTTP_OPTION_AUTOLOGON_POLICY = 77; + WINHTTP_OPTION_SERVER_CERT_CONTEXT = 78; + WINHTTP_OPTION_ENABLE_FEATURE = 79; + WINHTTP_OPTION_WORKER_THREAD_COUNT = 80; + WINHTTP_OPTION_PASSPORT_COBRANDING_TEXT = 81; + WINHTTP_OPTION_PASSPORT_COBRANDING_URL = 82; + WINHTTP_OPTION_CONFIGURE_PASSPORT_AUTH = 83; + WINHTTP_OPTION_SECURE_PROTOCOLS = 84; + WINHTTP_OPTION_ENABLETRACING = 85; + WINHTTP_OPTION_PASSPORT_SIGN_OUT = 86; + WINHTTP_OPTION_PASSPORT_RETURN_URL = 87; + WINHTTP_OPTION_REDIRECT_POLICY = 88; + WINHTTP_OPTION_MAX_HTTP_AUTOMATIC_REDIRECTS = 89; + WINHTTP_OPTION_MAX_HTTP_STATUS_CONTINUE = 90; + WINHTTP_OPTION_MAX_RESPONSE_HEADER_SIZE = 91; + WINHTTP_OPTION_MAX_RESPONSE_DRAIN_SIZE = 92; + WINHTTP_OPTION_CONNECTION_INFO = 93; + WINHTTP_OPTION_CLIENT_CERT_ISSUER_LIST = 94; + WINHTTP_OPTION_SPN = 96; + WINHTTP_OPTION_GLOBAL_PROXY_CREDS = 97; + WINHTTP_OPTION_GLOBAL_SERVER_CREDS = 98; + WINHTTP_OPTION_UNLOAD_NOTIFY_EVENT = 99; + WINHTTP_OPTION_REJECT_USERPWD_IN_URL = 100; + WINHTTP_OPTION_USE_GLOBAL_SERVER_CREDENTIALS = 101; + WINHTTP_OPTION_RECEIVE_PROXY_CONNECT_RESPONSE = 103; + WINHTTP_OPTION_IS_PROXY_CONNECT_RESPONSE = 104; + WINHTTP_OPTION_SERVER_SPN_USED = 106; + WINHTTP_OPTION_PROXY_SPN_USED = 107; + WINHTTP_OPTION_SERVER_CBT = 108; + // options for newer WinHTTP versions + WINHTTP_OPTION_DECOMPRESSION = 118; + // + WINHTTP_FIRST_OPTION = WINHTTP_OPTION_CALLBACK; + //WINHTTP_LAST_OPTION = WINHTTP_OPTION_SERVER_CBT; + + WINHTTP_OPTION_USERNAME = $1000; + WINHTTP_OPTION_PASSWORD = $1001; + WINHTTP_OPTION_PROXY_USERNAME = $1002; + WINHTTP_OPTION_PROXY_PASSWORD = $1003; + + // manifest value for WINHTTP_OPTION_MAX_CONNS_PER_SERVER and WINHTTP_OPTION_MAX_CONNS_PER_1_0_SERVER + WINHTTP_CONNS_PER_SERVER_UNLIMITED = $FFFFFFFF; + + // values for WINHTTP_OPTION_AUTOLOGON_POLICY + WINHTTP_AUTOLOGON_SECURITY_LEVEL_MEDIUM = 0; + WINHTTP_AUTOLOGON_SECURITY_LEVEL_LOW = 1; + WINHTTP_AUTOLOGON_SECURITY_LEVEL_HIGH = 2; + + WINHTTP_AUTOLOGON_SECURITY_LEVEL_DEFAULT = WINHTTP_AUTOLOGON_SECURITY_LEVEL_MEDIUM; + + // values for WINHTTP_OPTION_REDIRECT_POLICY + WINHTTP_OPTION_REDIRECT_POLICY_NEVER = 0; + WINHTTP_OPTION_REDIRECT_POLICY_DISALLOW_HTTPS_TO_HTTP = 1; + WINHTTP_OPTION_REDIRECT_POLICY_ALWAYS = 2; + + WINHTTP_OPTION_REDIRECT_POLICY_LAST = WINHTTP_OPTION_REDIRECT_POLICY_ALWAYS; + WINHTTP_OPTION_REDIRECT_POLICY_DEFAULT = WINHTTP_OPTION_REDIRECT_POLICY_DISALLOW_HTTPS_TO_HTTP; + + WINHTTP_DISABLE_PASSPORT_AUTH = $00000000; + WINHTTP_ENABLE_PASSPORT_AUTH = $10000000; + WINHTTP_DISABLE_PASSPORT_KEYRING = $20000000; + WINHTTP_ENABLE_PASSPORT_KEYRING = $40000000; + + // values for WINHTTP_OPTION_DISABLE_FEATURE + WINHTTP_DISABLE_COOKIES = $00000001; + WINHTTP_DISABLE_REDIRECTS = $00000002; + WINHTTP_DISABLE_AUTHENTICATION = $00000004; + WINHTTP_DISABLE_KEEP_ALIVE = $00000008; + + // values for WINHTTP_OPTION_ENABLE_FEATURE + WINHTTP_ENABLE_SSL_REVOCATION = $00000001; + WINHTTP_ENABLE_SSL_REVERT_IMPERSONATION = $00000002; + + // values for WINHTTP_OPTION_SPN + WINHTTP_DISABLE_SPN_SERVER_PORT = $00000000; + WINHTTP_ENABLE_SPN_SERVER_PORT = $00000001; + WINHTTP_OPTION_SPN_MASK = WINHTTP_ENABLE_SPN_SERVER_PORT; + + // winhttp handle types + WINHTTP_HANDLE_TYPE_SESSION = 1; + WINHTTP_HANDLE_TYPE_CONNECT = 2; + WINHTTP_HANDLE_TYPE_REQUEST = 3; + + // values for auth schemes + WINHTTP_AUTH_SCHEME_BASIC = $00000001; + WINHTTP_AUTH_SCHEME_NTLM = $00000002; + WINHTTP_AUTH_SCHEME_PASSPORT = $00000004; + WINHTTP_AUTH_SCHEME_DIGEST = $00000008; + WINHTTP_AUTH_SCHEME_NEGOTIATE = $00000010; + + // WinHttp supported Authentication Targets + WINHTTP_AUTH_TARGET_SERVER = $00000000; + WINHTTP_AUTH_TARGET_PROXY = $00000001; + + // options for WINHTTP_OPTION_DECOMPRESSION + WINHTTP_DECOMPRESSION_FLAG_GZIP = $00000001; + WINHTTP_DECOMPRESSION_FLAG_DEFLATE = $00000002; + WINHTTP_DECOMPRESSION_FLAG_ALL = WINHTTP_DECOMPRESSION_FLAG_GZIP + or WINHTTP_DECOMPRESSION_FLAG_DEFLATE; + + // values for WINHTTP_OPTION_SECURITY_FLAGS + + // query only + SECURITY_FLAG_SECURE = $00000001; // can query only + SECURITY_FLAG_STRENGTH_WEAK = $10000000; + SECURITY_FLAG_STRENGTH_MEDIUM = $40000000; + SECURITY_FLAG_STRENGTH_STRONG = $20000000; + + // Secure connection error status flags + WINHTTP_CALLBACK_STATUS_FLAG_CERT_REV_FAILED = $00000001; + WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CERT = $00000002; + WINHTTP_CALLBACK_STATUS_FLAG_CERT_REVOKED = $00000004; + WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CA = $00000008; + WINHTTP_CALLBACK_STATUS_FLAG_CERT_CN_INVALID = $00000010; + WINHTTP_CALLBACK_STATUS_FLAG_CERT_DATE_INVALID = $00000020; + WINHTTP_CALLBACK_STATUS_FLAG_CERT_WRONG_USAGE = $00000040; + WINHTTP_CALLBACK_STATUS_FLAG_SECURITY_CHANNEL_ERROR = $80000000; + + WINHTTP_FLAG_SECURE_PROTOCOL_SSL2 = $00000008; + WINHTTP_FLAG_SECURE_PROTOCOL_SSL3 = $00000020; + WINHTTP_FLAG_SECURE_PROTOCOL_TLS1 = $00000080; + WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1 = $00000200; + WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2 = $00000800; + + // Note: SECURE_PROTOCOL_ALL does not include TLS1.1 and higher! + WINHTTP_FLAG_SECURE_PROTOCOL_ALL = WINHTTP_FLAG_SECURE_PROTOCOL_SSL2 + or WINHTTP_FLAG_SECURE_PROTOCOL_SSL3 + or WINHTTP_FLAG_SECURE_PROTOCOL_TLS1; + + // AutoProxy + WINHTTP_AUTOPROXY_AUTO_DETECT = $00000001; + WINHTTP_AUTOPROXY_CONFIG_URL = $00000002; + WINHTTP_AUTOPROXY_HOST_KEEPCASE = $00000004; + WINHTTP_AUTOPROXY_HOST_LOWERCASE = $00000008; + WINHTTP_AUTOPROXY_RUN_INPROCESS = $00010000; + WINHTTP_AUTOPROXY_RUN_OUTPROCESS_ONLY = $00020000; + + // Flags for dwAutoDetectFlags + WINHTTP_AUTO_DETECT_TYPE_DHCP = $00000001; + WINHTTP_AUTO_DETECT_TYPE_DNS_A = $00000002; + +const + WINHTTP_ERROR_BASE = 12000; + ERROR_WINHTTP_OUT_OF_HANDLES = WINHTTP_ERROR_BASE + 1; + ERROR_WINHTTP_TIMEOUT = WINHTTP_ERROR_BASE + 2; + ERROR_WINHTTP_INTERNAL_ERROR = WINHTTP_ERROR_BASE + 4; + ERROR_WINHTTP_INVALID_URL = WINHTTP_ERROR_BASE + 5; + ERROR_WINHTTP_UNRECOGNIZED_SCHEME = WINHTTP_ERROR_BASE + 6; + ERROR_WINHTTP_NAME_NOT_RESOLVED = WINHTTP_ERROR_BASE + 7; + ERROR_WINHTTP_INVALID_OPTION = WINHTTP_ERROR_BASE + 9; + ERROR_WINHTTP_OPTION_NOT_SETTABLE = WINHTTP_ERROR_BASE + 11; + ERROR_WINHTTP_SHUTDOWN = WINHTTP_ERROR_BASE + 12; + ERROR_WINHTTP_LOGIN_FAILURE = WINHTTP_ERROR_BASE + 15; + ERROR_WINHTTP_OPERATION_CANCELLED = WINHTTP_ERROR_BASE + 17; + ERROR_WINHTTP_INCORRECT_HANDLE_TYPE = WINHTTP_ERROR_BASE + 18; + ERROR_WINHTTP_INCORRECT_HANDLE_STATE = WINHTTP_ERROR_BASE + 19; + ERROR_WINHTTP_CANNOT_CONNECT = WINHTTP_ERROR_BASE + 29; + ERROR_WINHTTP_CONNECTION_ERROR = WINHTTP_ERROR_BASE + 30; + ERROR_WINHTTP_RESEND_REQUEST = WINHTTP_ERROR_BASE + 32; + ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED = WINHTTP_ERROR_BASE + 44; + ERROR_WINHTTP_CANNOT_CALL_BEFORE_OPEN = WINHTTP_ERROR_BASE + 100; + ERROR_WINHTTP_CANNOT_CALL_BEFORE_SEND = WINHTTP_ERROR_BASE + 101; + ERROR_WINHTTP_CANNOT_CALL_AFTER_SEND = WINHTTP_ERROR_BASE + 102; + ERROR_WINHTTP_CANNOT_CALL_AFTER_OPEN = WINHTTP_ERROR_BASE + 103; + ERROR_WINHTTP_HEADER_NOT_FOUND = WINHTTP_ERROR_BASE + 150; + ERROR_WINHTTP_INVALID_SERVER_RESPONSE = WINHTTP_ERROR_BASE + 152; + ERROR_WINHTTP_INVALID_HEADER = WINHTTP_ERROR_BASE + 153; + ERROR_WINHTTP_INVALID_QUERY_REQUEST = WINHTTP_ERROR_BASE + 154; + ERROR_WINHTTP_HEADER_ALREADY_EXISTS = WINHTTP_ERROR_BASE + 155; + ERROR_WINHTTP_REDIRECT_FAILED = WINHTTP_ERROR_BASE + 156; + ERROR_WINHTTP_AUTO_PROXY_SERVICE_ERROR = WINHTTP_ERROR_BASE + 178; + ERROR_WINHTTP_BAD_AUTO_PROXY_SCRIPT = WINHTTP_ERROR_BASE + 166; + ERROR_WINHTTP_UNABLE_TO_DOWNLOAD_SCRIPT = WINHTTP_ERROR_BASE + 167; + ERROR_WINHTTP_NOT_INITIALIZED = WINHTTP_ERROR_BASE + 172; + ERROR_WINHTTP_SECURE_FAILURE = WINHTTP_ERROR_BASE + 175; + + // Certificate security errors. Additional information is provided + // via the WINHTTP_CALLBACK_STATUS_SECURE_FAILURE callback notification. + ERROR_WINHTTP_SECURE_CERT_DATE_INVALID = WINHTTP_ERROR_BASE + 37; + ERROR_WINHTTP_SECURE_CERT_CN_INVALID = WINHTTP_ERROR_BASE + 38; + ERROR_WINHTTP_SECURE_INVALID_CA = WINHTTP_ERROR_BASE + 45; + ERROR_WINHTTP_SECURE_CERT_REV_FAILED = WINHTTP_ERROR_BASE + 57; + ERROR_WINHTTP_SECURE_CHANNEL_ERROR = WINHTTP_ERROR_BASE + 157; + ERROR_WINHTTP_SECURE_INVALID_CERT = WINHTTP_ERROR_BASE + 169; + ERROR_WINHTTP_SECURE_CERT_REVOKED = WINHTTP_ERROR_BASE + 170; + ERROR_WINHTTP_SECURE_CERT_WRONG_USAGE = WINHTTP_ERROR_BASE + 179; + + ERROR_WINHTTP_AUTODETECTION_FAILED = WINHTTP_ERROR_BASE + 180; + ERROR_WINHTTP_HEADER_COUNT_EXCEEDED = WINHTTP_ERROR_BASE + 181; + ERROR_WINHTTP_HEADER_SIZE_OVERFLOW = WINHTTP_ERROR_BASE + 182; + ERROR_WINHTTP_CHUNKED_ENCODING_HEADER_SIZE_OVERFLOW = WINHTTP_ERROR_BASE + 183; + ERROR_WINHTTP_RESPONSE_DRAIN_OVERFLOW = WINHTTP_ERROR_BASE + 184; + ERROR_WINHTTP_CLIENT_CERT_NO_PRIVATE_KEY = WINHTTP_ERROR_BASE + 185; + ERROR_WINHTTP_CLIENT_CERT_NO_ACCESS_PRIVATE_KEY = WINHTTP_ERROR_BASE + 186; + + WINHTTP_ERROR_LAST = WINHTTP_ERROR_BASE + 186; + + +const + WINHTTP_THRIFT_DEFAULTS = WINHTTP_FLAG_NULL_CODEPAGE + or WINHTTP_FLAG_BYPASS_PROXY_CACHE + or WINHTTP_FLAG_ESCAPE_DISABLE; + + + +type + IWinHTTPSession = interface; + IWinHTTPConnection = interface; + + IWinHTTPRequest = interface + ['{F65952F2-2F3B-47DC-B524-F1694E6D2AD7}'] + function Handle : HINTERNET; + function Connection : IWinHTTPConnection; + function AddRequestHeader( const aHeader : string; const addflag : DWORD = WINHTTP_ADDREQ_FLAG_ADD) : Boolean; + function SetTimeouts( const aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout : Int32) : Boolean; + procedure TryAutoProxy( const aUrl : string); + procedure EnableAutomaticContentDecompression( const aEnable : Boolean); + function SendRequest( const pBuf : Pointer; const dwBytes : DWORD; const dwExtra : DWORD = 0) : Boolean; + function WriteExtraData( const pBuf : Pointer; const dwBytes : DWORD) : DWORD; + function FlushAndReceiveResponse : Boolean; + function ReadData( const dwRead : DWORD) : TBytes; overload; + function ReadData( const pBuf : Pointer; const dwRead : DWORD) : DWORD; overload; + end; + + IWinHTTPConnection = interface + ['{ED5BCA49-84D6-4CFE-BF18-3238B1FF2AFB}'] + function Handle : HINTERNET; + function Session : IWinHTTPSession; + function OpenRequest( const secure : Boolean; const aVerb, aObjName, aAcceptTypes : UnicodeString) : IWinHTTPRequest; + end; + + IWinHTTPSession = interface + ['{261ADCB7-5465-4407-8840-468C17F009F0}'] + function Handle : HINTERNET; + function Connect( const aHostName : UnicodeString; const aPort : INTERNET_PORT = INTERNET_DEFAULT_PORT) : IWinHTTPConnection; + function SetTimeouts( const aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout : Int32) : Boolean; + function EnableSecureProtocols( const aFlagSet : DWORD) : Boolean; + end; + + IWinHTTPUrl = interface + ['{78BE977C-4171-4AF5-A250-FD2890205E63}'] + // url parts getter + function GetScheme : UnicodeString; + function GetNumScheme : INTERNET_SCHEME; + function GetHostName : UnicodeString; + function GetPort : INTERNET_PORT; + function GetUserName : UnicodeString; + function GetPassword : UnicodeString; + function GetUrlPath : UnicodeString; + function GetExtraInfo : UnicodeString; + + // url parts setter + procedure SetScheme( const value : UnicodeString); + procedure SetHostName ( const value : UnicodeString); + procedure SetPort( const value : INTERNET_PORT); + procedure SetUserName( const value : UnicodeString); + procedure SetPassword( const value : UnicodeString); + procedure SetUrlPath( const value : UnicodeString); + procedure SetExtraInfo( const value : UnicodeString); + + // url as a whole + function BuildUrl : UnicodeString; + procedure CrackUrl( const value : UnicodeString); + + // url parts + property Scheme : UnicodeString read GetScheme write SetScheme; + property NumScheme : INTERNET_SCHEME read GetNumScheme; // readonly + property HostName : UnicodeString read GetHostName write SetHostName; + property Port : INTERNET_PORT read GetPort write SetPort; + property UserName : UnicodeString read GetUserName write SetUserName; + property Password : UnicodeString read GetPassword write SetPassword; + property UrlPath : UnicodeString read GetUrlPath write SetUrlPath; + property ExtraInfo : UnicodeString read GetExtraInfo write SetExtraInfo; + + // url as a whole + property CompleteURL : UnicodeString read BuildUrl write CrackUrl; + end; + + + + +type + TWinHTTPHandleObjectImpl = class( TInterfacedObject) + strict protected + FHandle : HINTERNET; + function Handle : HINTERNET; + public + constructor Create( const aHandle : HINTERNET); + destructor Destroy; override; + end; + + + TWinHTTPSessionImpl = class( TWinHTTPHandleObjectImpl, IWinHTTPSession) + strict protected + + // IWinHTTPSession + function Connect( const aHostName : UnicodeString; const aPort : INTERNET_PORT = INTERNET_DEFAULT_PORT) : IWinHTTPConnection; + function SetTimeouts( const aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout : Int32) : Boolean; + function EnableSecureProtocols( const aFlagSet : DWORD) : Boolean; + public + constructor Create( const aAgent : UnicodeString; + const aAccessType : DWORD = WINHTTP_ACCESS_TYPE_DEFAULT_PROXY; + const aProxy : UnicodeString = ''; + const aProxyBypass : UnicodeString = ''; + const aFlags : DWORD = 0); + destructor Destroy; override; + end; + + + TWinHTTPConnectionImpl = class( TWinHTTPHandleObjectImpl, IWinHTTPConnection) + strict protected + FSession : IWinHTTPSession; + + // IWinHTTPConnection + function OpenRequest( const secure : Boolean; const aVerb, aObjName, aAcceptTypes : UnicodeString) : IWinHTTPRequest; + function Session : IWinHTTPSession; + + public + constructor Create( const aSession : IWinHTTPSession; const aHostName : UnicodeString; const aPort : INTERNET_PORT); + destructor Destroy; override; + end; + + + TAcceptTypesArray = array of string; + + TWinHTTPRequestImpl = class( TWinHTTPHandleObjectImpl, IWinHTTPRequest) + strict protected + FConnection : IWinHTTPConnection; + + // IWinHTTPRequest + function Connection : IWinHTTPConnection; + function AddRequestHeader( const aHeader : string; const addflag : DWORD = WINHTTP_ADDREQ_FLAG_ADD) : Boolean; + function SetTimeouts( const aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout : Int32) : Boolean; + procedure TryAutoProxy( const aUrl : string); + procedure EnableAutomaticContentDecompression( const aEnable : Boolean); + function SendRequest( const pBuf : Pointer; const dwBytes : DWORD; const dwExtra : DWORD = 0) : Boolean; + function WriteExtraData( const pBuf : Pointer; const dwBytes : DWORD) : DWORD; + function FlushAndReceiveResponse : Boolean; + function ReadData( const dwRead : DWORD) : TBytes; overload; + function ReadData( const pBuf : Pointer; const dwRead : DWORD) : DWORD; overload; + + public + constructor Create( const aConnection : IWinHTTPConnection; + const aVerb, aObjName : UnicodeString; + const aVersion : UnicodeString = ''; + const aReferrer : UnicodeString = ''; + const aAcceptTypes : UnicodeString = '*/*'; + const aFlags : DWORD = WINHTTP_THRIFT_DEFAULTS + ); + + destructor Destroy; override; + end; + + + TWinHTTPUrlImpl = class( TInterfacedObject, IWinHTTPUrl) + strict private + FScheme : UnicodeString; + FNumScheme : INTERNET_SCHEME; + FHostName : UnicodeString; + FPort : INTERNET_PORT; + FUserName : UnicodeString; + FPassword : UnicodeString; + FUrlPath : UnicodeString; + FExtraInfo : UnicodeString; + + strict protected + // url parts getter + function GetScheme : UnicodeString; + function GetNumScheme : INTERNET_SCHEME; + function GetHostName : UnicodeString; + function GetPort : INTERNET_PORT; + function GetUserName : UnicodeString; + function GetPassword : UnicodeString; + function GetUrlPath : UnicodeString; + function GetExtraInfo : UnicodeString; + + // url parts setter + procedure SetScheme( const value : UnicodeString); + procedure SetHostName ( const value : UnicodeString); + procedure SetPort( const value : INTERNET_PORT); + procedure SetUserName( const value : UnicodeString); + procedure SetPassword( const value : UnicodeString); + procedure SetUrlPath( const value : UnicodeString); + procedure SetExtraInfo( const value : UnicodeString); + + // url as a whole + function BuildUrl : UnicodeString; + procedure CrackUrl( const value : UnicodeString); + + public + constructor Create( const aUri : UnicodeString); + destructor Destroy; override; + end; + + + WINHTTP_PROXY_INFO_Helper = record helper for WINHTTP_PROXY_INFO + procedure Initialize; + procedure FreeAllocatedResources; + end; + + + WINHTTP_CURRENT_USER_IE_PROXY_CONFIG_Helper = record helper for WINHTTP_CURRENT_USER_IE_PROXY_CONFIG + procedure Initialize; + procedure FreeAllocatedResources; + end; + + + EWinHTTPException = class(Exception); + +{ helper functions } + +function WinHttpSysErrorMessage( const error : Cardinal): string; +procedure RaiseLastWinHttpError; + + +implementation + +const WINHTTP_DLL = 'WinHTTP.dll'; + +function WinHttpCloseHandle; stdcall; external WINHTTP_DLL; +function WinHttpOpen; stdcall; external WINHTTP_DLL; +function WinHttpConnect; stdcall; external WINHTTP_DLL; +function WinHttpOpenRequest; stdcall; external WINHTTP_DLL; +function WinHttpSendRequest; stdcall; external WINHTTP_DLL; +function WinHttpSetTimeouts; stdcall; external WINHTTP_DLL; +function WinHttpQueryOption; stdcall; external WINHTTP_DLL; +function WinHttpSetOption; stdcall; external WINHTTP_DLL; +function WinHttpAddRequestHeaders; stdcall; external WINHTTP_DLL; +function WinHttpGetProxyForUrl; stdcall; external WINHTTP_DLL; +function WinHttpGetIEProxyConfigForCurrentUser; stdcall; external WINHTTP_DLL; +function WinHttpWriteData; stdcall; external WINHTTP_DLL; +function WinHttpReceiveResponse; stdcall; external WINHTTP_DLL; +function WinHttpQueryHeaders; stdcall; external WINHTTP_DLL; +function WinHttpQueryDataAvailable; stdcall; external WINHTTP_DLL; +function WinHttpReadData; stdcall; external WINHTTP_DLL; +function WinHttpCrackUrl; stdcall; external WINHTTP_DLL; +function WinHttpCreateUrl; stdcall; external WINHTTP_DLL; + + +{ helper functions } + +function WinHttpSysErrorMessage( const error : Cardinal): string; +const FLAGS = FORMAT_MESSAGE_ALLOCATE_BUFFER + or FORMAT_MESSAGE_IGNORE_INSERTS + or FORMAT_MESSAGE_FROM_SYSTEM + or FORMAT_MESSAGE_FROM_HMODULE; +var pBuffer : PChar; + nChars : Cardinal; +begin + if (error < WINHTTP_ERROR_BASE) + or (error > WINHTTP_ERROR_LAST) + then Exit( SysUtils.SysErrorMessage( error)); + + pBuffer := nil; + try + nChars := FormatMessage( FLAGS, + Pointer( GetModuleHandle( WINHTTP_DLL)), + error, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // default language + @pBuffer, 0, + nil); + SetString( result, pBuffer, nChars); + finally + LocalFree( NativeUInt( pBuffer)); + end; +end; + + +procedure RaiseLastWinHttpError; +var error : Cardinal; + sMsg : string; +begin + error := Cardinal( GetLastError); + if error <> NOERROR then begin + sMSg := IntToStr(Integer(error))+' '+WinHttpSysErrorMessage(error); + raise EWinHTTPException.Create( sMsg); + end; +end; + + + +{ misc. record helper } + + +procedure GlobalFreeAndNil( var p : LPWSTR); +begin + if p <> nil then begin + GlobalFree( HGLOBAL( p)); + p := nil; + end; +end; + + +procedure WINHTTP_PROXY_INFO_Helper.Initialize; +begin + FillChar( Self, SizeOf(Self), 0); +end; + + +procedure WINHTTP_PROXY_INFO_Helper.FreeAllocatedResources; +// The caller must free the lpszProxy and lpszProxyBypass strings +// if they are non-NULL. Use GlobalFree to free the strings. +begin + GlobalFreeAndNil( lpszProxy); + GlobalFreeAndNil( lpszProxyBypass); + Initialize; +end; + + +procedure WINHTTP_CURRENT_USER_IE_PROXY_CONFIG_Helper.Initialize; +begin + FillChar( Self, SizeOf(Self), 0); +end; + + +procedure WINHTTP_CURRENT_USER_IE_PROXY_CONFIG_Helper.FreeAllocatedResources; +// The caller must free the lpszProxy, lpszProxyBypass and lpszAutoConfigUrl strings +// if they are non-NULL. Use GlobalFree to free the strings. +begin + GlobalFreeAndNil( lpszProxy); + GlobalFreeAndNil( lpszProxyBypass); + GlobalFreeAndNil( lpszAutoConfigUrl); + Initialize; +end; + + +{ TWinHTTPHandleObjectImpl } + +constructor TWinHTTPHandleObjectImpl.Create( const aHandle : HINTERNET); +begin + inherited Create; + FHandle := aHandle; + + if FHandle = nil + then raise EWinHTTPException.Create('Invalid handle'); +end; + + +destructor TWinHTTPHandleObjectImpl.Destroy; +begin + try + if Assigned(FHandle) then begin + WinHttpCloseHandle(FHandle); + FHandle := nil; + end; + + finally + inherited Destroy; + end; +end; + + +function TWinHTTPHandleObjectImpl.Handle : HINTERNET; +begin + result := FHandle; +end; + + +{ TWinHTTPSessionImpl } + + +constructor TWinHTTPSessionImpl.Create( const aAgent : UnicodeString; const aAccessType : DWORD; + const aProxy, aProxyBypass : UnicodeString; const aFlags : DWORD); +var handle : HINTERNET; +begin + handle := WinHttpOpen( PWideChar(aAgent), aAccessType, + PWideChar(Pointer(aProxy)), // may be nil + PWideChar(Pointer(aProxyBypass)), // may be nil + aFlags); + if handle = nil then RaiseLastWinHttpError; + inherited Create( handle); +end; + + +destructor TWinHTTPSessionImpl.Destroy; +begin + inherited Destroy; + // add code here +end; + + +function TWinHTTPSessionImpl.Connect( const aHostName : UnicodeString; const aPort : INTERNET_PORT) : IWinHTTPConnection; +begin + result := TWinHTTPConnectionImpl.Create( Self, aHostName, aPort); +end; + + +function TWinHTTPSessionImpl.SetTimeouts( const aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout : Int32) : Boolean; +begin + result := WinHttpSetTimeouts( FHandle, aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout); +end; + + +function TWinHTTPSessionImpl.EnableSecureProtocols( const aFlagSet : DWORD) : Boolean; +var dwSize : DWORD; +begin + dwSize := SizeOf(aFlagSet); + result := WinHttpSetOption( Handle, WINHTTP_OPTION_SECURE_PROTOCOLS, @aFlagset, dwSize); +end; + + +{ TWinHTTPConnectionImpl } + +constructor TWinHTTPConnectionImpl.Create( const aSession : IWinHTTPSession; const aHostName : UnicodeString; const aPort : INTERNET_PORT); +var handle : HINTERNET; +begin + FSession := aSession; + handle := WinHttpConnect( FSession.Handle, PWideChar(aHostName), aPort, 0); + if handle = nil then RaiseLastWinHttpError; + inherited Create( handle); +end; + + +destructor TWinHTTPConnectionImpl.Destroy; +begin + inherited Destroy; + FSession := nil; +end; + + +function TWinHTTPConnectionImpl.Session : IWinHTTPSession; +begin + result := FSession; +end; + + +function TWinHTTPConnectionImpl.OpenRequest( const secure : Boolean; const aVerb, aObjName, aAcceptTypes : UnicodeString) : IWinHTTPRequest; +var dwFlags : DWORD; +begin + dwFlags := WINHTTP_THRIFT_DEFAULTS; + if secure + then dwFlags := dwFlags or WINHTTP_FLAG_SECURE + else dwFlags := dwFlags and not WINHTTP_FLAG_SECURE; + + result := TWinHTTPRequestImpl.Create( Self, aVerb, aObjName, '', '', aAcceptTypes, dwFlags); +end; + + +{ TWinHTTPRequestImpl } + +constructor TWinHTTPRequestImpl.Create( const aConnection : IWinHTTPConnection; + const aVerb, aObjName, aVersion, aReferrer : UnicodeString; + const aAcceptTypes : UnicodeString; + const aFlags : DWORD + ); +var handle : HINTERNET; + accept : array[0..1] of PWideChar; +begin + FConnection := aConnection; + + accept[0] := PWideChar(aAcceptTypes); + accept[1] := nil; + + handle := WinHttpOpenRequest( FConnection.Handle, + PWideChar(UpperCase(aVerb)), + PWideChar(aObjName), + PWideChar(aVersion), + PWideChar(aReferrer), + @accept, + aFlags); + if handle = nil then RaiseLastWinHttpError; + inherited Create( handle); +end; + + +destructor TWinHTTPRequestImpl.Destroy; +begin + inherited Destroy; + FConnection := nil; +end; + + +function TWinHTTPRequestImpl.Connection : IWinHTTPConnection; +begin + result := FConnection; +end; + + +function TWinHTTPRequestImpl.SetTimeouts( const aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout : Int32) : Boolean; +begin + result := WinHttpSetTimeouts( FHandle, aResolveTimeout, aConnectTimeout, aSendTimeout, aReceiveTimeout); +end; + + +function TWinHTTPRequestImpl.AddRequestHeader( const aHeader : string; const addflag : DWORD) : Boolean; +begin + result := WinHttpAddRequestHeaders( FHandle, PWideChar(aHeader), DWORD(-1), addflag); +end; + + +procedure TWinHTTPRequestImpl.TryAutoProxy( const aUrl : string); +// From MSDN: +// AutoProxy support is not fully integrated into the HTTP stack in WinHTTP. +// Before sending a request, the application must call WinHttpGetProxyForUrl +// to obtain the name of a proxy server and then call WinHttpSetOption using +// WINHTTP_OPTION_PROXY to set the proxy configuration on the WinHTTP request +// handle created by WinHttpOpenRequest. +// See https://docs.microsoft.com/en-us/windows/desktop/winhttp/winhttp-autoproxy-api +var + options : WINHTTP_AUTOPROXY_OPTIONS; + proxy : WINHTTP_PROXY_INFO; + ieProxy : WINHTTP_CURRENT_USER_IE_PROXY_CONFIG; + dwSize : DWORD; +begin + // try AutoProxy via PAC first + proxy.Initialize; + try + FillChar( options, SizeOf(options), 0); + options.dwFlags := WINHTTP_AUTOPROXY_AUTO_DETECT; + options.dwAutoDetectFlags := WINHTTP_AUTO_DETECT_TYPE_DHCP or WINHTTP_AUTO_DETECT_TYPE_DNS_A; + options.fAutoLogonIfChallenged := TRUE; + if WinHttpGetProxyForUrl( FConnection.Session.Handle, PChar(aUrl), options, proxy) then begin + dwSize := SizeOf(proxy); + WinHttpSetOption( Handle, WINHTTP_OPTION_PROXY, @proxy, dwSize); + Exit; + end; + + finally + proxy.FreeAllocatedResources; + end; + + // Use IE settings as a fallback, useful in client (i.e. non-server) environments + ieProxy.Initialize; + try + if WinHttpGetIEProxyConfigForCurrentUser( ieProxy) + then begin + + // lpszAutoConfigUrl = "Use automatic proxy configuration" + if ieProxy.lpszAutoConfigUrl <> nil then begin + options.lpszAutoConfigUrl := ieProxy.lpszAutoConfigUrl; + options.dwFlags := options.dwFlags or WINHTTP_AUTOPROXY_CONFIG_URL; + + proxy.Initialize; + try + if WinHttpGetProxyForUrl( FConnection.Session.Handle, PChar(aUrl), options, proxy) then begin + dwSize := SizeOf(proxy); + WinHttpSetOption( Handle, WINHTTP_OPTION_PROXY, @proxy, dwSize); + Exit; + end; + finally + proxy.FreeAllocatedResources; + end; + end; + + // lpszProxy = "use a proxy server" + if ieProxy.lpszProxy <> nil then begin + proxy.Initialize; + try + proxy.dwAccessType := WINHTTP_ACCESS_TYPE_NAMED_PROXY; + proxy.lpszProxy := ieProxy.lpszProxy; + proxy.lpszProxyBypass := ieProxy.lpszProxyBypass; + dwSize := SizeOf(proxy); + WinHttpSetOption( Handle, WINHTTP_OPTION_PROXY, @proxy, dwSize); + Exit; + finally + proxy.Initialize; // not FreeAllocatedResources, we only hold pointer copies! + end; + end; + + end; + + finally + ieProxy.FreeAllocatedResources; + end; +end; + + +procedure TWinHTTPRequestImpl.EnableAutomaticContentDecompression( const aEnable : Boolean); +// Enable automatic gzip,deflate decompression on systems that support this option +// From the docs: WinHTTP will automatically set an appropriate Accept-Encoding header, +// overriding any value supplied by the caller -> we don't have to do this +// Available on Win 8.1 or higher +var value : DWORD; +begin + if aEnable + then value := WINHTTP_DECOMPRESSION_FLAG_ALL + else value := 0; + + // ignore returned value, the option is not supported with older WinHTTP versions + WinHttpSetOption( Handle, WINHTTP_OPTION_DECOMPRESSION, @value, SizeOf(DWORD)); +end; + + +function TWinHTTPRequestImpl.SendRequest( const pBuf : Pointer; const dwBytes, dwExtra : DWORD) : Boolean; +begin + result := WinHttpSendRequest( FHandle, + WINHTTP_NO_ADDITIONAL_HEADERS, 0, + pBuf, dwBytes, // number of bytes in pBuf + dwBytes + dwExtra, // becomes the Content-Length + nil); // context for async operations +end; + + +function TWinHTTPRequestImpl.WriteExtraData( const pBuf : Pointer; const dwBytes : DWORD) : DWORD; +begin + if not WinHttpWriteData( FHandle, pBuf, dwBytes, result) + then result := 0; +end; + + +function TWinHTTPRequestImpl.FlushAndReceiveResponse : Boolean; +begin + result := WinHttpReceiveResponse( FHandle, nil); +end; + + +function TWinHTTPRequestImpl.ReadData( const dwRead : DWORD) : TBytes; +var dwAvailable, dwReceived : DWORD; +begin + if WinHttpQueryDataAvailable( FHandle, dwAvailable) + then dwAvailable := Min( dwRead, dwAvailable) + else dwAvailable := 0; + + SetLength( result, dwAvailable); + if dwAvailable = 0 then Exit; + + if WinHttpReadData( FHandle, @result[0], Length(result), dwReceived) + then SetLength( result, dwReceived) + else SetLength( result, 0); +end; + + +function TWinHTTPRequestImpl.ReadData( const pBuf : Pointer; const dwRead : DWORD) : DWORD; +var dwAvailable : DWORD; +begin + if WinHttpQueryDataAvailable( FHandle, dwAvailable) + then dwAvailable := Min( dwRead, dwAvailable) + else dwAvailable := 0; + + if (dwAvailable = 0) + or not WinHttpReadData( FHandle, pBuf, dwAvailable, result) + then result := 0; +end; + + +{ TWinHTTPUrlImpl } + +constructor TWinHTTPUrlImpl.Create(const aUri: UnicodeString); +begin + inherited Create; + CrackUrl( aUri) +end; + + +destructor TWinHTTPUrlImpl.Destroy; +begin + inherited Destroy; +end; + + +procedure TWinHTTPUrlImpl.CrackURL( const value : UnicodeString); +const FLAGS = 0; // no special operations, leave components as-is +var components : URL_COMPONENTS; +begin + FillChar(components, SizeOf(components), 0); + components.dwStructSize := SizeOf(components); + + if value <> '' then begin + { For the WinHttpCrackUrl function, [...] if the pointer member is NULL but the + length member is not zero, both the pointer and length members are returned. } + components.dwSchemeLength := DWORD(-1); + components.dwHostNameLength := DWORD(-1); + components.dwUserNameLength := DWORD(-1); + components.dwPasswordLength := DWORD(-1); + components.dwUrlPathLength := DWORD(-1); + components.dwExtraInfoLength := DWORD(-1); + + WinHttpCrackUrl( PWideChar(value), Length(value), FLAGS, components); + end; + + FNumScheme := components.nScheme; + FPort := components.nPort; + SetString( FScheme, components.lpszScheme, components.dwSchemeLength); + SetString( FHostName, components.lpszHostName, components.dwHostNameLength); + SetString( FUserName, components.lpszUserName, components.dwUserNameLength); + SetString( FPassword, components.lpszPassword, components.dwPasswordLength); + SetString( FUrlPath, components.lpszUrlPath, components.dwUrlPathLength); + SetString( FExtraInfo, components.lpszExtraInfo, components.dwExtraInfoLength); +end; + + +function TWinHTTPUrlImpl.BuildUrl : UnicodeString; +const FLAGS = 0; // no special operations, leave components as-is +var components : URL_COMPONENTS; + dwChars : DWORD; +begin + FillChar(components, SizeOf(components), 0); + components.dwStructSize := SizeOf(components); + components.lpszScheme := PWideChar(FScheme); + components.dwSchemeLength := Length(FScheme); + components.lpszHostName := PWideChar(FHostName); + components.dwHostNameLength := Length(FHostName); + components.nPort := FPort; + components.lpszUserName := PWideChar(FUserName); + components.dwUserNameLength := Length(FUserName); + components.lpszPassword := PWideChar(FPassword); + components.dwPasswordLength := Length(FPassword); + components.lpszUrlPath := PWideChar(FUrlPath); + components.dwUrlPathLength := Length(FUrlPath); + components.lpszExtraInfo := PWideChar(FExtraInfo); + components.dwExtraInfoLength := Length(FExtraInfo); + + WinHttpCreateUrl( components, FLAGS, nil, dwChars); + if dwChars = 0 + then result := '' + else begin + SetLength( result, dwChars + 1); + WinHttpCreateUrl( components, FLAGS, @result[1], dwChars); + SetLength( result, dwChars); // cut off terminating #0 + end; +end; + + +function TWinHTTPUrlImpl.GetExtraInfo: UnicodeString; +begin + result := FExtraInfo; +end; + +function TWinHTTPUrlImpl.GetHostName: UnicodeString; +begin + result := FHostName; +end; + +function TWinHTTPUrlImpl.GetNumScheme: INTERNET_SCHEME; +begin + result := FNumScheme; +end; + +function TWinHTTPUrlImpl.GetPassword: UnicodeString; +begin + result := FPassword; +end; + +function TWinHTTPUrlImpl.GetPort: INTERNET_PORT; +begin + result := FPort; +end; + +function TWinHTTPUrlImpl.GetScheme: UnicodeString; +begin + result := FScheme; +end; + +function TWinHTTPUrlImpl.GetUrlPath: UnicodeString; +begin + result := FUrlPath; +end; + +function TWinHTTPUrlImpl.GetUserName: UnicodeString; +begin + result := FUserName; +end; + +procedure TWinHTTPUrlImpl.SetExtraInfo(const value: UnicodeString); +begin + FExtraInfo := value; +end; + +procedure TWinHTTPUrlImpl.SetHostName(const value: UnicodeString); +begin + FHostName := value; +end; + +procedure TWinHTTPUrlImpl.SetPassword(const value: UnicodeString); +begin + FPassword := value; +end; + +procedure TWinHTTPUrlImpl.SetPort(const value: INTERNET_PORT); +begin + FPort := value; +end; + +procedure TWinHTTPUrlImpl.SetScheme(const value: UnicodeString); +begin + FScheme := value; +end; + +procedure TWinHTTPUrlImpl.SetUrlPath(const value: UnicodeString); +begin + FUrlPath := value; +end; + +procedure TWinHTTPUrlImpl.SetUserName(const value: UnicodeString); +begin + FUserName := value; +end; + + +initialization + OutputDebugString( PChar( SysErrorMessage( 12002))); + +end. + + diff --git a/src/jaegertracing/thrift/lib/delphi/src/Thrift.pas b/src/jaegertracing/thrift/lib/delphi/src/Thrift.pas new file mode 100644 index 000000000..2ee83441b --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/src/Thrift.pas @@ -0,0 +1,239 @@ +(* + * 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; + +interface + +uses + SysUtils, + Thrift.Exception, + Thrift.Protocol; + +const + Version = '0.13.0'; + +type + TException = Thrift.Exception.TException; // compatibility alias + + TApplicationExceptionSpecializedClass = class of TApplicationExceptionSpecialized; + + TApplicationException = class( TException) + public + type +{$SCOPEDENUMS ON} + TExceptionType = ( + Unknown, + UnknownMethod, + InvalidMessageType, + WrongMethodName, + BadSequenceID, + MissingResult, + InternalError, + ProtocolError, + InvalidTransform, + InvalidProtocol, + UnsupportedClientType + ); +{$SCOPEDENUMS OFF} + private + function GetType: TExceptionType; + protected + constructor HiddenCreate(const Msg: string); + public + // purposefully hide inherited constructor + class function Create(const Msg: string): TApplicationException; overload; deprecated 'Use specialized TApplicationException types (or regenerate from IDL)'; + class function Create: TApplicationException; overload; deprecated 'Use specialized TApplicationException types (or regenerate from IDL)'; + class function Create( AType: TExceptionType): TApplicationException; overload; deprecated 'Use specialized TApplicationException types (or regenerate from IDL)'; + class function Create( AType: TExceptionType; const msg: string): TApplicationException; overload; deprecated 'Use specialized TApplicationException types (or regenerate from IDL)'; + + class function GetSpecializedExceptionType(AType: TExceptionType): TApplicationExceptionSpecializedClass; + + class function Read( const iprot: IProtocol): TApplicationException; + procedure Write( const oprot: IProtocol ); + end; + + // Needed to remove deprecation warning + TApplicationExceptionSpecialized = class abstract (TApplicationException) + public + constructor Create(const Msg: string); + end; + + TApplicationExceptionUnknown = class (TApplicationExceptionSpecialized); + TApplicationExceptionUnknownMethod = class (TApplicationExceptionSpecialized); + TApplicationExceptionInvalidMessageType = class (TApplicationExceptionSpecialized); + TApplicationExceptionWrongMethodName = class (TApplicationExceptionSpecialized); + TApplicationExceptionBadSequenceID = class (TApplicationExceptionSpecialized); + TApplicationExceptionMissingResult = class (TApplicationExceptionSpecialized); + TApplicationExceptionInternalError = class (TApplicationExceptionSpecialized); + TApplicationExceptionProtocolError = class (TApplicationExceptionSpecialized); + TApplicationExceptionInvalidTransform = class (TApplicationExceptionSpecialized); + TApplicationExceptionInvalidProtocol = class (TApplicationExceptionSpecialized); + TApplicationExceptionUnsupportedClientType = class (TApplicationExceptionSpecialized); + + +implementation + +{ TApplicationException } + +function TApplicationException.GetType: TExceptionType; +begin + if Self is TApplicationExceptionUnknownMethod then Result := TExceptionType.UnknownMethod + else if Self is TApplicationExceptionInvalidMessageType then Result := TExceptionType.InvalidMessageType + else if Self is TApplicationExceptionWrongMethodName then Result := TExceptionType.WrongMethodName + else if Self is TApplicationExceptionBadSequenceID then Result := TExceptionType.BadSequenceID + else if Self is TApplicationExceptionMissingResult then Result := TExceptionType.MissingResult + else if Self is TApplicationExceptionInternalError then Result := TExceptionType.InternalError + else if Self is TApplicationExceptionProtocolError then Result := TExceptionType.ProtocolError + else if Self is TApplicationExceptionInvalidTransform then Result := TExceptionType.InvalidTransform + else if Self is TApplicationExceptionInvalidProtocol then Result := TExceptionType.InvalidProtocol + else if Self is TApplicationExceptionUnsupportedClientType then Result := TExceptionType.UnsupportedClientType + else Result := TExceptionType.Unknown; +end; + +constructor TApplicationException.HiddenCreate(const Msg: string); +begin + inherited Create(Msg); +end; + +class function TApplicationException.Create(const Msg: string): TApplicationException; +begin + Result := TApplicationExceptionUnknown.Create(Msg); +end; + +class function TApplicationException.Create: TApplicationException; +begin + Result := TApplicationExceptionUnknown.Create(''); +end; + +class function TApplicationException.Create( AType: TExceptionType): TApplicationException; +begin +{$WARN SYMBOL_DEPRECATED OFF} + Result := Create(AType, ''); +{$WARN SYMBOL_DEPRECATED DEFAULT} +end; + +class function TApplicationException.Create( AType: TExceptionType; const msg: string): TApplicationException; +begin + Result := GetSpecializedExceptionType(AType).Create(msg); +end; + +class function TApplicationException.GetSpecializedExceptionType(AType: TExceptionType): TApplicationExceptionSpecializedClass; +begin + case AType of + TExceptionType.UnknownMethod: Result := TApplicationExceptionUnknownMethod; + TExceptionType.InvalidMessageType: Result := TApplicationExceptionInvalidMessageType; + TExceptionType.WrongMethodName: Result := TApplicationExceptionWrongMethodName; + TExceptionType.BadSequenceID: Result := TApplicationExceptionBadSequenceID; + TExceptionType.MissingResult: Result := TApplicationExceptionMissingResult; + TExceptionType.InternalError: Result := TApplicationExceptionInternalError; + TExceptionType.ProtocolError: Result := TApplicationExceptionProtocolError; + TExceptionType.InvalidTransform: Result := TApplicationExceptionInvalidTransform; + TExceptionType.InvalidProtocol: Result := TApplicationExceptionInvalidProtocol; + TExceptionType.UnsupportedClientType: Result := TApplicationExceptionUnsupportedClientType; + else + Result := TApplicationExceptionUnknown; + end; +end; + +class function TApplicationException.Read( const iprot: IProtocol): TApplicationException; +var + field : TThriftField; + msg : string; + typ : TExceptionType; + struc : TThriftStruct; +begin + msg := ''; + typ := TExceptionType.Unknown; + struc := iprot.ReadStructBegin; + while ( True ) do + begin + field := iprot.ReadFieldBegin; + if ( field.Type_ = TType.Stop) then + begin + Break; + end; + + case field.Id of + 1 : begin + if ( field.Type_ = TType.String_) then + begin + msg := iprot.ReadString; + end else + begin + TProtocolUtil.Skip( iprot, field.Type_ ); + end; + end; + + 2 : begin + if ( field.Type_ = TType.I32) then + begin + typ := TExceptionType( iprot.ReadI32 ); + end else + begin + TProtocolUtil.Skip( iprot, field.Type_ ); + end; + end else + begin + TProtocolUtil.Skip( iprot, field.Type_); + end; + end; + iprot.ReadFieldEnd; + end; + iprot.ReadStructEnd; + Result := GetSpecializedExceptionType(typ).Create(msg); +end; + +procedure TApplicationException.Write( const oprot: IProtocol); +var + struc : TThriftStruct; + field : TThriftField; +begin + Init(struc, 'TApplicationException'); + Init(field); + + oprot.WriteStructBegin( struc ); + if Message <> '' then + begin + field.Name := 'message'; + field.Type_ := TType.String_; + field.Id := 1; + oprot.WriteFieldBegin( field ); + oprot.WriteString( Message ); + oprot.WriteFieldEnd; + end; + + field.Name := 'type'; + field.Type_ := TType.I32; + field.Id := 2; + oprot.WriteFieldBegin(field); + oprot.WriteI32(Integer(GetType)); + oprot.WriteFieldEnd(); + oprot.WriteFieldStop(); + oprot.WriteStructEnd(); +end; + +{ TApplicationExceptionSpecialized } + +constructor TApplicationExceptionSpecialized.Create(const Msg: string); +begin + inherited HiddenCreate(Msg); +end; + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/ConsoleHelper.pas b/src/jaegertracing/thrift/lib/delphi/test/ConsoleHelper.pas new file mode 100644 index 000000000..0a8ddcf10 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/ConsoleHelper.pas @@ -0,0 +1,132 @@ +(* + * 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 ConsoleHelper; + +interface + +uses Classes; + +type + TThriftConsole = class + public + procedure Write( const S: string); virtual; + procedure WriteLine( const S: string); virtual; + end; + + TGUIConsole = class( TThriftConsole ) + private + FLineBreak : Boolean; + FMemo : TStrings; + + procedure InternalWrite( const S: string; bWriteLine: Boolean); + public + procedure Write( const S: string); override; + procedure WriteLine( const S: string); override; + constructor Create( AMemo: TStrings); + end; + +function Console: TThriftConsole; +procedure ChangeConsole( AConsole: TThriftConsole ); +procedure RestoreConsoleToDefault; + +implementation + +var + FDefaultConsole : TThriftConsole; + FConsole : TThriftConsole; + +function Console: TThriftConsole; +begin + Result := FConsole; +end; + +{ TThriftConsole } + +procedure TThriftConsole.Write(const S: string); +begin + System.Write( S ); +end; + +procedure TThriftConsole.WriteLine(const S: string); +begin + System.Writeln( S ); +end; + +procedure ChangeConsole( AConsole: TThriftConsole ); +begin + FConsole := AConsole; +end; + +procedure RestoreConsoleToDefault; +begin + FConsole := FDefaultConsole; +end; + +{ TGUIConsole } + +constructor TGUIConsole.Create( AMemo: TStrings); +begin + inherited Create; + FMemo := AMemo; + FLineBreak := True; +end; + +procedure TGUIConsole.InternalWrite(const S: string; bWriteLine: Boolean); +var + idx : Integer; +begin + if FLineBreak then + begin + FMemo.Add( S ); + end else + begin + idx := FMemo.Count - 1; + if idx < 0 then + FMemo.Add( S ) + else + FMemo[idx] := FMemo[idx] + S; + end; + FLineBreak := bWriteLine; +end; + +procedure TGUIConsole.Write(const S: string); +begin + InternalWrite( S, False); +end; + +procedure TGUIConsole.WriteLine(const S: string); +begin + InternalWrite( S, True); +end; + +initialization +begin + FDefaultConsole := TThriftConsole.Create; + FConsole := FDefaultConsole; +end; + +finalization +begin + FDefaultConsole.Free; +end; + +end. + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/Performance/DataFactory.pas b/src/jaegertracing/thrift/lib/delphi/test/Performance/DataFactory.pas new file mode 100644 index 000000000..e131822a3 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/Performance/DataFactory.pas @@ -0,0 +1,176 @@ +// 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 DataFactory; + +interface + +uses + SysUtils, + Thrift.Collections, + Thrift.Test; + +type + TestDataFactory = class + strict protected + class function CreateSetField(const count : Integer) : IHashSet< IInsanity>; static; + class function CreateInsanity(const count : Integer) : IInsanity; static; + class function CreateBytesArray(const count : Integer) : TBytes; static; + class function CreateXtructs(const count : Integer) : IThriftList< IXtruct>; static; + class function CreateXtruct(const count : Integer) : IXtruct; static; + class function CreateListField(const count : Integer) : IThriftList< IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>>; static; + class function CreateUserMap(const count : Integer) : IThriftDictionary< TNumberz, Int64>; static; + class function CreateListFieldData(const count : Integer) : IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>; static; + class function CreateIntHashSet(const count : Integer) : IHashSet< Integer>; static; + class function CreateListFieldDataDict(const count : Integer) : IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>; static; + class function CreateListFieldDataDictValue(const count : Integer) : IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>; static; + class function CreateListFieldDataDictValueList(const count : Integer) : IThriftList< IThriftDictionary< IInsanity, string>>; static; + class function CreateListFieldDataDictValueListDict(const count : Integer) : IThriftDictionary< IInsanity, string>; static; + public + class function CreateCrazyNesting(const count : Integer = 10) : ICrazyNesting; static; + end; + +implementation + + +class function TestDataFactory.CreateCrazyNesting(const count : Integer = 10) : ICrazyNesting; +begin + if (count <= 0) + then Exit(nil); + + result := TCrazyNestingImpl.Create; + result.Binary_field := CreateBytesArray(count); + result.List_field := CreateListField(count); + result.Set_field := CreateSetField(count); + result.String_field := Format('data level %d', [count]); +end; + +class function TestDataFactory.CreateSetField(const count : Integer) : IHashSet< IInsanity>; +var i : Integer; +begin + result := THashSetImpl< IInsanity>.Create; + for i := 0 to count-1 do begin + result.Add(CreateInsanity(count)); + end; +end; + +class function TestDataFactory.CreateInsanity(const count : Integer) : IInsanity; +begin + result := TInsanityImpl.Create; + result.UserMap := CreateUserMap(count); + result.Xtructs := CreateXtructs(count); +end; + +class function TestDataFactory.CreateXtructs(const count : Integer) : IThriftList< IXtruct>; +var i : Integer; +begin + result := TThriftListImpl< IXtruct>.Create; + for i := 0 to count-1 do begin + result.Add(CreateXtruct(count)); + end; +end; + +class function TestDataFactory.CreateXtruct(const count : Integer) : IXtruct; +begin + result := TXtructImpl.Create; + result.Byte_thing := SmallInt(count mod 128); + result.I32_thing := count; + result.I64_thing := count; + result.String_thing := Format('data level %d', [count]); +end; + +class function TestDataFactory.CreateUserMap(const count : Integer) : IThriftDictionary< TNumberz, Int64>; +begin + result := TThriftDictionaryImpl< TNumberz, Int64>.Create; + result.Add(TNumberz.ONE, count); + result.Add(TNumberz.TWO, count); + result.Add(TNumberz.THREE, count); + result.Add(TNumberz.FIVE, count); + result.Add(TNumberz.SIX, count); + result.Add(TNumberz.EIGHT, count); +end; + +class function TestDataFactory.CreateListField(const count : Integer) : IThriftList< IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>>; +var i : Integer; +begin + result := TThriftListImpl< IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>>.Create; + for i := 0 to count-1 do begin + result.Add(CreateListFieldData(count)); + end; +end; + +class function TestDataFactory.CreateListFieldData(const count : Integer) : IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>; +var i : Integer; +begin + result := TThriftDictionaryImpl< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>.Create; + for i := 0 to count-1 do begin + result.Add( CreateIntHashSet(count), CreateListFieldDataDict(count)); + end; +end; + +class function TestDataFactory.CreateIntHashSet(const count : Integer) : IHashSet< Integer>; +var i : Integer; +begin + result := THashSetImpl< Integer>.Create; + for i := 0 to count-1 do begin + result.Add(i); + end; +end; + +class function TestDataFactory.CreateListFieldDataDict(const count : Integer) : IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>; +var i : Integer; +begin + result := TThriftDictionaryImpl< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>.Create; + for i := 0 to count-1 do begin + result.Add(i, CreateListFieldDataDictValue(count)); + end; +end; + +class function TestDataFactory.CreateListFieldDataDictValue(const count : Integer) : IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>; +var i : Integer; +begin + result := THashSetImpl< IThriftList< IThriftDictionary< IInsanity, string>>>.Create; + for i := 0 to count-1 do begin + result.Add( CreateListFieldDataDictValueList(count)); + end; +end; + +class function TestDataFactory.CreateListFieldDataDictValueList(const count : Integer) : IThriftList< IThriftDictionary< IInsanity, string>>; +var i : Integer; +begin + result := TThriftListImpl< IThriftDictionary< IInsanity, string>>.Create; + for i := 0 to count-1 do begin + result.Add(CreateListFieldDataDictValueListDict(count)); + end; +end; + +class function TestDataFactory.CreateListFieldDataDictValueListDict(const count : Integer) : IThriftDictionary< IInsanity, string>; +begin + result := TThriftDictionaryImpl< IInsanity, string>.Create; + result.Add(CreateInsanity(count), Format('data level %d', [count])); +end; + +class function TestDataFactory.CreateBytesArray(const count : Integer) : TBytes; +var i : Integer; +begin + SetLength( result, count); + for i := 0 to count-1 do begin + result[i] := i mod $FF; + end; +end; + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/Performance/PerfTests.pas b/src/jaegertracing/thrift/lib/delphi/test/Performance/PerfTests.pas new file mode 100644 index 000000000..2c820b1f3 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/Performance/PerfTests.pas @@ -0,0 +1,173 @@ +// 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 PerfTests; + +interface + +uses + Windows, Classes, SysUtils, + Thrift.Collections, + Thrift.Test, + Thrift.Protocol, + Thrift.Protocol.JSON, + Thrift.Protocol.Compact, + Thrift.Transport, + Thrift.Stream, + ConsoleHelper, + TestConstants, + DataFactory; + +type + TPerformanceTests = class + strict private + Testdata : ICrazyNesting; + MemBuffer : TMemoryStream; + Transport : ITransport; + + procedure ProtocolPeformanceTest; + procedure RunTest( const ptyp : TKnownProtocol; const layered : TLayeredTransport); + function GenericProtocolFactory(const ptyp : TKnownProtocol; const layered : TLayeredTransport; const forWrite : Boolean) : IProtocol; + function GetProtocolTransportName(const ptyp : TKnownProtocol; const layered : TLayeredTransport) : string; + public + class function Execute : Integer; + end; + + +implementation + + +// not available in all versions, so make sure we have this one imported +function IsDebuggerPresent: BOOL; stdcall; external KERNEL32 name 'IsDebuggerPresent'; + + +class function TPerformanceTests.Execute : Integer; +var instance : TPerformanceTests; +begin + instance := TPerformanceTests.Create; + instance.ProtocolPeformanceTest; + + // debug only + if IsDebuggerPresent then begin + Console.Write('Hit ENTER ...'); + ReadLn; + end; + + result := 0; +end; + + +procedure TPerformanceTests.ProtocolPeformanceTest; +var layered : TLayeredTransport; +begin + Console.WriteLine('Setting up for ProtocolPeformanceTest ...'); + Testdata := TestDataFactory.CreateCrazyNesting(); + + for layered := Low(TLayeredTransport) to High(TLayeredTransport) do begin + RunTest( TKnownProtocol.prot_Binary, layered); + RunTest( TKnownProtocol.prot_Compact, layered); + RunTest( TKnownProtocol.prot_JSON, layered); + end; +end; + + +procedure TPerformanceTests.RunTest( const ptyp : TKnownProtocol; const layered : TLayeredTransport); +var freq, start, stop : Int64; + proto : IProtocol; + restored : ICrazyNesting; +begin + QueryPerformanceFrequency( freq); + + proto := GenericProtocolFactory( ptyp, layered, TRUE); + QueryPerformanceCounter( start); + Testdata.Write(proto); + Transport.Flush; + QueryPerformanceCounter( stop); + Console.WriteLine( Format('RunTest(%s): write = %d msec', [ + GetProtocolTransportName(ptyp,layered), + Round(1000.0*(stop-start)/freq) + ])); + + restored := TCrazyNestingImpl.Create; + proto := GenericProtocolFactory( ptyp, layered, FALSE); + QueryPerformanceCounter( start); + restored.Read(proto); + QueryPerformanceCounter( stop); + Console.WriteLine( Format('RunTest(%s): read = %d msec', [ + GetProtocolTransportName(ptyp,layered), + Round(1000.0*(stop-start)/freq) + ])); +end; + + +function TPerformanceTests.GenericProtocolFactory(const ptyp : TKnownProtocol; const layered : TLayeredTransport; const forWrite : Boolean) : IProtocol; +var newBuf : TMemoryStream; + stream : IThriftStream; + trans : IStreamTransport; +const COPY_ENTIRE_STREAM = 0; +begin + // read happens after write here, so let's take over the written bytes + newBuf := TMemoryStream.Create; + if not forWrite then newBuf.CopyFrom( MemBuffer, COPY_ENTIRE_STREAM); + MemBuffer := newBuf; + MemBuffer.Position := 0; + + // layered transports anyone? + stream := TThriftStreamAdapterDelphi.Create( newBuf, TRUE); + if forWrite + then trans := TStreamTransportImpl.Create( nil, stream) + else trans := TStreamTransportImpl.Create( stream, nil); + case layered of + trns_Framed : Transport := TFramedTransportImpl.Create( trans); + trns_Buffered : Transport := TBufferedTransportImpl.Create( trans); + else + Transport := trans; + end; + + if not Transport.IsOpen + then Transport.Open; + + case ptyp of + prot_Binary : result := TBinaryProtocolImpl.Create(trans); + prot_Compact : result := TCompactProtocolImpl.Create(trans); + prot_JSON : result := TJSONProtocolImpl.Create(trans); + else + ASSERT(FALSE); + end; +end; + + +function TPerformanceTests.GetProtocolTransportName(const ptyp : TKnownProtocol; const layered : TLayeredTransport) : string; +begin + case layered of + trns_Framed : result := ' + framed'; + trns_Buffered : result := ' + buffered'; + else + result := ''; + end; + + case ptyp of + prot_Binary : result := 'binary' + result; + prot_Compact : result := 'compact' + result; + prot_JSON : result := 'JSON' + result; + else + ASSERT(FALSE); + end; +end; + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestClient.pas b/src/jaegertracing/thrift/lib/delphi/test/TestClient.pas new file mode 100644 index 000000000..e59c32720 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestClient.pas @@ -0,0 +1,1506 @@ +(* + * 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 TestClient; + +{$I ../src/Thrift.Defines.inc} + +{.$DEFINE StressTest} // activate to stress-test the server with frequent connects/disconnects +{.$DEFINE PerfTest} // activate the performance test +{$DEFINE Exceptions} // activate the exceptions test (or disable while debugging) + +{$if CompilerVersion >= 28} +{$DEFINE SupportsAsync} +{$ifend} + +{$WARN SYMBOL_PLATFORM OFF} // Win32Check + +interface + +uses + Windows, SysUtils, Classes, Math, ComObj, ActiveX, + {$IFDEF SupportsAsync} System.Threading, {$ENDIF} + DateUtils, + Generics.Collections, + TestConstants, + ConsoleHelper, + PerfTests, + Thrift, + Thrift.Protocol.Compact, + Thrift.Protocol.JSON, + Thrift.Protocol, + Thrift.Transport.Pipes, + Thrift.Transport.WinHTTP, + Thrift.Transport.MsxmlHTTP, + Thrift.Transport, + Thrift.Stream, + Thrift.Test, + Thrift.WinHTTP, + Thrift.Utils, + Thrift.Collections; + +type + TThreadConsole = class + private + FThread : TThread; + public + procedure Write( const S : string); + procedure WriteLine( const S : string); + constructor Create( AThread: TThread); + end; + + TTestSetup = record + protType : TKnownProtocol; + endpoint : TEndpointTransport; + layered : TLayeredTransports; + useSSL : Boolean; // include where appropriate (TLayeredTransport?) + host : string; + port : Integer; + sPipeName : string; + hAnonRead, hAnonWrite : THandle; + end; + + TClientThread = class( TThread ) + private type + TTestGroup = ( + test_Unknown, + test_BaseTypes, + test_Structs, + test_Containers, + test_Exceptions + // new values here + ); + TTestGroups = set of TTestGroup; + + TTestSize = ( + Empty, // Edge case: the zero-length empty binary + Normal, // Fairly small array of usual size (256 bytes) + ByteArrayTest, // THRIFT-4454 Large writes/reads may cause range check errors in debug mode + PipeWriteLimit, // THRIFT-4372 Pipe write operations across a network are limited to 65,535 bytes per write. + TwentyMB // that's quite a bit of data + ); + + private + FSetup : TTestSetup; + FTransport : ITransport; + FProtocol : IProtocol; + FNumIteration : Integer; + FConsole : TThreadConsole; + + // test reporting, will be refactored out into separate class later + FTestGroup : string; + FCurrentTest : TTestGroup; + FSuccesses : Integer; + FErrors : TStringList; + FFailed : TTestGroups; + FExecuted : TTestGroups; + procedure StartTestGroup( const aGroup : string; const aTest : TTestGroup); + procedure Expect( aTestResult : Boolean; const aTestInfo : string); + procedure ReportResults; + function CalculateExitCode : Byte; + + procedure ClientTest; + {$IFDEF SupportsAsync} + procedure ClientAsyncTest; + {$ENDIF} + + procedure InitializeProtocolTransportStack; + procedure ShutdownProtocolTransportStack; + function InitializeHttpTransport( const aTimeoutSetting : Integer) : IHTTPClient; + + procedure JSONProtocolReadWriteTest; + function PrepareBinaryData( aRandomDist : Boolean; aSize : TTestSize) : TBytes; + {$IFDEF StressTest} + procedure StressTest(const client : TThriftTest.Iface); + {$ENDIF} + {$IFDEF Win64} + procedure UseInterlockedExchangeAdd64; + {$ENDIF} + protected + procedure Execute; override; + public + constructor Create( const aSetup : TTestSetup; const aNumIteration: Integer); + destructor Destroy; override; + end; + + TTestClient = class + private + class var + FNumIteration : Integer; + FNumThread : Integer; + + class procedure PrintCmdLineHelp; + class procedure InvalidArgs; + public + class function Execute( const args: array of string) : Byte; + end; + + +implementation + +const + EXITCODE_SUCCESS = $00; // no errors bits set + // + EXITCODE_FAILBIT_BASETYPES = $01; + EXITCODE_FAILBIT_STRUCTS = $02; + EXITCODE_FAILBIT_CONTAINERS = $04; + EXITCODE_FAILBIT_EXCEPTIONS = $08; + + MAP_FAILURES_TO_EXITCODE_BITS : array[TClientThread.TTestGroup] of Byte = ( + EXITCODE_SUCCESS, // no bits here + EXITCODE_FAILBIT_BASETYPES, + EXITCODE_FAILBIT_STRUCTS, + EXITCODE_FAILBIT_CONTAINERS, + EXITCODE_FAILBIT_EXCEPTIONS + ); + + + +function BoolToString( b : Boolean) : string; +// overrides global BoolToString() +begin + if b + then result := 'true' + else result := 'false'; +end; + +// not available in all versions, so make sure we have this one imported +function IsDebuggerPresent: BOOL; stdcall; external KERNEL32 name 'IsDebuggerPresent'; + +{ TTestClient } + +class procedure TTestClient.PrintCmdLineHelp; +const HELPTEXT = ' [options]'#10 + + #10 + + 'Allowed options:'#10 + + ' -h [ --help ] produce help message'#10 + + ' --host arg (=localhost) Host to connect'#10 + + ' --port arg (=9090) Port number to connect'#10 + + ' --domain-socket arg Domain Socket (e.g. /tmp/ThriftTest.thrift),'#10 + + ' instead of host and port'#10 + + ' --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe)'#10 + + ' --anon-pipes hRead hWrite Windows Anonymous Pipes pair (handles)'#10 + + ' --transport arg (=sockets) Transport: buffered, framed, http, winhttp'#10 + + ' --protocol arg (=binary) Protocol: binary, compact, json'#10 + + ' --ssl Encrypted Transport using SSL'#10 + + ' -n [ --testloops ] arg (=1) Number of Tests'#10 + + ' -t [ --threads ] arg (=1) Number of Test threads'#10 + + ' --performance Run the built-in performance test (no other arguments)'#10 + ; +begin + Writeln( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + HELPTEXT); +end; + +class procedure TTestClient.InvalidArgs; +begin + Console.WriteLine( 'Invalid args.'); + Console.WriteLine( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + ' -h for more information'); + Abort; +end; + +class function TTestClient.Execute(const args: array of string) : Byte; +var + i : Integer; + threadExitCode : Byte; + s : string; + threads : array of TThread; + dtStart : TDateTime; + test : Integer; + thread : TThread; + setup : TTestSetup; +begin + // init record + with setup do begin + protType := prot_Binary; + endpoint := trns_Sockets; + layered := []; + useSSL := FALSE; + host := 'localhost'; + port := 9090; + sPipeName := ''; + hAnonRead := INVALID_HANDLE_VALUE; + hAnonWrite := INVALID_HANDLE_VALUE; + end; + + try + i := 0; + while ( i < Length(args) ) do begin + s := args[i]; + Inc( i); + + if (s = '-h') or (s = '--help') then begin + // -h [ --help ] produce help message + PrintCmdLineHelp; + result := $FF; // all tests failed + Exit; + end + else if s = '--host' then begin + // --host arg (=localhost) Host to connect + setup.host := args[i]; + Inc( i); + end + else if s = '--port' then begin + // --port arg (=9090) Port number to connect + s := args[i]; + Inc( i); + setup.port := StrToIntDef(s,0); + if setup.port <= 0 then InvalidArgs; + end + else if s = '--domain-socket' then begin + // --domain-socket arg Domain Socket (e.g. /tmp/ThriftTest.thrift), instead of host and port + raise Exception.Create('domain-socket not supported'); + end + else if s = '--named-pipe' then begin + // --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe) + setup.endpoint := trns_NamedPipes; + setup.sPipeName := args[i]; + Inc( i); + Console.WriteLine('Using named pipe ('+setup.sPipeName+')'); + end + else if s = '--anon-pipes' then begin + // --anon-pipes hRead hWrite Windows Anonymous Pipes pair (handles) + setup.endpoint := trns_AnonPipes; + setup.hAnonRead := THandle( StrToIntDef( args[i], Integer(INVALID_HANDLE_VALUE))); + Inc( i); + setup.hAnonWrite := THandle( StrToIntDef( args[i], Integer(INVALID_HANDLE_VALUE))); + Inc( i); + Console.WriteLine('Using anonymous pipes ('+IntToStr(Integer(setup.hAnonRead))+' and '+IntToStr(Integer(setup.hAnonWrite))+')'); + end + else if s = '--transport' then begin + // --transport arg (=sockets) Transport: buffered, framed, http, winhttp, evhttp + s := args[i]; + Inc( i); + + if s = 'buffered' then Include( setup.layered, trns_Buffered) + else if s = 'framed' then Include( setup.layered, trns_Framed) + else if s = 'http' then setup.endpoint := trns_MsXmlHttp + else if s = 'winhttp' then setup.endpoint := trns_WinHttp + else if s = 'evhttp' then setup.endpoint := trns_EvHttp // recognized, but not supported + else InvalidArgs; + end + else if s = '--protocol' then begin + // --protocol arg (=binary) Protocol: binary, compact, json + s := args[i]; + Inc( i); + + if s = 'binary' then setup.protType := prot_Binary + else if s = 'compact' then setup.protType := prot_Compact + else if s = 'json' then setup.protType := prot_JSON + else InvalidArgs; + end + else if s = '--ssl' then begin + // --ssl Encrypted Transport using SSL + setup.useSSL := TRUE; + + end + else if (s = '-n') or (s = '--testloops') then begin + // -n [ --testloops ] arg (=1) Number of Tests + FNumIteration := StrToIntDef( args[i], 0); + Inc( i); + if FNumIteration <= 0 + then InvalidArgs; + + end + else if (s = '-t') or (s = '--threads') then begin + // -t [ --threads ] arg (=1) Number of Test threads + FNumThread := StrToIntDef( args[i], 0); + Inc( i); + if FNumThread <= 0 + then InvalidArgs; + end + else if (s = '--performance') then begin + result := TPerformanceTests.Execute; + Exit; + end + else begin + InvalidArgs; + end; + end; + + + // In the anonymous pipes mode the client is launched by the test server + // -> behave nicely and allow for attaching a debugger to this process + if (setup.endpoint = trns_AnonPipes) and not IsDebuggerPresent + then MessageBox( 0, 'Attach Debugger and/or click OK to continue.', + 'Thrift TestClient (Delphi)', + MB_OK or MB_ICONEXCLAMATION); + + SetLength( threads, FNumThread); + dtStart := Now; + + // layered transports are not really meant to be stacked upon each other + if (trns_Framed in setup.layered) then begin + Console.WriteLine('Using framed transport'); + end + else if (trns_Buffered in setup.layered) then begin + Console.WriteLine('Using buffered transport'); + end; + + Console.WriteLine(THRIFT_PROTOCOLS[setup.protType]+' protocol'); + + for test := 0 to FNumThread - 1 do begin + thread := TClientThread.Create( setup, FNumIteration); + threads[test] := thread; + thread.Start; + end; + + result := 0; + for test := 0 to FNumThread - 1 do begin + threadExitCode := threads[test].WaitFor; + result := result or threadExitCode; + threads[test].Free; + threads[test] := nil; + end; + + Console.Write('Total time: ' + IntToStr( MilliSecondsBetween(Now, dtStart))); + + except + on E: EAbort do raise; + on E: Exception do begin + Console.WriteLine( E.Message + #10 + E.StackTrace); + raise; + end; + end; + + Console.WriteLine(''); + Console.WriteLine('done!'); +end; + +{ TClientThread } + +procedure TClientThread.ClientTest; +var + client : TThriftTest.Iface; + s : string; + i8 : ShortInt; + i32 : Integer; + i64 : Int64; + binOut,binIn : TBytes; + dub : Double; + o : IXtruct; + o2 : IXtruct2; + i : IXtruct; + i2 : IXtruct2; + mapout : IThriftDictionary<Integer,Integer>; + mapin : IThriftDictionary<Integer,Integer>; + strmapout : IThriftDictionary<string,string>; + strmapin : IThriftDictionary<string,string>; + j : Integer; + first : Boolean; + key : Integer; + strkey : string; + listout : IThriftList<Integer>; + listin : IThriftList<Integer>; + setout : IHashSet<Integer>; + setin : IHashSet<Integer>; + ret : TNumberz; + uid : Int64; + mm : IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>; + pos : IThriftDictionary<Integer, Integer>; + neg : IThriftDictionary<Integer, Integer>; + m2 : IThriftDictionary<Integer, Integer>; + k2 : Integer; + insane : IInsanity; + truck : IXtruct; + whoa : IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; + key64 : Int64; + val : IThriftDictionary<TNumberz, IInsanity>; + k2_2 : TNumberz; + k3 : TNumberz; + v2 : IInsanity; + userMap : IThriftDictionary<TNumberz, Int64>; + xtructs : IThriftList<IXtruct>; + x : IXtruct; + arg0 : ShortInt; + arg1 : Integer; + arg2 : Int64; + arg3 : IThriftDictionary<SmallInt, string>; + arg4 : TNumberz; + arg5 : Int64; + {$IFDEF PerfTest} + StartTick : Cardinal; + k : Integer; + {$ENDIF} + hello, goodbye : IXtruct; + crazy : IInsanity; + looney : IInsanity; + first_map : IThriftDictionary<TNumberz, IInsanity>; + second_map : IThriftDictionary<TNumberz, IInsanity>; + pair : TPair<TNumberz, TUserId>; + testsize : TTestSize; +begin + client := TThriftTest.TClient.Create( FProtocol); + FTransport.Open; + + {$IFDEF StressTest} + StressTest( client); + {$ENDIF StressTest} + + {$IFDEF Exceptions} + // in-depth exception test + // (1) do we get an exception at all? + // (2) do we get the right exception? + // (3) does the exception contain the expected data? + StartTestGroup( 'testException', test_Exceptions); + // case 1: exception type declared in IDL at the function call + try + client.testException('Xception'); + Expect( FALSE, 'testException(''Xception''): must trow an exception'); + except + on e:TXception do begin + Expect( e.ErrorCode = 1001, 'error code'); + Expect( e.Message_ = 'Xception', 'error message'); + Console.WriteLine( ' = ' + IntToStr(e.ErrorCode) + ', ' + e.Message_ ); + end; + on e:TTransportException do Expect( FALSE, 'Unexpected : "'+e.ToString+'"'); + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + // case 2: exception type NOT declared in IDL at the function call + // this will close the connection + try + client.testException('TException'); + Expect( FALSE, 'testException(''TException''): must trow an exception'); + except + on e:TTransportException do begin + Console.WriteLine( e.ClassName+' = '+e.Message); // this is what we get + end; + on e:TApplicationException do begin + Console.WriteLine( e.ClassName+' = '+e.Message); // this is what we get + end; + on e:TException do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + + if FTransport.IsOpen then FTransport.Close; + FTransport.Open; // re-open connection, server has already closed + + + // case 3: no exception + try + client.testException('something'); + Expect( TRUE, 'testException(''something''): must not trow an exception'); + except + on e:TTransportException do Expect( FALSE, 'Unexpected : "'+e.ToString+'"'); + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + {$ENDIF Exceptions} + + + // simple things + StartTestGroup( 'simple Thrift calls', test_BaseTypes); + client.testVoid(); + Expect( TRUE, 'testVoid()'); // success := no exception + + s := BoolToString( client.testBool(TRUE)); + Expect( s = BoolToString(TRUE), 'testBool(TRUE) = '+s); + s := BoolToString( client.testBool(FALSE)); + Expect( s = BoolToString(FALSE), 'testBool(FALSE) = '+s); + + s := client.testString('Test'); + Expect( s = 'Test', 'testString(''Test'') = "'+s+'"'); + + s := client.testString(''); // empty string + Expect( s = '', 'testString('''') = "'+s+'"'); + + s := client.testString(HUGE_TEST_STRING); + Expect( length(s) = length(HUGE_TEST_STRING), + 'testString( length(HUGE_TEST_STRING) = '+IntToStr(Length(HUGE_TEST_STRING))+') ' + +'=> length(result) = '+IntToStr(Length(s))); + + i8 := client.testByte(1); + Expect( i8 = 1, 'testByte(1) = ' + IntToStr( i8 )); + + i32 := client.testI32(-1); + Expect( i32 = -1, 'testI32(-1) = ' + IntToStr(i32)); + + Console.WriteLine('testI64(-34359738368)'); + i64 := client.testI64(-34359738368); + Expect( i64 = -34359738368, 'testI64(-34359738368) = ' + IntToStr( i64)); + + // random binary small + for testsize := Low(TTestSize) to High(TTestSize) do begin + binOut := PrepareBinaryData( TRUE, testsize); + Console.WriteLine('testBinary('+IntToStr(Length(binOut))+' bytes)'); + try + binIn := client.testBinary(binOut); + Expect( Length(binOut) = Length(binIn), 'testBinary('+IntToStr(Length(binOut))+' bytes): '+IntToStr(Length(binIn))+' bytes received'); + i32 := Min( Length(binOut), Length(binIn)); + Expect( CompareMem( binOut, binIn, i32), 'testBinary('+IntToStr(Length(binOut))+' bytes): validating received data'); + except + on e:TApplicationException do Console.WriteLine('testBinary(): '+e.Message); + on e:Exception do Expect( FALSE, 'testBinary(): Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + end; + + Console.WriteLine('testDouble(5.325098235)'); + dub := client.testDouble(5.325098235); + Expect( abs(dub-5.325098235) < 1e-14, 'testDouble(5.325098235) = ' + FloatToStr( dub)); + + // structs + StartTestGroup( 'testStruct', test_Structs); + Console.WriteLine('testStruct({''Zero'', 1, -3, -5})'); + o := TXtructImpl.Create; + o.String_thing := 'Zero'; + o.Byte_thing := 1; + o.I32_thing := -3; + o.I64_thing := -5; + i := client.testStruct(o); + Expect( i.String_thing = 'Zero', 'i.String_thing = "'+i.String_thing+'"'); + Expect( i.Byte_thing = 1, 'i.Byte_thing = '+IntToStr(i.Byte_thing)); + Expect( i.I32_thing = -3, 'i.I32_thing = '+IntToStr(i.I32_thing)); + Expect( i.I64_thing = -5, 'i.I64_thing = '+IntToStr(i.I64_thing)); + Expect( i.__isset_String_thing, 'i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + Expect( i.__isset_Byte_thing, 'i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( i.__isset_I32_thing, 'i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( i.__isset_I64_thing, 'i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + + // nested structs + StartTestGroup( 'testNest', test_Structs); + Console.WriteLine('testNest({1, {''Zero'', 1, -3, -5}, 5})'); + o2 := TXtruct2Impl.Create; + o2.Byte_thing := 1; + o2.Struct_thing := o; + o2.I32_thing := 5; + i2 := client.testNest(o2); + i := i2.Struct_thing; + Expect( i.String_thing = 'Zero', 'i.String_thing = "'+i.String_thing+'"'); + Expect( i.Byte_thing = 1, 'i.Byte_thing = '+IntToStr(i.Byte_thing)); + Expect( i.I32_thing = -3, 'i.I32_thing = '+IntToStr(i.I32_thing)); + Expect( i.I64_thing = -5, 'i.I64_thing = '+IntToStr(i.I64_thing)); + Expect( i2.Byte_thing = 1, 'i2.Byte_thing = '+IntToStr(i2.Byte_thing)); + Expect( i2.I32_thing = 5, 'i2.I32_thing = '+IntToStr(i2.I32_thing)); + Expect( i.__isset_String_thing, 'i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + Expect( i.__isset_Byte_thing, 'i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( i.__isset_I32_thing, 'i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( i.__isset_I64_thing, 'i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + Expect( i2.__isset_Byte_thing, 'i2.__isset_Byte_thing'); + Expect( i2.__isset_I32_thing, 'i2.__isset_I32_thing'); + + // map<type1,type2>: A map of strictly unique keys to values. + // Translates to an STL map, Java HashMap, PHP associative array, Python/Ruby dictionary, etc. + StartTestGroup( 'testMap', test_Containers); + mapout := TThriftDictionaryImpl<Integer,Integer>.Create; + for j := 0 to 4 do + begin + mapout.AddOrSetValue( j, j - 10); + end; + Console.Write('testMap({'); + first := True; + for key in mapout.Keys do + begin + if first + then first := False + else Console.Write( ', ' ); + Console.Write( IntToStr( key) + ' => ' + IntToStr( mapout[key])); + end; + Console.WriteLine('})'); + + mapin := client.testMap( mapout ); + Expect( mapin.Count = mapout.Count, 'testMap: mapin.Count = mapout.Count'); + for j := 0 to 4 do + begin + Expect( mapout.ContainsKey(j), 'testMap: mapout.ContainsKey('+IntToStr(j)+') = '+BoolToString(mapout.ContainsKey(j))); + end; + for key in mapin.Keys do + begin + Expect( mapin[key] = mapout[key], 'testMap: '+IntToStr(key) + ' => ' + IntToStr( mapin[key])); + Expect( mapin[key] = key - 10, 'testMap: mapin['+IntToStr(key)+'] = '+IntToStr( mapin[key])); + end; + + + // map<type1,type2>: A map of strictly unique keys to values. + // Translates to an STL map, Java HashMap, PHP associative array, Python/Ruby dictionary, etc. + StartTestGroup( 'testStringMap', test_Containers); + strmapout := TThriftDictionaryImpl<string,string>.Create; + for j := 0 to 4 do + begin + strmapout.AddOrSetValue( IntToStr(j), IntToStr(j - 10)); + end; + Console.Write('testStringMap({'); + first := True; + for strkey in strmapout.Keys do + begin + if first + then first := False + else Console.Write( ', ' ); + Console.Write( strkey + ' => ' + strmapout[strkey]); + end; + Console.WriteLine('})'); + + strmapin := client.testStringMap( strmapout ); + Expect( strmapin.Count = strmapout.Count, 'testStringMap: strmapin.Count = strmapout.Count'); + for j := 0 to 4 do + begin + Expect( strmapout.ContainsKey(IntToStr(j)), + 'testStringMap: strmapout.ContainsKey('+IntToStr(j)+') = ' + + BoolToString(strmapout.ContainsKey(IntToStr(j)))); + end; + for strkey in strmapin.Keys do + begin + Expect( strmapin[strkey] = strmapout[strkey], 'testStringMap: '+strkey + ' => ' + strmapin[strkey]); + Expect( strmapin[strkey] = IntToStr( StrToInt(strkey) - 10), 'testStringMap: strmapin['+strkey+'] = '+strmapin[strkey]); + end; + + + // set<type>: An unordered set of unique elements. + // Translates to an STL set, Java HashSet, set in Python, etc. + // Note: PHP does not support sets, so it is treated similar to a List + StartTestGroup( 'testSet', test_Containers); + setout := THashSetImpl<Integer>.Create; + for j := -2 to 2 do + begin + setout.Add( j ); + end; + Console.Write('testSet({'); + first := True; + for j in setout do + begin + if first + then first := False + else Console.Write(', '); + Console.Write(IntToStr( j)); + end; + Console.WriteLine('})'); + + setin := client.testSet(setout); + Expect( setin.Count = setout.Count, 'testSet: setin.Count = setout.Count'); + Expect( setin.Count = 5, 'testSet: setin.Count = '+IntToStr(setin.Count)); + for j := -2 to 2 do // unordered, we can't rely on the order => test for known elements only + begin + Expect( setin.Contains(j), 'testSet: setin.Contains('+IntToStr(j)+') => '+BoolToString(setin.Contains(j))); + end; + + // list<type>: An ordered list of elements. + // Translates to an STL vector, Java ArrayList, native arrays in scripting languages, etc. + StartTestGroup( 'testList', test_Containers); + listout := TThriftListImpl<Integer>.Create; + listout.Add( +1); + listout.Add( -2); + listout.Add( +3); + listout.Add( -4); + listout.Add( 0); + Console.Write('testList({'); + first := True; + for j in listout do + begin + if first + then first := False + else Console.Write(', '); + Console.Write(IntToStr( j)); + end; + Console.WriteLine('})'); + + listin := client.testList(listout); + Expect( listin.Count = listout.Count, 'testList: listin.Count = listout.Count'); + Expect( listin.Count = 5, 'testList: listin.Count = '+IntToStr(listin.Count)); + Expect( listin[0] = +1, 'listin[0] = '+IntToStr( listin[0])); + Expect( listin[1] = -2, 'listin[1] = '+IntToStr( listin[1])); + Expect( listin[2] = +3, 'listin[2] = '+IntToStr( listin[2])); + Expect( listin[3] = -4, 'listin[3] = '+IntToStr( listin[3])); + Expect( listin[4] = 0, 'listin[4] = '+IntToStr( listin[4])); + + // enums + ret := client.testEnum(TNumberz.ONE); + Expect( ret = TNumberz.ONE, 'testEnum(ONE) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.TWO); + Expect( ret = TNumberz.TWO, 'testEnum(TWO) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.THREE); + Expect( ret = TNumberz.THREE, 'testEnum(THREE) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.FIVE); + Expect( ret = TNumberz.FIVE, 'testEnum(FIVE) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.EIGHT); + Expect( ret = TNumberz.EIGHT, 'testEnum(EIGHT) = '+IntToStr(Ord(ret))); + + + // typedef + uid := client.testTypedef(309858235082523); + Expect( uid = 309858235082523, 'testTypedef(309858235082523) = '+IntToStr(uid)); + + + // maps of maps + StartTestGroup( 'testMapMap(1)', test_Containers); + mm := client.testMapMap(1); + Console.Write(' = {'); + for key in mm.Keys do + begin + Console.Write( IntToStr( key) + ' => {'); + m2 := mm[key]; + for k2 in m2.Keys do + begin + Console.Write( IntToStr( k2) + ' => ' + IntToStr( m2[k2]) + ', '); + end; + Console.Write('}, '); + end; + Console.WriteLine('}'); + + // verify result data + Expect( mm.Count = 2, 'mm.Count = '+IntToStr(mm.Count)); + pos := mm[4]; + neg := mm[-4]; + for j := 1 to 4 do + begin + Expect( pos[j] = j, 'pos[j] = '+IntToStr(pos[j])); + Expect( neg[-j] = -j, 'neg[-j] = '+IntToStr(neg[-j])); + end; + + + + // insanity + StartTestGroup( 'testInsanity', test_Structs); + insane := TInsanityImpl.Create; + insane.UserMap := TThriftDictionaryImpl<TNumberz, Int64>.Create; + insane.UserMap.AddOrSetValue( TNumberz.FIVE, 5000); + truck := TXtructImpl.Create; + truck.String_thing := 'Truck'; + truck.Byte_thing := -8; // byte is signed + truck.I32_thing := 32; + truck.I64_thing := 64; + insane.Xtructs := TThriftListImpl<IXtruct>.Create; + insane.Xtructs.Add( truck ); + whoa := client.testInsanity( insane ); + Console.Write(' = {'); + for key64 in whoa.Keys do + begin + val := whoa[key64]; + Console.Write( IntToStr( key64) + ' => {'); + for k2_2 in val.Keys do + begin + v2 := val[k2_2]; + Console.Write( IntToStr( Integer( k2_2)) + ' => {'); + userMap := v2.UserMap; + Console.Write('{'); + if userMap <> nil then + begin + for k3 in userMap.Keys do + begin + Console.Write( IntToStr( Integer( k3)) + ' => ' + IntToStr( userMap[k3]) + ', '); + end; + end else + begin + Console.Write('null'); + end; + Console.Write('}, '); + xtructs := v2.Xtructs; + Console.Write('{'); + + if xtructs <> nil then + begin + for x in xtructs do + begin + Console.Write('{"' + x.String_thing + '", ' + + IntToStr( x.Byte_thing) + ', ' + + IntToStr( x.I32_thing) + ', ' + + IntToStr( x.I32_thing) + '}, '); + end; + end else + begin + Console.Write('null'); + end; + Console.Write('}'); + Console.Write('}, '); + end; + Console.Write('}, '); + end; + Console.WriteLine('}'); + + (** + * So you think you've got this all worked, out eh? + * + * Creates a the returned map with these values and prints it out: + * { 1 => { 2 => argument, + * 3 => argument, + * }, + * 2 => { 6 => <empty Insanity struct>, }, + * } + * @return map<UserId, map<Numberz,Insanity>> - a map with the above values + *) + + // verify result data + Expect( whoa.Count = 2, 'whoa.Count = '+IntToStr(whoa.Count)); + // + first_map := whoa[1]; + second_map := whoa[2]; + Expect( first_map.Count = 2, 'first_map.Count = '+IntToStr(first_map.Count)); + Expect( second_map.Count = 1, 'second_map.Count = '+IntToStr(second_map.Count)); + // + looney := second_map[TNumberz.SIX]; + Expect( Assigned(looney), 'Assigned(looney) = '+BoolToString(Assigned(looney))); + Expect( not looney.__isset_UserMap, 'looney.__isset_UserMap = '+BoolToString(looney.__isset_UserMap)); + Expect( not looney.__isset_Xtructs, 'looney.__isset_Xtructs = '+BoolToString(looney.__isset_Xtructs)); + // + for ret in [TNumberz.TWO, TNumberz.THREE] do begin + crazy := first_map[ret]; + Console.WriteLine('first_map['+intToStr(Ord(ret))+']'); + + Expect( crazy.__isset_UserMap, 'crazy.__isset_UserMap = '+BoolToString(crazy.__isset_UserMap)); + Expect( crazy.__isset_Xtructs, 'crazy.__isset_Xtructs = '+BoolToString(crazy.__isset_Xtructs)); + + Expect( crazy.UserMap.Count = insane.UserMap.Count, 'crazy.UserMap.Count = '+IntToStr(crazy.UserMap.Count)); + for pair in insane.UserMap do begin + Expect( crazy.UserMap[pair.Key] = pair.Value, 'crazy.UserMap['+IntToStr(Ord(pair.key))+'] = '+IntToStr(crazy.UserMap[pair.Key])); + end; + + Expect( crazy.Xtructs.Count = insane.Xtructs.Count, 'crazy.Xtructs.Count = '+IntToStr(crazy.Xtructs.Count)); + for arg0 := 0 to insane.Xtructs.Count-1 do begin + hello := insane.Xtructs[arg0]; + goodbye := crazy.Xtructs[arg0]; + Expect( goodbye.String_thing = hello.String_thing, 'goodbye.String_thing = '+goodbye.String_thing); + Expect( goodbye.Byte_thing = hello.Byte_thing, 'goodbye.Byte_thing = '+IntToStr(goodbye.Byte_thing)); + Expect( goodbye.I32_thing = hello.I32_thing, 'goodbye.I32_thing = '+IntToStr(goodbye.I32_thing)); + Expect( goodbye.I64_thing = hello.I64_thing, 'goodbye.I64_thing = '+IntToStr(goodbye.I64_thing)); + end; + end; + + + // multi args + StartTestGroup( 'testMulti', test_BaseTypes); + arg0 := 1; + arg1 := 2; + arg2 := High(Int64); + arg3 := TThriftDictionaryImpl<SmallInt, string>.Create; + arg3.AddOrSetValue( 1, 'one'); + arg4 := TNumberz.FIVE; + arg5 := 5000000; + Console.WriteLine('Test Multi(' + IntToStr( arg0) + ',' + + IntToStr( arg1) + ',' + IntToStr( arg2) + ',' + + arg3.ToString + ',' + IntToStr( Integer( arg4)) + ',' + + IntToStr( arg5) + ')'); + + i := client.testMulti( arg0, arg1, arg2, arg3, arg4, arg5); + Expect( i.String_thing = 'Hello2', 'testMulti: i.String_thing = "'+i.String_thing+'"'); + Expect( i.Byte_thing = arg0, 'testMulti: i.Byte_thing = '+IntToStr(i.Byte_thing)); + Expect( i.I32_thing = arg1, 'testMulti: i.I32_thing = '+IntToStr(i.I32_thing)); + Expect( i.I64_thing = arg2, 'testMulti: i.I64_thing = '+IntToStr(i.I64_thing)); + Expect( i.__isset_String_thing, 'testMulti: i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + Expect( i.__isset_Byte_thing, 'testMulti: i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( i.__isset_I32_thing, 'testMulti: i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( i.__isset_I64_thing, 'testMulti: i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + + // multi exception + StartTestGroup( 'testMultiException(1)', test_Exceptions); + try + i := client.testMultiException( 'need more pizza', 'run out of beer'); + Expect( i.String_thing = 'run out of beer', 'i.String_thing = "' +i.String_thing+ '"'); + Expect( i.__isset_String_thing, 'i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + { this is not necessarily true, these fields are default-serialized + Expect( not i.__isset_Byte_thing, 'i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( not i.__isset_I32_thing, 'i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( not i.__isset_I64_thing, 'i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + } + except + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + StartTestGroup( 'testMultiException(Xception)', test_Exceptions); + try + i := client.testMultiException( 'Xception', 'second test'); + Expect( FALSE, 'testMultiException(''Xception''): must trow an exception'); + except + on x:TXception do begin + Expect( x.__isset_ErrorCode, 'x.__isset_ErrorCode = '+BoolToString(x.__isset_ErrorCode)); + Expect( x.__isset_Message_, 'x.__isset_Message_ = '+BoolToString(x.__isset_Message_)); + Expect( x.ErrorCode = 1001, 'x.ErrorCode = '+IntToStr(x.ErrorCode)); + Expect( x.Message_ = 'This is an Xception', 'x.Message = "'+x.Message_+'"'); + end; + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + StartTestGroup( 'testMultiException(Xception2)', test_Exceptions); + try + i := client.testMultiException( 'Xception2', 'third test'); + Expect( FALSE, 'testMultiException(''Xception2''): must trow an exception'); + except + on x:TXception2 do begin + Expect( x.__isset_ErrorCode, 'x.__isset_ErrorCode = '+BoolToString(x.__isset_ErrorCode)); + Expect( x.__isset_Struct_thing, 'x.__isset_Struct_thing = '+BoolToString(x.__isset_Struct_thing)); + Expect( x.ErrorCode = 2002, 'x.ErrorCode = '+IntToStr(x.ErrorCode)); + Expect( x.Struct_thing.String_thing = 'This is an Xception2', 'x.Struct_thing.String_thing = "'+x.Struct_thing.String_thing+'"'); + Expect( x.Struct_thing.__isset_String_thing, 'x.Struct_thing.__isset_String_thing = '+BoolToString(x.Struct_thing.__isset_String_thing)); + { this is not necessarily true, these fields are default-serialized + Expect( not x.Struct_thing.__isset_Byte_thing, 'x.Struct_thing.__isset_Byte_thing = '+BoolToString(x.Struct_thing.__isset_Byte_thing)); + Expect( not x.Struct_thing.__isset_I32_thing, 'x.Struct_thing.__isset_I32_thing = '+BoolToString(x.Struct_thing.__isset_I32_thing)); + Expect( not x.Struct_thing.__isset_I64_thing, 'x.Struct_thing.__isset_I64_thing = '+BoolToString(x.Struct_thing.__isset_I64_thing)); + } + end; + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + + // oneway functions + StartTestGroup( 'Test Oneway(1)', test_Unknown); + client.testOneway(1); + Expect( TRUE, 'Test Oneway(1)'); // success := no exception + + // call time + {$IFDEF PerfTest} + StartTestGroup( 'Test Calltime()'); + StartTick := GetTickCount; + for k := 0 to 1000 - 1 do + begin + client.testVoid(); + end; + Console.WriteLine(' = ' + FloatToStr( (GetTickCount - StartTick) / 1000 ) + ' ms a testVoid() call' ); + {$ENDIF PerfTest} + + // no more tests here + StartTestGroup( '', test_Unknown); +end; + + +{$IFDEF SupportsAsync} +procedure TClientThread.ClientAsyncTest; +var + client : TThriftTest.IAsync; + s : string; + i8 : ShortInt; +begin + StartTestGroup( 'Async Tests', test_Unknown); + client := TThriftTest.TClient.Create( FProtocol); + FTransport.Open; + + // oneway void functions + client.testOnewayAsync(1).Wait; + Expect( TRUE, 'Test Oneway(1)'); // success := no exception + + // normal functions + s := client.testStringAsync(HUGE_TEST_STRING).Value; + Expect( length(s) = length(HUGE_TEST_STRING), + 'testString( length(HUGE_TEST_STRING) = '+IntToStr(Length(HUGE_TEST_STRING))+') ' + +'=> length(result) = '+IntToStr(Length(s))); + + i8 := client.testByte(1).Value; + Expect( i8 = 1, 'testByte(1) = ' + IntToStr( i8 )); +end; +{$ENDIF} + + +{$IFDEF StressTest} +procedure TClientThread.StressTest(const client : TThriftTest.Iface); +begin + while TRUE do begin + try + if not FTransport.IsOpen then FTransport.Open; // re-open connection, server has already closed + try + client.testString('Test'); + Write('.'); + finally + if FTransport.IsOpen then FTransport.Close; + end; + except + on e:Exception do Writeln(#10+e.message); + end; + end; +end; +{$ENDIF} + + +function TClientThread.PrepareBinaryData( aRandomDist : Boolean; aSize : TTestSize) : TBytes; +var i : Integer; +begin + case aSize of + Empty : SetLength( result, 0); + Normal : SetLength( result, $100); + ByteArrayTest : SetLength( result, SizeOf(TByteArray) + 128); + PipeWriteLimit : SetLength( result, 65535 + 128); + TwentyMB : SetLength( result, 20 * 1024 * 1024); + else + raise EArgumentException.Create('aSize'); + end; + + ASSERT( Low(result) = 0); + if Length(result) = 0 then Exit; + + // linear distribution, unless random is requested + if not aRandomDist then begin + for i := Low(result) to High(result) do begin + result[i] := i mod $100; + end; + Exit; + end; + + // random distribution of all 256 values + FillChar( result[0], Length(result) * SizeOf(result[0]), $0); + for i := Low(result) to High(result) do begin + result[i] := Byte( Random($100)); + end; +end; + + +{$IFDEF Win64} +procedure TClientThread.UseInterlockedExchangeAdd64; +var a,b : Int64; +begin + a := 1; + b := 2; + Thrift.Utils.InterlockedExchangeAdd64( a,b); + Expect( a = 3, 'InterlockedExchangeAdd64'); +end; +{$ENDIF} + + +procedure TClientThread.JSONProtocolReadWriteTest; +// Tests only then read/write procedures of the JSON protocol +// All tests succeed, if we can read what we wrote before +// Note that passing this test does not imply, that our JSON is really compatible to what +// other clients or servers expect as the real JSON. This is beyond the scope of this test. +var prot : IProtocol; + stm : TStringStream; + list : TThriftList; + binary, binRead, emptyBinary : TBytes; + i,iErr : Integer; +const + TEST_SHORT = ShortInt( $FE); + TEST_SMALL = SmallInt( $FEDC); + TEST_LONG = LongInt( $FEDCBA98); + TEST_I64 = Int64( $FEDCBA9876543210); + TEST_DOUBLE = -1.234e-56; + DELTA_DOUBLE = TEST_DOUBLE * 1e-14; + TEST_STRING = 'abc-'#$00E4#$00f6#$00fc; // german umlauts (en-us: "funny chars") + // Test THRIFT-2336 and THRIFT-3404 with U+1D11E (G Clef symbol) and 'Русское Название'; + G_CLEF_AND_CYRILLIC_TEXT = #$1d11e' '#$0420#$0443#$0441#$0441#$043a#$043e#$0435' '#$041d#$0430#$0437#$0432#$0430#$043d#$0438#$0435; + G_CLEF_AND_CYRILLIC_JSON = '"\ud834\udd1e \u0420\u0443\u0441\u0441\u043a\u043e\u0435 \u041d\u0430\u0437\u0432\u0430\u043d\u0438\u0435"'; + // test both possible solidus encodings + SOLIDUS_JSON_DATA = '"one/two\/three"'; + SOLIDUS_EXCPECTED = 'one/two/three'; +begin + stm := TStringStream.Create; + try + StartTestGroup( 'JsonProtocolTest', test_Unknown); + + // prepare binary data + binary := PrepareBinaryData( FALSE, Normal); + SetLength( emptyBinary, 0); // empty binary data block + + // output setup + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + nil, TThriftStreamAdapterDelphi.Create( stm, FALSE))); + + // write + Init( list, TType.String_, 9); + prot.WriteListBegin( list); + prot.WriteBool( TRUE); + prot.WriteBool( FALSE); + prot.WriteByte( TEST_SHORT); + prot.WriteI16( TEST_SMALL); + prot.WriteI32( TEST_LONG); + prot.WriteI64( TEST_I64); + prot.WriteDouble( TEST_DOUBLE); + prot.WriteString( TEST_STRING); + prot.WriteBinary( binary); + prot.WriteString( ''); // empty string + prot.WriteBinary( emptyBinary); // empty binary data block + prot.WriteListEnd; + + // input setup + Expect( stm.Position = stm.Size, 'Stream position/length after write'); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + + // read and compare + list := prot.ReadListBegin; + Expect( list.ElementType = TType.String_, 'list element type'); + Expect( list.Count = 9, 'list element count'); + Expect( prot.ReadBool, 'WriteBool/ReadBool: TRUE'); + Expect( not prot.ReadBool, 'WriteBool/ReadBool: FALSE'); + Expect( prot.ReadByte = TEST_SHORT, 'WriteByte/ReadByte'); + Expect( prot.ReadI16 = TEST_SMALL, 'WriteI16/ReadI16'); + Expect( prot.ReadI32 = TEST_LONG, 'WriteI32/ReadI32'); + Expect( prot.ReadI64 = TEST_I64, 'WriteI64/ReadI64'); + Expect( abs(prot.ReadDouble-TEST_DOUBLE) < abs(DELTA_DOUBLE), 'WriteDouble/ReadDouble'); + Expect( prot.ReadString = TEST_STRING, 'WriteString/ReadString'); + binRead := prot.ReadBinary; + Expect( Length(prot.ReadString) = 0, 'WriteString/ReadString (empty string)'); + Expect( Length(prot.ReadBinary) = 0, 'empty WriteBinary/ReadBinary (empty data block)'); + prot.ReadListEnd; + + // test binary data + Expect( Length(binary) = Length(binRead), 'Binary data length check'); + iErr := -1; + for i := Low(binary) to High(binary) do begin + if binary[i] <> binRead[i] then begin + iErr := i; + Break; + end; + end; + if iErr < 0 + then Expect( TRUE, 'Binary data check ('+IntToStr(Length(binary))+' Bytes)') + else Expect( FALSE, 'Binary data check at offset '+IntToStr(iErr)); + + Expect( stm.Position = stm.Size, 'Stream position after read'); + + + // Solidus can be encoded in two ways. Make sure we can read both + stm.Position := 0; + stm.Size := 0; + stm.WriteString(SOLIDUS_JSON_DATA); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + Expect( prot.ReadString = SOLIDUS_EXCPECTED, 'Solidus encoding'); + + + // Widechars should work too. Do they? + // After writing, we ensure that we are able to read it back + // We can't assume hex-encoding, since (nearly) any Unicode char is valid JSON + stm.Position := 0; + stm.Size := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + nil, TThriftStreamAdapterDelphi.Create( stm, FALSE))); + prot.WriteString( G_CLEF_AND_CYRILLIC_TEXT); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + Expect( prot.ReadString = G_CLEF_AND_CYRILLIC_TEXT, 'Writing JSON with chars > 8 bit'); + + // Widechars should work with hex-encoding too. Do they? + stm.Position := 0; + stm.Size := 0; + stm.WriteString( G_CLEF_AND_CYRILLIC_JSON); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + Expect( prot.ReadString = G_CLEF_AND_CYRILLIC_TEXT, 'Reading JSON with chars > 8 bit'); + + + finally + stm.Free; + prot := nil; //-> Release + StartTestGroup( '', test_Unknown); // no more tests here + end; +end; + + +procedure TClientThread.StartTestGroup( const aGroup : string; const aTest : TTestGroup); +begin + FTestGroup := aGroup; + FCurrentTest := aTest; + + Include( FExecuted, aTest); + + if FTestGroup <> '' then begin + Console.WriteLine(''); + Console.WriteLine( aGroup+' tests'); + Console.WriteLine( StringOfChar('-',60)); + end; +end; + + +procedure TClientThread.Expect( aTestResult : Boolean; const aTestInfo : string); +begin + if aTestResult then begin + Inc(FSuccesses); + Console.WriteLine( aTestInfo+': passed'); + end + else begin + FErrors.Add( FTestGroup+': '+aTestInfo); + Include( FFailed, FCurrentTest); + Console.WriteLine( aTestInfo+': *** FAILED ***'); + + // We have a failed test! + // -> issue DebugBreak ONLY if a debugger is attached, + // -> unhandled DebugBreaks would cause Windows to terminate the app otherwise + if IsDebuggerPresent + then {$IFDEF CPUX64} DebugBreak {$ELSE} asm int 3 end {$ENDIF}; + end; +end; + + +procedure TClientThread.ReportResults; +var nTotal : Integer; + sLine : string; +begin + // prevent us from stupid DIV/0 errors + nTotal := FSuccesses + FErrors.Count; + if nTotal = 0 then begin + Console.WriteLine('No results logged'); + Exit; + end; + + Console.WriteLine(''); + Console.WriteLine( StringOfChar('=',60)); + Console.WriteLine( IntToStr(nTotal)+' tests performed'); + Console.WriteLine( IntToStr(FSuccesses)+' tests succeeded ('+IntToStr(round(100*FSuccesses/nTotal))+'%)'); + Console.WriteLine( IntToStr(FErrors.Count)+' tests failed ('+IntToStr(round(100*FErrors.Count/nTotal))+'%)'); + Console.WriteLine( StringOfChar('=',60)); + if FErrors.Count > 0 then begin + Console.WriteLine('FAILED TESTS:'); + for sLine in FErrors do Console.WriteLine('- '+sLine); + Console.WriteLine( StringOfChar('=',60)); + InterlockedIncrement( ExitCode); // return <> 0 on errors + end; + Console.WriteLine(''); +end; + + +function TClientThread.CalculateExitCode : Byte; +var test : TTestGroup; +begin + result := EXITCODE_SUCCESS; + for test := Low(TTestGroup) to High(TTestGroup) do begin + if (test in FFailed) or not (test in FExecuted) + then result := result or MAP_FAILURES_TO_EXITCODE_BITS[test]; + end; +end; + + +constructor TClientThread.Create( const aSetup : TTestSetup; const aNumIteration: Integer); +begin + FSetup := aSetup; + FNumIteration := ANumIteration; + + FConsole := TThreadConsole.Create( Self ); + FCurrentTest := test_Unknown; + + // error list: keep correct order, allow for duplicates + FErrors := TStringList.Create; + FErrors.Sorted := FALSE; + FErrors.Duplicates := dupAccept; + + inherited Create( TRUE); +end; + +destructor TClientThread.Destroy; +begin + FreeAndNil( FConsole); + FreeAndNil( FErrors); + inherited; +end; + +procedure TClientThread.Execute; +var + i : Integer; +begin + // perform all tests + try + {$IFDEF Win64} + UseInterlockedExchangeAdd64; + {$ENDIF} + JSONProtocolReadWriteTest; + + // must be run in the context of the thread + InitializeProtocolTransportStack; + try + for i := 0 to FNumIteration - 1 do begin + ClientTest; + {$IFDEF SupportsAsync} + ClientAsyncTest; + {$ENDIF} + end; + + // report the outcome + ReportResults; + SetReturnValue( CalculateExitCode); + + finally + ShutdownProtocolTransportStack; + end; + + except + on e:Exception do Expect( FALSE, 'unexpected exception: "'+e.message+'"'); + end; +end; + + +function TClientThread.InitializeHttpTransport( const aTimeoutSetting : Integer) : IHTTPClient; +var sUrl : string; + comps : URL_COMPONENTS; + dwChars : DWORD; +begin + ASSERT( FSetup.endpoint in [trns_MsxmlHttp, trns_WinHttp]); + + if FSetup.useSSL + then sUrl := 'https://' + else sUrl := 'http://'; + + sUrl := sUrl + FSetup.host; + + // add the port number if necessary and at the right place + FillChar( comps, SizeOf(comps), 0); + comps.dwStructSize := SizeOf(comps); + comps.dwSchemeLength := MAXINT; + comps.dwHostNameLength := MAXINT; + comps.dwUserNameLength := MAXINT; + comps.dwPasswordLength := MAXINT; + comps.dwUrlPathLength := MAXINT; + comps.dwExtraInfoLength := MAXINT; + Win32Check( WinHttpCrackUrl( PChar(sUrl), Length(sUrl), 0, comps)); + case FSetup.port of + 80 : if FSetup.useSSL then comps.nPort := FSetup.port; + 443 : if not FSetup.useSSL then comps.nPort := FSetup.port; + else + if FSetup.port > 0 then comps.nPort := FSetup.port; + end; + dwChars := Length(sUrl) + 64; + SetLength( sUrl, dwChars); + Win32Check( WinHttpCreateUrl( comps, 0, @sUrl[1], dwChars)); + SetLength( sUrl, dwChars); + + + Console.WriteLine('Target URL: '+sUrl); + case FSetup.endpoint of + trns_MsxmlHttp : result := TMsxmlHTTPClientImpl.Create( sUrl); + trns_WinHttp : result := TWinHTTPClientImpl.Create( sUrl); + else + raise Exception.Create(ENDPOINT_TRANSPORTS[FSetup.endpoint]+' unhandled case'); + end; + + result.DnsResolveTimeout := aTimeoutSetting; + result.ConnectionTimeout := aTimeoutSetting; + result.SendTimeout := aTimeoutSetting; + result.ReadTimeout := aTimeoutSetting; +end; + + +procedure TClientThread.InitializeProtocolTransportStack; +var streamtrans : IStreamTransport; + canSSL : Boolean; +const + DEBUG_TIMEOUT = 30 * 1000; + RELEASE_TIMEOUT = DEFAULT_THRIFT_TIMEOUT; + PIPE_TIMEOUT = RELEASE_TIMEOUT; + HTTP_TIMEOUTS = 10 * 1000; +begin + // needed for HTTP clients as they utilize the MSXML COM components + OleCheck( CoInitialize( nil)); + + canSSL := FALSE; + case FSetup.endpoint of + trns_Sockets: begin + Console.WriteLine('Using sockets ('+FSetup.host+' port '+IntToStr(FSetup.port)+')'); + streamtrans := TSocketImpl.Create( FSetup.host, FSetup.port ); + FTransport := streamtrans; + end; + + trns_MsxmlHttp, + trns_WinHttp: begin + Console.WriteLine('Using HTTPClient'); + FTransport := InitializeHttpTransport( HTTP_TIMEOUTS); + canSSL := TRUE; + end; + + trns_EvHttp: begin + raise Exception.Create(ENDPOINT_TRANSPORTS[FSetup.endpoint]+' transport not implemented'); + end; + + trns_NamedPipes: begin + streamtrans := TNamedPipeTransportClientEndImpl.Create( FSetup.sPipeName, 0, nil, PIPE_TIMEOUT, PIPE_TIMEOUT); + FTransport := streamtrans; + end; + + trns_AnonPipes: begin + streamtrans := TAnonymousPipeTransportImpl.Create( FSetup.hAnonRead, FSetup.hAnonWrite, FALSE); + FTransport := streamtrans; + end; + + else + raise Exception.Create('Unhandled endpoint transport'); + end; + ASSERT( FTransport <> nil); + + // layered transports are not really meant to be stacked upon each other + if (trns_Framed in FSetup.layered) then begin + FTransport := TFramedTransportImpl.Create( FTransport); + end + else if (trns_Buffered in FSetup.layered) and (streamtrans <> nil) then begin + FTransport := TBufferedTransportImpl.Create( streamtrans, 32); // small buffer to test read() + end; + + if FSetup.useSSL and not canSSL then begin + raise Exception.Create('SSL/TLS not implemented'); + end; + + // create protocol instance, default to BinaryProtocol + case FSetup.protType of + prot_Binary : FProtocol := TBinaryProtocolImpl.Create( FTransport, BINARY_STRICT_READ, BINARY_STRICT_WRITE); + prot_JSON : FProtocol := TJSONProtocolImpl.Create( FTransport); + prot_Compact : FProtocol := TCompactProtocolImpl.Create( FTransport); + else + raise Exception.Create('Unhandled protocol'); + end; + + ASSERT( (FTransport <> nil) and (FProtocol <> nil)); +end; + + +procedure TClientThread.ShutdownProtocolTransportStack; +begin + try + FProtocol := nil; + + if FTransport <> nil then begin + FTransport.Close; + FTransport := nil; + end; + + finally + CoUninitialize; + end; +end; + + +{ TThreadConsole } + +constructor TThreadConsole.Create(AThread: TThread); +begin + inherited Create; + FThread := AThread; +end; + +procedure TThreadConsole.Write(const S: string); +var + proc : TThreadProcedure; +begin + proc := procedure + begin + Console.Write( S ); + end; + TThread.Synchronize( FThread, proc); +end; + +procedure TThreadConsole.WriteLine(const S: string); +var + proc : TThreadProcedure; +begin + proc := procedure + begin + Console.WriteLine( S ); + end; + TThread.Synchronize( FThread, proc); +end; + +initialization +begin + TTestClient.FNumIteration := 1; + TTestClient.FNumThread := 1; +end; + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestConstants.pas b/src/jaegertracing/thrift/lib/delphi/test/TestConstants.pas new file mode 100644 index 000000000..ae3b3e8a3 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestConstants.pas @@ -0,0 +1,164 @@ +(* + * 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 TestConstants; + +interface + +uses SysUtils; + +type + TKnownProtocol = ( + prot_Binary, // default binary protocol + prot_JSON, // JSON protocol + prot_Compact + ); + + TServerType = ( + srv_Simple, + srv_Nonblocking, + srv_Threadpool, + srv_Threaded + ); + + TEndpointTransport = ( + trns_Sockets, + trns_MsxmlHttp, + trns_WinHttp, + trns_NamedPipes, + trns_AnonPipes, + trns_EvHttp // as listed on http://thrift.apache.org/test + ); + + TLayeredTransport = ( + trns_None, + trns_Buffered, + trns_Framed + ); + + TLayeredTransports = set of TLayeredTransport; + +const + SERVER_TYPES : array[TServerType] of string + = ('Simple', 'Nonblocking', 'Threadpool', 'Threaded'); + + THRIFT_PROTOCOLS : array[TKnownProtocol] of string + = ('Binary', 'JSON', 'Compact'); + + LAYERED_TRANSPORTS : array[TLayeredTransport] of string + = ('None', 'Buffered', 'Framed'); + + ENDPOINT_TRANSPORTS : array[TEndpointTransport] of string + = ('Sockets', 'Http', 'WinHttp', 'Named Pipes','Anon Pipes', 'EvHttp'); + + // defaults are: read=false, write=true + BINARY_STRICT_READ = FALSE; + BINARY_STRICT_WRITE = FALSE; + + HUGE_TEST_STRING = 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. '; + + +function BytesToHex( const bytes : TBytes) : string; + + +implementation + + +function BytesToHex( const bytes : TBytes) : string; +var i : Integer; +begin + result := ''; + for i := Low(bytes) to High(bytes) do begin + result := result + IntToHex(bytes[i],2); + end; +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestServer.pas b/src/jaegertracing/thrift/lib/delphi/test/TestServer.pas new file mode 100644 index 000000000..2a80d52a7 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestServer.pas @@ -0,0 +1,684 @@ +(* + * 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 TestServer; + +{$I ../src/Thrift.Defines.inc} +{$WARN SYMBOL_PLATFORM OFF} + +{.$DEFINE RunEndless} // activate to interactively stress-test the server stop routines via Ctrl+C + +interface + +uses + Windows, SysUtils, + Generics.Collections, + Thrift.Server, + Thrift.Transport, + Thrift.Transport.Pipes, + Thrift.Protocol, + Thrift.Protocol.JSON, + Thrift.Protocol.Compact, + Thrift.Collections, + Thrift.Utils, + Thrift.Test, + Thrift, + TestConstants, + TestServerEvents, + ConsoleHelper, + Contnrs; + +type + TTestServer = class + public + type + + ITestHandler = interface( TThriftTest.Iface ) + procedure SetServer( const AServer : IServer ); + procedure TestStop; + end; + + TTestHandlerImpl = class( TInterfacedObject, ITestHandler ) + private + FServer : IServer; + protected + procedure testVoid(); + function testBool(thing: Boolean): Boolean; + function testString(const thing: string): string; + function testByte(thing: ShortInt): ShortInt; + function testI32(thing: Integer): Integer; + function testI64(const thing: Int64): Int64; + function testDouble(const thing: Double): Double; + function testBinary(const thing: TBytes): TBytes; + function testStruct(const thing: IXtruct): IXtruct; + function testNest(const thing: IXtruct2): IXtruct2; + function testMap(const thing: IThriftDictionary<Integer, Integer>): IThriftDictionary<Integer, Integer>; + function testStringMap(const thing: IThriftDictionary<string, string>): IThriftDictionary<string, string>; + function testSet(const thing: IHashSet<Integer>): IHashSet<Integer>; + function testList(const thing: IThriftList<Integer>): IThriftList<Integer>; + function testEnum(thing: TNumberz): TNumberz; + function testTypedef(const thing: Int64): Int64; + function testMapMap(hello: Integer): IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>; + function testInsanity(const argument: IInsanity): IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; + function testMulti(arg0: ShortInt; arg1: Integer; const arg2: Int64; const arg3: IThriftDictionary<SmallInt, string>; arg4: TNumberz; const arg5: Int64): IXtruct; + procedure testException(const arg: string); + function testMultiException(const arg0: string; const arg1: string): IXtruct; + procedure testOneway(secondsToSleep: Integer); + + procedure TestStop; + procedure SetServer( const AServer : IServer ); + end; + + class procedure PrintCmdLineHelp; + class procedure InvalidArgs; + + class procedure LaunchAnonPipeChild( const app : string; const transport : IAnonymousPipeServerTransport); + class procedure Execute( const args: array of string); + end; + +implementation + + +var g_Handler : TTestServer.ITestHandler = nil; + + +function MyConsoleEventHandler( dwCtrlType : DWORD) : BOOL; stdcall; +// Note that this Handler procedure is called from another thread +var handler : TTestServer.ITestHandler; +begin + result := TRUE; + try + case dwCtrlType of + CTRL_C_EVENT : Console.WriteLine( 'Ctrl+C pressed'); + CTRL_BREAK_EVENT : Console.WriteLine( 'Ctrl+Break pressed'); + CTRL_CLOSE_EVENT : Console.WriteLine( 'Received CloseTask signal'); + CTRL_LOGOFF_EVENT : Console.WriteLine( 'Received LogOff signal'); + CTRL_SHUTDOWN_EVENT : Console.WriteLine( 'Received Shutdown signal'); + else + Console.WriteLine( 'Received console event #'+IntToStr(Integer(dwCtrlType))); + end; + + handler := g_Handler; + if handler <> nil then handler.TestStop; + + except + // catch all + end; +end; + + +{ TTestServer.TTestHandlerImpl } + +procedure TTestServer.TTestHandlerImpl.SetServer( const AServer: IServer); +begin + FServer := AServer; +end; + +function TTestServer.TTestHandlerImpl.testByte(thing: ShortInt): ShortInt; +begin + Console.WriteLine('testByte("' + IntToStr( thing) + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testDouble( const thing: Double): Double; +begin + Console.WriteLine('testDouble("' + FloatToStr( thing ) + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testBinary(const thing: TBytes): TBytes; +begin + Console.WriteLine('testBinary('+IntToStr(Length(thing)) + ' bytes)'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testEnum(thing: TNumberz): TNumberz; +begin + Console.WriteLine('testEnum(' + EnumUtils<TNumberz>.ToString(Ord(thing)) + ')'); + Result := thing; +end; + +procedure TTestServer.TTestHandlerImpl.testException(const arg: string); +begin + Console.WriteLine('testException(' + arg + ')'); + if ( arg = 'Xception') then + begin + raise TXception.Create( 1001, arg); + end; + + if (arg = 'TException') then + begin + raise TException.Create('TException'); + end; + + // else do not throw anything +end; + +function TTestServer.TTestHandlerImpl.testI32(thing: Integer): Integer; +begin + Console.WriteLine('testI32("' + IntToStr( thing) + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testI64( const thing: Int64): Int64; +begin + Console.WriteLine('testI64("' + IntToStr( thing) + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testInsanity( + const argument: IInsanity): IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; +var + looney : IInsanity; + first_map : IThriftDictionary<TNumberz, IInsanity>; + second_map : IThriftDictionary<TNumberz, IInsanity>; + insane : IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; + +begin + Console.Write('testInsanity('); + if argument <> nil then Console.Write(argument.ToString); + Console.WriteLine(')'); + + + (** + * So you think you've got this all worked, out eh? + * + * Creates a the returned map with these values and prints it out: + * { 1 => { 2 => argument, + * 3 => argument, + * }, + * 2 => { 6 => <empty Insanity struct>, }, + * } + * @return map<UserId, map<Numberz,Insanity>> - a map with the above values + *) + + first_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create; + second_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create; + + first_map.AddOrSetValue( TNumberz.TWO, argument); + first_map.AddOrSetValue( TNumberz.THREE, argument); + + looney := TInsanityImpl.Create; + second_map.AddOrSetValue( TNumberz.SIX, looney); + + insane := TThriftDictionaryImpl<Int64, IThriftDictionary<TNumberz, IInsanity>>.Create; + + insane.AddOrSetValue( 1, first_map); + insane.AddOrSetValue( 2, second_map); + + Result := insane; +end; + +function TTestServer.TTestHandlerImpl.testList( const thing: IThriftList<Integer>): IThriftList<Integer>; +begin + Console.Write('testList('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testMap( + const thing: IThriftDictionary<Integer, Integer>): IThriftDictionary<Integer, Integer>; +begin + Console.Write('testMap('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.TestMapMap( + hello: Integer): IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>; +var + mapmap : IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>; + pos : IThriftDictionary<Integer, Integer>; + neg : IThriftDictionary<Integer, Integer>; + i : Integer; +begin + Console.WriteLine('testMapMap(' + IntToStr( hello) + ')'); + mapmap := TThriftDictionaryImpl<Integer, IThriftDictionary<Integer, Integer>>.Create; + pos := TThriftDictionaryImpl<Integer, Integer>.Create; + neg := TThriftDictionaryImpl<Integer, Integer>.Create; + + for i := 1 to 4 do + begin + pos.AddOrSetValue( i, i); + neg.AddOrSetValue( -i, -i); + end; + + mapmap.AddOrSetValue(4, pos); + mapmap.AddOrSetValue( -4, neg); + + Result := mapmap; +end; + +function TTestServer.TTestHandlerImpl.testMulti(arg0: ShortInt; arg1: Integer; + const arg2: Int64; const arg3: IThriftDictionary<SmallInt, string>; + arg4: TNumberz; const arg5: Int64): IXtruct; +var + hello : IXtruct; +begin + Console.WriteLine('testMulti()'); + hello := TXtructImpl.Create; + hello.String_thing := 'Hello2'; + hello.Byte_thing := arg0; + hello.I32_thing := arg1; + hello.I64_thing := arg2; + Result := hello; +end; + +function TTestServer.TTestHandlerImpl.testMultiException( const arg0, arg1: string): IXtruct; +var + x2 : TXception2; +begin + Console.WriteLine('testMultiException(' + arg0 + ', ' + arg1 + ')'); + if ( arg0 = 'Xception') then begin + raise TXception.Create( 1001, 'This is an Xception'); // test the new rich CTOR + end; + + if ( arg0 = 'Xception2') then begin + x2 := TXception2.Create; // the old way still works too? + x2.ErrorCode := 2002; + x2.Struct_thing := TXtructImpl.Create; + x2.Struct_thing.String_thing := 'This is an Xception2'; + x2.UpdateMessageProperty; + raise x2; + end; + + Result := TXtructImpl.Create; + Result.String_thing := arg1; +end; + +function TTestServer.TTestHandlerImpl.testNest( const thing: IXtruct2): IXtruct2; +begin + Console.Write('testNest('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + + Result := thing; +end; + +procedure TTestServer.TTestHandlerImpl.testOneway(secondsToSleep: Integer); +begin + Console.WriteLine('testOneway(' + IntToStr( secondsToSleep )+ '), sleeping...'); + Sleep(secondsToSleep * 1000); + Console.WriteLine('testOneway finished'); +end; + +function TTestServer.TTestHandlerImpl.testSet( const thing: IHashSet<Integer>):IHashSet<Integer>; +begin + Console.Write('testSet('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')');; + + Result := thing; +end; + +procedure TTestServer.TTestHandlerImpl.testStop; +begin + if FServer <> nil then begin + FServer.Stop; + end; +end; + +function TTestServer.TTestHandlerImpl.testBool(thing: Boolean): Boolean; +begin + Console.WriteLine('testBool(' + BoolToStr(thing,true) + ')'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testString( const thing: string): string; +begin + Console.WriteLine('teststring("' + thing + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testStringMap( + const thing: IThriftDictionary<string, string>): IThriftDictionary<string, string>; +begin + Console.Write('testStringMap('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testTypedef( const thing: Int64): Int64; +begin + Console.WriteLine('testTypedef(' + IntToStr( thing) + ')'); + Result := thing; +end; + +procedure TTestServer.TTestHandlerImpl.TestVoid; +begin + Console.WriteLine('testVoid()'); +end; + +function TTestServer.TTestHandlerImpl.testStruct( const thing: IXtruct): IXtruct; +begin + Console.Write('testStruct('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + + Result := thing; +end; + + +{ TTestServer } + + +class procedure TTestServer.PrintCmdLineHelp; +const HELPTEXT = ' [options]'#10 + + #10 + + 'Allowed options:'#10 + + ' -h [ --help ] produce help message'#10 + + ' --port arg (=9090) Port number to listen'#10 + + ' --domain-socket arg Unix Domain Socket (e.g. /tmp/ThriftTest.thrift)'#10 + + ' --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe)'#10 + + ' --server-type arg (=simple) type of server, "simple", "thread-pool",'#10 + + ' "threaded", or "nonblocking"'#10 + + ' --transport arg (=socket) transport: buffered, framed, http, anonpipe'#10 + + ' --protocol arg (=binary) protocol: binary, compact, json'#10 + + ' --ssl Encrypted Transport using SSL'#10 + + ' --processor-events processor-events'#10 + + ' -n [ --workers ] arg (=4) Number of thread pools workers. Only valid for'#10 + + ' thread-pool server type'#10 + ; +begin + Console.WriteLine( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + HELPTEXT); +end; + +class procedure TTestServer.InvalidArgs; +begin + Console.WriteLine( 'Invalid args.'); + Console.WriteLine( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + ' -h for more information'); + Abort; +end; + +class procedure TTestServer.LaunchAnonPipeChild( const app : string; const transport : IAnonymousPipeServerTransport); +//Launch child process and pass R/W anonymous pipe handles on cmd line. +//This is a simple example and does not include elevation or other +//advanced features. +var pi : PROCESS_INFORMATION; + si : STARTUPINFO; + sArg, sHandles, sCmdLine : string; + i : Integer; +begin + GetStartupInfo( si); //set startupinfo for the spawned process + + // preformat handles args + sHandles := Format( '%d %d', + [ Integer(transport.ClientAnonRead), + Integer(transport.ClientAnonWrite)]); + + // pass all settings to client + sCmdLine := app; + for i := 1 to ParamCount do begin + sArg := ParamStr(i); + + // add anonymous handles and quote strings where appropriate + if sArg = '-anon' + then sArg := sArg +' '+ sHandles + else begin + if Pos(' ',sArg) > 0 + then sArg := '"'+sArg+'"'; + end;; + + sCmdLine := sCmdLine +' '+ sArg; + end; + + // spawn the child process + Console.WriteLine('Starting client '+sCmdLine); + Win32Check( CreateProcess( nil, PChar(sCmdLine), nil,nil,TRUE,0,nil,nil,si,pi)); + + CloseHandle( pi.hThread); + CloseHandle( pi.hProcess); +end; + + +class procedure TTestServer.Execute( const args: array of string); +var + Port : Integer; + ServerEvents : Boolean; + sPipeName : string; + testHandler : ITestHandler; + testProcessor : IProcessor; + ServerTrans : IServerTransport; + ServerEngine : IServer; + anonymouspipe : IAnonymousPipeServerTransport; + namedpipe : INamedPipeServerTransport; + TransportFactory : ITransportFactory; + ProtocolFactory : IProtocolFactory; + i, numWorker : Integer; + s : string; + protType : TKnownProtocol; + servertype : TServerType; + endpoint : TEndpointTransport; + layered : TLayeredTransports; + UseSSL : Boolean; // include where appropriate (TLayeredTransport?) +begin + try + ServerEvents := FALSE; + protType := prot_Binary; + servertype := srv_Simple; + endpoint := trns_Sockets; + layered := []; + UseSSL := FALSE; + Port := 9090; + sPipeName := ''; + numWorker := 4; + + i := 0; + while ( i < Length(args) ) do begin + s := args[i]; + Inc(i); + + // Allowed options: + if (s = '-h') or (s = '--help') then begin + // -h [ --help ] produce help message + PrintCmdLineHelp; + Exit; + end + else if (s = '--port') then begin + // --port arg (=9090) Port number to listen + s := args[i]; + Inc(i); + Port := StrToIntDef( s, Port); + end + else if (s = '--domain-socket') then begin + // --domain-socket arg Unix Domain Socket (e.g. /tmp/ThriftTest.thrift) + raise Exception.Create('domain-socket not supported'); + end + else if (s = '--named-pipe') then begin + // --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe) + endpoint := trns_NamedPipes; + sPipeName := args[i]; // -pipe <name> + Inc( i ); + end + else if (s = '--server-type') then begin + // --server-type arg (=simple) type of server, + // arg = "simple", "thread-pool", "threaded", or "nonblocking" + s := args[i]; + Inc(i); + + if s = 'simple' then servertype := srv_Simple + else if s = 'thread-pool' then servertype := srv_Threadpool + else if s = 'threaded' then servertype := srv_Threaded + else if s = 'nonblocking' then servertype := srv_Nonblocking + else InvalidArgs; + end + else if (s = '--transport') then begin + // --transport arg (=buffered) transport: buffered, framed, http + s := args[i]; + Inc(i); + + if s = 'buffered' then Include( layered, trns_Buffered) + else if s = 'framed' then Include( layered, trns_Framed) + else if s = 'http' then endpoint := trns_MsxmlHttp + else if s = 'winhttp' then endpoint := trns_WinHttp + else if s = 'anonpipe' then endpoint := trns_AnonPipes + else InvalidArgs; + end + else if (s = '--protocol') then begin + // --protocol arg (=binary) protocol: binary, compact, json + s := args[i]; + Inc(i); + + if s = 'binary' then protType := prot_Binary + else if s = 'compact' then protType := prot_Compact + else if s = 'json' then protType := prot_JSON + else InvalidArgs; + end + else if (s = '--ssl') then begin + // --ssl Encrypted Transport using SSL + UseSSL := TRUE; + end + else if (s = '--processor-events') then begin + // --processor-events processor-events + ServerEvents := TRUE; + end + else if (s = '-n') or (s = '--workers') then begin + // -n [ --workers ] arg (=4) Number of thread pools workers. + // Only valid for thread-pool server type + s := args[i]; + numWorker := StrToIntDef(s,0); + if numWorker > 0 + then Inc(i) + else numWorker := 4; + end + else begin + InvalidArgs; + end; + end; + + + Console.WriteLine('Server configuration: '); + + // create protocol factory, default to BinaryProtocol + case protType of + prot_Binary : ProtocolFactory := TBinaryProtocolImpl.TFactory.Create( BINARY_STRICT_READ, BINARY_STRICT_WRITE); + prot_JSON : ProtocolFactory := TJSONProtocolImpl.TFactory.Create; + prot_Compact : ProtocolFactory := TCompactProtocolImpl.TFactory.Create; + else + raise Exception.Create('Unhandled protocol'); + end; + ASSERT( ProtocolFactory <> nil); + Console.WriteLine('- '+THRIFT_PROTOCOLS[protType]+' protocol'); + + case endpoint of + + trns_Sockets : begin + Console.WriteLine('- sockets (port '+IntToStr(port)+')'); + if (trns_Buffered in layered) then Console.WriteLine('- buffered'); + servertrans := TServerSocketImpl.Create( Port, 0, (trns_Buffered in layered)); + end; + + trns_MsxmlHttp, + trns_WinHttp : begin + raise Exception.Create('HTTP server transport not implemented'); + end; + + trns_NamedPipes : begin + Console.WriteLine('- named pipe ('+sPipeName+')'); + namedpipe := TNamedPipeServerTransportImpl.Create( sPipeName, 4096, PIPE_UNLIMITED_INSTANCES); + servertrans := namedpipe; + end; + + trns_AnonPipes : begin + Console.WriteLine('- anonymous pipes'); + anonymouspipe := TAnonymousPipeServerTransportImpl.Create; + servertrans := anonymouspipe; + end + + else + raise Exception.Create('Unhandled endpoint transport'); + end; + ASSERT( servertrans <> nil); + + if UseSSL then begin + raise Exception.Create('SSL not implemented'); + end; + + if (trns_Framed in layered) then begin + Console.WriteLine('- framed transport'); + TransportFactory := TFramedTransportImpl.TFactory.Create + end + else begin + TransportFactory := TTransportFactoryImpl.Create; + end; + ASSERT( TransportFactory <> nil); + + testHandler := TTestHandlerImpl.Create; + testProcessor := TThriftTest.TProcessorImpl.Create( testHandler ); + + case servertype of + srv_Simple : begin + ServerEngine := TSimpleServer.Create( testProcessor, ServerTrans, TransportFactory, ProtocolFactory); + end; + + srv_Nonblocking : begin + raise Exception.Create(SERVER_TYPES[servertype]+' server not implemented'); + end; + + srv_Threadpool, + srv_Threaded: begin + if numWorker > 1 then {use here}; + raise Exception.Create(SERVER_TYPES[servertype]+' server not implemented'); + end; + + else + raise Exception.Create('Unhandled server type'); + end; + ASSERT( ServerEngine <> nil); + + testHandler.SetServer( ServerEngine); + + // test events? + if ServerEvents then begin + Console.WriteLine('- server events test enabled'); + ServerEngine.ServerEvents := TServerEventsImpl.Create; + end; + + // start the client now when we have the anon handles, but before the server starts + if endpoint = trns_AnonPipes + then LaunchAnonPipeChild( ExtractFilePath(ParamStr(0))+'client.exe', anonymouspipe); + + // install Ctrl+C handler before the server starts + g_Handler := testHandler; + SetConsoleCtrlHandler( @MyConsoleEventHandler, TRUE); + + Console.WriteLine(''); + repeat + Console.WriteLine('Starting the server ...'); + serverEngine.Serve; + until {$IFDEF RunEndless} FALSE {$ELSE} TRUE {$ENDIF}; + + testHandler.SetServer( nil); + g_Handler := nil; + + except + on E: EAbort do raise; + on E: Exception do begin + Console.WriteLine( E.Message + #10 + E.StackTrace ); + end; + end; + Console.WriteLine( 'done.'); +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestServerEvents.pas b/src/jaegertracing/thrift/lib/delphi/test/TestServerEvents.pas new file mode 100644 index 000000000..2208cd4ba --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestServerEvents.pas @@ -0,0 +1,174 @@ +(* + * 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 TestServerEvents; + +interface + +uses + SysUtils, + Thrift, + Thrift.Protocol, + Thrift.Transport, + Thrift.Server, + ConsoleHelper; + +type + TRequestEventsImpl = class( TInterfacedObject, IRequestEvents) + protected + FStart : TDateTime; + // IRequestProcessingEvents + procedure PreRead; + procedure PostRead; + procedure PreWrite; + procedure PostWrite; + procedure OnewayComplete; + procedure UnhandledError( const e : Exception); + procedure CleanupContext; + public + constructor Create; + end; + + + TProcessorEventsImpl = class( TInterfacedObject, IProcessorEvents) + protected + FReqs : Integer; + // IProcessorEvents + procedure Processing( const transport : ITransport); + function CreateRequestContext( const aFunctionName : string) : IRequestEvents; + procedure CleanupContext; + public + constructor Create; + end; + + + TServerEventsImpl = class( TInterfacedObject, IServerEvents) + protected + // IServerEvents + procedure PreServe; + procedure PreAccept; + function CreateProcessingContext( const input, output : IProtocol) : IProcessorEvents; + end; + + +implementation + +{ TServerEventsImpl } + +procedure TServerEventsImpl.PreServe; +begin + Console.WriteLine('ServerEvents: Server starting to serve requests'); +end; + + +procedure TServerEventsImpl.PreAccept; +begin + Console.WriteLine('ServerEvents: Server transport is ready to accept incoming calls'); +end; + + +function TServerEventsImpl.CreateProcessingContext(const input, output: IProtocol): IProcessorEvents; +begin + result := TProcessorEventsImpl.Create; +end; + + +{ TProcessorEventsImpl } + +constructor TProcessorEventsImpl.Create; +begin + inherited Create; + FReqs := 0; + Console.WriteLine('ProcessorEvents: Client connected, processing begins'); +end; + +procedure TProcessorEventsImpl.Processing(const transport: ITransport); +begin + Console.WriteLine('ProcessorEvents: Processing of incoming request begins'); +end; + + +function TProcessorEventsImpl.CreateRequestContext( const aFunctionName: string): IRequestEvents; +begin + result := TRequestEventsImpl.Create; + Inc( FReqs); +end; + + +procedure TProcessorEventsImpl.CleanupContext; +begin + Console.WriteLine( 'ProcessorEvents: completed after handling '+IntToStr(FReqs)+' requests.'); +end; + + +{ TRequestEventsImpl } + + +constructor TRequestEventsImpl.Create; +begin + inherited Create; + FStart := Now; + Console.WriteLine('RequestEvents: New request'); +end; + + +procedure TRequestEventsImpl.PreRead; +begin + Console.WriteLine('RequestEvents: Reading request message ...'); +end; + + +procedure TRequestEventsImpl.PostRead; +begin + Console.WriteLine('RequestEvents: Reading request message completed'); +end; + +procedure TRequestEventsImpl.PreWrite; +begin + Console.WriteLine('RequestEvents: Writing response message ...'); +end; + + +procedure TRequestEventsImpl.PostWrite; +begin + Console.WriteLine('RequestEvents: Writing response message completed'); +end; + + +procedure TRequestEventsImpl.OnewayComplete; +begin + Console.WriteLine('RequestEvents: Oneway message processed'); +end; + + +procedure TRequestEventsImpl.UnhandledError(const e: Exception); +begin + Console.WriteLine('RequestEvents: Unhandled exception of type '+e.classname); +end; + + +procedure TRequestEventsImpl.CleanupContext; +var millis : Double; +begin + millis := (Now - FStart) * (24*60*60*1000); + Console.WriteLine( 'Request processing completed in '+IntToStr(Round(millis))+' ms'); +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/client.dpr b/src/jaegertracing/thrift/lib/delphi/test/client.dpr new file mode 100644 index 000000000..83727f619 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/client.dpr @@ -0,0 +1,77 @@ +(* + * 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. + *) + + +program client; + +{$APPTYPE CONSOLE} + +uses + SysUtils, + DataFactory in 'Performance\DataFactory.pas', + PerfTests in 'Performance\PerfTests.pas', + TestClient in 'TestClient.pas', + Thrift.Test, // in 'gen-delphi\Thrift.Test.pas', + Thrift in '..\src\Thrift.pas', + Thrift.Transport in '..\src\Thrift.Transport.pas', + Thrift.Socket in '..\src\Thrift.Socket.pas', + Thrift.Exception in '..\src\Thrift.Exception.pas', + Thrift.Transport.Pipes in '..\src\Thrift.Transport.Pipes.pas', + Thrift.Transport.WinHTTP in '..\src\Thrift.Transport.WinHTTP.pas', + Thrift.Transport.MsxmlHTTP in '..\src\Thrift.Transport.MsxmlHTTP.pas', + Thrift.Protocol in '..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\src\Thrift.Protocol.JSON.pas', + Thrift.Protocol.Compact in '..\src\Thrift.Protocol.Compact.pas', + Thrift.Protocol.Multiplex in '..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Collections in '..\src\Thrift.Collections.pas', + Thrift.Server in '..\src\Thrift.Server.pas', + Thrift.Stream in '..\src\Thrift.Stream.pas', + Thrift.TypeRegistry in '..\src\Thrift.TypeRegistry.pas', + Thrift.WinHTTP in '..\src\Thrift.WinHTTP.pas', + Thrift.Utils in '..\src\Thrift.Utils.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : string; + +begin + try + Writeln( 'Delphi TestClient '+Thrift.Version); + nParamCount := ParamCount; + SetLength( args, nParamCount); + for i := 1 to nParamCount do begin + arg := ParamStr( i ); + args[i-1] := arg; + end; + + ExitCode := TTestClient.Execute( args); + + except + on E: EAbort do begin + ExitCode := $FF; + end; + on E: Exception do begin + Writeln(E.ClassName, ': ', E.Message); + ExitCode := $FF; + end; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/codegen/README.md b/src/jaegertracing/thrift/lib/delphi/test/codegen/README.md new file mode 100644 index 000000000..a0145890f --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/codegen/README.md @@ -0,0 +1,28 @@ +How to use the test case: +---------------------------------------------- +- copy and the template batch file +- open the batch file and adjust configuration as necessary +- run the batch + + +Configuration: +---------------------------------------------- +SVNWORKDIR +should point to the Thrift working copy root + +MY_THRIFT_FILES +can be set to point to a folder with more thrift IDL files. +If you don't have any such files, just leave the setting blank. + +BIN +Local MSYS binary folder. Your THRIFT.EXE is installed here. + +MINGW_BIN +Local MinGW bin folder. Contains DLL files required by THRIFT.EXE + +DCC +Identifies the Delphi Command Line compiler (dcc32.exe) +To be configuired only, if the default is not suitable. + +---------------------------------------------- +*EOF*
\ No newline at end of file diff --git a/src/jaegertracing/thrift/lib/delphi/test/codegen/run-Pascal-Codegen-Tests.bat.tmpl b/src/jaegertracing/thrift/lib/delphi/test/codegen/run-Pascal-Codegen-Tests.bat.tmpl new file mode 100644 index 000000000..dbab0ae7c --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/codegen/run-Pascal-Codegen-Tests.bat.tmpl @@ -0,0 +1,173 @@ +REM /* +REM * Licensed to the Apache Software Foundation (ASF) under one +REM * or more contributor license agreements. See the NOTICE file +REM * distributed with this work for additional information +REM * regarding copyright ownership. The ASF licenses this file +REM * to you under the Apache License, Version 2.0 (the +REM * "License"); you may not use this file except in compliance +REM * with the License. You may obtain a copy of the License at +REM * +REM * http://www.apache.org/licenses/LICENSE-2.0 +REM * +REM * Unless required by applicable law or agreed to in writing, +REM * software distributed under the License is distributed on an +REM * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +REM * KIND, either express or implied. See the License for the +REM * specific language governing permissions and limitations +REM * under the License. +REM */ +@echo off +if ""=="%1" goto CONFIG +goto HANDLEDIR + +REM ----------------------------------------------------- +:CONFIG +REM ----------------------------------------------------- + +rem * CONFIGURATION BEGIN +rem * configuration settings, adjust as necessary to meet your system setup +set SVNWORKDIR= +set MY_THRIFT_FILES= +set BIN=C:\MSys10\local\bin +set MINGW_BIN=C:\MinGW\bin +set DCC= +set SUBDIR=gen-delphi +rem * CONFIGURATION END + + +REM ----------------------------------------------------- +:START +REM ----------------------------------------------------- + +rem * configured? +if "%SVNWORKDIR%"=="" goto CONFIG_ERROR + +rem * try to find dcc32.exe +echo Looking for dcc32.exe ... +if not exist "%DCC%" set DCC=%ProgramFiles%\Embarcadero\RAD Studio\8.0\bin\dcc32.exe +if not exist "%DCC%" set DCC=%ProgramFiles(x86)%\Embarcadero\RAD Studio\8.0\bin\dcc32.exe +if not exist "%DCC%" goto CONFIG_ERROR +echo Found %DCC% +echo. + +rem * some helpers +set PATH=%BIN%;%MINGW_BIN%;%PATH% +set TARGET=%SVNWORKDIR%\..\thrift-testing +set SOURCE=%SVNWORKDIR% +set TESTAPP=TestProject +set UNITSEARCH=%SOURCE%\lib\pas\src;%SOURCE%\lib\delphi\src +set OUTDCU="%TARGET%\dcu" +set LOGFILE=%TARGET%\%SUBDIR%\codegen.log + +rem * create and/or empty target dirs +if not exist "%TARGET%" md "%TARGET%" +if not exist "%TARGET%\%SUBDIR%" md "%TARGET%\%SUBDIR%" +if not exist "%OUTDCU%" md "%OUTDCU%" +if exist "%TARGET%\*.thrift" del "%TARGET%\*.thrift" /Q +if exist "%TARGET%\%SUBDIR%\*.*" del "%TARGET%\%SUBDIR%\*.*" /Q +if exist "%OUTDCU%\*.*" del "%OUTDCU%\*.*" /Q + +rem * recurse through thrift WC and "my thrift files" folder +rem * copies all .thrift files into thrift-testing +call %0 %SOURCE% +if not "%MY_THRIFT_FILES%"=="" call %0 %MY_THRIFT_FILES% + +rem * compile all thrift files, generate PAS and C++ code +echo. +echo Generating code, please wait ... +cd "%TARGET%" +for %%a in (*.thrift) do "%BIN%\thrift.exe" -v --gen delphi:register_types,constprefix,events,xmldoc "%%a" 2>> "%LOGFILE%" +REM * for %%a in (*.thrift) do "%BIN%\thrift.exe" -v --gen cpp "%%a" >> NUL: +cmd /c start notepad "%LOGFILE%" +cd .. + +rem * check for special Delphi testcases being processed +if not exist "%TARGET%\%SUBDIR%\ReservedKeywords.pas" goto TESTCASE_MISSING + + +rem * generate a minimal DPR file that uses all generated pascal units +cd "%TARGET%\%SUBDIR%\" +if exist inherited.* ren inherited.* _inherited.* +echo program %TESTAPP%; > %TESTAPP%.dpr +echo {$APPTYPE CONSOLE} >> %TESTAPP%.dpr +echo. >> %TESTAPP%.dpr +echo uses >> %TESTAPP%.dpr +for %%a in (*.pas) do echo %%~na, >> %TESTAPP%.dpr +echo Windows, Classes, SysUtils; >> %TESTAPP%.dpr +echo. >> %TESTAPP%.dpr +echo begin >> %TESTAPP%.dpr +echo Writeln('Successfully compiled!'); >> %TESTAPP%.dpr +echo Writeln('List of units:'); >> %TESTAPP%.dpr +for %%a in (*.pas) do echo Write('%%~na':30,'':10); >> %TESTAPP%.dpr +echo Writeln; >> %TESTAPP%.dpr +echo end. >> %TESTAPP%.dpr +echo. >> %TESTAPP%.dpr +cd ..\.. + +rem * try to compile the DPR +rem * this should not throw any errors, warnings or hints +"%DCC%" -B "%TARGET%\%SUBDIR%\%TESTAPP%" -U"%UNITSEARCH%" -I"%UNITSEARCH%" -N"%OUTDCU%" -E"%TARGET%\%SUBDIR%" +dir "%TARGET%\%SUBDIR%\%TESTAPP%.exe" +if not exist "%TARGET%\%SUBDIR%\%TESTAPP%.exe" goto CODEGEN_FAILED +echo. +echo ----------------------------------------------------------------- +echo The compiled program is now executed. If it hangs or crashes, we +echo have a serious problem with the generated code. Expected output +echo is "Successfully compiled:" followed by a list of generated units. +echo ----------------------------------------------------------------- +"%TARGET%\%SUBDIR%\%TESTAPP%.exe" +echo ----------------------------------------------------------------- +echo. +pause +GOTO EOF + +REM ----------------------------------------------------- +:DXE_NOT_FOUND +REM ----------------------------------------------------- +echo Delphi Compiler (dcc32.exe) not found. +echo Please check the "DCC" setting in this batch. +echo. +cmd /c start notepad README.MD +cmd /c start notepad %0 +pause +GOTO EOF + + +REM ----------------------------------------------------- +:CONFIG_ERROR +REM ----------------------------------------------------- +echo Missing, incomplete or wrong configuration settings! +cmd /c start notepad README.MD +cmd /c start notepad %0 +pause +GOTO EOF + + +REM ----------------------------------------------------- +:TESTCASE_MISSING +REM ----------------------------------------------------- +echo Missing an expected Delphi testcase! +pause +GOTO EOF + + +REM ----------------------------------------------------- +:CODEGEN_FAILED +REM ----------------------------------------------------- +echo Code generation FAILED! +pause +GOTO EOF + + +REM ----------------------------------------------------- +:HANDLEDIR +REM ----------------------------------------------------- +REM echo %1 +for /D %%a in (%1\*) do call %0 %%a +if exist "%1\*.thrift" copy /b "%1\*.thrift" "%TARGET%\*.*" +GOTO EOF + + +REM ----------------------------------------------------- +:EOF +REM ----------------------------------------------------- diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedIncluded.thrift b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedIncluded.thrift new file mode 100644 index 000000000..8b47a50bc --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedIncluded.thrift @@ -0,0 +1,25 @@ +/* + * 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. + */ + +// make sure generated code does not produce name collisions with predefined keywords +namespace delphi SysUtils + +const i32 integer = 42 + +// EOF diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dpr b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dpr new file mode 100644 index 000000000..1fbc8c1d7 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dpr @@ -0,0 +1,15 @@ +program ReservedKeywords; + +{$APPTYPE CONSOLE} + +uses + SysUtils, System_; + +begin + try + { TODO -oUser -cConsole Main : Code hier einfgen } + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dproj b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dproj new file mode 100644 index 000000000..6bd9544bc --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dproj @@ -0,0 +1,112 @@ + <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{F2E9B6FC-A931-4271-8E30-5A4E402481B4}</ProjectGuid> + <MainSource>ReservedKeywords.dpr</MainSource> + <ProjectVersion>12.3</ProjectVersion> + <Basis>True</Basis> + <Config Condition="'$(Config)'==''">Debug</Config> + <Platform>Win32</Platform> + <AppType>Console</AppType> + <FrameworkType>None</FrameworkType> + <DCC_DCCCompiler>DCC32</DCC_DCCCompiler> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Basis' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_DcuOutput>.\$(Config)\$(Platform)</DCC_DcuOutput> + <DCC_UnitSearchPath>gen-delphi;..\..\src;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> + <DCC_UnitAlias>WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;$(DCC_UnitAlias)</DCC_UnitAlias> + <DCC_ExeOutput>.\$(Config)\$(Platform)</DCC_ExeOutput> + <DCC_N>false</DCC_N> + <DCC_S>false</DCC_S> + <DCC_K>false</DCC_K> + <DCC_E>false</DCC_E> + <DCC_F>false</DCC_F> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_DebugInformation>false</DCC_DebugInformation> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="ReservedKeywords.dpr"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <BuildConfiguration Include="Release"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Basis"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Debug"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/> + <Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/> + <PropertyGroup> + <PreBuildEvent><![CDATA[thrift -r -gen delphi ReservedKeywords.thrift]]></PreBuildEvent> + </PropertyGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType/> + <BorlandProject> + <Delphi.Personality> + <VersionInfo> + <VersionInfo Name="IncludeVerInfo">False</VersionInfo> + <VersionInfo Name="AutoIncBuild">False</VersionInfo> + <VersionInfo Name="MajorVer">1</VersionInfo> + <VersionInfo Name="MinorVer">0</VersionInfo> + <VersionInfo Name="Release">0</VersionInfo> + <VersionInfo Name="Build">0</VersionInfo> + <VersionInfo Name="Debug">False</VersionInfo> + <VersionInfo Name="PreRelease">False</VersionInfo> + <VersionInfo Name="Special">False</VersionInfo> + <VersionInfo Name="Private">False</VersionInfo> + <VersionInfo Name="DLL">False</VersionInfo> + <VersionInfo Name="Locale">1031</VersionInfo> + <VersionInfo Name="CodePage">1252</VersionInfo> + </VersionInfo> + <VersionInfoKeys> + <VersionInfoKeys Name="CompanyName"/> + <VersionInfoKeys Name="FileDescription"/> + <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="InternalName"/> + <VersionInfoKeys Name="LegalCopyright"/> + <VersionInfoKeys Name="LegalTrademarks"/> + <VersionInfoKeys Name="OriginalFilename"/> + <VersionInfoKeys Name="ProductName"/> + <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="Comments"/> + </VersionInfoKeys> + <Source> + <Source Name="MainSource">ReservedKeywords.dpr</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Win32">True</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + </Project> diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.thrift b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.thrift new file mode 100644 index 000000000..2f49d742c --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.thrift @@ -0,0 +1,138 @@ +/* + * 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. + */ + +// make sure generated code does not produce name collisions with predefined keywords +namespace delphi System + +include "ReservedIncluded.thrift" + + +typedef i32 Cardinal +typedef string message +typedef list< map< Cardinal, message>> program + +struct unit { + 1: Cardinal downto; + 2: program procedure; +} + +typedef set< unit> units + +exception exception1 { + 1: program message; + 2: unit array; +} + +service constructor { + unit Create(1: Cardinal asm; 2: message inherited) throws (1: exception1 label); + units Destroy(); +} + +const Cardinal downto = +1 +const Cardinal published = -1 + +enum keywords { + record = 1, + repeat = 2, + deprecated = 3 +} + + +struct Struct_lists { + 1: list<Struct_simple> init; + 2: list<Struct_simple> struc; + 3: list<Struct_simple> field; + 4: list<Struct_simple> field_; + 5: list<Struct_simple> tracker; + 6: list<Struct_simple> Self; +} + +struct Struct_structs { + 1: Struct_simple init; + 2: Struct_simple struc; + 3: Struct_simple field; + 4: Struct_simple field_; + 5: Struct_simple tracker; + 6: Struct_simple Self; +} + +struct Struct_simple { + 1: bool init; + 2: bool struc; + 3: bool field; + 4: bool field_; + 5: bool tracker; + 6: bool Self; +} + +struct Struct_strings { + 1: string init; + 2: string struc; + 3: string field; + 4: string field_; + 5: string tracker; + 6: string Self; +} + +struct Struct_binary { + 1: binary init; + 2: binary struc; + 3: binary field; + 4: binary field_; + 5: binary tracker; + 6: binary Self; +} + + +typedef i32 IProtocol +typedef i32 ITransport +typedef i32 IFace +typedef i32 IAsync +typedef i32 System +typedef i32 SysUtils +typedef i32 Generics +typedef i32 Thrift + +struct Struct_Thrift_Names { + 1: IProtocol IProtocol + 2: ITransport ITransport + 3: IFace IFace + 4: IAsync IAsync + 5: System System + 6: SysUtils SysUtils + 7: Generics Generics + 8: Thrift Thrift +} + + +enum Thrift4554_Enum { + Foo = 0, + Bar = 1, + Baz = 2, +} + +struct Thrift4554_Struct { + 1 : optional double MinValue + 2 : optional double MaxValue + 3 : optional bool Integer // causes issue + 4 : optional Thrift4554_Enum Foo +} + + +// EOF diff --git a/src/jaegertracing/thrift/lib/delphi/test/maketest.sh b/src/jaegertracing/thrift/lib/delphi/test/maketest.sh new file mode 100755 index 000000000..8f0639c05 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/maketest.sh @@ -0,0 +1,23 @@ +#!/bin/sh + +# +# 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. +# + +../../../compiler/cpp/thrift --gen delphi -o . ../../../test/ThriftTest.thrift + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Client.Main.pas b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Client.Main.pas new file mode 100644 index 000000000..35fdf6f5b --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Client.Main.pas @@ -0,0 +1,131 @@ +(* + * 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 Multiplex.Client.Main; + +{.$DEFINE StressTest} // activate to stress-test the server with frequent connects/disconnects +{.$DEFINE PerfTest} // activate to activate the performance test + +interface + +uses + Windows, SysUtils, Classes, + DateUtils, + Generics.Collections, + Thrift, + Thrift.Protocol, + Thrift.Protocol.Multiplex, + Thrift.Transport.Pipes, + Thrift.Transport, + Thrift.Stream, + Thrift.Collections, + Benchmark, // in gen-delphi folder + Aggr, // in gen-delphi folder + Multiplex.Test.Common; + +type + TTestClient = class + protected + FProtocol : IProtocol; + + procedure ParseArgs( const args: array of string); + procedure Setup; + procedure Run; + public + constructor Create( const args: array of string); + class procedure Execute( const args: array of string); + end; + +implementation + + +type + IServiceClient = interface + ['{7745C1C2-AB20-43BA-B6F0-08BF92DE0BAC}'] + procedure Test; + end; + +//--- TTestClient ------------------------------------- + + +class procedure TTestClient.Execute( const args: array of string); +var client : TTestClient; +begin + client := TTestClient.Create(args); + try + client.Run; + finally + client.Free; + end; +end; + + +constructor TTestClient.Create( const args: array of string); +begin + inherited Create; + ParseArgs(args); + Setup; +end; + + +procedure TTestClient.ParseArgs( const args: array of string); +begin + if Length(args) <> 0 + then raise Exception.Create('No args accepted so far'); +end; + + +procedure TTestClient.Setup; +var trans : ITransport; +begin + trans := TSocketImpl.Create( 'localhost', 9090); + trans := TFramedTransportImpl.Create( trans); + trans.Open; + FProtocol := TBinaryProtocolImpl.Create( trans, TRUE, TRUE); +end; + + +procedure TTestClient.Run; +var bench : TBenchmarkService.Iface; + aggr : TAggr.Iface; + multiplex : IProtocol; + i : Integer; +begin + try + multiplex := TMultiplexedProtocol.Create( FProtocol, NAME_BENCHMARKSERVICE); + bench := TBenchmarkService.TClient.Create( multiplex); + + multiplex := TMultiplexedProtocol.Create( FProtocol, NAME_AGGR); + aggr := TAggr.TClient.Create( multiplex); + + for i := 1 to 10 + do aggr.addValue( bench.fibonacci(i)); + + for i in aggr.getValues + do Write(IntToStr(i)+' '); + WriteLn; + except + on e:Exception do Writeln(#10+e.Message); + end; +end; + + +end. + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Server.Main.pas b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Server.Main.pas new file mode 100644 index 000000000..3860f5ace --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Server.Main.pas @@ -0,0 +1,201 @@ +(* + * 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 Multiplex.Server.Main; + +{$WARN SYMBOL_PLATFORM OFF} + +{.$DEFINE RunEndless} // activate to interactively stress-test the server stop routines via Ctrl+C + +interface + +uses + Windows, SysUtils, + Generics.Collections, + Thrift.Server, + Thrift.Transport, + Thrift.Transport.Pipes, + Thrift.Protocol, + Thrift.Protocol.Multiplex, + Thrift.Processor.Multiplex, + Thrift.Collections, + Thrift.Utils, + Thrift, + Benchmark, // in gen-delphi folder + Aggr, // in gen-delphi folder + Multiplex.Test.Common, + ConsoleHelper, + Contnrs; + +type + TTestServer = class + public type + ITestHandler = interface + ['{CAE09AAB-80FB-48E9-B3A8-7F9B96F5419A}'] + procedure SetServer( const AServer : IServer ); + end; + + protected type + TTestHandlerImpl = class( TInterfacedObject, ITestHandler) + private + FServer : IServer; + protected + // ITestHandler + procedure SetServer( const AServer : IServer ); + + property Server : IServer read FServer write SetServer; + end; + + TBenchmarkServiceImpl = class( TTestHandlerImpl, TBenchmarkService.Iface) + protected + // TBenchmarkService.Iface + function fibonacci(n: ShortInt): Integer; + end; + + + TAggrImpl = class( TTestHandlerImpl, TAggr.Iface) + protected + FList : IThriftList<Integer>; + + // TAggr.Iface + procedure addValue(value: Integer); + function getValues(): IThriftList<Integer>; + public + constructor Create; + destructor Destroy; override; + end; + + public + class procedure Execute( const args: array of string); + end; + + +implementation + + +{ TTestServer.TTestHandlerImpl } + +procedure TTestServer.TTestHandlerImpl.SetServer( const AServer: IServer); +begin + FServer := AServer; +end; + + +{ TTestServer.TBenchmarkServiceImpl } + +function TTestServer.TBenchmarkServiceImpl.fibonacci(n: ShortInt): Integer; +var prev, next : Integer; +begin + prev := 0; + result := 1; + while n > 0 do begin + next := result + prev; + prev := result; + result := next; + Dec(n); + end; +end; + +{ TTestServer.TAggrImpl } + +constructor TTestServer.TAggrImpl.Create; +begin + inherited Create; + FList := TThriftListImpl<Integer>.Create; +end; + + +destructor TTestServer.TAggrImpl.Destroy; +begin + try + FreeAndNil( FList); + finally + inherited Destroy; + end; +end; + + +procedure TTestServer.TAggrImpl.addValue(value: Integer); +begin + FList.Add( value); +end; + + +function TTestServer.TAggrImpl.getValues(): IThriftList<Integer>; +begin + result := FList; +end; + + +{ TTestServer } + +class procedure TTestServer.Execute( const args: array of string); +var + TransportFactory : ITransportFactory; + ProtocolFactory : IProtocolFactory; + ServerTrans : IServerTransport; + benchHandler : TBenchmarkService.Iface; + aggrHandler : TAggr.Iface; + benchProcessor : IProcessor; + aggrProcessor : IProcessor; + multiplex : IMultiplexedProcessor; + ServerEngine : IServer; +begin + try + // create protocol factory, default to BinaryProtocol + ProtocolFactory := TBinaryProtocolImpl.TFactory.Create( TRUE, TRUE); + servertrans := TServerSocketImpl.Create( 9090, 0, FALSE); + TransportFactory := TFramedTransportImpl.TFactory.Create; + + benchHandler := TBenchmarkServiceImpl.Create; + benchProcessor := TBenchmarkService.TProcessorImpl.Create( benchHandler); + + aggrHandler := TAggrImpl.Create; + aggrProcessor := TAggr.TProcessorImpl.Create( aggrHandler); + + multiplex := TMultiplexedProcessorImpl.Create; + multiplex.RegisterProcessor( NAME_BENCHMARKSERVICE, benchProcessor); + multiplex.RegisterProcessor( NAME_AGGR, aggrProcessor); + + ServerEngine := TSimpleServer.Create( multiplex, + ServerTrans, + TransportFactory, + ProtocolFactory); + + (benchHandler as ITestHandler).SetServer( ServerEngine); + (aggrHandler as ITestHandler).SetServer( ServerEngine); + + Console.WriteLine('Starting the server ...'); + ServerEngine.serve(); + + (benchHandler as ITestHandler).SetServer( nil); + (aggrHandler as ITestHandler).SetServer( nil); + + except + on E: Exception do + begin + Console.Write( E.Message); + end; + end; + Console.WriteLine( 'done.'); +end; + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Client.dpr b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Client.dpr new file mode 100644 index 000000000..a57e93a2e --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Client.dpr @@ -0,0 +1,68 @@ +(* + * 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. + *) + + +program Multiplex.Test.Client; + +{$APPTYPE CONSOLE} + +uses + SysUtils, + Multiplex.Client.Main in 'Multiplex.Client.Main.pas', + Thrift in '..\..\src\Thrift.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Transport.Pipes in '..\..\src\Thrift.Transport.Pipes.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.Multiplex in '..\..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : string; + s : string; + +begin + try + Writeln( 'Multiplex TestClient '+Thrift.Version); + nParamCount := ParamCount; + SetLength( args, nParamCount); + for i := 1 to nParamCount do + begin + arg := ParamStr( i ); + args[i-1] := arg; + end; + TTestClient.Execute( args ); + Readln; + except + on E: Exception do begin + Writeln(E.ClassName, ': ', E.Message); + ExitCode := $FFFF; + end; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Common.pas b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Common.pas new file mode 100644 index 000000000..2caf08108 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Common.pas @@ -0,0 +1,35 @@ +(* + * 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 Multiplex.Test.Common; + +interface + +const + NAME_BENCHMARKSERVICE = 'BenchmarkService'; + NAME_AGGR = 'Aggr'; + + +implementation + +// nix + +end. + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Server.dpr b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Server.dpr new file mode 100644 index 000000000..81ed3ddc4 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Server.dpr @@ -0,0 +1,69 @@ +(* + * 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. + *) + +program Multiplex.Test.Server; + +{$APPTYPE CONSOLE} + +uses + SysUtils, + Multiplex.Server.Main in 'Multiplex.Server.Main.pas', + ConsoleHelper in '..\ConsoleHelper.pas', + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Transport.Pipes in '..\..\src\Thrift.Transport.Pipes.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.Multiplex in '..\..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Processor.Multiplex in '..\..\src\Thrift.Processor.Multiplex.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : string; + s : string; + +begin + try + Writeln( 'Multiplex TestServer '+Thrift.Version); + nParamCount := ParamCount; + SetLength( args, nParamCount); + for i := 1 to nParamCount do + begin + arg := ParamStr( i ); + args[i-1] := arg; + end; + TTestServer.Execute( args ); + Writeln('Press ENTER to close ... '); Readln; + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. + + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.Data.pas b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.Data.pas new file mode 100644 index 000000000..2420e9a2f --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.Data.pas @@ -0,0 +1,354 @@ +(* + * 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 TestSerializer.Data; + +interface + +uses + SysUtils, + Thrift.Collections, + DebugProtoTest; + + +type + Fixtures = class + public + class function CreateOneOfEach : IOneOfEach; + class function CreateNesting : INesting; + class function CreateHolyMoley : IHolyMoley; + class function CreateCompactProtoTestStruct : ICompactProtoTestStruct; + + // These byte arrays are serialized versions of the above structs. + // They were serialized in binary protocol using thrift 0.6.x and are used to + // test backwards compatibility with respect to the standard scheme. + (* + all data copied from JAVA version, + to be used later + + public static final byte[] persistentBytesOneOfEach = new byte[] { + $02, $00, $01, $01, $02, $00, $02, $00, $03, $00, + $03, $D6, $06, $00, $04, $69, $78, $08, $00, $05, + $01, $00, $00, $00, $0A, $00, $06, $00, $00, $00, + $01, $65, $A0, $BC, $00, $04, $00, $07, $40, $09, + $21, $FB, $54, $44, $2D, $18, $0B, $00, $08, $00, + $00, $00, $0D, $4A, $53, $4F, $4E, $20, $54, $48, + $49, $53, $21, $20, $22, $01, $0B, $00, $09, $00, + $00, $00, $2E, $D3, $80, $E2, $85, $AE, $CE, $9D, + $20, $D0, $9D, $CE, $BF, $E2, $85, $BF, $D0, $BE, + $C9, $A1, $D0, $B3, $D0, $B0, $CF, $81, $E2, $84, + $8E, $20, $CE, $91, $74, $74, $CE, $B1, $E2, $85, + $BD, $CE, $BA, $EF, $BF, $BD, $E2, $80, $BC, $02, + $00, $0A, $00, $0B, $00, $0B, $00, $00, $00, $06, + $62, $61, $73, $65, $36, $34, $0F, $00, $0C, $03, + $00, $00, $00, $03, $01, $02, $03, $0F, $00, $0D, + $06, $00, $00, $00, $03, $00, $01, $00, $02, $00, + $03, $0F, $00, $0E, $0A, $00, $00, $00, $03, $00, + $00, $00, $00, $00, $00, $00, $01, $00, $00, $00, + $00, $00, $00, $00, $02, $00, $00, $00, $00, $00, + $00, $00, $03, $00 }; + + + public static final byte[] persistentBytesNesting = new byte[] { + $0C, $00, $01, $08, $00, $01, $00, $00, $7A, $69, + $0B, $00, $02, $00, $00, $00, $13, $49, $20, $61, + $6D, $20, $61, $20, $62, $6F, $6E, $6B, $2E, $2E, + $2E, $20, $78, $6F, $72, $21, $00, $0C, $00, $02, + $02, $00, $01, $01, $02, $00, $02, $00, $03, $00, + $03, $D6, $06, $00, $04, $69, $78, $08, $00, $05, + $01, $00, $00, $00, $0A, $00, $06, $00, $00, $00, + $01, $65, $A0, $BC, $00, $04, $00, $07, $40, $09, + $21, $FB, $54, $44, $2D, $18, $0B, $00, $08, $00, + $00, $00, $0D, $4A, $53, $4F, $4E, $20, $54, $48, + $49, $53, $21, $20, $22, $01, $0B, $00, $09, $00, + $00, $00, $2E, $D3, $80, $E2, $85, $AE, $CE, $9D, + $20, $D0, $9D, $CE, $BF, $E2, $85, $BF, $D0, $BE, + $C9, $A1, $D0, $B3, $D0, $B0, $CF, $81, $E2, $84, + $8E, $20, $CE, $91, $74, $74, $CE, $B1, $E2, $85, + $BD, $CE, $BA, $EF, $BF, $BD, $E2, $80, $BC, $02, + $00, $0A, $00, $0B, $00, $0B, $00, $00, $00, $06, + $62, $61, $73, $65, $36, $34, $0F, $00, $0C, $03, + $00, $00, $00, $03, $01, $02, $03, $0F, $00, $0D, + $06, $00, $00, $00, $03, $00, $01, $00, $02, $00, + $03, $0F, $00, $0E, $0A, $00, $00, $00, $03, $00, + $00, $00, $00, $00, $00, $00, $01, $00, $00, $00, + $00, $00, $00, $00, $02, $00, $00, $00, $00, $00, + $00, $00, $03, $00, $00 }; + + public static final byte[] persistentBytesHolyMoley = new byte[] { + $0F, $00, $01, $0C, $00, $00, $00, $02, $02, $00, + $01, $01, $02, $00, $02, $00, $03, $00, $03, $23, + $06, $00, $04, $69, $78, $08, $00, $05, $01, $00, + $00, $00, $0A, $00, $06, $00, $00, $00, $01, $65, + $A0, $BC, $00, $04, $00, $07, $40, $09, $21, $FB, + $54, $44, $2D, $18, $0B, $00, $08, $00, $00, $00, + $0D, $4A, $53, $4F, $4E, $20, $54, $48, $49, $53, + $21, $20, $22, $01, $0B, $00, $09, $00, $00, $00, + $2E, $D3, $80, $E2, $85, $AE, $CE, $9D, $20, $D0, + $9D, $CE, $BF, $E2, $85, $BF, $D0, $BE, $C9, $A1, + $D0, $B3, $D0, $B0, $CF, $81, $E2, $84, $8E, $20, + $CE, $91, $74, $74, $CE, $B1, $E2, $85, $BD, $CE, + $BA, $EF, $BF, $BD, $E2, $80, $BC, $02, $00, $0A, + $00, $0B, $00, $0B, $00, $00, $00, $06, $62, $61, + $73, $65, $36, $34, $0F, $00, $0C, $03, $00, $00, + $00, $03, $01, $02, $03, $0F, $00, $0D, $06, $00, + $00, $00, $03, $00, $01, $00, $02, $00, $03, $0F, + $00, $0E, $0A, $00, $00, $00, $03, $00, $00, $00, + $00, $00, $00, $00, $01, $00, $00, $00, $00, $00, + $00, $00, $02, $00, $00, $00, $00, $00, $00, $00, + $03, $00, $02, $00, $01, $01, $02, $00, $02, $00, + $03, $00, $03, $D6, $06, $00, $04, $69, $78, $08, + $00, $05, $01, $00, $00, $00, $0A, $00, $06, $00, + $00, $00, $01, $65, $A0, $BC, $00, $04, $00, $07, + $40, $09, $21, $FB, $54, $44, $2D, $18, $0B, $00, + $08, $00, $00, $00, $0D, $4A, $53, $4F, $4E, $20, + $54, $48, $49, $53, $21, $20, $22, $01, $0B, $00, + $09, $00, $00, $00, $2E, $D3, $80, $E2, $85, $AE, + $CE, $9D, $20, $D0, $9D, $CE, $BF, $E2, $85, $BF, + $D0, $BE, $C9, $A1, $D0, $B3, $D0, $B0, $CF, $81, + $E2, $84, $8E, $20, $CE, $91, $74, $74, $CE, $B1, + $E2, $85, $BD, $CE, $BA, $EF, $BF, $BD, $E2, $80, + $BC, $02, $00, $0A, $00, $0B, $00, $0B, $00, $00, + $00, $06, $62, $61, $73, $65, $36, $34, $0F, $00, + $0C, $03, $00, $00, $00, $03, $01, $02, $03, $0F, + $00, $0D, $06, $00, $00, $00, $03, $00, $01, $00, + $02, $00, $03, $0F, $00, $0E, $0A, $00, $00, $00, + $03, $00, $00, $00, $00, $00, $00, $00, $01, $00, + $00, $00, $00, $00, $00, $00, $02, $00, $00, $00, + $00, $00, $00, $00, $03, $00, $0E, $00, $02, $0F, + $00, $00, $00, $03, $0B, $00, $00, $00, $00, $0B, + $00, $00, $00, $03, $00, $00, $00, $0F, $74, $68, + $65, $6E, $20, $61, $20, $6F, $6E, $65, $2C, $20, + $74, $77, $6F, $00, $00, $00, $06, $74, $68, $72, + $65, $65, $21, $00, $00, $00, $06, $46, $4F, $55, + $52, $21, $21, $0B, $00, $00, $00, $02, $00, $00, + $00, $09, $61, $6E, $64, $20, $61, $20, $6F, $6E, + $65, $00, $00, $00, $09, $61, $6E, $64, $20, $61, + $20, $74, $77, $6F, $0D, $00, $03, $0B, $0F, $00, + $00, $00, $03, $00, $00, $00, $03, $74, $77, $6F, + $0C, $00, $00, $00, $02, $08, $00, $01, $00, $00, + $00, $01, $0B, $00, $02, $00, $00, $00, $05, $57, + $61, $69, $74, $2E, $00, $08, $00, $01, $00, $00, + $00, $02, $0B, $00, $02, $00, $00, $00, $05, $57, + $68, $61, $74, $3F, $00, $00, $00, $00, $05, $74, + $68, $72, $65, $65, $0C, $00, $00, $00, $00, $00, + $00, $00, $04, $7A, $65, $72, $6F, $0C, $00, $00, + $00, $00, $00 }; + + +*) + + private + const + kUnicodeBytes : packed array[0..43] of Byte + = ( $d3, $80, $e2, $85, $ae, $ce, $9d, $20, $d0, $9d, + $ce, $bf, $e2, $85, $bf, $d0, $be, $c9, $a1, $d0, + $b3, $d0, $b0, $cf, $81, $e2, $84, $8e, $20, $ce, + $91, $74, $74, $ce, $b1, $e2, $85, $bd, $ce, $ba, + $83, $e2, $80, $bc); + + end; + + +implementation + + +class function Fixtures.CreateOneOfEach : IOneOfEach; +var db : Double; + us : Utf8String; +begin + result := TOneOfEachImpl.Create; + result.setIm_true( TRUE); + result.setIm_false( FALSE); + result.setA_bite( ShortInt($D6)); + result.setInteger16( 27000); + result.setInteger32( 1 shl 24); + result.setInteger64( Int64(6000) * Int64(1000) * Int64(1000)); + db := Pi; + result.setDouble_precision( db); + result.setSome_characters( 'JSON THIS! \"\1'); + + // ?? + SetLength( us, Length(kUnicodeBytes)); + Move( kUnicodeBytes[0], us[1], Length(kUnicodeBytes)); + // ?? + SetString( us, PChar(@kUnicodeBytes[0]), Length(kUnicodeBytes)); + // !! + result.setZomg_unicode( UnicodeString( us)); + + {$IF cDebugProtoTest_Option_AnsiStr_Binary} + result.SetBase64('base64'); + {$ELSE} + result.SetBase64( TEncoding.UTF8.GetBytes('base64')); + {$IFEND} + + // byte, i16, and i64 lists are populated by default constructor +end; + + +class function Fixtures.CreateNesting : INesting; +var bonk : IBonk; +begin + bonk := TBonkImpl.Create; + bonk.Type_ := 31337; + bonk.Message := 'I am a bonk... xor!'; + + result := TNestingImpl.Create; + result.My_bonk := bonk; + result.My_ooe := CreateOneOfEach; +end; + + +class function Fixtures.CreateHolyMoley : IHolyMoley; +var big : IThriftList<IOneOfEach>; + stage1 : IThriftList<String>; + stage2 : IThriftList<IBonk>; + b : IBonk; +begin + result := THolyMoleyImpl.Create; + + big := TThriftListImpl<IOneOfEach>.Create; + big.add( CreateOneOfEach); + big.add( CreateNesting.my_ooe); + result.Big := big; + result.Big[0].setA_bite( $22); + result.Big[0].setA_bite( $23); + + result.Contain := THashSetImpl< IThriftList<string>>.Create; + stage1 := TThriftListImpl<String>.Create; + stage1.add( 'and a one'); + stage1.add( 'and a two'); + result.Contain.add( stage1); + + stage1 := TThriftListImpl<String>.Create; + stage1.add( 'then a one, two'); + stage1.add( 'three!'); + stage1.add( 'FOUR!!'); + result.Contain.add( stage1); + + stage1 := TThriftListImpl<String>.Create; + result.Contain.add( stage1); + + stage2 := TThriftListImpl<IBonk>.Create; + result.Bonks := TThriftDictionaryImpl< String, IThriftList< IBonk>>.Create; + // one empty + result.Bonks.Add( 'zero', stage2); + + // one with two + stage2 := TThriftListImpl<IBonk>.Create; + b := TBonkImpl.Create; + b.type_ := 1; + b.message := 'Wait.'; + stage2.Add( b); + b := TBonkImpl.Create; + b.type_ := 2; + b.message := 'What?'; + stage2.Add( b); + result.Bonks.Add( 'two', stage2); + + // one with three + stage2 := TThriftListImpl<IBonk>.Create; + b := TBonkImpl.Create; + b.type_ := 3; + b.message := 'quoth'; + stage2.Add( b); + b := TBonkImpl.Create; + b.type_ := 4; + b.message := 'the raven'; + stage2.Add( b); + b := TBonkImpl.Create; + b.type_ := 5; + b.message := 'nevermore'; + stage2.Add( b); + result.bonks.Add( 'three', stage2); +end; + + +class function Fixtures.CreateCompactProtoTestStruct : ICompactProtoTestStruct; +// superhuge compact proto test struct +begin + result := TCompactProtoTestStructImpl.Create; + result.A_byte := TDebugProtoTestConstants.COMPACT_TEST.A_byte; + result.A_i16 := TDebugProtoTestConstants.COMPACT_TEST.A_i16; + result.A_i32 := TDebugProtoTestConstants.COMPACT_TEST.A_i32; + result.A_i64 := TDebugProtoTestConstants.COMPACT_TEST.A_i64; + result.A_double := TDebugProtoTestConstants.COMPACT_TEST.A_double; + result.A_string := TDebugProtoTestConstants.COMPACT_TEST.A_string; + result.A_binary := TDebugProtoTestConstants.COMPACT_TEST.A_binary; + result.True_field := TDebugProtoTestConstants.COMPACT_TEST.True_field; + result.False_field := TDebugProtoTestConstants.COMPACT_TEST.False_field; + result.Empty_struct_field := TDebugProtoTestConstants.COMPACT_TEST.Empty_struct_field; + result.Byte_list := TDebugProtoTestConstants.COMPACT_TEST.Byte_list; + result.I16_list := TDebugProtoTestConstants.COMPACT_TEST.I16_list; + result.I32_list := TDebugProtoTestConstants.COMPACT_TEST.I32_list; + result.I64_list := TDebugProtoTestConstants.COMPACT_TEST.I64_list; + result.Double_list := TDebugProtoTestConstants.COMPACT_TEST.Double_list; + result.String_list := TDebugProtoTestConstants.COMPACT_TEST.String_list; + result.Binary_list := TDebugProtoTestConstants.COMPACT_TEST.Binary_list; + result.Boolean_list := TDebugProtoTestConstants.COMPACT_TEST.Boolean_list; + result.Struct_list := TDebugProtoTestConstants.COMPACT_TEST.Struct_list; + result.Byte_set := TDebugProtoTestConstants.COMPACT_TEST.Byte_set; + result.I16_set := TDebugProtoTestConstants.COMPACT_TEST.I16_set; + result.I32_set := TDebugProtoTestConstants.COMPACT_TEST.I32_set; + result.I64_set := TDebugProtoTestConstants.COMPACT_TEST.I64_set; + result.Double_set := TDebugProtoTestConstants.COMPACT_TEST.Double_set; + result.String_set := TDebugProtoTestConstants.COMPACT_TEST.String_set; + result.String_set := TDebugProtoTestConstants.COMPACT_TEST.String_set; + result.String_set := TDebugProtoTestConstants.COMPACT_TEST.String_set; + result.Binary_set := TDebugProtoTestConstants.COMPACT_TEST.Binary_set; + result.Boolean_set := TDebugProtoTestConstants.COMPACT_TEST.Boolean_set; + result.Struct_set := TDebugProtoTestConstants.COMPACT_TEST.Struct_set; + result.Byte_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_byte_map; + result.I16_byte_map := TDebugProtoTestConstants.COMPACT_TEST.I16_byte_map; + result.I32_byte_map := TDebugProtoTestConstants.COMPACT_TEST.I32_byte_map; + result.I64_byte_map := TDebugProtoTestConstants.COMPACT_TEST.I64_byte_map; + result.Double_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Double_byte_map; + result.String_byte_map := TDebugProtoTestConstants.COMPACT_TEST.String_byte_map; + result.Binary_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Binary_byte_map; + result.Boolean_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Boolean_byte_map; + result.Byte_i16_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_i16_map; + result.Byte_i32_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_i32_map; + result.Byte_i64_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_i64_map; + result.Byte_double_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_double_map; + result.Byte_string_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_string_map; + result.Byte_binary_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_binary_map; + result.Byte_boolean_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_boolean_map; + result.List_byte_map := TDebugProtoTestConstants.COMPACT_TEST.List_byte_map; + result.Set_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Set_byte_map; + result.Map_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Map_byte_map; + result.Byte_map_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_map_map; + result.Byte_set_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_set_map; + result.Byte_list_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_list_map; + + result.Field500 := 500; + result.Field5000 := 5000; + result.Field20000 := 20000; + + {$IF cDebugProtoTest_Option_AnsiStr_Binary} + result.A_binary := AnsiString( #0#1#2#3#4#5#6#7#8); + {$ELSE} + result.A_binary := TEncoding.UTF8.GetBytes( #0#1#2#3#4#5#6#7#8); + {$IFEND} +end; + + + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.dpr b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.dpr new file mode 100644 index 000000000..56d0d15d4 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.dpr @@ -0,0 +1,283 @@ +(* + * 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. + *) + +program TestSerializer; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, Generics.Collections, + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Protocol.Compact in '..\..\src\Thrift.Protocol.Compact.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.Serializer in '..\..\src\Thrift.Serializer.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + System_, + DebugProtoTest, + TestSerializer.Data; + + + +type + TTestSerializer = class //extends TestCase { + private type + TMethod = ( + mt_Bytes, + mt_Stream + ); + + private + FProtocols : TList< IProtocolFactory>; + + class function Serialize(const input : IBase; const factory : IProtocolFactory) : TBytes; overload; + class procedure Serialize(const input : IBase; const factory : IProtocolFactory; const aStream : TStream); overload; + class procedure Deserialize( const input : TBytes; const target : IBase; const factory : IProtocolFactory); overload; + class procedure Deserialize( const input : TStream; const target : IBase; const factory : IProtocolFactory); overload; + + procedure Test_Serializer_Deserializer; + procedure Test_OneOfEach( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); + procedure Test_CompactStruct( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); + + public + constructor Create; + destructor Destroy; override; + + procedure RunTests; + end; + + + +{ TTestSerializer } + +constructor TTestSerializer.Create; +begin + inherited Create; + FProtocols := TList< IProtocolFactory>.Create; + FProtocols.Add( TBinaryProtocolImpl.TFactory.Create); + FProtocols.Add( TCompactProtocolImpl.TFactory.Create); + FProtocols.Add( TJSONProtocolImpl.TFactory.Create); +end; + + +destructor TTestSerializer.Destroy; +begin + try + FreeAndNil( FProtocols); + finally + inherited Destroy; + end; +end; + + +procedure TTestSerializer.Test_OneOfEach( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); +var tested, correct : IOneOfEach; + bytes : TBytes; + i : Integer; +begin + // write + tested := Fixtures.CreateOneOfEach; + case method of + mt_Bytes: bytes := Serialize( tested, factory); + mt_Stream: begin + stream.Size := 0; + Serialize( tested, factory, stream); + end + else + ASSERT( FALSE); + end; + + // init + read + tested := TOneOfEachImpl.Create; + case method of + mt_Bytes: Deserialize( bytes, tested, factory); + mt_Stream: begin + stream.Position := 0; + Deserialize( stream, tested, factory); + end + else + ASSERT( FALSE); + end; + + // check + correct := Fixtures.CreateOneOfEach; + ASSERT( tested.Im_true = correct.Im_true); + ASSERT( tested.Im_false = correct.Im_false); + ASSERT( tested.A_bite = correct.A_bite); + ASSERT( tested.Integer16 = correct.Integer16); + ASSERT( tested.Integer32 = correct.Integer32); + ASSERT( tested.Integer64 = correct.Integer64); + ASSERT( Abs( tested.Double_precision - correct.Double_precision) < 1E-12); + ASSERT( tested.Some_characters = correct.Some_characters); + ASSERT( tested.Zomg_unicode = correct.Zomg_unicode); + ASSERT( tested.What_who = correct.What_who); + + ASSERT( Length(tested.Base64) = Length(correct.Base64)); + ASSERT( CompareMem( @tested.Base64[0], @correct.Base64[0], Length(correct.Base64))); + + ASSERT( tested.Byte_list.Count = correct.Byte_list.Count); + for i := 0 to tested.Byte_list.Count-1 + do ASSERT( tested.Byte_list[i] = correct.Byte_list[i]); + + ASSERT( tested.I16_list.Count = correct.I16_list.Count); + for i := 0 to tested.I16_list.Count-1 + do ASSERT( tested.I16_list[i] = correct.I16_list[i]); + + ASSERT( tested.I64_list.Count = correct.I64_list.Count); + for i := 0 to tested.I64_list.Count-1 + do ASSERT( tested.I64_list[i] = correct.I64_list[i]); +end; + + +procedure TTestSerializer.Test_CompactStruct( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); +var tested, correct : ICompactProtoTestStruct; + bytes : TBytes; +begin + // write + tested := Fixtures.CreateCompactProtoTestStruct; + case method of + mt_Bytes: bytes := Serialize( tested, factory); + mt_Stream: begin + stream.Size := 0; + Serialize( tested, factory, stream); + end + else + ASSERT( FALSE); + end; + + // init + read + correct := TCompactProtoTestStructImpl.Create; + case method of + mt_Bytes: Deserialize( bytes, tested, factory); + mt_Stream: begin + stream.Position := 0; + Deserialize( stream, tested, factory); + end + else + ASSERT( FALSE); + end; + + // check + correct := Fixtures.CreateCompactProtoTestStruct; + ASSERT( correct.Field500 = tested.Field500); + ASSERT( correct.Field5000 = tested.Field5000); + ASSERT( correct.Field20000 = tested.Field20000); +end; + + +procedure TTestSerializer.Test_Serializer_Deserializer; +var factory : IProtocolFactory; + stream : TFileStream; + method : TMethod; +begin + stream := TFileStream.Create( 'TestSerializer.dat', fmCreate); + try + + for method in [Low(TMethod)..High(TMethod)] do begin + for factory in FProtocols do begin + + Test_OneOfEach( method, factory, stream); + Test_CompactStruct( method, factory, stream); + end; + end; + + finally + stream.Free; + end; +end; + + +procedure TTestSerializer.RunTests; +begin + try + Test_Serializer_Deserializer; + except + on e:Exception do begin + Writeln( e.Message); + Write('Hit ENTER to close ... '); Readln; + end; + end; +end; + + +class function TTestSerializer.Serialize(const input : IBase; const factory : IProtocolFactory) : TBytes; +var serial : TSerializer; +begin + serial := TSerializer.Create( factory); + try + result := serial.Serialize( input); + finally + serial.Free; + end; +end; + + +class procedure TTestSerializer.Serialize(const input : IBase; const factory : IProtocolFactory; const aStream : TStream); +var serial : TSerializer; +begin + serial := TSerializer.Create( factory); + try + serial.Serialize( input, aStream); + finally + serial.Free; + end; +end; + + +class procedure TTestSerializer.Deserialize( const input : TBytes; const target : IBase; const factory : IProtocolFactory); +var serial : TDeserializer; +begin + serial := TDeserializer.Create( factory); + try + serial.Deserialize( input, target); + finally + serial.Free; + end; +end; + +class procedure TTestSerializer.Deserialize( const input : TStream; const target : IBase; const factory : IProtocolFactory); +var serial : TDeserializer; +begin + serial := TDeserializer.Create( factory); + try + serial.Deserialize( input, target); + finally + serial.Free; + end; +end; + + +var test : TTestSerializer; +begin + test := TTestSerializer.Create; + try + test.RunTests; + finally + test.Free; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/server.dpr b/src/jaegertracing/thrift/lib/delphi/test/server.dpr new file mode 100644 index 000000000..9731dd4fa --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/server.dpr @@ -0,0 +1,74 @@ +(* + * 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. + *) + +program server; + +{$APPTYPE CONSOLE} + +uses + SysUtils, + TestServer in 'TestServer.pas', + TestServerEvents in 'TestServerEvents.pas', + Thrift.Test, // in gen-delphi folder + Thrift in '..\src\Thrift.pas', + Thrift.Exception in '..\src\Thrift.Exception.pas', + Thrift.Transport in '..\src\Thrift.Transport.pas', + Thrift.Socket in '..\src\Thrift.Socket.pas', + Thrift.Transport.Pipes in '..\src\Thrift.Transport.Pipes.pas', + Thrift.Protocol in '..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\src\Thrift.Protocol.JSON.pas', + Thrift.Protocol.Compact in '..\src\Thrift.Protocol.Compact.pas', + Thrift.Protocol.Multiplex in '..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Processor.Multiplex in '..\src\Thrift.Processor.Multiplex.pas', + Thrift.Collections in '..\src\Thrift.Collections.pas', + Thrift.Server in '..\src\Thrift.Server.pas', + Thrift.TypeRegistry in '..\src\Thrift.TypeRegistry.pas', + Thrift.Utils in '..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\src\Thrift.WinHTTP.pas', + Thrift.Stream in '..\src\Thrift.Stream.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : string; + +begin + try + Writeln( 'Delphi TestServer '+Thrift.Version); + nParamCount := ParamCount; + SetLength( args, nParamCount); + for i := 1 to nParamCount do begin + arg := ParamStr( i ); + args[i-1] := arg; + end; + + TTestServer.Execute( args ); + + except + on E: EAbort do begin + ExitCode := $FF; + end; + on E: Exception do begin + Writeln(E.ClassName, ': ', E.Message); + ExitCode := $FF; + end; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/README.md b/src/jaegertracing/thrift/lib/delphi/test/skip/README.md new file mode 100644 index 000000000..f34936834 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/README.md @@ -0,0 +1,11 @@ +These two projects belong together. Both programs +simulate server and client for different versions +of the same protocol. + +The intention of this test is to ensure fully +working compatibility features of the Delphi Thrift +implementation. + +The expected test result is, that no errors occur +with both programs, regardless in which order they +might be started. diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_1.thrift b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_1.thrift new file mode 100644 index 000000000..8353c5e12 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_1.thrift @@ -0,0 +1,45 @@ +/* + * 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. + */ + + +// version 1 of the interface + +namespace * Skiptest.One + +const i32 SKIPTESTSERVICE_VERSION = 1 + +struct Pong { + 1 : optional i32 version1 +} + +struct Ping { + 1 : optional i32 version1 +} + +exception PongFailed { + 222 : optional i32 pongErrorCode +} + + +service SkipTestService { + void PingPong( 1: Ping pong) throws (444: PongFailed pof); +} + + +// EOF
\ No newline at end of file diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_2.thrift b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_2.thrift new file mode 100644 index 000000000..f3352d327 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_2.thrift @@ -0,0 +1,69 @@ +/* + * 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. + */ + + +// version 2 of the interface + +namespace * Skiptest.Two + +const i32 SKIPTESTSERVICE_VERSION = 2 + +struct Pong { + 1 : optional i32 version1 + 2 : optional i16 version2 +} + +struct Ping { + 1 : optional i32 version1 + 10 : optional bool boolVal + 11 : optional byte byteVal + 12 : optional double dbVal + 13 : optional i16 i16Val + 14 : optional i32 i32Val + 15 : optional i64 i64Val + 16 : optional string strVal + 17 : optional Pong structVal + 18 : optional map< list< Pong>, set< string>> mapVal +} + +exception PingFailed { + 1 : optional i32 pingErrorCode +} + +exception PongFailed { + 222 : optional i32 pongErrorCode + 10 : optional bool boolVal + 11 : optional byte byteVal + 12 : optional double dbVal + 13 : optional i16 i16Val + 14 : optional i32 i32Val + 15 : optional i64 i64Val + 16 : optional string strVal + 17 : optional Pong structVal + 18 : optional map< list< Pong>, set< string>> mapVal +} + + +service SkipTestService { + Ping PingPong( 1: Ping ping, 3: Pong pong) throws (1: PingFailed pif, 444: PongFailed pof); +} + + +// EOF + diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version1.dpr b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version1.dpr new file mode 100644 index 000000000..0bfe96fef --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version1.dpr @@ -0,0 +1,202 @@ +(* + * 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. + *) + +program skiptest_version1; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, + Skiptest.One, + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas'; + +const + REQUEST_EXT = '.request'; + RESPONSE_EXT = '.response'; + + +function CreatePing : IPing; +begin + result := TPingImpl.Create; + result.Version1 := Tskiptest_version_1Constants.SKIPTESTSERVICE_VERSION; +end; + + +type + TDummyServer = class( TInterfacedObject, TSkipTestService.Iface) + protected + // TSkipTestService.Iface + procedure PingPong(const ping: IPing); + end; + + +procedure TDummyServer.PingPong(const ping: IPing); +// TSkipTestService.Iface +begin + Writeln('- performing request from version '+IntToStr(ping.Version1)+' client'); +end; + + +function CreateProtocol( protfact : IProtocolFactory; stm : TStream; aForInput : Boolean) : IProtocol; +var adapt : IThriftStream; + trans : ITransport; +begin + adapt := TThriftStreamAdapterDelphi.Create( stm, FALSE); + if aForInput + then trans := TStreamTransportImpl.Create( adapt, nil) + else trans := TStreamTransportImpl.Create( nil, adapt); + result := protfact.GetProtocol( trans); +end; + + +procedure CreateRequest( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + ping : IPing; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- creating new request'); + stm := TFileStream.Create( fname+REQUEST_EXT+'.tmp', fmCreate); + try + ping := CreatePing; + + // save request data + proto := CreateProtocol( protfact, stm, FALSE); + client := TSkipTestService.TClient.Create( nil, proto); + cliRef := client as IUnknown; + client.send_PingPong( ping); + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; + + DeleteFile( fname+REQUEST_EXT); + RenameFile( fname+REQUEST_EXT+'.tmp', fname+REQUEST_EXT); +end; + + +procedure ReadResponse( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- reading response'); + stm := TFileStream.Create( fname+RESPONSE_EXT, fmOpenRead); + try + // save request data + proto := CreateProtocol( protfact, stm, TRUE); + client := TSkipTestService.TClient.Create( proto, nil); + cliRef := client as IUnknown; + client.recv_PingPong; + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; +end; + + +procedure ProcessFile( protfact : IProtocolFactory; fname : string); +var stmIn, stmOut : TFileStream; + protIn, protOut : IProtocol; + server : IProcessor; +begin + Writeln('- processing request'); + stmOut := nil; + stmIn := TFileStream.Create( fname+REQUEST_EXT, fmOpenRead); + try + stmOut := TFileStream.Create( fname+RESPONSE_EXT+'.tmp', fmCreate); + + // process request and write response data + protIn := CreateProtocol( protfact, stmIn, TRUE); + protOut := CreateProtocol( protfact, stmOut, FALSE); + + server := TSkipTestService.TProcessorImpl.Create( TDummyServer.Create); + server.Process( protIn, protOut); + + finally + server := nil; // not Free! + stmIn.Free; + stmOut.Free; + if server = nil then {warning suppressed}; + end; + + DeleteFile( fname+RESPONSE_EXT); + RenameFile( fname+RESPONSE_EXT+'.tmp', fname+RESPONSE_EXT); +end; + + +procedure Test( protfact : IProtocolFactory; fname : string); +begin + // try to read an existing request + if FileExists( fname + REQUEST_EXT) then begin + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); + end; + + // create a new request and try to process + CreateRequest( protfact, fname); + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); +end; + + +const + FILE_BINARY = 'pingpong.bin'; + FILE_JSON = 'pingpong.json'; +begin + try + Writeln( 'Delphi SkipTest '+IntToStr(Tskiptest_version_1Constants.SKIPTESTSERVICE_VERSION)+' using '+Thrift.Version); + + Writeln; + Writeln('Binary protocol'); + Test( TBinaryProtocolImpl.TFactory.Create, FILE_BINARY); + + Writeln; + Writeln('JSON protocol'); + Test( TJSONProtocolImpl.TFactory.Create, FILE_JSON); + + Writeln; + Writeln('Test completed without errors.'); + Writeln; + Write('Press ENTER to close ...'); Readln; + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version2.dpr b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version2.dpr new file mode 100644 index 000000000..7893748a0 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version2.dpr @@ -0,0 +1,229 @@ +(* + * 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. + *) + +program skiptest_version2; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, + Skiptest.Two, + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas'; + +const + REQUEST_EXT = '.request'; + RESPONSE_EXT = '.response'; + +function CreatePing : IPing; +var list : IThriftList<IPong>; + set_ : IHashSet<string>; +begin + result := TPingImpl.Create; + result.Version1 := Tskiptest_version_2Constants.SKIPTESTSERVICE_VERSION; + result.BoolVal := TRUE; + result.ByteVal := 2; + result.DbVal := 3; + result.I16Val := 4; + result.I32Val := 5; + result.I64Val := 6; + result.StrVal := 'seven'; + + result.StructVal := TPongImpl.Create; + result.StructVal.Version1 := -1; + result.StructVal.Version2 := -2; + + list := TThriftListImpl<IPong>.Create; + list.Add( result.StructVal); + list.Add( result.StructVal); + + set_ := THashSetImpl<string>.Create; + set_.Add( 'one'); + set_.Add( 'uno'); + set_.Add( 'eins'); + set_.Add( 'een'); + + result.MapVal := TThriftDictionaryImpl< IThriftList<IPong>, IHashSet<string>>.Create; + result.MapVal.Add( list, set_); +end; + + +type + TDummyServer = class( TInterfacedObject, TSkipTestService.Iface) + protected + // TSkipTestService.Iface + function PingPong(const ping: IPing; const pong: IPong): IPing; + end; + + +function TDummyServer.PingPong(const ping: IPing; const pong: IPong): IPing; +// TSkipTestService.Iface +begin + Writeln('- performing request from version '+IntToStr(ping.Version1)+' client'); + result := CreatePing; +end; + + +function CreateProtocol( protfact : IProtocolFactory; stm : TStream; aForInput : Boolean) : IProtocol; +var adapt : IThriftStream; + trans : ITransport; +begin + adapt := TThriftStreamAdapterDelphi.Create( stm, FALSE); + if aForInput + then trans := TStreamTransportImpl.Create( adapt, nil) + else trans := TStreamTransportImpl.Create( nil, adapt); + result := protfact.GetProtocol( trans); +end; + + +procedure CreateRequest( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + ping : IPing; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- creating new request'); + stm := TFileStream.Create( fname+REQUEST_EXT+'.tmp', fmCreate); + try + ping := CreatePing; + + // save request data + proto := CreateProtocol( protfact, stm, FALSE); + client := TSkipTestService.TClient.Create( nil, proto); + cliRef := client as IUnknown; + client.send_PingPong( ping, ping.StructVal); + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; + + DeleteFile( fname+REQUEST_EXT); + RenameFile( fname+REQUEST_EXT+'.tmp', fname+REQUEST_EXT); +end; + + +procedure ReadResponse( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + ping : IPing; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- reading response'); + stm := TFileStream.Create( fname+RESPONSE_EXT, fmOpenRead); + try + // save request data + proto := CreateProtocol( protfact, stm, TRUE); + client := TSkipTestService.TClient.Create( proto, nil); + cliRef := client as IUnknown; + ping := client.recv_PingPong; + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; +end; + + +procedure ProcessFile( protfact : IProtocolFactory; fname : string); +var stmIn, stmOut : TFileStream; + protIn, protOut : IProtocol; + server : IProcessor; +begin + Writeln('- processing request'); + stmOut := nil; + stmIn := TFileStream.Create( fname+REQUEST_EXT, fmOpenRead); + try + stmOut := TFileStream.Create( fname+RESPONSE_EXT+'.tmp', fmCreate); + + // process request and write response data + protIn := CreateProtocol( protfact, stmIn, TRUE); + protOut := CreateProtocol( protfact, stmOut, FALSE); + + server := TSkipTestService.TProcessorImpl.Create( TDummyServer.Create); + server.Process( protIn, protOut); + + finally + server := nil; // not Free! + stmIn.Free; + stmOut.Free; + if server = nil then {warning suppressed}; + end; + + DeleteFile( fname+RESPONSE_EXT); + RenameFile( fname+RESPONSE_EXT+'.tmp', fname+RESPONSE_EXT); +end; + + +procedure Test( protfact : IProtocolFactory; fname : string); +begin + // try to read an existing request + if FileExists( fname + REQUEST_EXT) then begin + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); + end; + + // create a new request and try to process + CreateRequest( protfact, fname); + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); +end; + + +const + FILE_BINARY = 'pingpong.bin'; + FILE_JSON = 'pingpong.json'; +begin + try + Writeln( 'Delphi SkipTest '+IntToStr(Tskiptest_version_2Constants.SKIPTESTSERVICE_VERSION)+' using '+Thrift.Version); + + Writeln; + Writeln('Binary protocol'); + Test( TBinaryProtocolImpl.TFactory.Create, FILE_BINARY); + + Writeln; + Writeln('JSON protocol'); + Test( TJSONProtocolImpl.TFactory.Create, FILE_JSON); + + Writeln; + Writeln('Test completed without errors.'); + Writeln; + Write('Press ENTER to close ...'); Readln; + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/typeregistry/TestTypeRegistry.dpr b/src/jaegertracing/thrift/lib/delphi/test/typeregistry/TestTypeRegistry.dpr new file mode 100644 index 000000000..fd5e3dd4e --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/typeregistry/TestTypeRegistry.dpr @@ -0,0 +1,91 @@ +(* + * 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. + *) + +program TestTypeRegistry; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, Generics.Collections, TypInfo, + Thrift in '..\..\src\Thrift.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.Serializer in '..\..\src\Thrift.Serializer.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + DebugProtoTest; + +type + Tester<T : IInterface> = class + public + class procedure Test; + end; + +class procedure Tester<T>.Test; +var instance : T; + name : string; +begin + instance := TypeRegistry.Construct<T>; + name := GetTypeName(TypeInfo(T)); + if instance <> nil + then Writeln( name, ' = ok') + else begin + Writeln( name, ' = failed'); + raise Exception.Create( 'Test with '+name+' failed!'); + end; +end; + +begin + Writeln('Testing ...'); + Tester<IDoubles>.Test; + Tester<IOneOfEach>.Test; + Tester<IBonk>.Test; + Tester<INesting>.Test; + Tester<IHolyMoley>.Test; + Tester<IBackwards>.Test; + Tester<IEmpty>.Test; + Tester<IWrapper>.Test; + Tester<IRandomStuff>.Test; + Tester<IBase64>.Test; + Tester<ICompactProtoTestStruct>.Test; + Tester<ISingleMapTestStruct>.Test; + Tester<IBlowUp>.Test; + Tester<IReverseOrderStruct>.Test; + Tester<IStructWithSomeEnum>.Test; + Tester<ITestUnion>.Test; + Tester<ITestUnionMinusStringField>.Test; + Tester<IComparableUnion>.Test; + Tester<IStructWithAUnion>.Test; + Tester<IPrimitiveThenStruct>.Test; + Tester<IStructWithASomemap>.Test; + Tester<IBigFieldIdStruct>.Test; + Tester<IBreaksRubyCompactProtocol>.Test; + Tester<ITupleProtocolTestStruct>.Test; + Writeln('Completed.'); + + +end. + |