unit TestSphinx.Module;

interface

uses
  System.SysUtils,
  System.Classes,
  Aurelius.Engine.DatabaseManager,
  Aurelius.Drivers.Interfaces,
  Sparkle.HttpServer.Module,
  Sparkle.HttpServer.Context,
  Sphinx.Server.Module,
  Sphinx.Comp.Config,
  Sparkle.Comp.Server,
  Sparkle.Comp.CorsMiddleware,
  Sparkle.Comp.GenericMiddleware,
  XData.Comp.Server,
  Sphinx.Comp.Server,
  Aurelius.Comp.DBSchema,
  Sparkle.Comp.LoggingMiddleware;

type
  TSphinxModule = class(TDataModule)
    SphinxSchema: TAureliusDBSchema;
    SphinxServer1: TSphinxServer;
    SphinxServer1CORS: TSparkleCorsMiddleware;
    SphinxServer1Generic: TSparkleGenericMiddleware;
    SphinxConfig1: TSphinxConfig;
    SphinxServer1Logging: TSparkleLoggingMiddleware;
    procedure DataModuleDestroy(Sender: TObject);
    procedure DataModuleCreate(Sender: TObject);
    procedure SphinxConfig1ConfigureToken(Sender: TObject; Args: TConfigureTokenArgs);
    procedure SphinxConfig1GenerateEmailConfirmationToken(Sender: TObject; Args: TGenerateEmailConfirmationTokenArgs);
    procedure SphinxConfig1GeneratePasswordResetToken(Sender: TObject; Args: TGeneratePasswordResetTokenArgs);
    procedure SphinxConfig1GetSigningData(Sender: TObject; Args: TGetSigningDataArgs);
    procedure SphinxConfig1UserCreated(Sender: TObject; Args: TUserCreatedArgs);
    procedure SphinxConfig1UserPasswordChanged(Sender: TObject; Args: TUserPasswordChangedArgs);
    procedure SphinxServer1LoggingFilterLogEx(Sender: TObject; Context: THttpServerContext; Info: TLoggingInfo;
      var Accept: Boolean);
    procedure SphinxServer1Request(Sender: TObject; Context: THttpServerContext; Next: THttpServerProc);
  private
    FLoginAppFolder: string;
    FPasswordEmails: TStrings;
    procedure AddClientApps;
    function GetDBConnection: IDBConnection;
  public
    procedure LoadConfig;
    procedure UpdateSphinx;
    function CreateDefaultUser(const AName, AEmail, APassword, AFirstName, ALastName: string): string;
    function ValidatePassword(const TestPassword: string): string;
    property DBConnection: IDBConnection read GetDBConnection;
  end;

var
  SphinxModule: TSphinxModule;

implementation

{%CLASSGROUP 'Vcl.Controls.TControl'}

uses
  System.StrUtils,
  System.Hash,
  System.DateUtils,
  Aurelius.Engine.ObjectManager,
  Sparkle.Security,
  Sphinx.Context,
  Sphinx.Entities,
  Sphinx.Extensions,
  TestApp.Shared,
  Test.DistributionConfig,
  TestApp.Servers.Shared,
  App.Enumerations;

{$R *.dfm}

const
  Login_Timeout = 10 * 60;

procedure TSphinxModule.DataModuleDestroy(Sender: TObject);
begin
  FPasswordEmails.Free;
end;

function TSphinxModule.CreateDefaultUser(const AName, AEmail, APassword, AFirstName, ALastName: string): string;
var
  lUser: TUser;
  lContext: ISphinxContext;
begin
  lContext := SphinxServer1.CreateContext;
  lUser := lContext.UserManager.FindByEmail(AEmail);
  if not Assigned(lUser) then
  begin
    lUser := lContext.UserManager.CreateUserInstance;
    lContext.AddOwnership(lUser);
    lUser.UserName := AName;
    lUser.Email := AEmail;
    lContext.UserManager.CreateUser(lUser, APassword);
  end;

  lUser.Email := AEmail;
  lUser.EmailConfirmed := True;
  lUser.TwoFactorEnabled := False;
  TUserEx(lUser).UserStatus := TUserStatus.Active;
  TUserEx(lUser).UserCategory := TUserCategory.Admin;
  TUserEx(lUser).FirstName := AFirstName;
  TUserEx(lUser).LastName := ALastName;
  lContext.UserManager.UpdateUser(lUser);
  Result := lUser.Id;
end;

procedure TSphinxModule.DataModuleCreate(Sender: TObject);
begin
  FPasswordEmails := TStringList.Create;
