unit Bcl.Json.BaseObjectConverter;

{$I bcl.inc}

interface

uses
  Generics.Collections, Rtti, TypInfo, SysUtils,
  Bcl.Collections,
  Bcl.Json.Converters,
  Bcl.Json.Reader,
  Bcl.Json.Writer;

type
  TJsonBaseObjectConverterFactory = class;

  TJsonBaseObjectConverter = class abstract(TInterfacedObject, IJsonTypeConverter)
  strict private
    FClass: TClass;
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}
    FFactory: TJsonBaseObjectConverterFactory;
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}
    FConverters: TJsonConverters;
  private
    function FindReferencedObject(RefId: integer): TObject;
  strict protected
    { abstract functions to be implemented }
    function ReadProperty(const PropName: string; AObject: TObject;
      AReader: TJsonReader): Boolean; virtual; abstract;
    procedure WriteProperties(AObject: TObject; AWriter: TJsonWriter); virtual; abstract;
    function QualifiedName(AClass: TClass): string; virtual; abstract;
    function FindType(const AQualifiedName: string): TClass; virtual; abstract;
  protected
    { Read functions }
    function ReadObject(JReader: TJsonReader; Target: TObject): TObject;
    procedure ReadJsonProperty(JReader: TJsonReader; Target: TObject; const PropId: string);
  protected
    { Write functions }
    procedure WriteObject(Writer: TJsonWriter; const AObject: TObject);
  protected
    function Depth: Integer;
    procedure ObjectCreated(Obj: TObject);
    procedure NotifyPropertyWrite(Member: TRttiMember; Value: TValue);
    property Factory: TJsonBaseObjectConverterFactory read FFactory;
    property Converters: TJsonConverters read FConverters;
  public
    procedure WriteJson(const Writer: TJsonWriter; const Value: TValue);
    procedure ReadJson(const Reader: TJsonReader; var Value: TValue);
  public
    constructor Create(const AClass: TClass; AConverters: TJsonConverters;
      AFactory: TJsonBaseObjectConverterFactory);
  end;

  TJsonBaseObjectConverterFactory = class(TJsonAbstractObjectConverterFactory)
  strict private
    FInstanceTypeProp: string;
    FInstanceReferenceProp: string;
    FInstanceIdProp: string;
    FDepth: Integer;
    FCurId: integer;
    FReferenceMap: TDictionary<integer, TObject>;
    FObjectMap: TDictionary<TObject, integer>;
  private
    property ObjectMap: TDictionary<TObject, Integer> read FObjectMap;
  protected
    property Depth: Integer read FDepth write FDepth;
    property CurId: Integer read FCurId write FCurId;
    property ReferenceMap: TDictionary<integer, TObject> read FReferenceMap;
  public
    property InstanceTypeProp: string read FInstanceTypeProp write FInstanceTypeProp;
    property InstanceReferenceProp: string read FInstanceReferenceProp write FInstanceReferenceProp;
    property InstanceIdProp: string read FInstanceIdProp write FInstanceIdProp;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  EJsonException = class(Exception)
  end;

  EObjectReferenceNotAllowed = class(EJsonException)
  public
    constructor Create;
  end;

  EJsonTypeNotFound = class(EJsonException)
  public
    constructor Create(const TypeName: string);
  end;

  EInvalidJsonInstanceType = class(EJsonException)
  public
    constructor Create(const PropName, TypeName, BaseTypeName: string); overload;
  end;

  EMissingJsonInstanceType = class(EJsonException)
  public
    constructor Create(const PropName: string);
  end;

  EReferencedObjectNotFound = class(EJsonException)
  public
    constructor Create(RefId: integer);
  end;

  EInvalidJsonProperty = class(EJsonException)
  public
    constructor Create(const Prop, EntityType: string);
  end;

  ECircularReferenceError = class(EJsonException)
  public
    constructor Create(AClass: TClass);
  end;

const
  JsonDefaultInstanceIdProp = '$id';
  JsonDefaultInstanceReferenceProp = '$ref';
  JsonDefaultInstanceTypeProp = '$type';

implementation

{ EObjectReferenceNotAllowed }

constructor EObjectReferenceNotAllowed.Create;
begin
  inherited Create('Object reference ($ref) invalid or not allowed');
end;

{ EJsonTypeNotFound }

constructor EJsonTypeNotFound.Create(const TypeName: string);
begin
  inherited CreateFmt('Could not deserialize JSON object. Type "%s" not found.', [TypeName]);
end;

{ EInvalidJsonInstanceType }

constructor EInvalidJsonInstanceType.Create(const PropName, TypeName,
  BaseTypeName: string);
begin
  inherited CreateFmt('Invalid "%s". Type mismatch between "%s" and "%s"',
    [PropName, TypeName, BaseTypeName]);
end;

{ EMissingJsonInstanceType }

constructor EMissingJsonInstanceType.Create(const PropName: string);
begin
  inherited CreateFmt('Missing "%s" property in JSON object.', [PropName]);
end;

{ EReferencedObjectNotFound }

