unit Sparkle.HttpServer.Module;

{$I Sparkle.Inc}

interface

uses
  Generics.Collections, System.SysUtils,
  Sparkle.HttpServer.Context,
  Sparkle.Logger,
  Sparkle.Uri;

type
  THttpServerProc = reference to procedure(const Context: THttpServerContext);
  TMiddlewareFunc = TFunc<THttpServerProc, THttpServerProc>;

  IHttpServerMiddleware = interface
  ['{AF0A916C-F5AE-4388-99A2-33869BA2A1F3}']
    function GetMiddlewareFunc: TMiddlewareFunc;
  end;

  THttpServerMiddleware = class(TInterfacedObject, IHttpServerMiddleware)
  private
    function MiddlewareFunc(Next: THttpServerProc): THttpServerProc;
  protected
    function GetMiddlewareFunc: TMiddlewareFunc;
    procedure ProcessRequest(Context: THttpServerContext; Next: THttpServerProc); virtual;
  end;

  TBaseHttpServerModule = class abstract(TInterfacedObject)
  strict private
    FMiddlewareList: TList<IHttpServerMiddleware>;
  strict protected
    procedure SetLogEngine(const ALogEngine: ILogEngine); virtual; abstract;
    function GetLogEngine: ILogEngine; virtual; abstract;
  protected
    procedure ProcessRequest(const Context: THttpServerContext); virtual; abstract;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Execute(const Context: THttpServerContext);
    procedure AddMiddleware(const AMiddleware: IHttpServerMiddleware);
    property LogEngine: ILogEngine read GetLogEngine write SetLogEngine;
  end;

  THttpServerModule = class(TBaseHttpServerModule)
  strict private
    FBaseUri: TUri;
    FLogger: TLogger;
    function GetBaseUri: TUri;
  strict protected
    procedure SetLogEngine(const ALogEngine: ILogEngine); override;
    function GetLogEngine: ILogEngine; override;
    property Logger: TLogger read FLogger;
  public
    constructor Create(const ABaseUri: string); virtual;
    destructor Destroy; override;
    function GetRelativeSegments(AUri: TUri): TArray<string>;
    property BaseUri: TUri read GetBaseUri;
  end;

  TRequestProc = THttpServerProc;

  TAnonymousServerModule = class(THttpServerModule)
  strict private
    FProc: TRequestProc;
  protected
    procedure ProcessRequest(const Context: THttpServerContext); override;
  public
    constructor Create(const ABaseUri: string; AProc: TRequestProc); reintroduce;
  end;

  TMiddlewareProc = reference to procedure(Context: THttpServerContext; Next: THttpServerProc);

  TAnonymousMiddleware = class(THttpServerMiddleware)
  strict private
    FProc: TMiddlewareProc;
  public
    constructor Create(AProc: TMiddlewareProc); reintroduce;
    procedure ProcessRequest(Context: THttpServerContext; Next: THttpServerProc); override;
  end;

  TBasicAuthenticationProvider = class
  strict protected
    function ValidateCredentials(const UserName, Password: string): boolean; virtual; abstract;
  public
    function Authenticate(const Context: THttpServerContext): boolean;

    function AuthenticateEx(const Context: THttpServerContext; out UserName, Password: string): boolean;
    function ExtractCredentials(const Context: THttpServerContext; out UserName, Password: string): boolean;
  end;

  TSimpleBasicAuthenticationProvider = class(TBasicAuthenticationProvider)
  strict private
    FValidate: TFunc<string, string, boolean>;
  strict protected
    function ValidateCredentials(const UserName, Password: string): boolean; override;
  public
    constructor Create(Validate: TFunc<string, string, boolean>);
  end;

implementation

uses
  Sparkle.Utils;

{ THttpServerModule }

constructor THttpServerModule.Create(const ABaseUri: string);
begin
  inherited Create;
  FBaseUri := TUri.Create(ABaseUri);
  FLogger := TLogger.Create;
end;

destructor THttpServerModule.Destroy;
begin
  FBaseUri.Free;
  FLogger.Free;
  inherited;
end;

function THttpServerModule.GetBaseUri: TUri;
begin
  Result := FBaseUri;
end;

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

function THttpServerModule.GetRelativeSegments(AUri: TUri): TArray<string>;
var
  I: Integer;
  BaseLen: integer;
