delphimvcframework/sources/MVCFramework.ActiveRecord.pas

// *************************************************************************** }
//
// Delphi MVC Framework
//
// Copyright (c) 2010-2018 Daniele Teti and the DMVCFramework Team
//
// https://github.com/danieleteti/delphimvcframework
//
// ***************************************************************************
//
// Licensed 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 MVCFramework.ActiveRecord;

interface

uses
  System.Generics.Defaults,
  System.Generics.Collections,
  System.RTTI,

  FireDAC.DApt,
  FireDAC.Stan.Param,
  Data.DB,
  MVCFramework.Commons,
  MVCFramework.RQL.Parser,
  MVCFramework,
  MVCFramework.Serializer.Intf,
  FireDAC.Comp.Client,
  System.SysUtils;

type
  EMVCActiveRecord = class(EMVCException)
  public
    constructor Create(const AMsg: string); reintroduce; { do not override!! }
  end;

  TMVCActiveRecordClass = class of TMVCActiveRecord;
  TMVCActiveRecordFieldOption = (foAutoGenerated);
  TMVCActiveRecordFieldOptions = set of TMVCActiveRecordFieldOption;
  TMVCEntityAction = (eaCreate, eaRetrieve, eaUpdate, eaDelete);
  TMVCEntityActions = set of TMVCEntityAction;

  IMVCEntityProcessor = interface
    ['{E7CD11E6-9FF9-46D2-B7B0-DA5B38EAA14E}']
    procedure GetEntities(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; var Handled: Boolean);
    procedure GetEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; const id: Integer;
      var Handled: Boolean);
    procedure CreateEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string;
      var Handled: Boolean);
    procedure UpdateEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; const id: Integer;
      var Handled: Boolean);
    procedure DeleteEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; const id: Integer;
      var Handled: Boolean);
  end;

  MVCActiveRecordCustomAttribute = class(TCustomAttribute)

  end;

  TableAttribute = class(MVCActiveRecordCustomAttribute)
    Name: string;
    constructor Create(aName: string);
  end;

  TableFieldAttribute = class(MVCActiveRecordCustomAttribute)
  public
    FieldName: string;
    constructor Create(aFieldName: string);
  end;

  PrimaryKeyAttribute = class(MVCActiveRecordCustomAttribute)
  public
    FieldName: string;
    FieldOptions: TMVCActiveRecordFieldOptions;
    constructor Create(const aFieldName: string; const aFieldOptions: TMVCActiveRecordFieldOptions); overload;
    constructor Create(const aFieldName: string); overload;
  end;

  EntityActionsAttribute = class(MVCActiveRecordCustomAttribute)
  private
    EntityAllowedActions: TMVCEntityActions;
  public
    constructor Create(const aEntityAllowedActions: TMVCEntityActions);

  end;

  TMVCActiveRecord = class
  private
    fConn: TFDConnection;
    fPrimaryKeyFieldName: string;
    fPrimaryKeyOptions: TMVCActiveRecordFieldOptions;
    fEntityAllowedActions: TMVCEntityActions;
    function TableFieldsDelimited(const Delimiter: string = ','): string;
    procedure MapColumnToTValue(const aFieldName: string; const aField: TField; const aRTTIField: TRttiField);
    procedure MapTValueToParam(const aValue: TValue; const aParam: TFDParam);
  protected
    fRTTIType: TRttiType;
    fProps: TArray<TRttiField>;
    fObjAttributes: TArray<TCustomAttribute>;
    fPropsAttributes: TArray<TCustomAttribute>;
    fTableName: string;
    fMap: TDictionary<TRttiField, string>;
    fPrimaryKey: TRttiField;
    function Connection: TFDConnection;
    procedure InitTableInfo;
    function CreateInsertSQL: string; virtual;
    function CreateSelectByPKSQL(aPrimaryKey: int64): string; virtual;
    function CreateSelectSQL: string; virtual;
    function CreateUpdateSQL: string; virtual;
    function CreateDeleteSQL: string; virtual;
    function GetWhereByPrimaryKey: string; virtual;
    function GetWhereByPrimaryKeyWithValue: string; virtual;
    class function ExecQuery(const SQL: string; const Values: array of Variant): TDataSet; overload;
    class function ExecQuery(const SQL: string; const Values: array of Variant; const Connection: TFDConnection): TDataSet; overload;

    // class function ExecNonQuery(const SQL: string; const Values: array of Variant): int64; overload;
    // class function ExecNonQuery(const SQL: string; const Values: array of Variant; const Connection: TFDConnection): int64; overload;

    function ExecNonQuery(const SQL: string; RefreshAutoGenerated: Boolean = false): int64; overload;
    // load events
    /// <summary>
    /// Called everywhere before persist object into database
    /// </summary>
    procedure OnValidation; virtual;

    /// <summary>
    /// Called just after load the object state from database
    /// </summary>
    procedure OnAfterLoad; virtual;

    /// <summary>
    /// Called before load the object state from database
    /// </summary>
    procedure OnBeforeLoad; virtual;

    /// <summary>
    /// Called before insert the object state to database
    /// </summary>

    procedure OnBeforeInsert; virtual;
    /// <summary>
    /// Called before update the object state to database
    /// </summary>

    procedure OnBeforeUpdate; virtual;

    /// <summary>
    /// Called before delete object from database
    /// </summary>
    procedure OnBeforeDelete; virtual;

    /// <summary>
    /// Called before insert or update the object to the database
    /// </summary>
    procedure OnBeforeInsertOrUpdate; virtual;

  public
    constructor Create(aLazyLoadConnection: Boolean); overload; { cannot be virtual! }
    constructor Create; overload; virtual;
    destructor Destroy; override;
    function CheckAction(const aEntityAction: TMVCEntityAction; const aRaiseException: Boolean = True): Boolean;
    procedure Insert;
    function GetMapping: TMVCFieldsMapping;
    function LoadByPK(id: int64): Boolean;
    procedure Update;
    procedure Delete;
    function TableInfo: string;
    procedure LoadByDataset(const aDataSet: TDataSet);
    procedure SetPK(const aValue: TValue);
    function GetPK: TValue;
    class function GetByPrimaryKey<T: TMVCActiveRecord, constructor>(const aValue: int64): T; overload;
    class function GetByPrimaryKey(const aClass: TMVCActiveRecordClass; const aValue: int64): TMVCActiveRecord; overload;
    class function Select<T: TMVCActiveRecord, constructor>(const SQL: string; const Params: array of Variant): TObjectList<T>; overload;
    class function Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant)
      : TObjectList<TMVCActiveRecord>; overload;
    class function Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant;
      const Connection: TFDConnection)
      : TObjectList<TMVCActiveRecord>; overload;
    class function SelectRQL(const aClass: TMVCActiveRecordClass;
      const RQL: string; const Mapping: TMVCFieldsMapping; const RQLBackend: TRQLBackend): TObjectList<TMVCActiveRecord>; overload;
    class function Where<T: TMVCActiveRecord, constructor>(const SQLWhere: string; const Params: array of Variant): TObjectList<T>;
      overload;
    class function Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant)
      : TObjectList<TMVCActiveRecord>; overload;
    class function Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant;
      const Connection: TFDConnection)
      : TObjectList<TMVCActiveRecord>; overload;
    class function All<T: TMVCActiveRecord, constructor>: TObjectList<T>; overload;
    class function All(const aClass: TMVCActiveRecordClass): TObjectList<TMVCActiveRecord>; overload;
    class function SelectDataSet(const SQL: string; const Params: array of Variant): TDataSet;
  end;

  IMVCEntitiesRegistry = interface
    ['{BB227BEB-A74A-4637-8897-B13BA938C07B}']
    procedure AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass);
    procedure AddEntityProcessor(const aURLSegment: string; const aEntityProcessor: IMVCEntityProcessor);
    function FindEntityClassByURLSegment(const aURLSegment: string; out aMVCActiveRecordClass: TMVCActiveRecordClass): Boolean;
    function FindProcessorByURLSegment(const aURLSegment: string; out aMVCEntityProcessor: IMVCEntityProcessor): Boolean;
  end;

  TMVCEntitiesRegistry = class(TInterfacedObject, IMVCEntitiesRegistry)
  private
    fEntitiesDict: TDictionary<string, TMVCActiveRecordClass>;
    fProcessorsDict: TDictionary<string, IMVCEntityProcessor>;
  public
    constructor Create; virtual;
    destructor Destroy; override;
  protected
    procedure AddEntityProcessor(const aURLSegment: string;
      const aEntityProcessor: IMVCEntityProcessor);
    procedure AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass);
    function FindEntityClassByURLSegment(const aURLSegment: string; out aMVCActiveRecordClass: TMVCActiveRecordClass): Boolean;
    function FindProcessorByURLSegment(const aURLSegment: string; out aMVCEntityProcessor: IMVCEntityProcessor): Boolean;
  end;

  IMVCActiveRecordConnections = interface
    ['{7B87473C-1784-489F-A838-925E7DDD0DE2}']
    procedure AddConnection(const aName: string; const aConnection: TFDConnection);
    procedure RemoveConnection(const aName: string);
    procedure SetCurrent(const aName: string);
    function GetCurrent: TFDConnection;
  end;

  TMVCConnectionsRepository = class(TInterfacedObject, IMVCActiveRecordConnections)
  private
    fMREW: TMultiReadExclusiveWriteSynchronizer;
    fConnectionsDict: TDictionary<string, TFDConnection>;
    fCurrentConnectionsByThread: TDictionary<TThreadID, string>;
    function GetKeyName(const aName: string): string;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure AddConnection(const aName: string; const aConnection: TFDConnection);
    procedure RemoveConnection(const aName: string);
    procedure SetCurrent(const aName: string);
    function GetCurrent: TFDConnection;
    function GetByName(const aName: string): TFDConnection;
  end;

