(*
 * 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.