unit Sparkle.Comp.Server;

interface

uses
  Generics.Collections, System.SysUtils, System.Classes,
  Sparkle.HttpServer.Context,
  Sparkle.HttpServer.Dispatcher,
  Sparkle.HttpServer.Module;

type
  TSparkleDispatcher = class;
  TSparkleServer = class;

  TSparkleMiddleware = class(TComponent)
  private
    FServer: TSparkleServer;
    procedure SetServer(const Value: TSparkleServer);
  protected
    function CreateMiddlewareInterface: IHttpServerMiddleware; virtual; abstract;
    class function GetDisplayName: string; virtual;
  public
    class function DisplayName: string;
    function GetParentComponent: TComponent; override;
    procedure SetParentComponent(AParent: TComponent); override;
    function HasParent: Boolean; override;
  public
    destructor Destroy; override;
    function GetMiddlewareInterface: IHttpServerMiddleware; virtual;
    property Server: TSparkleServer read FServer write SetServer;
  end;

  TSparkleMiddlewareClass = class of TSparkleMiddleware;

  TSparkleModuleEvent = procedure(Sender: TObject; Module: THttpServerModule) of object;

  TSparkleMiddlewareList = class
  strict private
    FList: TList<TSparkleMiddleware>;
  private
    function GetCount: Integer;
    function GetMiddleware(Index: Integer): TSparkleMiddleware;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure SetMiddlewareIndex(AMiddleware: TSparkleMiddleware; Value: Integer);
    function Add(Value: TSparkleMiddleware): Integer;
    function Remove(Value: TSparkleMiddleware): Integer;
    function IndexOf(AMiddleware: TSparkleMiddleware): Integer;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TSparkleMiddleware read GetMiddleware; default;
  end;

  TSparkleServer = class(TComponent)
  private
    FBaseUrl: string;
    FDispatcher: TSparkleDispatcher;
    FOnModuleCreate: TSparkleModuleEvent;
    FMiddlewareList: TSparkleMiddlewareList;
    procedure SetDispatcher(const Value: TSparkleDispatcher);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    procedure SetChildOrder(Component: TComponent; Order: Integer); override;
  protected
    procedure AddMiddlewareList(Module: THttpServerModule); virtual;
    function CreateSparkleModule: THttpServerModule; virtual; abstract;
    procedure DoModuleCreate(Module: THttpServerModule); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function CreateModule: THttpServerModule;
    property BaseUrl: string read FBaseUrl write FBaseUrl;
    property Dispatcher: TSparkleDispatcher read FDispatcher write SetDispatcher;
    property MiddlewareList: TSparkleMiddlewareList read FMiddlewareList;
    property OnModuleCreate: TSparkleModuleEvent read FOnModuleCreate write FOnModuleCreate;
  end;

  TSparkleDispatcher = class(TComponent)
  private
    FServers: TList<TSparkleServer>;
    FInternalActive: Boolean;
    procedure SetActive(const Value: Boolean);
  protected
    procedure Loaded; override;
  strict protected
    procedure DoStart; virtual; abstract;
    procedure DoStop; virtual; abstract;
    function GetActive: Boolean; virtual;
    function InternalGetActive: Boolean;
    function GetServerCount: Integer; virtual;
    function GetServer(Index: Integer): TSparkleServer; virtual;
  protected
    procedure AddDispatcherModules(HttpDisp: THttpDispatcher); virtual;
    procedure AddDispatcherModule(HttpDisp: THttpDispatcher; Server: TSparkleServer); virtual;
    procedure RegisterServer(Server: TSparkleServer); virtual;
    procedure UnregisterServer(Server: TSparkleServer); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Start;
    procedure Stop;
    property Active: Boolean read InternalGetActive write SetActive default False;
  end;

  THttpServerContext = Sparkle.HttpServer.Context.THttpServerContext;
  TProcessRequestEvent = procedure(Sender: TObject; Context: THttpServerContext) of object;

  TSparkleGenericServer = class(TSparkleServer)
  private
    FOnProcessRequest: TProcessRequestEvent;
  protected
    function CreateSparkleModule: THttpServerModule; override;
    procedure DoProcessRequest(Context: THttpServerContext); virtual;
  published
    property BaseUrl;
    property Dispatcher;
    property OnProcessRequest: TProcessRequestEvent read FOnProcessRequest write FOnProcessRequest;
  end;

procedure RegisterMiddleware(const AMiddlewareClasses: array of TSparkleMiddlewareClass);
function RegisteredMiddleware: TEnumerable<TSparkleMiddlewareClass>;
function FindMiddleware(const DisplayName: string): TSparkleMiddlewareClass;

implementation