function ActiveRecordConnectionsRegistry: IMVCActiveRecordConnections;

function ActiveRecordMappingRegistry: IMVCEntitiesRegistry;

function GetBackEndByConnection(aConnection: TFDConnection): TRQLBackend;

implementation

uses
  System.TypInfo,
  System.IOUtils,
  System.Classes,
  MVCFramework.DataSet.Utils,
  MVCFramework.Logger,
  FireDAC.Stan.Option,
  Data.FmtBcd;

var
  gCtx: TRttiContext;
  gEntitiesRegistry: IMVCEntitiesRegistry;
  gConnections: IMVCActiveRecordConnections;
  gLock: TObject;

function GetBackEndByConnection(aConnection: TFDConnection): TRQLBackend;
begin
  if aConnection.DriverName = 'FB' then
    Exit(cbFirebird);
  if aConnection.DriverName = 'MySQL' then
    Exit(cbMySQL);
  raise ERQLException.CreateFmt('Unknown driver fro RQL backend "%s"', [aConnection.DriverName]);
end;

function ActiveRecordConnectionsRegistry: IMVCActiveRecordConnections;
begin
  if gConnections = nil then // double check here
  begin
    TMonitor.Enter(gLock);
    try
      if gConnections = nil then
      begin
        gConnections := TMVCConnectionsRepository.Create;
      end;
    finally
      TMonitor.Exit(gLock);
    end;
  end;
  Result := gConnections;