constructor EReferencedObjectNotFound.Create(RefId: integer);
begin
  inherited CreateFmt('Referenced object not found. JSON object with $id = %d does not exist.', [RefId]);
end;

{ EInvalidJsonProperty }

constructor EInvalidJsonProperty.Create(const Prop, EntityType: string);
begin
  inherited CreateFmt('Property "%s" does not refer to a known property in type "%s"', [Prop, EntityType]);
end;

{ ECircularReferenceError }

constructor ECircularReferenceError.Create(AClass: TClass);
begin
  inherited CreateFmt('Circular reference detected when serializing object of type %s', [AClass.ClassName]);
end;

{ TJsonObjectConverter }

constructor TJsonBaseObjectConverter.Create(const AClass: TClass;
  AConverters: TJsonConverters;
  AFactory: TJsonBaseObjectConverterFactory);
begin
  FClass := AClass;
  FFactory := AFactory;
  FConverters := AConverters;
end;

function TJsonBaseObjectConverter.Depth: Integer;
begin
  Result := FFactory.Depth;
end;

function TJsonBaseObjectConverter.FindReferencedObject(RefId: integer): TObject;
begin
  if not FFactory.ReferenceMap.TryGetValue(RefId, Result) then
    raise EReferencedObjectNotFound.Create(RefId);
end;

procedure TJsonBaseObjectConverter.NotifyPropertyWrite(Member: TRttiMember;
  Value: TValue);
var
  Notify: Boolean;
  Obj: TObject;
begin
  if not Value.IsObject then Exit;
  Obj := Value.AsObject;

  // Hard code (backward compatibility). Do not notify if object is tlist
  Notify := (Obj <> nil) and not IsValueList(Obj.ClassType);
  if Notify then
    Converters.ObjectWritten(Obj);
end;

procedure TJsonBaseObjectConverter.ObjectCreated(Obj: TObject);
begin
  Converters.ObjectCreated(Obj);
end;

procedure TJsonBaseObjectConverter.WriteObject(Writer: TJsonWriter;
  const AObject: TObject);
var
  RefId: integer;
  EntityType: TClass;
begin
  if AObject = nil then
  begin
    Writer.WriteNull;
    Exit;
  end;

  EntityType := AObject.ClassType;

  // Check if object is in the map. If yes, that means that we are in a cyclical
  // reference loop (or just means the object has been already serialized, in the case
  // InstanceRefSerialization is always). Thus we will not serialize the object again
  // but instead take an action depending on InstanceLoopHandling value
  if FFactory.ObjectMap.TryGetValue(AObject, RefId) then
  begin
    case FFactory.InstanceLoopHandling of
      TInstanceLoopHandling.Error:
        raise ECircularReferenceError.Create(EntityType);
      TInstanceLoopHandling.Ignore: ; // do nothing
      TInstanceLoopHandling.Reference:
        begin
          // write instance reference
          Writer
            .WriteBeginObject
            .WriteName(FFactory.InstanceReferenceProp)
            .WriteInteger(RefId)
            .WriteEndObject;
        end;
    end;
  end
  else
  begin
    FFactory.CurId := FFactory.CurId + 1;
    FFactory.ObjectMap.Add(AObject, FFactory.CurId);

    Writer.WriteBeginObject;

    if FFactory.InstanceLoopHandling = TInstanceLoopHandling.Reference then
    begin
      // write instance id if we are going to use references for cyclical objects
      Writer
        .WriteName(FFactory.InstanceIdProp)
        .WriteInteger(FFactory.CurId);
    end;

    // write type
    // either always write, or write if the object
    if (FFactory.InstanceTypeSerialization = TInstanceTypeSerialization.Always) or (EntityType <> FClass) then
      Writer
        .WriteName(FFactory.InstanceTypeProp)
        .WriteString(QualifiedName(EntityType));

    FFactory.Depth := FFactory.Depth + 1;
    WriteProperties(AObject, Writer);
    FFactory.Depth := FFactory.Depth - 1;
    Writer.WriteEndObject;

    // We will only keep the object in the map if we are using reference for instance loops
    // and ref serialization is always. Otherwise, we will only check for recursive loops
    if not ((FFactory.InstanceLoopHandling = TInstanceLoopHandling.Reference) and
      (FFactory.InstanceRefSerialization = TInstanceRefSerialization.Always)) then
      FFactory.ObjectMap.Remove(AObject);
  end;
end;

procedure TJsonBaseObjectConverter.ReadJson(const Reader: TJsonReader;
  var Value: TValue);
begin
  Value := ReadObject(Reader, Value.AsObject);
end;

procedure TJsonBaseObjectConverter.ReadJsonProperty(JReader: TJsonReader; Target: TObject;
  const PropId: string);
begin
  if not ReadProperty(PropId, Target, JReader) then
    case FFactory.UnknownMemberHandling of
      TUnknownMemberHandling.Ignore:
        JReader.SkipValue;
      TUnknownMemberHandling.Error:
        raise EInvalidJsonProperty.Create(PropId, QualifiedName(Target.ClassType));
    end;
end;

