unit XData.Comp.Server;

interface

uses
  System.Classes, System.SysUtils,
  Sparkle.Comp.Server,
  Sparkle.HttpServer.Module,
  Aurelius.Drivers.Interfaces,
  XData.Aurelius.Model,
  XData.Aurelius.ModelBuilder,
  XData.Comp.ConnectionPool,
  XData.Module.Events,
  XData.Server.Module;

type
  { aliases for event types }
  TEntityInsertingArgs = XData.Module.Events.TEntityInsertingArgs;
  TEntityInsertedArgs = XData.Module.Events.TEntityInsertedArgs;
  TEntityModifyingArgs = XData.Module.Events.TEntityModifyingArgs;
  TEntityModifiedArgs = XData.Module.Events.TEntityModifiedArgs;
  TEntityDeletingArgs = XData.Module.Events.TEntityDeletingArgs;
  TEntityDeletedArgs = XData.Module.Events.TEntityDeletedArgs;
  TEntityGetArgs = XData.Module.Events.TEntityGetArgs;
  TEntityListArgs = XData.Module.Events.TEntityListArgs;
  TModuleExceptionArgs = XData.Module.Events.TModuleExceptionArgs;
  TManagerCreateArgs = XData.Module.Events.TManagerCreateArgs;
  IDBConnectionPool = Aurelius.Drivers.Interfaces.IDBConnectionPool;

  { other aliases }
  TSwaggerAuthMode = XData.Server.Module.TSwaggerAuthMode;
  TSwaggerUIExpansion = XData.Server.Module.TSwaggerUIExpansion;