var
  MiddlewareClasses: TList<TSparkleMiddlewareClass>;

function RegisteredMiddleware: TEnumerable<TSparkleMiddlewareClass>;
begin
  Result := MiddlewareClasses;
end;

procedure RegisterMiddleware(const AMiddlewareClasses: array of TSparkleMiddlewareClass);
var
  I: Integer;
begin
  for I := Low(AMiddlewareClasses) to High(AMiddlewareClasses) do
    if MiddlewareClasses.IndexOf(AMiddlewareClasses[I]) = -1 then
    begin
      MiddlewareClasses.Add(AMiddlewareClasses[I]);
      RegisterClass(AMiddlewareClasses[I]);
    end;
end;

function FindMiddleware(const DisplayName: string): TSparkleMiddlewareClass;
var
  I: Integer;
begin
  for I := 0 to MiddlewareClasses.Count - 1 do
    if SameText(MiddlewareClasses[I].DisplayName, DisplayName) then
      Exit(MiddlewareClasses[I]);
  Result := nil;
end;

{ TSparkleMiddleware }

destructor TSparkleMiddleware.Destroy;
begin
  if FServer <> nil then
    FServer.MiddlewareList.Remove(Self);
  inherited;
end;

class function TSparkleMiddleware.DisplayName: string;
begin
  Result := GetDisplayName;
end;

class function TSparkleMiddleware.GetDisplayName: string;
begin
  Result := Self.ClassName;
end;

function TSparkleMiddleware.GetMiddlewareInterface: IHttpServerMiddleware;
begin
  Result := CreateMiddlewareInterface;
end;

function TSparkleMiddleware.GetParentComponent: TComponent;
begin
  Result := Server;
end;

function TSparkleMiddleware.HasParent: Boolean;
begin
  Result := True;
end;

procedure TSparkleMiddleware.SetParentComponent(AParent: TComponent);
begin
  if AParent is TSparkleServer then
    Server := AParent as TSparkleServer;
end;

procedure TSparkleMiddleware.SetServer(const Value: TSparkleServer);
begin
  if Value <> FServer then
  begin
    if FServer <> nil then
      FServer.FMiddlewareList.Remove(Self);

    if (Value <> nil) then
      Value.FMiddlewareList.Add(Self);
    FServer := Value;
  end;
end;

{ TSparkleServer }

procedure TSparkleServer.AddMiddlewareList(Module: THttpServerModule);
var
  I: Integer;
  MiddlewareIntf: IHttpServerMiddleware;
begin
  for I := 0 to MiddlewareList.Count - 1 do
    begin
      MiddlewareIntf := MiddlewareList[I].GetMiddlewareInterface;
      if Assigned(MiddlewareIntf) then
        Module.AddMiddleware(MiddlewareIntf);
    end;
end;

constructor TSparkleServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMiddlewareList := TSparkleMiddlewareList.Create;
end;

function TSparkleServer.CreateModule: THttpServerModule;
begin
  Result := CreateSparkleModule;
  try
    AddMiddlewareList(Result);
    DoModuleCreate(Result);
  except
    Result.Free;
    raise;
  end;
end;

destructor TSparkleServer.Destroy;
begin
  Destroying;
  Dispatcher := nil;
  FMiddlewareList.Free;
  inherited;
end;

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

procedure TSparkleServer.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
  I: Integer;
begin
  for I := 0 to FMiddlewareList.Count - 1 do
    if FMiddlewareList[I].Owner = Root then Proc(FMiddlewareList[I]);
end;

procedure TSparkleServer.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) then
  begin
    if AComponent = FDispatcher then
      FDispatcher := nil;
  end;
end;

procedure TSparkleServer.SetChildOrder(Component: TComponent; Order: Integer);
var
  M: TSparkleMiddleware;
begin
  if Component is TSparkleMiddleware then
  begin
    M := Component as TSparkleMiddleware;
    if FMiddlewareList.IndexOf(M) >= 0 then
      FMiddlewareList.SetMiddlewareIndex(M, Order);
  end;
end;

procedure TSparkleServer.SetDispatcher(const Value: TSparkleDispatcher);
begin
  if FDispatcher <> Value then
  begin
    if Assigned(FDispatcher) then
    begin
      FDispatcher.UnregisterServer(Self);
      FDispatcher.RemoveFreeNotification(Self);
    end;
    FDispatcher := Value;
    if Assigned(FDispatcher) then
    begin
      FDispatcher.RegisterServer(Self);
      FDispatcher.FreeNotification(Self);
    end;
  end;
end;

{ TSparkleDispatcher }

procedure TSparkleDispatcher.AddDispatcherModule(HttpDisp: THttpDispatcher;
  Server: TSparkleServer);