begin
  // this function considers that if this module is being called,
  // it means that server has already compared the base url with the requested url
  // so we won't check it here again, we will just remove the base url segments
  BaseLen := Length(BaseUri.Segments);
  SetLength(Result, Length(AUri.Segments) - BaseLen);
  for I := BaseLen to Length(AUri.Segments) - 1 do
    Result[I - BaseLen] := AUri.Segments[I];
end;

procedure THttpServerModule.SetLogEngine(const ALogEngine: ILogEngine);
begin
  Logger.LogEngine := ALogEngine;
end;

{ TBasicAuthenticationProvider }

function TBasicAuthenticationProvider.Authenticate(const Context: THttpServerContext): boolean;
var
  UserName, Password: string;
begin
  Result := AuthenticateEx(Context, UserName, Password);
end;

function TBasicAuthenticationProvider.AuthenticateEx(const Context: THttpServerContext; out UserName, Password: string): boolean;
begin
  Result :=
    ExtractCredentials(Context, UserName, Password) and
    ValidateCredentials(UserName, Password);
end;

function TBasicAuthenticationProvider.ExtractCredentials(const Context: THttpServerContext; out UserName, Password: string): boolean;
var
  Auth: string;
  P: integer;
begin
  Result := false;
  UserName := '';
  Password := '';
  Auth := Context.Request.Headers.Get('authorization');
  if Auth = '' then
    Exit;
  if not SameText('Basic ', Copy(Auth, 1, 6)) then
    Exit;

  Auth := TEncoding.UTF8.GetString(TSparkleUtils.DecodeBase64(Copy(Auth, 7, MaxInt)));
  P := Pos(':', Auth);
  if P > 0 then
  begin
    UserName := Copy(Auth, 1, P - 1);
    Password := Copy(Auth, P + 1, MaxInt);
    Result := True;
  end;
end;

{ TSimpleBasicAuthenticationProvider }

constructor TSimpleBasicAuthenticationProvider.Create(Validate: TFunc<string, string, boolean>);
begin
  inherited Create;
  FValidate := Validate;
end;

function TSimpleBasicAuthenticationProvider.ValidateCredentials(const UserName,
  Password: string): boolean;
begin
  Result := FValidate(UserName, Password);
end;

{ TAnonymousServerModule }

constructor TAnonymousServerModule.Create(const ABaseUri: string; AProc: TRequestProc);
begin
  FProc := AProc;
  inherited Create(ABaseUri);
end;

procedure TAnonymousServerModule.ProcessRequest(const Context: THttpServerContext);
begin
  FProc(Context);
end;

{ TBaseHttpServerModule }

procedure TBaseHttpServerModule.AddMiddleware(
  const AMiddleware: IHttpServerMiddleware);
begin
  FMiddlewareList.Add(AMiddleware);
end;

constructor TBaseHttpServerModule.Create;
begin
  FMiddlewareList := TList<IHttpServerMiddleware>.Create;
end;

destructor TBaseHttpServerModule.Destroy;
begin
  FMiddlewareList.Free;
  inherited;
end;

procedure TBaseHttpServerModule.Execute(const Context: THttpServerContext);
var
  ServerProc: THttpServerProc;
  MiddlewareFunc: TMiddlewareFunc;
  I: integer;
begin
  ServerProc := ProcessRequest;
  for I := FMiddlewareList.Count - 1 downto 0 do
  begin
    MiddlewareFunc := FMiddlewareList[I].GetMiddlewareFunc;
    ServerProc := MiddlewareFunc(ServerProc);
  end;

  ServerProc(Context);

  if not Context.Response.Closed then
    Context.Response.Close;
end;

{ THttpServerMiddleware }

function THttpServerMiddleware.GetMiddlewareFunc: TMiddlewareFunc;
begin
  Result := MiddlewareFunc;
end;

function THttpServerMiddleware.MiddlewareFunc(
  Next: THttpServerProc): THttpServerProc;
begin
  Result := procedure(const C: THttpServerContext)
    begin
      Self.ProcessRequest(C, Next);
    end;
end;

procedure THttpServerMiddleware.ProcessRequest(
  Context: THttpServerContext; Next: THttpServerProc);
begin
  Next(Context);
end;

{ TAnonymousMiddleware }

constructor TAnonymousMiddleware.Create(AProc: TMiddlewareProc);
begin
  inherited Create;
  FProc := AProc;
end;

procedure TAnonymousMiddleware.ProcessRequest(Context: THttpServerContext;
  Next: THttpServerProc);
begin
  FProc(Context, Next);
end;

end.