end;

{ TConnectionsRepository }

procedure TMVCConnectionsRepository.AddConnection(const aName: string; const aConnection: TFDConnection);
var
  lName: string;
  lConnKeyName: string;
begin
  lName := aName.ToLower;
  lConnKeyName := GetKeyName(lName);

  fMREW.BeginWrite;
  try
    fConnectionsDict.AddOrSetValue(lConnKeyName, aConnection);
    if lName = 'default' then
    begin
      fCurrentConnectionsByThread.AddOrSetValue(TThread.CurrentThread.ThreadID, lName);
    end;
  finally
    fMREW.EndWrite;
  end;
end;

constructor TMVCConnectionsRepository.Create;
begin
  inherited;
  fMREW := TMultiReadExclusiveWriteSynchronizer.Create;
  fConnectionsDict := TDictionary<string, TFDConnection>.Create;
  fCurrentConnectionsByThread := TDictionary<TThreadID, string>.Create;
end;

destructor TMVCConnectionsRepository.Destroy;
begin
  fConnectionsDict.Free;
  fCurrentConnectionsByThread.Free;
  fMREW.Free;
  inherited;
end;

function TMVCConnectionsRepository.GetByName(const aName: string): TFDConnection;
var
  lKeyName: string;
begin
  lKeyName := GetKeyName(aName.ToLower);
  fMREW.BeginRead;
  try
    if not fConnectionsDict.TryGetValue(lKeyName, Result) then
      raise Exception.CreateFmt('Unknown connection %s', [aName]);
  finally
    fMREW.EndRead;
  end;
end;

function TMVCConnectionsRepository.GetCurrent: TFDConnection;
var
  lName: string;
begin
  fMREW.BeginRead;
  try
    if fCurrentConnectionsByThread.TryGetValue(TThread.Current.ThreadID, lName) then
    begin
      Result := GetByName(lName);
    end
    else
    begin
      raise EMVCActiveRecord.Create('No current connection for thread');
    end;
  finally
    fMREW.EndRead;
  end;
end;

function TMVCConnectionsRepository.GetKeyName(const aName: string): string;
begin
  Result := Format('%10d::%s', [TThread.Current.ThreadID, aName]);
end;

procedure TMVCConnectionsRepository.RemoveConnection(const aName: string);
var
  lName: string;
  lConn: TFDConnection;
  lKeyName: string;
begin
  lName := aName.ToLower;
  lKeyName := GetKeyName(lName);

  fMREW.BeginWrite;
  try
    if not fConnectionsDict.TryGetValue(lKeyName, lConn) then
      raise Exception.CreateFmt('Unknown connection %s', [aName]);
    fConnectionsDict.Remove(lKeyName);
    try
      FreeAndNil(lConn);
    except
      on E: Exception do
      begin
        LogE('ActiveRecord: ' + E.ClassName + ' > ' + E.Message);
        raise;
      end;
    end;
  finally
    fMREW.EndWrite;
  end;
end;

procedure TMVCConnectionsRepository.SetCurrent(const aName: string);
var
  lName: string;
  lKeyName: string;
begin
  lName := aName.ToLower;
  lKeyName := GetKeyName(lName);

  fMREW.BeginWrite;
  try
    if not fConnectionsDict.ContainsKey(lKeyName) then
      raise Exception.CreateFmt('Unknown connection %s', [aName]);
    fCurrentConnectionsByThread.AddOrSetValue(TThread.Current.ThreadID, lName);
  finally
    fMREW.EndWrite;
  end;
end;

function ActiveRecordMappingRegistry: IMVCEntitiesRegistry;
begin
  if gEntitiesRegistry = nil then
  begin
    TMonitor.Enter(gLock);
    try
      if gEntitiesRegistry = nil then
      begin
        gEntitiesRegistry := TMVCEntitiesRegistry.Create;
      end;
    finally
      TMonitor.Exit(gLock);
    end;
  end;
  Result := gEntitiesRegistry;
end;

{ TableFieldAttribute }

constructor TableFieldAttribute.Create(aFieldName: string);
begin
  inherited Create;
  FieldName := aFieldName;
end;

{ TableAttribute }

constructor TableAttribute.Create(aName: string);
begin
  inherited Create;
  name := aName;
end;

{ TActiveRecord }

destructor TMVCActiveRecord.Destroy;
begin
  fMap.Free;
  fConn := nil;
  inherited;
end;

function TMVCActiveRecord.ExecNonQuery(const SQL: string; RefreshAutoGenerated: Boolean = false): int64;
var
  lQry: TFDQuery;
  lPar: TFDParam;
  lPair: TPair<TRttiField, string>;
  lValue: TValue;