begin
  HttpDisp.AddModule(Server.CreateModule);
end;

procedure TSparkleDispatcher.AddDispatcherModules(HttpDisp: THttpDispatcher);
var
  Server: TSparkleServer;
begin
  for Server in FServers do
    AddDispatcherModule(HttpDisp, Server);
end;

constructor TSparkleDispatcher.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FServers := TList<TSparkleServer>.Create;
end;

destructor TSparkleDispatcher.Destroy;
begin
  Destroying;
  SetActive(False);
  FServers.Free;
  inherited;
end;

function TSparkleDispatcher.GetActive: Boolean;
begin
  Result := False;
end;

function TSparkleDispatcher.GetServer(Index: Integer): TSparkleServer;
begin
  Result := FServers[Index];
end;

function TSparkleDispatcher.GetServerCount: Integer;
begin
  Result := FServers.Count;
end;

function TSparkleDispatcher.InternalGetActive: Boolean;
begin
  if (csDesigning in ComponentState) then
    Result := FInternalActive
  else
    Result := GetActive;
end;

procedure TSparkleDispatcher.Loaded;
begin
  inherited Loaded;
  try
    if FInternalActive then SetActive(True);
  except
    if csDesigning in ComponentState then
      if Assigned(System.Classes.ApplicationHandleException) then
        System.Classes.ApplicationHandleException(ExceptObject)
      else
        ShowException(ExceptObject, ExceptAddr)
    else
      raise;
  end;
end;

procedure TSparkleDispatcher.RegisterServer(Server: TSparkleServer);
begin
  FServers.Add(Server);
end;

procedure TSparkleDispatcher.SetActive(const Value: Boolean);
begin
  if (csDesigning in ComponentState) or (csReading in ComponentState) then
    FInternalActive := Value
  else
  if Value <> GetActive then
  begin
    if Value then
      DoStart
    else
      DoStop;
  end;
end;

procedure TSparkleDispatcher.Start;
begin
  SetActive(True);
end;

procedure TSparkleDispatcher.Stop;
begin
  SetActive(False);
end;

procedure TSparkleDispatcher.UnregisterServer(Server: TSparkleServer);
begin
  FServers.Remove(Server);
end;

{ TSparkleMiddlewareList }

function TSparkleMiddlewareList.Add(Value: TSparkleMiddleware): Integer;
begin
  Result := FList.Add(Value);
end;

procedure TSparkleMiddlewareList.Clear;
var
  I: Integer;
  Middleware: TSparkleMiddleware;
begin
  for I := FList.Count - 1 downto 0 do
  begin
    Middleware := FList[I];
    Middleware.FServer := nil;
    FList.Delete(I);
    Middleware.Free;
  end;
end;

constructor TSparkleMiddlewareList.Create;
begin
  FList := TList<TSparkleMiddleware>.Create;
end;

destructor TSparkleMiddlewareList.Destroy;
begin
  Clear;
  FList.Free;
  inherited;
end;

function TSparkleMiddlewareList.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TSparkleMiddlewareList.GetMiddleware(
  Index: Integer): TSparkleMiddleware;
begin
  Result := FList[Index];
end;

function TSparkleMiddlewareList.IndexOf(
  AMiddleware: TSparkleMiddleware): Integer;
begin
  Result := FList.IndexOf(AMiddleware);
end;

function TSparkleMiddlewareList.Remove(Value: TSparkleMiddleware): Integer;
begin
  Result := FList.Remove(Value);
end;

procedure TSparkleMiddlewareList.SetMiddlewareIndex(
  AMiddleware: TSparkleMiddleware; Value: Integer);
var
  CurIndex, Count: Integer;
begin
  CurIndex := FList.IndexOf(AMiddleware);
  if CurIndex >= 0 then
  begin
    Count := FList.Count;
    if Value < 0 then Value := 0;
    if Value >= Count then Value := Count - 1;
    if Value <> CurIndex then
    begin
      FList.Delete(CurIndex);
      FList.Insert(Value, AMiddleware);
    end;
  end;
end;

{ TSparkleGenericServer }

function TSparkleGenericServer.CreateSparkleModule: THttpServerModule;
begin
  Result := TAnonymousServerModule.Create(Self.BaseUrl,
    procedure(const Context: THttpServerContext)
    begin
      DoProcessRequest(Context);
    end
  );
end;

procedure TSparkleGenericServer.DoProcessRequest(Context: THttpServerContext);
begin
  if Assigned(FOnProcessRequest) then
    FOnProcessRequest(Self, Context);
end;

initialization
  MiddlewareClasses := TList<TSparkleMiddlewareClass>.Create;
finalization
  MiddlewareClasses.Free;
end.
