unit Sparkle.HttpServer.Dispatcher;

interface

uses
  Generics.Collections,
  Sparkle.Logger,
  Sparkle.Uri,
  Sparkle.HttpServer.Module,
  Sparkle.HttpServer.Context;

type
  THttpServerModuleInfo = class
  strict private
    FModule: TBaseHttpServerModule;
    FBaseUri: TUri;
  public
    constructor Create(const ABaseUri: TUri; AModule: TBaseHttpServerModule);
    destructor Destroy; override;
    property BaseUri: TUri read FBaseUri;
    property Module: TBaseHttpServerModule read FModule;
  end;

  THttpDispatcher = class
  strict private
    FModules: TList<THttpServerModuleInfo>;
    FDetailedErrorResponse: boolean;
    function FindModule(AUri: TUri): TBaseHttpServerModule;
    property DetailedErrorResponse: boolean read FDetailedErrorResponse write FDetailedErrorResponse;
  strict private
    FLogger: TLogger;
    function GetLogEngine: ILogEngine;
    procedure SetLogEngine(const Value: ILogEngine);
  strict private
    function GetModulesInfo: TEnumerable<THttpServerModuleInfo>; protected
    procedure AddModule(const ABaseUri: string; AModule: TBaseHttpServerModule); overload;
    procedure AddModule(const ABaseUri: TUri; AModule: TBaseHttpServerModule); overload;
    property Logger: TLogger read FLogger;
  protected
    procedure ProcessRequest(Context: THttpServerContext); virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ClearModules;
    procedure DispatchRequest(Context: THttpServerContext);
    procedure AddModule(AModule: THttpServerModule); overload;
    property LogEngine: ILogEngine read GetLogEngine write SetLogEngine;
    property ModulesInfo: TEnumerable<THttpServerModuleInfo> read GetModulesInfo;
  end;

implementation

uses
  System.SysUtils;

constructor THttpServerModuleInfo.Create(const ABaseUri: TUri;
  AModule: TBaseHttpServerModule);
begin
  FBaseUri := ABaseUri;
  FModule := AModule;
end;

destructor THttpServerModuleInfo.Destroy;
begin
  FBaseUri.Free;
  FModule.Free;
  inherited;
end;

{ THttpDispatcher }

procedure THttpDispatcher.AddModule(const ABaseUri: string;
  AModule: TBaseHttpServerModule);
begin
  AddModule(TUri.Create(ABaseUri), AModule);
end;

procedure THttpDispatcher.AddModule(AModule: THttpServerModule);
begin
  AddModule(AModule.BaseUri.Clone, AModule);
end;

procedure THttpDispatcher.AddModule(const ABaseUri: TUri;
  AModule: TBaseHttpServerModule);
begin
  AModule.LogEngine := Self.LogEngine;
  FModules.Add(THttpServerModuleInfo.Create(ABaseUri, AModule));
end;

procedure THttpDispatcher.ClearModules;
begin
  // Be careful when clearing modules - server might be running and
  // referencing existing modules
  FModules.Clear;
end;

constructor THttpDispatcher.Create;
begin
  inherited;
  FModules := TObjectList<THttpServerModuleInfo>.Create;
  FLogger := TLogger.Create;
  FDetailedErrorResponse := true;
end;

destructor THttpDispatcher.Destroy;
begin
  FModules.Free;
  FLogger.Free;
  inherited;
end;

procedure THttpDispatcher.DispatchRequest(Context: THttpServerContext);
var
  ErrorContent: TBytes;
begin
  {$IFDEF DEBUGLOG} Logger.Debug(Format('Context: %d', [Context.ContextId])); {$ENDIF}
  try
    Context.Response.StatusCode := 400;
    ProcessRequest(Context);
    if not Context.Response.Closed then
      Context.Response.Close;
  except
    // low-level, internal error catcher
    on E: Exception do
    begin
      try
        Logger.Log(Format('Exception on process requesting. %s: %s', [e.ClassName, e.Message]));

        // Send error
        if not Context.Response.HeadersSent then
        begin
          Context.Response.Headers.Clear;
          Context.Response.StatusCode := 500;
          Context.Response.ContentType := 'text/plain';
          Context.Response.ContentLength := 0;
          Context.Response.Chunked := false;
          if DetailedErrorResponse then
          begin
            ErrorContent :=
              TEncoding.UTF8.GetBytes(
              Format('Exception Class: %s '#13#10'Message: %s',
              [E.ClassName, E.Message]));
            Context.Response.ContentLength := Length(ErrorContent);
            Context.Response.Content.Write(ErrorContent[0], Length(ErrorContent));
          end;
        end;
        if not Context.Response.Closed then
          Context.Response.Close;
      except
      end;
    end;
  end;
end;

procedure THttpDispatcher.ProcessRequest(Context: THttpServerContext);
var
  Module: TBaseHttpServerModule;
begin
  {$IFDEF DEBUGLOG} Logger.Enter('DoProcessRequest'); {$ENDIF}
  try
    Context.Response.StatusCode := 400; // Bad Request if module does nothing
    {$IFDEF DEBUGLOG} Logger.Debug(Format('Uri: %s', [Context.Request.Uri.OriginalUri])); {$ENDIF}
    Module := FindModule(Context.Request.Uri);
    if Module <> nil then
      Module.Execute(Context)
    else
      Context.Response.StatusCode := 404;
  finally
    {$IFDEF DEBUGLOG} Logger.Leave('DoProcessRequest'); {$ENDIF}
  end;
end;

function THttpDispatcher.FindModule(AUri: TUri): TBaseHttpServerModule;
var
  ModuleInfo: THttpServerModuleInfo;
  I: integer;
  Len: integer;
  ChosenLen: Integer;
begin
  ChosenLen := 0;
  Result := nil;
  for ModuleInfo in FModules do
  begin
    Len := Length(ModuleInfo.BaseUri.Segments);
    if (Len = 0) and (Result = nil) then
      Result := ModuleInfo.Module;

    if Length(AUri.Segments) >= Len then
    begin
      for I := 0 to Len - 1 do
      begin
        if not SameText(ModuleInfo.BaseUri.Segments[I], AUri.Segments[I]) then
          break;

        // check if all segments match *and* the number of segements is
        // bigger than a previous chosen length (the most specific the URL,
        // the higher the precedence for the module to be chosen)
        if (I = Len - 1) and (Len > ChosenLen) then
        begin
          Result := ModuleInfo.Module;
          ChosenLen := Len;
        end;
      end;
    end;
  end;
end;

function THttpDispatcher.GetLogEngine: ILogEngine;
begin
  Result := Logger.LogEngine;
end;

function THttpDispatcher.GetModulesInfo: TEnumerable<THttpServerModuleInfo>;
begin
  Result := FModules;
end;

procedure THttpDispatcher.SetLogEngine(const Value: ILogEngine);
begin
  Logger.LogEngine := Value;
end;

end.