begin
  lQry := TFDQuery.Create(nil);
  try
    lQry.Connection := fConn;
    lQry.SQL.Text := SQL;
    // lQry.Prepare;
    for lPair in fMap do
    begin
      lPar := lQry.FindParam(lPair.value);
      if lPar <> nil then
      begin
        lValue := lPair.Key.GetValue(Self);
        MapTValueToParam(lValue, lPar);
      end
    end;

    // check if it's the primary key
    lPar := lQry.FindParam(fPrimaryKeyFieldName);
    if lPar <> nil then
    begin
      if lPar.DataType = ftUnknown then
      begin
        { TODO -oDanieleT -cGeneral : Let's find a smarter way to do this if the engine cannot recognize parameter's datatype }
        lPar.DataType := ftLargeint;
      end;
      MapTValueToParam(fPrimaryKey.GetValue(Self), lPar);
    end;

    if RefreshAutoGenerated and (foAutoGenerated in fPrimaryKeyOptions) then
    begin
      lQry.Open;
      fPrimaryKey.SetValue(Self, lQry.FieldByName(fPrimaryKeyFieldName).AsInteger);
      OnAfterLoad;
    end
    else
    begin
      lQry.ExecSQL(SQL);
    end;

    Result := lQry.RowsAffected;
  finally
    lQry.Free;
  end;
end;

// class function TMVCActiveRecord.ExecNonQuery(const SQL: string;
// const Values: array of Variant; const Connection: TFDConnection): int64;
// var
// lQry: TFDQuery;
// begin
// lQry := TFDQuery.Create(nil);
// try
// lQry.FetchOptions.Unidirectional := True;
// if Connection = nil then
// begin
// lQry.Connection := ActiveRecordConnectionsRegistry.GetCurrent;
// end
// else
// begin
// lQry.Connection := Connection;
// end;
// lQry.SQL.Text := SQL;
// lQry.Prepare;
// lQry.ExecSQL(SQL, Values);
// Result := lQry.RowsAffected;
// except
// lQry.Free;
// raise;
// end;
// end;
//
// class function TMVCActiveRecord.ExecNonQuery(const SQL: string;
// const Values: array of Variant): int64;
// begin
// Result := ExecNonQuery(SQL, Values, nil);
// end;

class function TMVCActiveRecord.ExecQuery(const SQL: string;
  const Values: array of Variant; const Connection: TFDConnection): TDataSet;
var
  lQry: TFDQuery;
begin
  lQry := TFDQuery.Create(nil);
  try
    lQry.FetchOptions.Unidirectional := True;
    if Connection = nil then
    begin
      lQry.Connection := ActiveRecordConnectionsRegistry.GetCurrent;
    end
    else
    begin
      lQry.Connection := Connection;
    end;
    lQry.SQL.Text := SQL;
    // lQry.Prepare;
    lQry.Open(SQL, Values);
    Result := lQry;
  except
    lQry.Free;
    raise;
  end;
end;

class function TMVCActiveRecord.ExecQuery(const SQL: string; const Values: array of Variant): TDataSet;
begin
  Result := ExecQuery(SQL, Values, nil);
end;

function TMVCActiveRecord.GetWhereByPrimaryKey: string;
begin
  Result := ' ' + fPrimaryKeyFieldName + '= :' + fPrimaryKeyFieldName;
end;

function TMVCActiveRecord.GetWhereByPrimaryKeyWithValue: string;
begin
  Result := ' ' + fPrimaryKeyFieldName + '= ' + IntToStr(fPrimaryKey.GetValue(Self).AsInt64);
end;

procedure TMVCActiveRecord.InitTableInfo;
var
  lAttribute: TCustomAttribute;
  lRTTIField: TRttiField;
begin
  fEntityAllowedActions := [TMVCEntityAction.eaCreate, TMVCEntityAction.eaRetrieve, TMVCEntityAction.eaUpdate, TMVCEntityAction.eaDelete];
  fTableName := '';
  fRTTIType := gCtx.GetType(Self.ClassInfo);
  fObjAttributes := fRTTIType.GetAttributes;
  for lAttribute in fObjAttributes do
  begin
    if lAttribute is TableAttribute then
    begin
      fTableName := TableAttribute(lAttribute).Name;
      continue;
    end;
    if lAttribute is EntityActionsAttribute then
    begin
      fEntityAllowedActions := EntityActionsAttribute(lAttribute).EntityAllowedActions;
      Break;
    end;
  end;

  if fTableName = '' then
    raise Exception.Create('Cannot find TableNameAttribute');

  fProps := fRTTIType.GetFields;
  for lRTTIField in fProps do
  begin
    fPropsAttributes := lRTTIField.GetAttributes;
    if Length(fPropsAttributes) = 0 then
      continue;
    for lAttribute in fPropsAttributes do
    begin
      if lAttribute is TableFieldAttribute then
      begin
        fMap.Add(lRTTIField, { fTableName + '.' + } TableFieldAttribute(lAttribute).FieldName);
      end
      else if lAttribute is PrimaryKeyAttribute then
      begin
        fPrimaryKey := lRTTIField;
        fPrimaryKeyFieldName := PrimaryKeyAttribute(lAttribute).FieldName;
        fPrimaryKeyOptions := PrimaryKeyAttribute(lAttribute).FieldOptions;
      end;
    end;
  end;
end;

procedure TMVCActiveRecord.Insert;
var
  SQL: string;
begin
  CheckAction(TMVCEntityAction.eaCreate);
  OnValidation;
  OnBeforeInsert;
  OnBeforeInsertOrUpdate;
  SQL := CreateInsertSQL;
  ExecNonQuery(SQL, True);
end;

constructor TMVCActiveRecord.Create(aLazyLoadConnection: Boolean);
begin
  inherited Create;
  fConn := nil;
  if not aLazyLoadConnection then
  begin
    Connection;
  end;
  fMap := TDictionary<TRttiField, string>.Create;
  InitTableInfo;
end;

function TMVCActiveRecord.CreateUpdateSQL: string;
var
  keyvalue: TPair<TRttiField, string>;