type
  TXDataModuleEvent = procedure(Sender: TObject; Module: TXDataServerModule) of object;
  TGetPoolInterfaceEvent = procedure(Sender: TObject; var Pool: IDBConnectionPool) of object;

  TEntityInsertingEvent = procedure(Sender: TObject; Args: TEntityInsertingArgs) of object;
  TEntityInsertedEvent = procedure(Sender: TObject; Args: TEntityInsertedArgs) of object;
  TEntityModifyingEvent = procedure(Sender: TObject; Args: TEntityModifyingArgs) of object;
  TEntityModifiedEvent = procedure(Sender: TObject; Args: TEntityModifiedArgs) of object;
  TEntityDeletingEvent = procedure(Sender: TObject; Args: TEntityDeletingArgs) of object;
  TEntityDeletedEvent = procedure(Sender: TObject; Args: TEntityDeletedArgs) of object;
  TEntityGetEvent = procedure(Sender: TObject; Args: TEntityGetArgs) of object;
  TEntityListEvent = procedure(Sender: TObject; Args: TEntityListArgs) of object;
  TModuleExceptionEvent = procedure(Sender: TObject; Args: TModuleExceptionArgs) of object;
  TManagerCreateEvent = procedure(Sender: TObject; Args: TManagerCreateArgs) of object;

  TEntitySetPermissionItem = class(TCollectionItem)
  private
    FEntitySetName: string;
    FPermissions: TEntitySetPermissions;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property EntitySetName: string read FEntitySetName write FEntitySetName;
    property Permissions: TEntitySetPermissions read FPermissions write FPermissions default [];
  end;

  TEntitySetPermissionItems = class(TOwnedCollection)
  private
    function GetItem(Index: Integer): TEntitySetPermissionItem;
    procedure SetItem(Index: Integer; const Value: TEntitySetPermissionItem);
  public
    function  Add: TEntitySetPermissionItem;
    property Items[Index: Integer]: TEntitySetPermissionItem read GetItem write SetItem; default;
  end;

  TXDataSwaggerOptions = class(TPersistent)
  private
    FAuthMode: TSwaggerAuthMode;
    FEnabled: Boolean;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property Enabled: Boolean read FEnabled write FEnabled default False;
    property AuthMode: TSwaggerAuthMode read FAuthMode write FAuthMode default TSwaggerAuthMode.None;
  end;

  TXDataSwaggerUIOptions = class(TPersistent)
  private
    FDocExpansion: TSwaggerUIExpansion;
    FShowFilter: Boolean;
    FEnabled: Boolean;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property Enabled: Boolean read FEnabled write FEnabled default False;
    property ShowFilter: Boolean read FShowFilter write FShowFilter default False;
    property DocExpansion: TSwaggerUIExpansion read FDocExpansion write FDocExpansion default TSwaggerUIExpansion.List;
  end;

  TXDataCustomServer = class(TSparkleServer)
  private
    FModelName: string;
    FSerializeInstanceType: TInstanceTypeSerialization;
    FDefaultExpandLevel: integer;
    FProxyListLoadDepth: Integer;
    FProxyLoadDepth: Integer;
    FFlushMode: TXDataFlushMode;
    FPostMode: TXDataPostMode;
    FPutMode: TXDataPutMode;
    FRoutingPrecedence: TXDataRoutingPrecedence;
    FSerializeInstanceRef: TInstanceRefSerialization;
    FUnknownMemberHandling: TUnknownMemberHandling;
    FPool: TXDataCustomConnectionPool;
    FOnModuleCreate: TXDataModuleEvent;
    FDefaultEntitySetPermissions: TEntitySetPermissions;
    FEntitySetPermissions: TEntitySetPermissionItems;
    FOnGetPoolInterface: TGetPoolInterfaceEvent;
    FOnEntityList: TEntityListEvent;
    FOnEntityInserting: TEntityInsertingEvent;
    FOnEntityInserted: TEntityInsertedEvent;
    FOnEntityModifying: TEntityModifyingEvent;
    FOnEntityModified: TEntityModifiedEvent;
    FOnEntityDeleting: TEntityDeletingEvent;
    FOnEntityDeleted: TEntityDeletedEvent;
    FOnModuleException: TModuleExceptionEvent;
    FOnManagerCreate: TManagerCreateEvent;
    FOnEntityGet: TEntityGetEvent;
    FSwaggerOptions: TXDataSwaggerOptions;
    FSwaggerUIOptions: TXDataSwaggerUIOptions;
    FEnableEntityKeyAsSegment: Boolean;
    function GetConnectionPool: IDBConnectionPool;
    function GetModel: TXDataAureliusModel;
    procedure SetPool(const Value: TXDataCustomConnectionPool);
    procedure SetDefaultEntitySetPermissions(
      const Value: TEntitySetPermissionItems);
    procedure SetSwaggerOptions(const Value: TXDataSwaggerOptions);
    procedure SetSwaggerUIOptions(const Value: TXDataSwaggerUIOptions);
  protected
    function CreateSparkleModule: THttpServerModule; override;
    procedure DoModuleCreate(Module: THttpServerModule); override;
    procedure DoModelBuild(Builder: TXDataModelBuilder); virtual;
    function CreateXDataModule(const ABaseUrl: string; AConnectionPool: IDBConnectionPool;
      AModel: TXDataAureliusModel): TXDataServerModule; virtual;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure DoEntityInserting(Args: TEntityInsertingArgs); virtual;
    procedure DoEntityInserted(Args: TEntityInsertedArgs); virtual;
    procedure DoEntityModifying(Args: TEntityModifyingArgs); virtual;
    procedure DoEntityModified(Args: TEntityModifiedArgs); virtual;
    procedure DoEntityDeleting(Args: TEntityDeletingArgs); virtual;
    procedure DoEntityDeleted(Args: TEntityDeletedArgs); virtual;
    procedure DoEntityGet(Args: TEntityGetArgs); virtual;
    procedure DoEntityList(Args: TEntityListArgs); virtual;
    procedure DoModuleException(Args: TModuleExceptionArgs); virtual;
    procedure DoManagerCreate(Args: TManagerCreateArgs); virtual;
  protected
    property Pool: TXDataCustomConnectionPool read FPool write SetPool;
    property ModelName: string read FModelName write FModelName;

    property DefaultExpandLevel: integer read FDefaultExpandLevel write FDefaultExpandLevel default 0;
    property PutMode: TXDataPutMode read FPutMode write FPutMode default TXDataPutMode.Merge;
    property PostMode: TXDataPostMode read FPostMode write FPostMode default TXDataPostMode.Replicate;
    property FlushMode: TXDataFlushMode read FFlushMode write FFlushMode default TXDataFlushMode.Single;
    property RoutingPrecedence: TXDataRoutingPrecedence read FRoutingPrecedence write FRoutingPrecedence default TXDataRoutingPrecedence.Crud;
    property ProxyLoadDepth: Integer read FProxyLoadDepth write FProxyLoadDepth default 0;
    property ProxyListLoadDepth: Integer read FProxyListLoadDepth write FProxyListLoadDepth default 0;
    property SerializeInstanceRef: TInstanceRefSerialization read FSerializeInstanceRef write FSerializeInstanceRef default TInstanceRefSerialization.IfRecursive;
    property SerializeInstanceType: TInstanceTypeSerialization read FSerializeInstanceType write FSerializeInstanceType default TInstanceTypeSerialization.IfNeeded;
    property UnknownMemberHandling: TUnknownMemberHandling read FUnknownMemberHandling write FUnknownMemberHandling default TUnknownMemberHandling.Ignore;
    property DefaultEntitySetPermissions: TEntitySetPermissions read FDefaultEntitySetPermissions write FDefaultEntitySetPermissions default [];
    property EntitySetPermissions: TEntitySetPermissionItems read FEntitySetPermissions write SetDefaultEntitySetPermissions;
    property EnableEntityKeyAsSegment: Boolean read FEnableEntityKeyAsSegment write FEnableEntityKeyAsSegment default False;
    property SwaggerOptions: TXDataSwaggerOptions read FSwaggerOptions write SetSwaggerOptions;
    property SwaggerUIOptions: TXDataSwaggerUIOptions read FSwaggerUIOptions write SetSwaggerUIOptions;

    property OnModuleCreate: TXDataModuleEvent read FOnModuleCreate write FOnModuleCreate;
    property OnGetPoolInterface: TGetPoolInterfaceEvent read FOnGetPoolInterface write FOnGetPoolInterface;
    property OnEntityInserting: TEntityInsertingEvent read FOnEntityInserting write FOnEntityInserting;
    property OnEntityInserted: TEntityInsertedEvent read FOnEntityInserted write FOnEntityInserted;
    property OnEntityModifying: TEntityModifyingEvent read FOnEntityModifying write FOnEntityModifying;
    property OnEntityModified: TEntityModifiedEvent read FOnEntityModified write FOnEntityModified;
    property OnEntityDeleting: TEntityDeletingEvent read FOnEntityDeleting write FOnEntityDeleting;
    property OnEntityDeleted: TEntityDeletedEvent read FOnEntityDeleted write FOnEntityDeleted;
    property OnEntityGet: TEntityGetEvent read FOnEntityGet write FOnEntityGet;
    property OnEntityList: TEntityListEvent read FOnEntityList write FOnEntityList;
    property OnModuleException: TModuleExceptionEvent read FOnModuleException write FOnModuleException;
    property OnManagerCreate: TManagerCreateEvent read FOnManagerCreate write FOnManagerCreate;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Model: TXDataAureliusModel read GetModel;
  end;

  TXDataServer = class(TXDataCustomServer)
  published
    property BaseUrl;
    property Dispatcher;
    property Pool;
    property ModelName;
    property DefaultExpandLevel;
    property PutMode;
    property PostMode;
    property FlushMode;
    property RoutingPrecedence;
    property ProxyLoadDepth;
    property ProxyListLoadDepth;
    property SerializeInstanceRef;
    property SerializeInstanceType;
    property UnknownMemberHandling;
    property DefaultEntitySetPermissions;
    property EntitySetPermissions;
    property EnableEntityKeyAsSegment;
    property SwaggerOptions;
    property SwaggerUIOptions;

    property OnModuleCreate;
    property OnGetPoolInterface;
    property OnEntityInserting;
    property OnEntityInserted;
    property OnEntityModifying;
    property OnEntityModified;
    property OnEntityDeleting;
    property OnEntityDeleted;
    property OnEntityGet;
    property OnEntityList;
    property OnModuleException;
    property OnManagerCreate;
  end;

  EXDataServerException = class(Exception)
  end;