function TJsonBaseObjectConverter.ReadObject(JReader: TJsonReader; Target: TObject): TObject;
var
  TargetCreated: Boolean;

  procedure TryAddToObjectMap(RefId: integer; Target: TObject);
  begin
    if (RefId <> -1) and (Target <> nil) then
      FFactory.ReferenceMap.AddOrSetValue(RefId, Target);
  end;

  function CreateInstance(AClass: TClass): TObject;
  begin
    Result := Converters.ObjectFactory.CreateInstance(AClass);
    TargetCreated := True;
  end;

var
  PropId: string;
  RefId: integer;
  TargetClass: TClass;
  TargetTypeName: string;
begin
  if JReader.Peek = TJsonToken.Null then
  begin
    JReader.ReadNull;
    Exit(nil);
  end;

  TargetCreated := False;
  try
    RefId := -1;
    JReader.ReadBeginObject;
    while JReader.HasNext do
    begin
      // read current json property and decide what to do based on it
      PropId := JReader.ReadName;

      // check for "$id" property
      if PropId = FFactory.InstanceIdProp then
      begin
        if RefId = -1 then
        begin
          RefId := JReader.ReadInteger;
          TryAddToObjectMap(RefId, Target);
        end
        else
          JReader.SkipValue; // just in case we have duplicated $id in json
      end
      else

      // check for "$ref" property (object reference)
      if PropId = FFactory.InstanceReferenceProp then
      begin
        // Target MUST be nil here. Otherwise, it means either:
        // a) other properties were already read (for example, JsonClassName and other object properties)
        //    and thus finding a reference now is invalid
        // b) Target was passed as parameter thus the object instance was already provided and could not
        //    be "replaced" by a reference.
        if Target <> nil then
          raise EObjectReferenceNotAllowed.Create;

        Result := FindReferencedObject(JReader.ReadInteger);

        // ignore all remaining properties
        while JReader.HasNext do
        begin
          JReader.ReadName;
          JReader.SkipValue;
        end;
        JReader.ReadEndObject;
        Exit;
      end
      else

      // check for type identification property (entity type)
      if PropId = FFactory.InstanceTypeProp then
      begin
        TargetTypeName := JReader.ReadString;
        TargetClass := FindType(TargetTypeName);
        if TargetClass = nil then
          raise EJsonTypeNotFound.Create(TargetTypeName);

        if Target = nil then
        begin
          // if basetype was specified, we should be sure TargetType inherited from BaseType
          if not TargetClass.InheritsFrom(Self.FClass) then
            raise EInvalidJsonInstanceType.Create(FFactory.InstanceTypeProp,
              QualifiedName(TargetClass), QualifiedName(Self.FClass));

          Target := CreateInstance(TargetClass);
          TryAddToObjectMap(RefId, Target);
        end
        else
        begin
          // Target already exists, and since JSON has the property identified by InstanceTypeProp declared, then
          // let's check if types match. If class type property is not present then no check would be done
          // but since it's here, we will perform the check to guarantee integrity.
          if Target.ClassType <> TargetClass then
            raise EInvalidJsonInstanceType.Create(FFactory.InstanceTypeProp,
              QualifiedName(TargetClass), QualifiedName(Target.ClassType));
        end;
      end
      else

      // check for regular properties
      begin
        // if we reach here with Target = nil (probably an insert), it means that we needed a
        // class type property in our JSON which was not present.
        // Thus we will use the Self.FClass as the class of the object to be created.
        if Target = nil then
        begin
          Target := CreateInstance(Self.FClass);
          TryAddToObjectMap(RefId, Target);
        end;

        FFactory.Depth := FFactory.Depth + 1;
        ReadJsonProperty(JReader, Target, PropId);
        FFactory.Depth := FFactory.Depth - 1;
      end;
    end;
    JReader.ReadEndObject;
    Result := Target;
    if TargetCreated then
      ObjectCreated(Target);
  except
    if TargetCreated then
      Target.Free;
    raise;
  end;
end;

procedure TJsonBaseObjectConverter.WriteJson(const Writer: TJsonWriter;
  const Value: TValue);
begin
  WriteObject(Writer, Value.AsObject);
end;

{ TJsonObjectConverterFactory }

constructor TJsonBaseObjectConverterFactory.Create;
begin
  FInstanceTypeProp := JsonDefaultInstanceTypeProp;
  FInstanceReferenceProp := JsonDefaultInstanceReferenceProp;
  FInstanceIdProp := JsonDefaultInstanceIdProp;
  FReferenceMap := TDictionary<integer, TObject>.Create;
  FObjectMap := TDictionary<TObject, Integer>.Create;
  InstanceRefSerialization := TInstanceRefSerialization.IfRecursive;
  InstanceTypeSerialization := TInstanceTypeSerialization.IfNeeded;
  InstanceLoopHandling := TInstanceLoopHandling.Error;
  UnknownMemberHandling := TUnknownMemberHandling.Ignore;
end;

destructor TJsonBaseObjectConverterFactory.Destroy;
begin
  FReferenceMap.Free;
  FObjectMap.Free;
  inherited;
end;

end.