begin
  Result := 'UPDATE ' + fTableName + ' SET ';
  for keyvalue in fMap do
  begin
    Result := Result + keyvalue.value + ' = :' + keyvalue.value + ',';
  end;
  Result[Length(Result)] := ' ';
  if Assigned(fPrimaryKey) then
  begin
    Result := Result + ' where ' + GetWhereByPrimaryKey;
  end;
end;

class function TMVCActiveRecord.GetByPrimaryKey(const aClass: TMVCActiveRecordClass; const aValue: int64): TMVCActiveRecord;
begin
  Result := aClass.Create;
  Result.LoadByPK(aValue);
end;

class function TMVCActiveRecord.GetByPrimaryKey<T>(const aValue: int64): T;
var
  lActiveRecord: TMVCActiveRecord;
begin
  Result := T.Create;
  lActiveRecord := TMVCActiveRecord(Result);
  lActiveRecord.LoadByPK(aValue);
end;

function TMVCActiveRecord.GetMapping: TMVCFieldsMapping;
var
  lPair: TPair<TRttiField, string>;
  i: Integer;
begin
  if not fPrimaryKeyFieldName.IsEmpty then
    SetLength(Result, fMap.Count + 1)
  else
    SetLength(Result, fMap.Count);

  i := 0;
  for lPair in fMap do
  begin
    Result[i].InstanceFieldName := lPair.Key.Name.Substring(1).ToLower;
    Result[i].DatabaseFieldName := lPair.value;
    inc(i);
  end;

  if not fPrimaryKeyFieldName.IsEmpty then
  begin
    Result[i].InstanceFieldName := fPrimaryKey.Name.Substring(1).ToLower;
    Result[i].DatabaseFieldName := fPrimaryKeyFieldName;
  end;
end;

function TMVCActiveRecord.GetPK: TValue;
begin
  if fPrimaryKeyFieldName.IsEmpty then
    raise Exception.Create('No primary key defined');
  Result := fPrimaryKey.GetValue(Self);
end;

function TMVCActiveRecord.CheckAction(const aEntityAction: TMVCEntityAction;
  const aRaiseException: Boolean): Boolean;
begin
  Result := aEntityAction in fEntityAllowedActions;
  if (not Result) and aRaiseException then
    raise EMVCActiveRecord.CreateFmt('Action not allowed on "%s"', [ClassName]);
end;

function TMVCActiveRecord.Connection: TFDConnection;
begin
  if fConn = nil then
  begin
    fConn := ActiveRecordConnectionsRegistry.GetCurrent;
  end;
  Result := fConn;
end;

constructor TMVCActiveRecord.Create;
begin
  Create(false);
end;

function TMVCActiveRecord.CreateDeleteSQL: string;
begin
  Result := 'DELETE FROM ' + fTableName + ' WHERE ' + GetWhereByPrimaryKeyWithValue;
end;

function TMVCActiveRecord.CreateInsertSQL: string;
var
  keyvalue: TPair<TRttiField, string>;
  lSB: TStringBuilder;
begin
  lSB := TStringBuilder.Create;
  try
    lSB.Append('INSERT INTO ' + fTableName + '(');
    for keyvalue in fMap do
      lSB.Append(keyvalue.value + ',');
    lSB.Remove(lSB.Length - 1, 1);
    lSB.Append(') values (');
    for keyvalue in fMap do
    begin
      lSB.Append(':' + keyvalue.value + ',');
    end;
    lSB.Remove(lSB.Length - 1, 1);
    lSB.Append(')');

    if foAutoGenerated in fPrimaryKeyOptions then
    begin
      case GetBackEndByConnection(fConn) of
        cbFirebird:
          begin
            lSB.Append(' RETURNING ' + fPrimaryKeyFieldName);
          end;
        cbMySQL:
          begin
            lSB.Append(';SELECT LAST_INSERT_ID() as ' + fPrimaryKeyFieldName);
          end;
      else
        raise EMVCActiveRecord.Create('Unsupported backend engine');
      end;
    end;
    Result := lSB.ToString;
  finally
    lSB.Free;
  end;
end;

function TMVCActiveRecord.CreateSelectByPKSQL(aPrimaryKey: int64): string;
begin
  Result := CreateSelectSQL + ' WHERE ' + fPrimaryKeyFieldName + ' = :' + fPrimaryKeyFieldName;
end;

function TMVCActiveRecord.CreateSelectSQL: string;
begin
  Result := 'SELECT ' + TableFieldsDelimited + ' FROM ' + fTableName;
end;

procedure TMVCActiveRecord.Delete;
var
  SQL: string;
begin
  if not Assigned(fPrimaryKey) then
    raise Exception.CreateFmt('Cannot delete %s without a primary key', [ClassName]);
  SQL := CreateDeleteSQL;
  ExecNonQuery(SQL, false);
end;

procedure TMVCActiveRecord.MapColumnToTValue(const aFieldName: string; const aField: TField; const aRTTIField: TRttiField);
var
  lMS: TMemoryStream;
  lInternalStream: TStream;