implementation

uses
  XData.OpenApi.Service.Internal,
  XData.SwaggerUI.Service.Internal;

{ TXDataCustomServer }

constructor TXDataCustomServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEntitySetPermissions := TEntitySetPermissionItems.Create(Self, TEntitySetPermissionItem);
  FPutMode := TXDataPutMode.Merge;
  FPostMode := TXDataPostMode.Replicate;
  FFlushMode := TXDataFlushMode.Single;
  FRoutingPrecedence := TXDataRoutingPrecedence.Crud;
  FSerializeInstanceRef := TInstanceRefSerialization.IfRecursive;
  FSerializeInstanceType := TInstanceTypeSerialization.IfNeeded;
  FUnknownMemberHandling := TUnknownMemberHandling.Ignore;;
  FSwaggerOptions := TXDataSwaggerOptions.Create;
  FSwaggerUIOptions := TXDataSwaggerUIOptions.Create;
end;

function TXDataCustomServer.CreateSparkleModule: THttpServerModule;
var
  Module: TXDataServerModule;
  I: Integer;
  PermissionItem: TEntitySetPermissionItem;
  SelfPtr: Pointer;
  Model: TXDataAureliusModel;
  Builder: TXDataModelBuilder;
begin
  Model := GetModel;
  Builder := TXDataModelBuilder.Create(Model);
  try
    DoModelBuild(Builder);
  finally
    Builder.Free;
  end;

  Module := CreateXDataModule(BaseUrl, GetConnectionPool, GetModel);
  Module.DefaultExpandLevel := Self.DefaultExpandLevel;
  Module.PutMode := Self.PutMode;
  Module.PostMode := Self.PostMode;
  Module.FlushMode := Self.FlushMode;
  Module.RoutingPrecedence := Self.RoutingPrecedence;
  Module.ProxyLoadDepth := Self.ProxyLoadDepth;
  Module.ProxyListLoadDepth := Self.ProxyListLoadDepth;
  Module.SerializeInstanceRef := Self.SerializeInstanceRef;
  Module.SerializeInstanceType := Self.SerializeInstanceType;
  Module.UnknownMemberHandling := Self.UnknownMemberHandling;
  Module.SetEntitySetPermissions('*', Self.DefaultEntitySetPermissions);
  Module.EnableEntityKeyAsSegment := Self.EnableEntityKeyAsSegment;

  Module.SwaggerOptions.AuthMode := Self.SwaggerOptions.AuthMode;
  Module.SwaggerUIOptions.ShowFilter := Self.SwaggerUIOptions.ShowFilter;
  Module.SwaggerUIOptions.DocExpansion := Self.SwaggerUIOptions.DocExpansion;

  for I := 0 to EntitySetPermissions.Count - 1 do
  begin
    PermissionItem := EntitySetPermissions[I];
    Module.SetEntitySetPermissions(PermissionItem.EntitySetName, PermissionItem.Permissions);
  end;

  SelfPtr := Self;
  if Assigned(FOnEntityList) then
    Module.Events.OnEntityList.Subscribe(procedure(Args: TEntityListArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityList(Args);
      end);
  if Assigned(FOnEntityDeleting) then
    Module.Events.OnEntityDeleting.Subscribe(procedure(Args: TEntityDeletingArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityDeleting(Args);
      end);
  if Assigned(FOnEntityDeleted) then
    Module.Events.OnEntityDeleted.Subscribe(procedure(Args: TEntityDeletedArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityDeleted(Args);
      end);
  if Assigned(FOnEntityModifying) then
    Module.Events.OnEntityModifying.Subscribe(procedure(Args: TEntityModifyingArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityModifying(Args);
      end);
  if Assigned(FOnEntityModified) then
    Module.Events.OnEntityModified.Subscribe(procedure(Args: TEntityModifiedArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityModified(Args);
      end);
  if Assigned(FOnEntityInserting) then
    Module.Events.OnEntityInserting.Subscribe(procedure(Args: TEntityInsertingArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityInserting(Args);
      end);
  if Assigned(FOnEntityInserted) then
    Module.Events.OnEntityInserted.Subscribe(procedure(Args: TEntityInsertedArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityInserted(Args);
      end);
  if Assigned(FOnEntityGet) then
    Module.Events.OnEntityGet.Subscribe(procedure(Args: TEntityGetArgs)
      begin
        TXDataCustomServer(SelfPtr).DoEntityGet(Args);
      end);
  if Assigned(FOnModuleException) then
    Module.Events.OnModuleException.Subscribe(procedure(Args: TModuleExceptionArgs)
      begin
        TXDataCustomServer(SelfPtr).DoModuleException(Args);
      end);
  if Assigned(FOnManagerCreate) then
    Module.Events.OnManagerCreate.Subscribe(procedure(Args: TManagerCreateArgs)
      begin
        TXDataCustomServer(SelfPtr).DoManagerCreate(Args);
      end);

  if SwaggerOptions.Enabled then
    Module.AddServiceImplementation(TCustomOpenApiService);
  if SwaggerUIOptions.Enabled then
    Module.AddServiceImplementation(TCustomSwaggerUIService);

  Result := Module;
end;

function TXDataCustomServer.CreateXDataModule(const ABaseUrl: string; AConnectionPool: IDBConnectionPool;
  AModel: TXDataAureliusModel): TXDataServerModule;
begin
  Result := TXDataServerModule.Create(BaseUrl, GetConnectionPool, GetModel);
end;

destructor TXDataCustomServer.Destroy;
begin
  FSwaggerOptions.Free;
  FSwaggerUIOptions.Free;
  FEntitySetPermissions.Free;
  inherited;
end;

procedure TXDataCustomServer.DoEntityDeleted(Args: TEntityDeletedArgs);
begin
  if Assigned(FOnEntityDeleted) then
    FOnEntityDeleted(Self, Args);
end;

procedure TXDataCustomServer.DoEntityDeleting(Args: TEntityDeletingArgs);
begin
  if Assigned(FOnEntityDeleting) then
    FOnEntityDeleting(Self, Args);
end;

procedure TXDataCustomServer.DoEntityGet(Args: TEntityGetArgs);
begin
  if Assigned(FOnEntityGet) then
    FOnEntityGet(Self, Args);
end;

procedure TXDataCustomServer.DoEntityInserted(Args: TEntityInsertedArgs);
begin
  if Assigned(FOnEntityInserted) then
    FOnEntityInserted(Self, Args);
end;

procedure TXDataCustomServer.DoEntityInserting(Args: TEntityInsertingArgs);
begin
  if Assigned(FOnEntityInserting) then
    FOnEntityInserting(Self, Args);
end;

procedure TXDataCustomServer.DoEntityList(Args: TEntityListArgs);
begin
  if Assigned(FOnEntityList) then
    FOnEntityList(Self, Args);
end;

procedure TXDataCustomServer.DoEntityModified(Args: TEntityModifiedArgs);
begin
  if Assigned(FOnEntityModified) then
    FOnEntityModified(Self, Args);
end;

procedure TXDataCustomServer.DoEntityModifying(Args: TEntityModifyingArgs);
begin
  if Assigned(FOnEntityModifying) then
    FOnEntityModifying(Self, Args);
end;

procedure TXDataCustomServer.DoManagerCreate(Args: TManagerCreateArgs);
begin
  if Assigned(FOnManagerCreate) then
    FOnManagerCreate(Self, Args);
end;

procedure TXDataCustomServer.DoModelBuild(Builder: TXDataModelBuilder);
begin
  if SwaggerOptions.Enabled then
    Builder.AddService<ICustomOpenApiService>;
  if SwaggerUIOptions.Enabled then
    Builder.AddService<ICustomSwaggerUIService>;
end;

procedure TXDataCustomServer.DoModuleCreate(Module: THttpServerModule);
begin
  if Assigned(FOnModuleCreate) then
    FOnModuleCreate(Self, Module as TXDataServerModule);
end;

procedure TXDataCustomServer.DoModuleException(Args: TModuleExceptionArgs);
begin
  if Assigned(FOnModuleException) then
    FOnModuleException(Self, Args);
end;

function TXDataCustomServer.GetConnectionPool: IDBConnectionPool;
begin
  if FPool = nil then
    Result := nil
  else
    Result := FPool.GetPoolInterface;
  if Assigned(FOnGetPoolInterface) then
    FOnGetPoolInterface(Self, Result);
end;

function TXDataCustomServer.GetModel: TXDataAureliusModel;
begin
  if ModelName = '' then
    Result := TXDataAureliusModel.Default
  else
    Result := TXDataAureliusModel.Get(ModelName);
end;

procedure TXDataCustomServer.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = FPool) and (Operation = opRemove) then
    FPool := nil;
end;

procedure TXDataCustomServer.SetDefaultEntitySetPermissions(
  const Value: TEntitySetPermissionItems);
begin
  FEntitySetPermissions.Assign(Value);
end;

procedure TXDataCustomServer.SetPool(const Value: TXDataCustomConnectionPool);
begin
  if FPool = Value then Exit;
  if Assigned(FPool) then
    FPool.RemoveFreeNotification(Self);
  FPool := Value;
  if Assigned(FPool) then
    FPool.FreeNotification(Self);
end;

procedure TXDataCustomServer.SetSwaggerOptions(const Value: TXDataSwaggerOptions);
begin
  FSwaggerOptions.Assign(Value);
end;

procedure TXDataCustomServer.SetSwaggerUIOptions(const Value: TXDataSwaggerUIOptions);
begin
  FSwaggerUIOptions.Assign(Value);
end;

{ TEntitySetPermissionItems }

function TEntitySetPermissionItems.Add: TEntitySetPermissionItem;
begin
  Result := TEntitySetPermissionItem(inherited Add);
end;

function TEntitySetPermissionItems.GetItem(
  Index: Integer): TEntitySetPermissionItem;
begin
  Result := TEntitySetPermissionItem(inherited Items[Index]);
end;

procedure TEntitySetPermissionItems.SetItem(Index: Integer;
  const Value: TEntitySetPermissionItem);
begin
  Items[Index].Assign(Value);
end;

{ TEntitySetPermissionItem }

procedure TEntitySetPermissionItem.Assign(Source: TPersistent);
begin
  if Source is TEntitySetPermissionItem then
  begin
    FEntitySetName := TEntitySetPermissionItem(Source).FEntitySetName;
    FPermissions := TEntitySetPermissionItem(Source).FPermissions;
  end
  else
    inherited Assign(Source);
end;

{ TXDataSwaggerUIOptions }

procedure TXDataSwaggerUIOptions.Assign(Source: TPersistent);
begin
  if Source is TXDataSwaggerUIOptions then
  begin
    ShowFilter := TXDataSwaggerUIOptions(Source).ShowFilter;
    DocExpansion := TXDataSwaggerUIOptions(Source).DocExpansion;
    Enabled := TXDataSwaggerOptions(Source).Enabled;
  end
  else
    inherited Assign(Source);
end;

{ TXDataSwaggerOptions }

procedure TXDataSwaggerOptions.Assign(Source: TPersistent);
begin
  if Source is TXDataSwaggerOptions then
  begin
    AuthMode := TXDataSwaggerOptions(Source).AuthMode;
    Enabled := TXDataSwaggerOptions(Source).Enabled;
  end
  else
    inherited Assign(Source);
end;

end.