end;

procedure TSphinxModule.AddClientApps;
var
  lClient: TSphinxClientApp;
  lUri: string;
begin
  if SphinxConfig1.Clients.Count > 0 then
    Exit;

  lClient := SphinxConfig1.Clients.Add;
  lClient.ClientId := App_Web_App_Id;
  lUri := Dist_OAuthRedirectBase;
  lClient.DefaultRedirectUri := lUri;
  lClient.RedirectUris.Add(lUri);
  lClient.RedirectUris.Add(Dist_OAuthRedirectIndexHtml);
  lClient.RequireClientSecret := False;
  lClient.AllowedGrantTypes := [TGrantType.gtAuthorizationCode];
  lClient.ValidScopes.Add('openid');
  lClient.ValidScopes.Add('email');
  lClient.LoginTimeout := Login_Timeout;

  lClient := SphinxConfig1.Clients.Add;
  lClient.ClientId := App_Manager_Id;
  lClient.RequireClientSecret := True;
  lClient.AllowedGrantTypes := [TGrantType.gtClientCredentials];
  lClient.AddSha256Secret(THashSHA2.GetHashBytes(App_Manager_Secret));
  lClient.ValidScopes.Add('openid');
  lClient.ValidScopes.Add(App_Manager_Scope);
  lClient.LoginTimeout := Login_Timeout;
end;

function TSphinxModule.GetDBConnection: IDBConnection;
begin
  Result := SphinxSchema.Connection.GetPoolInterface.GetConnection;
end;

procedure TSphinxModule.LoadConfig;
begin
  SphinxConfig1.UserClass := TUserEx;
  SphinxServer1.BaseUrl := Dist_DefaultSphinxAuthUrl;

  FLoginAppFolder := Dist_LoginAppFolder;
  SphinxConfig1.UIOptions.LoginAppFolder := FLoginAppFolder;

  AddClientApps;
end;

procedure TSphinxModule.SphinxConfig1ConfigureToken(Sender: TObject; Args: TConfigureTokenArgs);
begin
  Args.Token.Claims.AddOrSet(CLAIM_SCOPE, SCOPE_ADMIN);
end;

procedure TSphinxModule.SphinxConfig1GenerateEmailConfirmationToken(Sender: TObject;
  Args: TGenerateEmailConfirmationTokenArgs);
begin
  // Minimal test project: no outbound email (not required for login / logout repro).
end;

procedure TSphinxModule.SphinxConfig1GeneratePasswordResetToken(Sender: TObject; Args: TGeneratePasswordResetTokenArgs);
begin
  // Minimal test project: no outbound email (not required for login / logout repro).
end;

procedure TSphinxModule.SphinxConfig1GetSigningData(Sender: TObject; Args: TGetSigningDataArgs);
begin
  Args.Data.Key := TEncoding.UTF8.GetBytes(Sys_Signing_Key);
end;

procedure TSphinxModule.SphinxConfig1UserCreated(Sender: TObject; Args: TUserCreatedArgs);
begin
end;

procedure TSphinxModule.SphinxConfig1UserPasswordChanged(Sender: TObject; Args: TUserPasswordChangedArgs);
var
  lIdx: Integer;
begin
  lIdx := FPasswordEmails.IndexOfName(Args.User.Id);
  if lIdx > -1 then
    FPasswordEmails.Delete(lIdx);
end;

procedure TSphinxModule.SphinxServer1LoggingFilterLogEx(Sender: TObject; Context: THttpServerContext;
  Info: TLoggingInfo; var Accept: Boolean);
begin
  Accept := Context.Response.StatusCode > 299;
end;

procedure TSphinxModule.SphinxServer1Request(Sender: TObject; Context: THttpServerContext; Next: THttpServerProc);
var
  sPath: string;
  sLoginUrl: string;
  sHost: string;
  sProtocol: string;
  sBaseUrl: string;

  procedure ExtractHostAndProtocol;
  begin
    sHost := '';
    sProtocol := 'http';
    try
      sBaseUrl := Context.Request.Uri.ToString;
      if Pos('://', sBaseUrl) > 0 then
      begin
        if StartsText('https://', sBaseUrl) then
          sProtocol := 'https'
        else
          sProtocol := 'http';
        sHost := Copy(sBaseUrl, Pos('://', sBaseUrl) + 3, MaxInt);
        if Pos('/', sHost) > 0 then
          sHost := Copy(sHost, 1, Pos('/', sHost) - 1);
      end;
    except
      sHost := '';
      sProtocol := 'http';
    end;
    if sHost = '' then
    begin
      sHost := SphinxServer1.BaseUrl;
      if StartsText('https://', sHost) then
      begin
        sHost := Copy(sHost, 9, MaxInt);
        sProtocol := 'https';
      end
      else if StartsText('http://', sHost) then
      begin
        sHost := Copy(sHost, 8, MaxInt);
        sProtocol := 'http';
      end;
      if Pos('/', sHost) > 0 then
        sHost := Copy(sHost, 1, Pos('/', sHost) - 1);
    end;
    if (sHost <> '') and (sHost[1] = '+') then
      sHost := 'localhost' + Copy(sHost, 2, MaxInt);
  end;

