ceph/src/jaegertracing/thrift/lib/delphi/src/Thrift.Protocol.JSON.pas

   1 (*
   2  * Licensed to the Apache Software Foundation (ASF) under one
   3  * or more contributor license agreements. See the NOTICE file
   4  * distributed with this work for additional information
   5  * regarding copyright ownership. The ASF licenses this file
   6  * to you under the Apache License, Version 2.0 (the
   7  * "License"); you may not use this file except in compliance
   8  * with the License. You may obtain a copy of the License at
   9  *
  10  *   http://www.apache.org/licenses/LICENSE-2.0
  11  *
  12  * Unless required by applicable law or agreed to in writing,
  13  * software distributed under the License is distributed on an
  14  * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
  15  * KIND, either express or implied. See the License for the
  16  * specific language governing permissions and limitations
  17  * under the License.
  18  *)
  19
  20 {$SCOPEDENUMS ON}
  21
  22 unit Thrift.Protocol.JSON;
  23
  24 interface
  25
  26 uses
  27   Character,
  28   Classes,
  29   SysUtils,
  30   Math,
  31   Generics.Collections,
  32   Thrift.Transport,
  33   Thrift.Protocol,
  34   Thrift.Utils;
  35
  36 type
  37   IJSONProtocol = interface( IProtocol)
  38     ['{F0DAFDBD-692A-4B71-9736-F5D485A2178F}']
  39     // Read a byte that must match b; otherwise an exception is thrown.
  40     procedure ReadJSONSyntaxChar( b : Byte);
  41   end;
  42
  43   // JSON protocol implementation for thrift.
  44   // This is a full-featured protocol supporting Write and Read.
  45   // Please see the C++ class header for a detailed description of the protocol's wire format.
  46   // Adapted from the C# version.
  47   TJSONProtocolImpl = class( TProtocolImpl, IJSONProtocol)
  48   public
  49     type
  50       TFactory = class( TInterfacedObject, IProtocolFactory)
  51       public
  52         function GetProtocol( const trans: ITransport): IProtocol;
  53       end;
  54
  55   private
  56     class function GetTypeNameForTypeID(typeID : TType) : string;
  57     class function GetTypeIDForTypeName( const name : string) : TType;
  58
  59   protected
  60     type
  61       // Base class for tracking JSON contexts that may require
  62       // inserting/Reading additional JSON syntax characters.
  63       // This base context does nothing.
  64       TJSONBaseContext = class
  65       protected
  66         FProto : Pointer;  // weak IJSONProtocol;
  67       public
  68         constructor Create( const aProto : IJSONProtocol);
  69         procedure Write;  virtual;
  70         procedure Read;  virtual;
  71         function EscapeNumbers : Boolean;  virtual;
  72       end;
  73
  74       // Context for JSON lists.
  75       // Will insert/Read commas before each item except for the first one.
  76       TJSONListContext = class( TJSONBaseContext)
  77       private
  78         FFirst : Boolean;
  79       public
  80         constructor Create( const aProto : IJSONProtocol);
  81         procedure Write;  override;
  82         procedure Read;  override;
  83       end;
  84
  85       // Context for JSON records. Will insert/Read colons before the value portion of each record
  86       // pair, and commas before each key except the first. In addition, will indicate that numbers
  87       // in the key position need to be escaped in quotes (since JSON keys must be strings).
  88       TJSONPairContext = class( TJSONBaseContext)
  89       private
  90         FFirst, FColon : Boolean;
  91       public
  92         constructor Create( const aProto : IJSONProtocol);
  93         procedure Write;  override;
  94         procedure Read;  override;
  95         function EscapeNumbers : Boolean;  override;
  96       end;
  97
  98       // Holds up to one byte from the transport
  99       TLookaheadReader = class
 100       protected
 101         FProto : Pointer;  // weak IJSONProtocol;
 102         constructor Create( const aProto : IJSONProtocol);
 103
 104       private
 105         FHasData : Boolean;
 106         FData    : Byte;
 107
 108       public
 109         // Return and consume the next byte to be Read, either taking it from the
 110         // data buffer if present or getting it from the transport otherwise.
 111         function Read : Byte;
 112
 113         // Return the next byte to be Read without consuming, filling the data
 114         // buffer if it has not been filled alReady.
 115         function Peek : Byte;
 116       end;
 117
 118   protected
 119     // Stack of nested contexts that we may be in
 120     FContextStack : TStack<TJSONBaseContext>;
 121
 122     // Current context that we are in
 123     FContext : TJSONBaseContext;
 124
 125     // Reader that manages a 1-byte buffer
 126     FReader : TLookaheadReader;
 127
 128     // Push/pop a new JSON context onto/from the stack.
 129     procedure ResetContextStack;
 130     procedure PushContext( const aCtx : TJSONBaseContext);
 131     procedure PopContext;
 132
 133   public
 134     // TJSONProtocolImpl Constructor
 135     constructor Create( const aTrans : ITransport);
 136     destructor Destroy;   override;
 137
 138   protected
 139     // IJSONProtocol
 140     // Read a byte that must match b; otherwise an exception is thrown.
 141     procedure ReadJSONSyntaxChar( b : Byte);
 142
 143   private
 144     // Convert a byte containing a hex char ('0'-'9' or 'a'-'f') into its corresponding hex value
 145     class function HexVal( ch : Byte) : Byte;
 146
 147     // Convert a byte containing a hex value to its corresponding hex character
 148     class function HexChar( val : Byte) : Byte;
 149
 150     // Write the bytes in array buf as a JSON characters, escaping as needed
 151     procedure WriteJSONString( const b : TBytes);  overload;
 152     procedure WriteJSONString( const str : string);  overload;
 153
 154     // Write out number as a JSON value. If the context dictates so, it will be
 155     // wrapped in quotes to output as a JSON string.
 156     procedure WriteJSONInteger( const num : Int64);
 157
 158     // Write out a double as a JSON value. If it is NaN or infinity or if the
 159     // context dictates escaping, Write out as JSON string.
 160     procedure WriteJSONDouble( const num : Double);
 161
 162     // Write out contents of byte array b as a JSON string with base-64 encoded data
 163     procedure WriteJSONBase64( const b : TBytes);
 164
 165     procedure WriteJSONObjectStart;
 166     procedure WriteJSONObjectEnd;
 167     procedure WriteJSONArrayStart;
 168     procedure WriteJSONArrayEnd;
 169
 170   public
 171     // IProtocol
 172     procedure WriteMessageBegin( const aMsg : TThriftMessage); override;
 173     procedure WriteMessageEnd; override;
 174     procedure WriteStructBegin( const struc: TThriftStruct); override;
 175     procedure WriteStructEnd; override;
 176     procedure WriteFieldBegin( const field: TThriftField); override;
 177     procedure WriteFieldEnd; override;
 178     procedure WriteFieldStop; override;
 179     procedure WriteMapBegin( const map: TThriftMap); override;
 180     procedure WriteMapEnd; override;
 181     procedure WriteListBegin( const list: TThriftList); override;
 182     procedure WriteListEnd(); override;
 183     procedure WriteSetBegin( const set_: TThriftSet ); override;
 184     procedure WriteSetEnd(); override;
 185     procedure WriteBool( b: Boolean); override;
 186     procedure WriteByte( b: ShortInt); override;
 187     procedure WriteI16( i16: SmallInt); override;
 188     procedure WriteI32( i32: Integer); override;
 189     procedure WriteI64( const i64: Int64); override;
 190     procedure WriteDouble( const d: Double); override;
 191     procedure WriteString( const s: string );   override;
 192     procedure WriteBinary( const b: TBytes); override;
 193     //
 194     function ReadMessageBegin: TThriftMessage; override;
 195     procedure ReadMessageEnd(); override;
 196     function ReadStructBegin: TThriftStruct; override;
 197     procedure ReadStructEnd; override;
 198     function ReadFieldBegin: TThriftField; override;
 199     procedure ReadFieldEnd(); override;
 200     function ReadMapBegin: TThriftMap; override;
 201     procedure ReadMapEnd(); override;
 202     function ReadListBegin: TThriftList; override;
 203     procedure ReadListEnd(); override;
 204     function ReadSetBegin: TThriftSet; override;
 205     procedure ReadSetEnd(); override;
 206     function ReadBool: Boolean; override;
 207     function ReadByte: ShortInt; override;
 208     function ReadI16: SmallInt; override;
 209     function ReadI32: Integer; override;
 210     function ReadI64: Int64; override;
 211     function ReadDouble:Double; override;
 212     function ReadString : string;  override;
 213     function ReadBinary: TBytes; override;
 214
 215
 216   private
 217     // Reading methods.
 218
 219     // Read in a JSON string, unescaping as appropriate.
 220     // Skip Reading from the context if skipContext is true.
 221     function ReadJSONString( skipContext : Boolean) : TBytes;
 222
 223     // Return true if the given byte could be a valid part of a JSON number.
 224     function IsJSONNumeric( b : Byte) : Boolean;
 225
 226     // Read in a sequence of characters that are all valid in JSON numbers. Does
 227     // not do a complete regex check to validate that this is actually a number.
 228     function ReadJSONNumericChars : String;
 229
 230     // Read in a JSON number. If the context dictates, Read in enclosing quotes.
 231     function ReadJSONInteger : Int64;
 232
 233     // Read in a JSON double value. Throw if the value is not wrapped in quotes
 234     // when expected or if wrapped in quotes when not expected.
 235     function ReadJSONDouble : Double;
 236
 237     // Read in a JSON string containing base-64 encoded data and decode it.
 238     function ReadJSONBase64 : TBytes;
 239
 240     procedure ReadJSONObjectStart;
 241     procedure ReadJSONObjectEnd;
 242     procedure ReadJSONArrayStart;
 243     procedure ReadJSONArrayEnd;
 244   end;
 245
 246
 247 implementation
 248
 249 var
 250   COMMA     : TBytes;
 251   COLON     : TBytes;
 252   LBRACE    : TBytes;
 253   RBRACE    : TBytes;
 254   LBRACKET  : TBytes;
 255   RBRACKET  : TBytes;
 256   QUOTE     : TBytes;
 257   BACKSLASH : TBytes;
 258   ESCSEQ    : TBytes;
 259
 260 const
 261   VERSION = 1;
 262   JSON_CHAR_TABLE : array[0..$2F] of Byte
 263                   = (0,0,0,0, 0,0,0,0, Byte('b'),Byte('t'),Byte('n'),0, Byte('f'),Byte('r'),0,0,
 264                      0,0,0,0, 0,0,0,0, 0,0,0,0,  0,0,0,0,
 265                      1,1,Byte('"'),1,  1,1,1,1, 1,1,1,1, 1,1,1,1);
 266
 267   ESCAPE_CHARS     = '"\/btnfr';
 268   ESCAPE_CHAR_VALS = '"\/'#8#9#10#12#13;
 269
 270   DEF_STRING_SIZE = 16;
 271
 272   NAME_BOOL   = 'tf';
 273   NAME_BYTE   = 'i8';
 274   NAME_I16    = 'i16';
 275   NAME_I32    = 'i32';
 276   NAME_I64    = 'i64';
 277   NAME_DOUBLE = 'dbl';
 278   NAME_STRUCT = 'rec';
 279   NAME_STRING = 'str';
 280   NAME_MAP    = 'map';
 281   NAME_LIST   = 'lst';
 282   NAME_SET    = 'set';
 283
 284   INVARIANT_CULTURE : TFormatSettings
 285                     = ( ThousandSeparator: ',';
 286                         DecimalSeparator: '.');
 287
 288
 289
 290 //--- TJSONProtocolImpl ----------------------
 291
 292
 293 function TJSONProtocolImpl.TFactory.GetProtocol( const trans: ITransport): IProtocol;
 294 begin
 295   result := TJSONProtocolImpl.Create(trans);
 296 end;
 297
 298 class function TJSONProtocolImpl.GetTypeNameForTypeID(typeID : TType) : string;
 299 begin
 300   case typeID of
 301     TType.Bool_:    result := NAME_BOOL;
 302     TType.Byte_:    result := NAME_BYTE;
 303     TType.I16:      result := NAME_I16;
 304     TType.I32:      result := NAME_I32;
 305     TType.I64:      result := NAME_I64;
 306     TType.Double_:  result := NAME_DOUBLE;
 307     TType.String_:  result := NAME_STRING;
 308     TType.Struct:   result := NAME_STRUCT;
 309     TType.Map:      result := NAME_MAP;
 310     TType.Set_:     result := NAME_SET;
 311     TType.List:     result := NAME_LIST;
 312   else
 313     raise TProtocolExceptionNotImplemented.Create('Unrecognized type ('+IntToStr(Ord(typeID))+')');
 314   end;
 315 end;
 316
 317
 318 class function TJSONProtocolImpl.GetTypeIDForTypeName( const name : string) : TType;
 319 begin
 320   if      name = NAME_BOOL   then result := TType.Bool_
 321   else if name = NAME_BYTE   then result := TType.Byte_
 322   else if name = NAME_I16    then result := TType.I16
 323   else if name = NAME_I32    then result := TType.I32
 324   else if name = NAME_I64    then result := TType.I64
 325   else if name = NAME_DOUBLE then result := TType.Double_
 326   else if name = NAME_STRUCT then result := TType.Struct
 327   else if name = NAME_STRING then result := TType.String_
 328   else if name = NAME_MAP    then result := TType.Map
 329   else if name = NAME_LIST   then result := TType.List
 330   else if name = NAME_SET    then result := TType.Set_
 331   else raise TProtocolExceptionNotImplemented.Create('Unrecognized type ('+name+')');
 332 end;
 333
 334
 335 constructor TJSONProtocolImpl.TJSONBaseContext.Create( const aProto : IJSONProtocol);
 336 begin
 337   inherited Create;
 338   FProto := Pointer(aProto);
 339 end;
 340
 341
 342 procedure TJSONProtocolImpl.TJSONBaseContext.Write;
 343 begin
 344   // nothing
 345 end;
 346
 347
 348 procedure TJSONProtocolImpl.TJSONBaseContext.Read;
 349 begin
 350   // nothing
 351 end;
 352
 353
 354 function TJSONProtocolImpl.TJSONBaseContext.EscapeNumbers : Boolean;
 355 begin
 356   result := FALSE;
 357 end;
 358
 359
 360 constructor TJSONProtocolImpl.TJSONListContext.Create( const aProto : IJSONProtocol);
 361 begin
 362   inherited Create( aProto);
 363   FFirst := TRUE;
 364 end;
 365
 366
 367 procedure TJSONProtocolImpl.TJSONListContext.Write;
 368 begin
 369   if FFirst
 370   then FFirst := FALSE
 371   else IJSONProtocol(FProto).Transport.Write( COMMA);
 372 end;
 373
 374
 375 procedure TJSONProtocolImpl.TJSONListContext.Read;
 376 begin
 377   if FFirst
 378   then FFirst := FALSE
 379   else IJSONProtocol(FProto).ReadJSONSyntaxChar( COMMA[0]);
 380 end;
 381
 382
 383 constructor TJSONProtocolImpl.TJSONPairContext.Create( const aProto : IJSONProtocol);
 384 begin
 385   inherited Create( aProto);
 386   FFirst := TRUE;
 387   FColon := TRUE;
 388 end;
 389
 390
 391 procedure TJSONProtocolImpl.TJSONPairContext.Write;
 392 begin
 393   if FFirst then begin
 394     FFirst := FALSE;
 395     FColon := TRUE;
 396   end
 397   else begin
 398     if FColon
 399     then IJSONProtocol(FProto).Transport.Write( COLON)
 400     else IJSONProtocol(FProto).Transport.Write( COMMA);
 401     FColon := not FColon;
 402   end;
 403 end;
 404
 405
 406 procedure TJSONProtocolImpl.TJSONPairContext.Read;
 407 begin
 408   if FFirst then begin
 409     FFirst := FALSE;
 410     FColon := TRUE;
 411   end
 412   else begin
 413     if FColon
 414     then IJSONProtocol(FProto).ReadJSONSyntaxChar( COLON[0])
 415     else IJSONProtocol(FProto).ReadJSONSyntaxChar( COMMA[0]);
 416     FColon := not FColon;
 417   end;
 418 end;
 419
 420
 421 function TJSONProtocolImpl.TJSONPairContext.EscapeNumbers : Boolean;
 422 begin
 423   result := FColon;
 424 end;
 425
 426
 427 constructor TJSONProtocolImpl.TLookaheadReader.Create( const aProto : IJSONProtocol);
 428 begin
 429   inherited Create;
 430   FProto   := Pointer(aProto);
 431   FHasData := FALSE;
 432 end;
 433
 434
 435 function TJSONProtocolImpl.TLookaheadReader.Read : Byte;
 436 begin
 437   if FHasData
 438   then FHasData := FALSE
 439   else begin
 440     IJSONProtocol(FProto).Transport.ReadAll( @FData, SizeOf(FData), 0, 1);
 441   end;
 442   result := FData;
 443 end;
 444
 445
 446 function TJSONProtocolImpl.TLookaheadReader.Peek : Byte;
 447 begin
 448   if not FHasData then begin
 449     IJSONProtocol(FProto).Transport.ReadAll( @FData, SizeOf(FData), 0, 1);
 450     FHasData := TRUE;
 451   end;
 452   result := FData;
 453 end;
 454
 455
 456 constructor TJSONProtocolImpl.Create( const aTrans : ITransport);
 457 begin
 458   inherited Create( aTrans);
 459
 460   // Stack of nested contexts that we may be in
 461   FContextStack := TStack<TJSONBaseContext>.Create;
 462
 463   FContext := TJSONBaseContext.Create( Self);
 464   FReader  := TLookaheadReader.Create( Self);
 465 end;
 466
 467
 468 destructor TJSONProtocolImpl.Destroy;
 469 begin
 470   try
 471     ResetContextStack;  // free any contents
 472     FreeAndNil( FReader);
 473     FreeAndNil( FContext);
 474     FreeAndNil( FContextStack);
 475   finally
 476     inherited Destroy;
 477   end;
 478 end;
 479
 480
 481 procedure TJSONProtocolImpl.ResetContextStack;
 482 begin
 483   while FContextStack.Count > 0
 484   do PopContext;
 485 end;
 486
 487
 488 procedure TJSONProtocolImpl.PushContext( const aCtx : TJSONBaseContext);
 489 begin
 490   FContextStack.Push( FContext);
 491   FContext := aCtx;
 492 end;
 493
 494
 495 procedure TJSONProtocolImpl.PopContext;
 496 begin
 497   FreeAndNil(FContext);
 498   FContext := FContextStack.Pop;
 499 end;
 500
 501
 502 procedure TJSONProtocolImpl.ReadJSONSyntaxChar( b : Byte);
 503 var ch : Byte;
 504 begin
 505   ch := FReader.Read;
 506   if (ch <> b)
 507   then raise TProtocolExceptionInvalidData.Create('Unexpected character ('+Char(ch)+')');
 508 end;
 509
 510
 511 class function TJSONProtocolImpl.HexVal( ch : Byte) : Byte;
 512 var i : Integer;
 513 begin
 514   i := StrToIntDef( '$0'+Char(ch), -1);
 515   if (0 <= i) and (i < $10)
 516   then result := i
 517   else raise TProtocolExceptionInvalidData.Create('Expected hex character ('+Char(ch)+')');
 518 end;
 519
 520
 521 class function TJSONProtocolImpl.HexChar( val : Byte) : Byte;
 522 const HEXCHARS = '0123456789ABCDEF';
 523 begin
 524   result := Byte( PChar(HEXCHARS)[val and $0F]);
 525   ASSERT( Pos( Char(result), HEXCHARS) > 0);
 526 end;
 527
 528
 529 procedure TJSONProtocolImpl.WriteJSONString( const str : string);
 530 begin
 531   WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( str));
 532 end;
 533
 534
 535 procedure TJSONProtocolImpl.WriteJSONString( const b : TBytes);
 536 var i : Integer;
 537     tmp : TBytes;
 538 begin
 539   FContext.Write;
 540   Transport.Write( QUOTE);
 541   for i := 0 to Length(b)-1 do begin
 542
 543     if (b[i] and $00FF) >= $30 then begin
 544
 545       if (b[i] = BACKSLASH[0]) then begin
 546         Transport.Write( BACKSLASH);
 547         Transport.Write( BACKSLASH);
 548       end
 549       else begin
 550         Transport.Write( b, i, 1);
 551       end;
 552
 553     end
 554     else begin
 555       SetLength( tmp, 2);
 556       tmp[0] := JSON_CHAR_TABLE[b[i]];
 557       if (tmp[0] = 1) then begin
 558         Transport.Write( b, i, 1)
 559       end
 560       else if (tmp[0] > 1) then begin
 561         Transport.Write( BACKSLASH);
 562         Transport.Write( tmp, 0, 1);
 563       end
 564       else begin
 565         Transport.Write( ESCSEQ);
 566         tmp[0] := HexChar( b[i] div $10);
 567         tmp[1] := HexChar( b[i]);
 568         Transport.Write( tmp, 0, 2);
 569       end;
 570     end;
 571   end;
 572   Transport.Write( QUOTE);
 573 end;
 574
 575
 576 procedure TJSONProtocolImpl.WriteJSONInteger( const num : Int64);
 577 var str : String;
 578     escapeNum : Boolean;
 579 begin
 580   FContext.Write;
 581   str := IntToStr(num);
 582
 583   escapeNum := FContext.EscapeNumbers;
 584   if escapeNum
 585   then Transport.Write( QUOTE);
 586
 587   Transport.Write( SysUtils.TEncoding.UTF8.GetBytes( str));
 588
 589   if escapeNum
 590   then Transport.Write( QUOTE);
 591 end;
 592
 593
 594 procedure TJSONProtocolImpl.WriteJSONDouble( const num : Double);
 595 var str : string;
 596     special : Boolean;
 597     escapeNum : Boolean;
 598 begin
 599   FContext.Write;
 600
 601   str := FloatToStr( num, INVARIANT_CULTURE);
 602   special := FALSE;
 603
 604   case UpCase(str[1]) of
 605     'N' : special := TRUE;  // NaN
 606     'I' : special := TRUE;  // Infinity
 607     '-' : special := (UpCase(str[2]) = 'I'); // -Infinity
 608   end;
 609
 610   escapeNum := special or FContext.EscapeNumbers;
 611
 612
 613   if escapeNum
 614   then Transport.Write( QUOTE);
 615
 616   Transport.Write( SysUtils.TEncoding.UTF8.GetBytes( str));
 617
 618   if escapeNum
 619   then Transport.Write( QUOTE);
 620 end;
 621
 622
 623 procedure TJSONProtocolImpl.WriteJSONBase64( const b : TBytes);
 624 var len, off, cnt : Integer;
 625     tmpBuf : TBytes;
 626 begin
 627   FContext.Write;
 628   Transport.Write( QUOTE);
 629
 630   len := Length(b);
 631   off := 0;
 632   SetLength( tmpBuf, 4);
 633
 634   while len >= 3 do begin
 635     // Encode 3 bytes at a time
 636     Base64Utils.Encode( b, off, 3, tmpBuf, 0);
 637     Transport.Write( tmpBuf, 0, 4);
 638     Inc( off, 3);
 639     Dec( len, 3);
 640   end;
 641
 642   // Encode remainder, if any
 643   if len > 0 then begin
 644     cnt := Base64Utils.Encode( b, off, len, tmpBuf, 0);
 645     Transport.Write( tmpBuf, 0, cnt);
 646   end;
 647
 648   Transport.Write( QUOTE);
 649 end;
 650
 651
 652 procedure TJSONProtocolImpl.WriteJSONObjectStart;
 653 begin
 654   FContext.Write;
 655   Transport.Write( LBRACE);
 656   PushContext( TJSONPairContext.Create( Self));
 657 end;
 658
 659
 660 procedure TJSONProtocolImpl.WriteJSONObjectEnd;
 661 begin
 662   PopContext;
 663   Transport.Write( RBRACE);
 664 end;
 665
 666
 667 procedure TJSONProtocolImpl.WriteJSONArrayStart;
 668 begin
 669   FContext.Write;
 670   Transport.Write( LBRACKET);
 671   PushContext( TJSONListContext.Create( Self));
 672 end;
 673
 674
 675 procedure TJSONProtocolImpl.WriteJSONArrayEnd;
 676 begin
 677   PopContext;
 678   Transport.Write( RBRACKET);
 679 end;
 680
 681
 682 procedure TJSONProtocolImpl.WriteMessageBegin( const aMsg : TThriftMessage);
 683 begin
 684   ResetContextStack;  // THRIFT-1473
 685
 686   WriteJSONArrayStart;
 687   WriteJSONInteger(VERSION);
 688
 689   WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( aMsg.Name));
 690
 691   WriteJSONInteger( LongInt( aMsg.Type_));
 692   WriteJSONInteger( aMsg.SeqID);
 693 end;
 694
 695 procedure TJSONProtocolImpl.WriteMessageEnd;
 696 begin
 697   WriteJSONArrayEnd;
 698 end;
 699
 700
 701 procedure TJSONProtocolImpl.WriteStructBegin( const struc: TThriftStruct);
 702 begin
 703   WriteJSONObjectStart;
 704 end;
 705
 706
 707 procedure TJSONProtocolImpl.WriteStructEnd;
 708 begin
 709   WriteJSONObjectEnd;
 710 end;
 711
 712
 713 procedure TJSONProtocolImpl.WriteFieldBegin( const field : TThriftField);
 714 begin
 715   WriteJSONInteger(field.ID);
 716   WriteJSONObjectStart;
 717   WriteJSONString( GetTypeNameForTypeID(field.Type_));
 718 end;
 719
 720
 721 procedure TJSONProtocolImpl.WriteFieldEnd;
 722 begin
 723   WriteJSONObjectEnd;
 724 end;
 725
 726
 727 procedure TJSONProtocolImpl.WriteFieldStop;
 728 begin
 729   // nothing to do
 730 end;
 731
 732 procedure TJSONProtocolImpl.WriteMapBegin( const map: TThriftMap);
 733 begin
 734   WriteJSONArrayStart;
 735   WriteJSONString( GetTypeNameForTypeID( map.KeyType));
 736   WriteJSONString( GetTypeNameForTypeID( map.ValueType));
 737   WriteJSONInteger( map.Count);
 738   WriteJSONObjectStart;
 739 end;
 740
 741
 742 procedure TJSONProtocolImpl.WriteMapEnd;
 743 begin
 744   WriteJSONObjectEnd;
 745   WriteJSONArrayEnd;
 746 end;
 747
 748
 749 procedure TJSONProtocolImpl.WriteListBegin( const list: TThriftList);
 750 begin
 751   WriteJSONArrayStart;
 752   WriteJSONString( GetTypeNameForTypeID( list.ElementType));
 753   WriteJSONInteger(list.Count);
 754 end;
 755
 756
 757 procedure TJSONProtocolImpl.WriteListEnd;
 758 begin
 759   WriteJSONArrayEnd;
 760 end;
 761
 762
 763 procedure TJSONProtocolImpl.WriteSetBegin( const set_: TThriftSet);
 764 begin
 765   WriteJSONArrayStart;
 766   WriteJSONString( GetTypeNameForTypeID( set_.ElementType));
 767   WriteJSONInteger( set_.Count);
 768 end;
 769
 770
 771 procedure TJSONProtocolImpl.WriteSetEnd;
 772 begin
 773   WriteJSONArrayEnd;
 774 end;
 775
 776 procedure TJSONProtocolImpl.WriteBool( b: Boolean);
 777 begin
 778   if b
 779   then WriteJSONInteger( 1)
 780   else WriteJSONInteger( 0);
 781 end;
 782
 783 procedure TJSONProtocolImpl.WriteByte( b: ShortInt);
 784 begin
 785   WriteJSONInteger( b);
 786 end;
 787
 788 procedure TJSONProtocolImpl.WriteI16( i16: SmallInt);
 789 begin
 790   WriteJSONInteger( i16);
 791 end;
 792
 793 procedure TJSONProtocolImpl.WriteI32( i32: Integer);
 794 begin
 795   WriteJSONInteger( i32);
 796 end;
 797
 798 procedure TJSONProtocolImpl.WriteI64( const i64: Int64);
 799 begin
 800   WriteJSONInteger(i64);
 801 end;
 802
 803 procedure TJSONProtocolImpl.WriteDouble( const d: Double);
 804 begin
 805   WriteJSONDouble( d);
 806 end;
 807
 808 procedure TJSONProtocolImpl.WriteString( const s: string );
 809 begin
 810   WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( s));
 811 end;
 812
 813 procedure TJSONProtocolImpl.WriteBinary( const b: TBytes);
 814 begin
 815   WriteJSONBase64( b);
 816 end;
 817
 818
 819 function TJSONProtocolImpl.ReadJSONString( skipContext : Boolean) : TBytes;
 820 var buffer : TMemoryStream;
 821     ch  : Byte;
 822     wch : Word;
 823     highSurogate: Char;
 824     surrogatePairs: Array[0..1] of Char;
 825     off : Integer;
 826     tmp : TBytes;
 827 begin
 828   highSurogate := #0;
 829   buffer := TMemoryStream.Create;
 830   try
 831     if not skipContext
 832     then FContext.Read;
 833
 834     ReadJSONSyntaxChar( QUOTE[0]);
 835
 836     while TRUE do begin
 837       ch := FReader.Read;
 838
 839       if (ch = QUOTE[0])
 840       then Break;
 841
 842       // check for escapes
 843       if (ch <> ESCSEQ[0]) then begin
 844         buffer.Write( ch, 1);
 845         Continue;
 846       end;
 847
 848       // distuinguish between \uNNNN and \?
 849       ch := FReader.Read;
 850       if (ch <> ESCSEQ[1])
 851       then begin
 852         off := Pos( Char(ch), ESCAPE_CHARS);
 853         if off < 1
 854         then raise TProtocolExceptionInvalidData.Create('Expected control char');
 855         ch := Byte( ESCAPE_CHAR_VALS[off]);
 856         buffer.Write( ch, 1);
 857         Continue;
 858       end;
 859
 860       // it is \uXXXX
 861       SetLength( tmp, 4);
 862       Transport.ReadAll( tmp, 0, 4);
 863       wch := (HexVal(tmp[0]) shl 12)
 864            + (HexVal(tmp[1]) shl 8)
 865            + (HexVal(tmp[2]) shl 4)
 866            +  HexVal(tmp[3]);
 867
 868       // we need to make UTF8 bytes from it, to be decoded later
 869       if CharUtils.IsHighSurrogate(char(wch)) then begin
 870         if highSurogate <> #0
 871         then raise TProtocolExceptionInvalidData.Create('Expected low surrogate char');
 872         highSurogate := char(wch);
 873       end
 874       else if CharUtils.IsLowSurrogate(char(wch)) then begin
 875         if highSurogate = #0
 876         then TProtocolExceptionInvalidData.Create('Expected high surrogate char');
 877         surrogatePairs[0] := highSurogate;
 878         surrogatePairs[1] := char(wch);
 879         tmp := TEncoding.UTF8.GetBytes(surrogatePairs);
 880         buffer.Write( tmp[0], Length(tmp));
 881         highSurogate := #0;
 882       end
 883       else begin
 884         tmp := SysUtils.TEncoding.UTF8.GetBytes(Char(wch));
 885         buffer.Write( tmp[0], Length(tmp));
 886       end;
 887     end;
 888
 889     if highSurogate <> #0
 890     then raise TProtocolExceptionInvalidData.Create('Expected low surrogate char');
 891
 892     SetLength( result, buffer.Size);
 893     if buffer.Size > 0 then Move( buffer.Memory^, result[0], Length(result));
 894
 895   finally
 896     buffer.Free;
 897   end;
 898 end;
 899
 900
 901 function TJSONProtocolImpl.IsJSONNumeric( b : Byte) : Boolean;
 902 const NUMCHARS = ['+','-','.','0','1','2','3','4','5','6','7','8','9','E','e'];
 903 begin
 904   result := CharInSet( Char(b), NUMCHARS);
 905 end;
 906
 907
 908 function TJSONProtocolImpl.ReadJSONNumericChars : string;
 909 var strbld : TThriftStringBuilder;
 910     ch : Byte;
 911 begin
 912   strbld := TThriftStringBuilder.Create;
 913   try
 914     while TRUE do begin
 915       ch := FReader.Peek;
 916       if IsJSONNumeric(ch)
 917       then strbld.Append( Char(FReader.Read))
 918       else Break;
 919     end;
 920     result := strbld.ToString;
 921
 922   finally
 923     strbld.Free;
 924   end;
 925 end;
 926
 927
 928 function TJSONProtocolImpl.ReadJSONInteger : Int64;
 929 var str : string;
 930 begin
 931   FContext.Read;
 932   if FContext.EscapeNumbers
 933   then ReadJSONSyntaxChar( QUOTE[0]);
 934
 935   str := ReadJSONNumericChars;
 936
 937   if FContext.EscapeNumbers
 938   then ReadJSONSyntaxChar( QUOTE[0]);
 939
 940   try
 941     result := StrToInt64(str);
 942   except
 943     on e:Exception do begin
 944       raise TProtocolExceptionInvalidData.Create('Bad data encounted in numeric data ('+str+') ('+e.Message+')');
 945     end;
 946   end;
 947 end;
 948
 949
 950 function TJSONProtocolImpl.ReadJSONDouble : Double;
 951 var dub : Double;
 952     str : string;
 953 begin
 954   FContext.Read;
 955
 956   if FReader.Peek = QUOTE[0]
 957   then begin
 958     str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( TRUE));
 959     dub := StrToFloat( str, INVARIANT_CULTURE);
 960
 961     if not FContext.EscapeNumbers()
 962     and not Math.IsNaN(dub)
 963     and not Math.IsInfinite(dub)
 964     then begin
 965       // Throw exception -- we should not be in a string in  Self case
 966       raise TProtocolExceptionInvalidData.Create('Numeric data unexpectedly quoted');
 967     end;
 968     result := dub;
 969     Exit;
 970   end;
 971
 972   // will throw - we should have had a quote if escapeNum == true
 973   if FContext.EscapeNumbers
 974   then ReadJSONSyntaxChar( QUOTE[0]);
 975
 976   try
 977     str := ReadJSONNumericChars;
 978     result := StrToFloat( str, INVARIANT_CULTURE);
 979   except
 980     on e:Exception
 981     do raise TProtocolExceptionInvalidData.Create('Bad data encounted in numeric data ('+str+') ('+e.Message+')');
 982   end;
 983 end;
 984
 985
 986 function TJSONProtocolImpl.ReadJSONBase64 : TBytes;
 987 var b : TBytes;
 988     len, off, size : Integer;
 989 begin
 990   b := ReadJSONString(false);
 991
 992   len := Length(b);
 993   off := 0;
 994   size := 0;
 995
 996   // reduce len to ignore fill bytes
 997   Dec(len);
 998   while (len >= 0) and (b[len] = Byte('=')) do Dec(len);
 999   Inc(len);