begin
  case aField.DataType of
    ftString, ftWideString:
      begin
        aRTTIField.SetValue(Self, aField.AsString);
      end;
    ftLargeint:
      begin
        aRTTIField.SetValue(Self, aField.AsLargeInt);
      end;
    ftInteger, ftSmallint, ftShortint:
      begin
        aRTTIField.SetValue(Self, aField.AsInteger);
      end;
    ftLongWord, ftWord:
      begin
        aRTTIField.SetValue(Self, aField.AsLongWord);
      end;
    ftDate:
      begin
        aRTTIField.SetValue(Self, Trunc(aField.AsDateTime));
      end;
    ftDateTime:
      begin
        aRTTIField.SetValue(Self, aField.AsDateTime);
      end;
    ftBoolean:
      begin
        aRTTIField.SetValue(Self, aField.AsBoolean);
      end;
    ftMemo, ftWideMemo:
      begin
        aRTTIField.SetValue(Self, aField.AsString);
      end;
    ftBCD:
      begin
        aRTTIField.SetValue(Self, BCDtoCurrency(aField.AsBCD));
      end;
    ftBlob:
      begin
        lInternalStream := aRTTIField.GetValue(Self).AsObject as TStream;
        if lInternalStream = nil then
        begin
          raise EMVCActiveRecord.CreateFmt('Property target for %s field is nil', [aFieldName]);
        end;
        lInternalStream.Position := 0;
        TBlobField(aField).SaveToStream(lInternalStream);
        lInternalStream.Position := 0;
      end;
  else
    raise EMVCActiveRecord.CreateFmt('Unsupported FieldType (%d) for field %s', [Ord(aField.DataType), aFieldName]);
  end;

end;

procedure TMVCActiveRecord.MapTValueToParam(const aValue: TValue; const aParam: TFDParam);
var
  lStream: TStream;
begin
  case aValue.TypeInfo.Kind of
    // tkUnknown:
    // begin
    // { aParam.DataType could be pkUndefined for some RDBMS (es. MySQL), so we rely on Variant }
    // if (aValue.TypeInfo.Kind = tkClass) then
    // begin
    // if not aValue.IsInstanceOf(TStream) then
    // raise EMVCActiveRecord.CreateFmt('Unsupported type for param %s', [aParam.Name]);
    // lStream := aValue.AsType<TStream>(false);
    // if Assigned(lStream) then
    // begin
    // lStream.Position := 0;
    // aParam.LoadFromStream(lStream, ftBlob);
    // end
    // else
    // begin
    // aParam.Clear;
    // end;
    //
    // end
    // else
    // begin
    // aParam.value := aValue.AsVariant;
    // end;
    // end;
    tkString, tkUString:
      begin
        aParam.AsString := aValue.AsString;
      end;
    tkWideString:
      begin
        aParam.AsWideString := aValue.AsString;
      end;
    tkInt64:
      begin
        aParam.AsLargeInt := aValue.AsInt64;
      end;
    tkInteger:
      begin
        aParam.AsInteger := aValue.AsInteger;
      end;
    tkEnumeration:
      begin
        if aValue.TypeInfo = TypeInfo(System.Boolean) then
        begin
          aParam.AsBoolean := aValue.AsBoolean;
        end
        else
        begin
          aParam.AsInteger := Ord(aValue.AsInteger);
        end;
      end;
    tkFloat:
      begin
        if aValue.TypeInfo.Name = 'TDate' then
        begin
          aParam.AsDate := Trunc(aValue.AsExtended);
        end
        else if aValue.TypeInfo.Name = 'TDateTime' then
        begin
          aParam.AsDateTime := aValue.AsExtended;
        end;
      end;
    tkClass:
      begin
        if not aValue.IsInstanceOf(TStream) then
          raise EMVCActiveRecord.CreateFmt('Unsupported reference type for param %s: %s', [aParam.Name, aValue.AsObject.ClassName]);
        lStream := aValue.AsType<TStream>(false);
        if Assigned(lStream) then
        begin
          lStream.Position := 0;
          aParam.LoadFromStream(lStream, ftBlob);
        end
        else
        begin
          aParam.Clear;
        end;
      end;
    // ftBoolean:
    // begin
    // aParam.AsBoolean := aValue.AsBoolean;
    // end;
    // ftMemo:
    // begin
    // aParam.AsMemo := AnsiString(aValue.AsString);
    // end;
    // ftWideMemo:
    // begin
    // aParam.AsWideMemo := aValue.AsString;
    // end;
    // ftBCD:
    // begin
    // aParam.AsBCD := aValue.AsCurrency;
    // end;
    // ftBlob:
    // begin
    // lStream := aValue.AsType<TStream>(false);
    // if Assigned(lStream) then
    // begin
    // lStream.Position := 0;
    // aParam.LoadFromStream(lStream, ftBlob);
    // end
    // else
    // begin
    // aParam.Clear;
    // end;
    // end;
  else
    raise Exception.CreateFmt('Unsupported TypeKind (%d) for param %s', [Ord(aValue.TypeInfo.Kind), aParam.Name]);
  end;

  // case aParam.DataType of
  // ftUnknown:
  // begin
  // { aParam.DataType could be pkUndefined for some RDBMS (es. MySQL), so we rely on Variant }
  // if (aValue.TypeInfo.Kind = tkClass) then
  // begin
  // if not aValue.IsInstanceOf(TStream) then
  // raise EMVCActiveRecord.CreateFmt('Unsupported type for param %s', [aParam.Name]);
  // lStream := aValue.AsType<TStream>(false);
  // if Assigned(lStream) then
  // begin
  // lStream.Position := 0;
  // aParam.LoadFromStream(lStream, ftBlob);
  // end
  // else
  // begin
  // aParam.Clear;
  // end;
  //
  // end
  // else
  // begin
  // aParam.value := aValue.AsVariant;
  // end;
  // end;
  // ftString:
  // begin
  // aParam.AsString := aValue.AsString;
  // end;
  // ftWideString:
  // begin
  // aParam.AsWideString := aValue.AsString;
  // end;
  // ftLargeint:
  // begin
  // aParam.AsLargeInt := aValue.AsInt64;
  // end;
  // ftSmallint:
  // begin
  // aParam.AsSmallInt := aValue.AsInteger;
  // end;
  // ftInteger:
  // begin
  // aParam.AsInteger := aValue.AsInteger;
  // end;
  // ftLongWord:
  // begin
  // aParam.AsLongWord := aValue.AsInteger;
  // end;
  // ftWord:
  // begin
  // aParam.AsWord := aValue.AsInteger;
  // end;
  // ftDate:
  // begin
  // aParam.AsDate := Trunc(aValue.AsExtended);
  // end;
  // ftDateTime:
  // begin
  // aParam.AsDateTime := aValue.AsExtended;
  // end;
  // ftBoolean:
  // begin
  // aParam.AsBoolean := aValue.AsBoolean;
  // end;
  // ftMemo:
  // begin
  // aParam.AsMemo := AnsiString(aValue.AsString);
  // end;
  // ftWideMemo:
  // begin
  // aParam.AsWideMemo := aValue.AsString;
  // end;
  // ftBCD:
  // begin
  // aParam.AsBCD := aValue.AsCurrency;
  // end;
  // ftBlob:
  // begin
  // lStream := aValue.AsType<TStream>(false);
  // if Assigned(lStream) then
  // begin
  // lStream.Position := 0;
  // aParam.LoadFromStream(lStream, ftBlob);
  // end
  // else
  // begin
  // aParam.Clear;
  // end;
  // end;
  // else
  // raise Exception.CreateFmt('Unsupported FieldType (%d) for param %s', [Ord(aParam.DataType), aParam.Name]);
  // end;