begin
  sPath := '/';
  try
    sPath := Context.Request.Uri.Path;
    if sPath = '' then
      sPath := '/';
  except
    try
      sPath := Context.Request.Uri.AbsolutePath;
      if sPath = '' then
        sPath := '/';
    except
      sPath := '/';
    end;
  end;

  if (sPath = '/') or (sPath = '') then
  begin
    ExtractHostAndProtocol;
    sLoginUrl := sProtocol + '://' + sHost + '/' + cSphinxUrlPath + '/oauth/login/?client=' + App_Web_App_Id;
    Context.Response.StatusCode := 302;
    Context.Response.Headers.SetValue('Location', sLoginUrl);
  end
  else
  begin
    if Pos('/oauth/', LowerCase(sPath)) > 0 then
    begin
      sLoginUrl := Dist_OAuthRedirectBase;
      if not sLoginUrl.EndsWith('/') then
        sLoginUrl := sLoginUrl + '/';
      Context.Response.OnHeaders(
        procedure(Resp: THttpServerResponse)
        var
          bIsJsonError: Boolean;
          sContentType: string;
        begin
          bIsJsonError := (Resp.StatusCode >= 400) and (Resp.StatusCode < 500);
          if bIsJsonError then
          begin
            sContentType := Resp.Headers.Get('Content-Type');
            if (sContentType <> '') and (Pos('application/json', LowerCase(sContentType)) > 0) then
            begin
              Resp.StatusCode := 302;
              Resp.Headers.SetValue('Location', sLoginUrl);
            end;
          end;
        end
      );
    end;
    Next(Context);
  end;
end;

procedure TSphinxModule.UpdateSphinx;
begin
  SphinxSchema.UpdateDatabase;
end;

function TSphinxModule.ValidatePassword(const TestPassword: string): string;
var
  bHasDigit: Boolean;
  bHasLower: Boolean;
  bHasUpper: Boolean;
  bHasNonAlphaNumeric: Boolean;
  iLength: Integer;
  iIdx: Integer;
begin
  bHasDigit := False;
  bHasLower := False;
  bHasUpper := False;
  bHasNonAlphaNumeric := False;

  iLength := Length(TestPassword);
  for iIdx := 1 to Length(TestPassword) do
  begin
    bHasDigit := bHasDigit or (TestPassword[iIdx] in ['0'..'9']);
    bHasLower := bHasLower or (TestPassword[iIdx] in ['a'..'z']);
    bHasUpper := bHasUpper or (TestPassword[iIdx] in ['A'..'Z']);
    bHasNonAlphaNumeric := bHasNonAlphaNumeric or not (TestPassword[iIdx] in ['A'..'Z', 'a'..'z', '0'..'9']);
  end;

  Result := '';
  if SphinxConfig1.PasswordOptions.RequireDigit and not bHasDigit then
    Result := Result + 'Must contain a number' + sLineBreak;
  if SphinxConfig1.PasswordOptions.RequiredLength > iLength then
    Result := Result + 'Must be at least ' + IntToStr(SphinxConfig1.PasswordOptions.RequiredLength) + ' characters' + sLineBreak;
  if SphinxConfig1.PasswordOptions.RequireLowercase and not bHasLower then
    Result := Result + 'Must contain a lower case letter' + sLineBreak;
  if SphinxConfig1.PasswordOptions.RequireUppercase and not bHasUpper then
    Result := Result + 'Must contain an upper case letter' + sLineBreak;
  if SphinxConfig1.PasswordOptions.RequireNonAlphanumeric and not bHasNonAlphaNumeric then
    Result := Result + 'Must contain a non alpha-numeric letter' + sLineBreak;

  if Length(Result) = 0 then
    Result := 'Password validation passed';
end;

end.
