unit TestServer.Module;

interface

uses
  System.SysUtils,
  System.Classes,
  Sparkle.HttpServer.Module,
  Sparkle.HttpServer.Context,
  Sparkle.Comp.Server,
  Sparkle.Comp.HttpSysDispatcher,
  Aurelius.Drivers.Interfaces,
  Aurelius.Comp.Connection,
  XData.Comp.ConnectionPool,
  XData.Server.Module,
  XData.Comp.Server,
  FireDAC.Stan.Intf,
  FireDAC.Stan.Option,
  FireDAC.Stan.Error,
  FireDAC.UI.Intf,
  FireDAC.Phys.Intf,
  FireDAC.Stan.Def,
  FireDAC.Stan.Pool,
  FireDAC.Stan.Async,
  FireDAC.Phys,
  FireDAC.VCLUI.Wait,
  Data.DB,
  FireDAC.Comp.Client,
  Aurelius.Drivers.FireDAC,
  Sparkle.Comp.CorsMiddleware,
  Sparkle.Comp.JwtMiddleware,
  Sparkle.Security,
  Aurelius.Engine.ObjectManager,
  XData.Security.Attributes,
  Sparkle.Comp.GenericMiddleware,
  Sparkle.Comp.LoggingMiddleware,
  XData.Module.Events,
  FireDAC.Stan.Param,
  FireDAC.DatS,
  FireDAC.DApt.Intf,
  FireDAC.DApt,
  FireDAC.Comp.DataSet,
  Aurelius.Engine.DatabaseManager,
  Bcl.Lang,
  Sphinx.Server.Module,
  Sphinx.Comp.Server,
  Sphinx.Comp.Config,
  Sphinx.Extensions,
  Sparkle.Comp.ForwardMiddleware,
  FireDAC.Phys.FB,
  FireDAC.Phys.FBDef,
  XData.Module.Base;

type
  TServerContainer = class(TDataModule)
    XDataConnectionPool: TXDataConnectionPool;
    Connection: TFDConnection;
    AureliusConnection: TAureliusConnection;
    XDataServer: TXDataServer;
    XDataServerCORS: TSparkleCorsMiddleware;
    XDataServerJWT: TSparkleJwtMiddleware;
    XDataServerLogging: TSparkleLoggingMiddleware;
    MainDispatcher: TSparkleHttpSysDispatcher;

    procedure DataModuleCreate(Sender: TObject);

    procedure XDataServerEntityDeleted(Sender: TObject; Args: TEntityDeletedArgs);
    procedure XDataServerEntityDeleting(Sender: TObject; Args: TEntityDeletingArgs);
    procedure XDataServerEntityGet(Sender: TObject; Args: TEntityGetArgs);
    procedure XDataServerEntityInserted(Sender: TObject; Args: TEntityInsertedArgs);
    procedure XDataServerEntityInserting(Sender: TObject; Args: TEntityInsertingArgs);
    procedure XDataServerEntityList(Sender: TObject; Args: TEntityListArgs);
    procedure XDataServerEntityModified(Sender: TObject; Args: TEntityModifiedArgs);
    procedure XDataServerEntityModifying(Sender: TObject; Args: TEntityModifyingArgs);

    procedure XDataServerJWTGetSecret(Sender: TObject; var Secret: string);

  private
    function GetDBConnection: IDBConnection;

    function GetLocalDatabasePath: string;
    function GetLocalDatabaseFilename: string;

    procedure ValidateUser(Handler: TXDataBaseRequestHandler);

  public
    function GetDatabaseName: string;
    function IsRemoteDatabase: Boolean;
    function GetPooledConnection: IDBConnection;
    procedure StartServer;
    procedure StopServer;
    procedure UpdateDatabase;

    property DBConnection: IDBConnection read GetDBConnection;

    property LocalDatabasePath: string read GetLocalDatabasePath;
    property LocalDatabaseFilename: string read GetLocalDatabaseFilename;

  end;

var
  ServerContainer: TServerContainer;

implementation

uses
  System.IOUtils,
  System.Rtti,
  FireDAC.Phys.IBWrapper,
  Aurelius.Sql.Register,
  Aurelius.SQL.Firebird3,
  Aurelius.Schema.Firebird3,
  XData.Sys.Exceptions,
  TestApp.Servers.Shared,
  Test.DistributionConfig,
  TestSphinx.Module;

{%CLASSGROUP 'Vcl.Controls.TControl'}
{$R *.dfm}

procedure SetupFirebirdForXData(AConnection: TFDConnection; const AServer, ADatabaseName, AUserName, AUserPassword: string;
  const ACharacterSet: string; AAllowCreate: Boolean);
var
  lCharSet: TIBCharacterSet;
  lGenerator: TFirebird3SQLGenerator;