end;

procedure TMVCActiveRecord.LoadByDataset(const aDataSet: TDataSet);
var
  lItem: TPair<TRttiField, string>;
  lValue: TValue;
  lDestField: TValue;
  lStream: TStream;
begin
  CheckAction(TMVCEntityAction.eaRetrieve);
  OnBeforeLoad;
  for lItem in fMap do
  begin
    MapColumnToTValue(lItem.value, aDataSet.FieldByName(lItem.value), lItem.Key);
  end;
  if not fPrimaryKeyFieldName.IsEmpty then
  begin
    MapColumnToTValue(fPrimaryKeyFieldName, aDataSet.FieldByName(fPrimaryKeyFieldName), fPrimaryKey);
  end;
  OnAfterLoad;
end;

function TMVCActiveRecord.LoadByPK(id: int64): Boolean;
var
  SQL: string;
  lDataSet: TDataSet;
begin
  CheckAction(TMVCEntityAction.eaRetrieve);
  SQL := CreateSelectByPKSQL(id);
  lDataSet := ExecQuery(SQL, [id]);
  try
    Result := not lDataSet.Eof;
    if Result then
    begin
      LoadByDataset(lDataSet);
    end;
  finally
    lDataSet.Free;
  end;
end;

procedure TMVCActiveRecord.OnAfterLoad;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeDelete;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeInsert;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeInsertOrUpdate;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeLoad;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeUpdate;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnValidation;
begin
  // do nothing
end;

class function TMVCActiveRecord.Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant)
  : TObjectList<TMVCActiveRecord>;
begin
  Result := Select(aClass, SQL, Params, nil);
end;

class function TMVCActiveRecord.Select(const aClass: TMVCActiveRecordClass;
  const SQL: string; const Params: array of Variant;
  const Connection: TFDConnection): TObjectList<TMVCActiveRecord>;
var
  lDataSet: TDataSet;
  lAR: TMVCActiveRecord;
begin
  Result := TObjectList<TMVCActiveRecord>.Create(True);
  try
    lDataSet := ExecQuery(SQL, Params, Connection);
    try
      while not lDataSet.Eof do
      begin
        lAR := aClass.Create;
        Result.Add(lAR);
        lAR.LoadByDataset(lDataSet);
        lDataSet.Next;
      end;
      // lDataSet.First;
      // TFile.WriteAllText('output.json', lDataSet.AsJSONArray);
    finally
      lDataSet.Free;
    end;
  except
    Result.Free;
    raise;
  end;

end;

class function TMVCActiveRecord.Select<T>(const SQL: string; const Params: array of Variant): TObjectList<T>;
var
  lDataSet: TDataSet;
  lAR: TMVCActiveRecord;
begin
  Result := TObjectList<T>.Create(True);
  try
    lDataSet := ExecQuery(SQL, Params);
    try
      while not lDataSet.Eof do
      begin
        lAR := T.Create;
        Result.Add(lAR);
        lAR.LoadByDataset(lDataSet);
        lDataSet.Next;
      end;
    finally
      lDataSet.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

class function TMVCActiveRecord.SelectDataSet(const SQL: string; const Params: array of Variant): TDataSet;
begin
  Result := TMVCActiveRecord.ExecQuery(SQL, Params);
end;

class function TMVCActiveRecord.SelectRQL(const aClass: TMVCActiveRecordClass;
  const RQL: string; const Mapping: TMVCFieldsMapping; const RQLBackend: TRQLBackend): TObjectList<TMVCActiveRecord>;
var
  lRQL: TRQL2SQL;
  lSQL: string;
begin
  lRQL := TRQL2SQL.Create;
  try
    lRQL.Execute(RQL, lSQL, Mapping, RQLBackend);
    LogD(Format('RQL [%s] => SQL [%s]', [RQL, lSQL]));
    Result := Where(aClass, lSQL, []);
  finally
    lRQL.Free;
  end;