1000
1001   // read & decode full byte triplets = 4 source bytes
1002   while (len >= 4) do begin
1003     // Decode 4 bytes at a time
1004     Inc( size, Base64Utils.Decode( b, off, 4, b, size)); // decoded in place
1005     Inc( off, 4);
1006     Dec( len, 4);
1007   end;
1008
1009   // Don't decode if we hit the end or got a single leftover byte (invalid
1010   // base64 but legal for skip of regular string type)
1011   if len > 1 then begin
1012     // Decode remainder
1013     Inc( size, Base64Utils.Decode( b, off, len, b, size)); // decoded in place
1014   end;
1015
1016   // resize to final size and return the data
1017   SetLength( b, size);
1018   result := b;
1019 end;
1020
1021
1022 procedure TJSONProtocolImpl.ReadJSONObjectStart;
1023 begin
1024   FContext.Read;
1025   ReadJSONSyntaxChar( LBRACE[0]);
1026   PushContext( TJSONPairContext.Create( Self));
1027 end;
1028
1029
1030 procedure TJSONProtocolImpl.ReadJSONObjectEnd;
1031 begin
1032   ReadJSONSyntaxChar( RBRACE[0]);
1033   PopContext;
1034 end;
1035
1036
1037 procedure TJSONProtocolImpl.ReadJSONArrayStart;
1038 begin
1039   FContext.Read;
1040   ReadJSONSyntaxChar( LBRACKET[0]);
1041   PushContext( TJSONListContext.Create( Self));
1042 end;
1043
1044
1045 procedure TJSONProtocolImpl.ReadJSONArrayEnd;
1046 begin
1047   ReadJSONSyntaxChar( RBRACKET[0]);
1048   PopContext;
1049 end;
1050
1051
1052 function TJSONProtocolImpl.ReadMessageBegin: TThriftMessage;
1053 begin
1054   ResetContextStack;  // THRIFT-1473
1055
1056   Init( result);
1057   ReadJSONArrayStart;
1058
1059   if ReadJSONInteger <> VERSION
1060   then raise TProtocolExceptionBadVersion.Create('Message contained bad version.');
1061
1062   result.Name  := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE));
1063   result.Type_ := TMessageType( ReadJSONInteger);
1064   result.SeqID := ReadJSONInteger;
1065 end;
1066
1067
1068 procedure TJSONProtocolImpl.ReadMessageEnd;
1069 begin
1070   ReadJSONArrayEnd;
1071 end;
1072
1073
1074 function TJSONProtocolImpl.ReadStructBegin : TThriftStruct ;
1075 begin
1076   ReadJSONObjectStart;
1077   Init( result);
1078 end;
1079
1080
1081 procedure TJSONProtocolImpl.ReadStructEnd;
1082 begin
1083   ReadJSONObjectEnd;
1084 end;
1085
1086
1087 function TJSONProtocolImpl.ReadFieldBegin : TThriftField;
1088 var ch : Byte;
1089     str : string;
1090 begin
1091   Init( result);
1092   ch := FReader.Peek;
1093   if ch = RBRACE[0]
1094   then result.Type_ := TType.Stop
1095   else begin
1096     result.ID := ReadJSONInteger;
1097     ReadJSONObjectStart;
1098
1099     str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE));
1100     result.Type_ := GetTypeIDForTypeName( str);
1101   end;
1102 end;
1103
1104
1105 procedure TJSONProtocolImpl.ReadFieldEnd;
1106 begin
1107   ReadJSONObjectEnd;
1108 end;
1109
1110
1111 function TJSONProtocolImpl.ReadMapBegin : TThriftMap;
1112 var str : string;
1113 begin
1114   Init( result);
1115   ReadJSONArrayStart;
1116
1117   str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
1118   result.KeyType := GetTypeIDForTypeName( str);
1119
1120   str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
1121   result.ValueType := GetTypeIDForTypeName( str);
1122
1123   result.Count := ReadJSONInteger;
1124   ReadJSONObjectStart;
1125 end;
1126
1127
1128 procedure TJSONProtocolImpl.ReadMapEnd;
1129 begin
1130   ReadJSONObjectEnd;
1131   ReadJSONArrayEnd;
1132 end;
1133
1134
1135 function TJSONProtocolImpl.ReadListBegin : TThriftList;
1136 var str : string;
1137 begin
1138   Init( result);
1139   ReadJSONArrayStart;
1140
1141   str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
1142   result.ElementType := GetTypeIDForTypeName( str);
1143   result.Count := ReadJSONInteger;
1144 end;
1145
1146
1147 procedure TJSONProtocolImpl.ReadListEnd;
1148 begin
1149   ReadJSONArrayEnd;
1150 end;
1151
1152
1153 function TJSONProtocolImpl.ReadSetBegin : TThriftSet;
1154 var str : string;
1155 begin
1156   Init( result);
1157   ReadJSONArrayStart;
1158
1159   str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
1160   result.ElementType := GetTypeIDForTypeName( str);
1161   result.Count := ReadJSONInteger;
1162 end;
1163
1164
1165 procedure TJSONProtocolImpl.ReadSetEnd;
1166 begin
1167   ReadJSONArrayEnd;
1168 end;
1169
1170
1171 function TJSONProtocolImpl.ReadBool : Boolean;
1172 begin
1173   result := (ReadJSONInteger <> 0);
1174 end;
1175
1176
1177 function TJSONProtocolImpl.ReadByte : ShortInt;
1178 begin
1179   result := ReadJSONInteger;
1180 end;
1181
1182
1183 function TJSONProtocolImpl.ReadI16 : SmallInt;
1184 begin
1185   result := ReadJSONInteger;
1186 end;
1187
1188
1189 function TJSONProtocolImpl.ReadI32 : LongInt;
1190 begin
1191   result := ReadJSONInteger;
1192 end;
1193
1194
1195 function TJSONProtocolImpl.ReadI64 : Int64;
1196 begin
1197   result := ReadJSONInteger;
1198 end;
1199
1200
1201 function TJSONProtocolImpl.ReadDouble : Double;
1202 begin
1203   result := ReadJSONDouble;
1204 end;
1205
1206
1207 function TJSONProtocolImpl.ReadString : string;
1208 begin
1209   result := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE));
1210 end;
1211
1212
1213 function TJSONProtocolImpl.ReadBinary : TBytes;
1214 begin
1215   result := ReadJSONBase64;
1216 end;
1217
1218
1219 //--- init code ---
1220
1221 procedure InitBytes( var b : TBytes; aData : array of Byte);
1222 begin
1223   SetLength( b, Length(aData));
1224   Move( aData, b[0], Length(b));
1225 end;
1226
1227 initialization
1228   InitBytes( COMMA,     [Byte(',')]);
1229   InitBytes( COLON,     [Byte(':')]);
1230   InitBytes( LBRACE,    [Byte('{')]);
1231   InitBytes( RBRACE,    [Byte('}')]);
1232   InitBytes( LBRACKET,  [Byte('[')]);
1233   InitBytes( RBRACKET,  [Byte(']')]);
1234   InitBytes( QUOTE,     [Byte('"')]);
1235   InitBytes( BACKSLASH, [Byte('\')]);
1236   InitBytes( ESCSEQ,    [Byte('\'),Byte('u'),Byte('0'),Byte('0')]);
1237 end.