begin
  lGenerator := TSQLGeneratorRegister.GetInstance.GetGenerator('Firebird3') as TFirebird3SQLGenerator;
  lGenerator.UseBoolean := False;
  lGenerator.UseIdentity := False;

  AConnection.DriverName := 'FB';
  AConnection.ResourceOptions.SilentMode := True;

  if ACharacterSet <> '' then
    lCharSet := TRttiEnumerationType.GetValue<TIBCharacterSet>('cs' + ACharacterSet)
  else
    lCharSet := TIBCharacterSet.csNONE;

  AConnection.Params.Database := ADatabaseName;
  TFDPhysFBConnectionDefParams(AConnection.Params).Server := AServer;
  if AServer = '' then
    TFDPhysFBConnectionDefParams(AConnection.Params).Protocol := ipLocal
  else
    TFDPhysFBConnectionDefParams(AConnection.Params).Protocol := ipTCPIP;

  TFDPhysFBConnectionDefParams(AConnection.Params).CharacterSet := lCharSet;

  if AAllowCreate then
    TFDPhysFBConnectionDefParams(AConnection.Params).OpenMode := TIBOpenMode.omOpenOrCreate;

  AConnection.Params.UserName := AUserName;
  AConnection.Params.Password := AUserPassword;
end;

procedure TServerContainer.DataModuleCreate(Sender: TObject);
begin
  Dist_EnsureRuntimeDirectories;

  SetupFirebirdForXData(
    Connection,
    '',
    Dist_DatabaseFile,
    cFirebirdUser,
    cFirebirdPassword,
    'UTF8',
    True
  );

  TDirectory.CreateDirectory(Dist_LogPath);

  XDataServer.BaseUrl := Dist_DefaultXDataBaseUrl;

  XDataConnectionPool.Size := cConnectionPoolSize;

  SphinxModule := TSphinxModule.Create(Self.Owner);
  SphinxModule.SphinxServer1.Dispatcher := MainDispatcher;
  SphinxModule.SphinxServer1.Pool := XDataConnectionPool;
  SphinxModule.SphinxSchema.Connection := AureliusConnection;

  SphinxModule.LoadConfig;
end;

function TServerContainer.GetDatabaseName: string;
begin
  if TFDPhysFBConnectionDefParams(Connection.Params).Server <> '' then
    Result := TFDPhysFBConnectionDefParams(Connection.Params).Server + ':' + Connection.Params.Database
  else
    Result := Connection.Params.Database;
end;

function TServerContainer.IsRemoteDatabase: Boolean;
var
  sServer: string;
begin
  sServer := Trim(TFDPhysFBConnectionDefParams(Connection.Params).Server);
  Result := (sServer <> '') and not SameText(sServer, 'localhost') and not SameText(sServer, '127.0.0.1');
end;

function TServerContainer.GetDBConnection: IDBConnection;
begin
  Result := AureliusConnection.GetPoolInterface.GetConnection;
end;

function TServerContainer.GetPooledConnection: IDBConnection;
begin
  Result := XDataConnectionPool.GetPoolInterface.GetConnection;
end;

procedure TServerContainer.StartServer;
begin
  MainDispatcher.Start;
end;

procedure TServerContainer.StopServer;
begin
  MainDispatcher.Stop;
end;

procedure TServerContainer.UpdateDatabase;
begin
end;

procedure TServerContainer.ValidateUser(Handler: TXDataBaseRequestHandler);
var
  oUser: IUserIdentity;
begin
  oUser := Handler.Request.User;
  if not Assigned(oUser) then
    raise EXDataHttpUnauthorized.Create('Authentication required');
end;

procedure TServerContainer.XDataServerEntityDeleted(Sender: TObject; Args: TEntityDeletedArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerEntityDeleting(Sender: TObject; Args: TEntityDeletingArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerEntityGet(Sender: TObject; Args: TEntityGetArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerEntityInserted(Sender: TObject; Args: TEntityInsertedArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerEntityInserting(Sender: TObject; Args: TEntityInsertingArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerEntityList(Sender: TObject; Args: TEntityListArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerEntityModified(Sender: TObject; Args: TEntityModifiedArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerEntityModifying(Sender: TObject; Args: TEntityModifyingArgs);
begin
  ValidateUser(Args.Handler);
end;

procedure TServerContainer.XDataServerJWTGetSecret(Sender: TObject; var Secret: string);
begin
  Secret := Sys_Signing_Key;
end;

function TServerContainer.GetLocalDatabasePath: string;
begin
  Result := ExtractFilePath(GetLocalDatabaseFilename);
end;

function TServerContainer.GetLocalDatabaseFilename: string;
var
  sValue: string;
  lColon: Integer;
begin
  sValue := GetDatabaseName;
  lColon := Pos(':', sValue);
  if lColon <= 0 then
    Result := sValue
  else
    Result := Copy(sValue, lColon + 1, MaxInt);
end;

end.
