unit XData.JSchema.EntityGenerator;

{$I XData.inc}

interface

uses
  System.TypInfo, System.Rtti, System.Classes,
  Bcl.Json.Classes,
  XData.Aurelius.Model,
  XData.JSchema.Classes,
  XData.JSchema.Generators,
  XData.Model.Classes;

type
  TXDataJSchemaGeneratorFactory = class;

  TXDataJSchemaGenerator = class(TInterfacedObject, IJSchemaGenerator)
  strict private
    FFactory: TXDataJSchemaGeneratorFactory;
    FClass: TClass;
    function GetModel: TXDataAureliusModel;
    function GetGenerators: TJSchemaGenerators;
    property Model: TXDataAureliusModel read GetModel;
    property Generators: TJSchemaGenerators read GetGenerators;
  private
    procedure GenerateProperties(AType: TXDataEntityType; ASchema: TObjectSchema);
    procedure GenerateNavigationProperties(AType: TXDataEntityType; ASchema: TObjectSchema);
  protected
    function CreateSchema: TJsonSchema;
  public
    constructor Create(AClass: TClass; AFactory: TXDataJSchemaGeneratorFactory);
  end;

  TXDataJSchemaGeneratorFactory = class(TInterfacedObject, IJSchemaGeneratorFactory)
  strict private
    FModel: TXDataAureliusModel;
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}
    FGenerators: TJSchemaGenerators;
  protected
    property Model: TXDataAureliusModel read FModel;
    property Generators: TJSchemaGenerators read FGenerators;
  protected
    function CreateGenerator(Context: TJSchemaGeneratorContext; const ATypeToken: TTypeToken): IJSchemaGenerator;
  public
    constructor Create(AGenerators: TJSchemaGenerators; AModel: TXDataAureliusModel);
  end;

implementation

uses
  Aurelius.Mapping.Metadata,
  Aurelius.Mapping.Optimization,
  Bcl.Collections,
  Bcl.Rtti.Utils;

{ TXDataJSchemaGenerator }

constructor TXDataJSchemaGenerator.Create(AClass: TClass;
  AFactory: TXDataJSchemaGeneratorFactory);
begin
  inherited Create;
  FClass := AClass;
  FFactory := AFactory;
end;

function TXDataJSchemaGenerator.CreateSchema: TJsonSchema;
var
  Schema: TObjectSchema;
  EntityType: TXDataEntityType;
  Key: TXDataProperty;
  JKeys: TJArray;
  RootType: TXDataEntityType;
begin
  EntityType := Model.GetEntityTypeByClass(Self.FClass);
  Schema := TObjectSchema.Create;
  try
    Generators.TrySchemaDefinitions(Schema.Definitions);

    // add x-required
    Schema.CustomData.Add('x-required', TJArray.Create);

    GenerateProperties(EntityType, Schema);
    GenerateNavigationProperties(EntityType, Schema);

    // if no required fields, then remove
    if Schema.CustomData['x-required'].AsArray.Count = 0 then
      Schema.CustomData.Remove('x-required');

    // write keys
    RootType := EntityType;
    while RootType.BaseType <> nil do
      RootType := RootType.BaseType;
    JKeys := TJArray.Create;
    Schema.CustomData.Add('x-keys', JKeys);
    for Key in RootType.Key do
      JKeys.Add(Key.Name);
    Result := Schema;
  except
    Schema.Free;
    raise;
  end;
end;

procedure TXDataJSchemaGenerator.GenerateNavigationProperties(
  AType: TXDataEntityType; ASchema: TObjectSchema);
var
  RttiInfo: TRttiOptimization;
  NavProp: TXDataNavigationProperty;
  PropSchema: TJsonSchema;
begin
  if AType.BaseType <> nil then
    GenerateNavigationProperties(AType.BaseType, ASchema);
  for NavProp in AType.NavigationProperties do
  begin
    RttiInfo := Model.GetNavPropInfo(NavProp).RttiInfo;
    // Using RealType instead of MemberType, because Proxy<> does not have relevant schema information
    // (different from Nullable<T>)

    PropSchema := FFactory.Generators.ProcessRef(RttiInfo.RealType.Handle);
    ASchema.Properties.Add(NavProp.Name, PropSchema);
    PropSchema.Description := NavProp.Description;

    if NavProp.Required then
      ASchema.CustomData['x-required'].AsArray.Add(NavProp.Name);
  end;
end;

procedure TXDataJSchemaGenerator.GenerateProperties(AType: TXDataEntityType;
  ASchema: TObjectSchema);
var
  PropInfo: TXDataAureliusPropInfo;
  Prop: TXDataSimpleProperty;
  PropSchema: TJsonSchema;
begin
  if AType.BaseType <> nil then
    GenerateProperties(AType.BaseType, ASchema);
  for Prop in AType.Properties do
  begin
    PropInfo := Model.GetPropertyInfo(Prop);

//    PropSchema := FFactory.ProcessRef(RttiInfo.RealType, Generators.Get(RttiInfo.RealType.Handle));
    PropSchema := Generators.Get(PropInfo.RttiInfo.RealType.Handle).CreateSchema;
    ASchema.Properties.Add(Prop.Name, PropSchema);

    // Review this if schemas for simple properties might be generated as reference
    // for now they are always inline
    PropSchema.CustomData.Add('x-data-type', TJPrimitive.Create(Prop.PropertyType.QualifiedName));
    PropSchema.Description := Prop.Description;

    if Prop.Length <> 0 then
      PropSchema.CustomData.Add('x-length', TJPrimitive.Create(Prop.Length));
    if Prop.Precision <> 0 then
      PropSchema.CustomData.Add('x-precision', TJPrimitive.Create(Prop.Precision));
    if Prop.Scale <> 0 then
      PropSchema.CustomData.Add('x-scale', TJPrimitive.Create(Prop.Scale));
    if Prop.Required then
      ASchema.CustomData['x-required'].AsArray.Add(Prop.Name);
  end;
end;

function TXDataJSchemaGenerator.GetGenerators: TJSchemaGenerators;
begin
  Result := FFactory.Generators;
end;

function TXDataJSchemaGenerator.GetModel: TXDataAureliusModel;
begin
  Result := FFactory.Model;
end;

{ TXDataJSchemaGeneratorFactory }

constructor TXDataJSchemaGeneratorFactory.Create(AGenerators: TJSchemaGenerators;
  AModel: TXDataAureliusModel);
begin
  inherited Create;
  FGenerators := AGenerators;
  FModel := AModel;
end;

function TXDataJSchemaGeneratorFactory.CreateGenerator(Context: TJSchemaGeneratorContext;
  const ATypeToken: TTypeToken): IJSchemaGenerator;
var
  Clazz: TClass;
begin
  Result := nil;
  if ATypeToken.IsClass then
  begin
    Clazz := GetTypeData(ATypeToken)^.ClassType;
    if FModel.Explorer.Hierarchy.Contains(Clazz) then
      Result := TXDataJSchemaGenerator.Create(Clazz, Self);
  end;
end;

end.