end;

procedure TMVCActiveRecord.SetPK(const aValue: TValue);
begin
  if fPrimaryKeyFieldName.IsEmpty then
    raise Exception.Create('No primary key defined');
  fPrimaryKey.SetValue(Self, aValue);
end;

function TMVCActiveRecord.TableFieldsDelimited(const Delimiter: string): string;
var
  lPair: TPair<TRttiField, string>;
begin
  for lPair in fMap do
  begin
    Result := Result + lPair.value + Delimiter;
  end;
  Result := Copy(Result, 1, Length(Result) - Length(Delimiter));
  if not fPrimaryKeyFieldName.IsEmpty then
  begin
    Result := fPrimaryKeyFieldName + ',' + Result;
  end;
end;

function TMVCActiveRecord.TableInfo: string;
var
  keyvalue: TPair<TRttiField, string>;
begin
  Result := 'Table Name: ' + fTableName;
  for keyvalue in fMap do
    Result := Result + sLineBreak + #9 + keyvalue.Key.Name + ' = ' + keyvalue.value;
end;

procedure TMVCActiveRecord.Update;
var
  SQL: string;
begin
  CheckAction(TMVCEntityAction.eaUpdate);
  OnValidation;
  OnBeforeUpdate;
  OnBeforeInsertOrUpdate;
  SQL := CreateUpdateSQL;
  ExecNonQuery(SQL, false);
end;

class function TMVCActiveRecord.All(const aClass: TMVCActiveRecordClass): TObjectList<TMVCActiveRecord>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := aClass.Create;
  try
    Result := Select(aClass, lAR.CreateSelectSQL, []);
  finally
    lAR.Free;
  end;
end;

class function TMVCActiveRecord.All<T>: TObjectList<T>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := T.Create;
  try
    Result := Select<T>(lAR.CreateSelectSQL, []);
  finally
    lAR.Free;
  end;
end;

class function TMVCActiveRecord.Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string;
  const Params: array of Variant): TObjectList<TMVCActiveRecord>;
begin
  Result := Where(aClass, SQLWhere, Params, nil)
end;

class function TMVCActiveRecord.Where(const aClass: TMVCActiveRecordClass;
  const SQLWhere: string; const Params: array of Variant;
  const Connection: TFDConnection): TObjectList<TMVCActiveRecord>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := aClass.Create;
  try
    Result := Select(aClass, lAR.CreateSelectSQL + SQLWhere, Params, Connection);
  finally
    lAR.Free;
  end;
end;

class function TMVCActiveRecord.Where<T>(const SQLWhere: string; const Params: array of Variant): TObjectList<T>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := T.Create;
  try
    if not SQLWhere.Trim.IsEmpty then
    begin
      Result := Select<T>(lAR.CreateSelectSQL + ' WHERE ' + SQLWhere, Params);
    end
    else
    begin
      Result := Select<T>(lAR.CreateSelectSQL, Params);
    end;
  finally
    lAR.Free;
  end;
end;
{ PrimaryKeyAttribute }

constructor PrimaryKeyAttribute.Create(const aFieldName: string);
begin
  Create(aFieldName, []);
end;

constructor PrimaryKeyAttribute.Create(const aFieldName: string; const aFieldOptions: TMVCActiveRecordFieldOptions);
begin
  inherited Create;
  FieldName := aFieldName;
  FieldOptions := aFieldOptions;
end;

{ TMVCEntitiesRegistry }

procedure TMVCEntitiesRegistry.AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass);
begin
  fEntitiesDict.AddOrSetValue(aURLSegment.ToLower, aActiveRecordClass);
end;

procedure TMVCEntitiesRegistry.AddEntityProcessor(const aURLSegment: string;
  const aEntityProcessor: IMVCEntityProcessor);
begin
  fProcessorsDict.Add(aURLSegment, aEntityProcessor);
end;

constructor TMVCEntitiesRegistry.Create;
begin
  inherited;
  fEntitiesDict := TDictionary<string, TMVCActiveRecordClass>.Create;
  fProcessorsDict := TDictionary<string, IMVCEntityProcessor>.Create;
end;

destructor TMVCEntitiesRegistry.Destroy;
begin
  fEntitiesDict.Free;
  fProcessorsDict.Free;
  inherited;
end;

function TMVCEntitiesRegistry.FindEntityClassByURLSegment(const aURLSegment: string;
  out aMVCActiveRecordClass: TMVCActiveRecordClass): Boolean;
begin
  Result := fEntitiesDict.TryGetValue(aURLSegment.ToLower, aMVCActiveRecordClass);
end;

function TMVCEntitiesRegistry.FindProcessorByURLSegment(const aURLSegment: string; out aMVCEntityProcessor: IMVCEntityProcessor): Boolean;
begin
  Result := fProcessorsDict.TryGetValue(aURLSegment.ToLower, aMVCEntityProcessor);
end;

{ EMVCActiveRecord }

constructor EMVCActiveRecord.Create(const AMsg: string);
begin
  inherited Create(http_status.BadRequest, AMsg);
end;

{ EntityActionsAttribute }

constructor EntityActionsAttribute.Create(
  const aEntityAllowedActions: TMVCEntityActions);
begin
  inherited Create;
  EntityAllowedActions := aEntityAllowedActions;
end;

initialization

gLock := TObject.Create;
gCtx := TRttiContext.Create;
gCtx.FindType('');

finalization

gCtx.Free;
gLock.Free;

end.