From 885b6d6009b65f1a3ee1042680cf755536ff92d9 Mon Sep 17 00:00:00 2001 From: Exilon Date: Tue, 10 Oct 2023 11:35:44 +0200 Subject: [PATCH 1/5] Added HealthChecks --- Quick.Core.Extensions.HealthChecks.Entity.pas | 104 ++++ Quick.Core.Extensions.HealthChecks.Redis.pas | 140 +++++ ...Core.Extensions.HealthChecks.SqlServer.pas | 94 ++++ Quick.Core.Extensions.HealthChecks.pas | 528 ++++++++++++++++++ Quick.Core.Mvc.Extensions.HealthChecks.pas | 86 +++ 5 files changed, 952 insertions(+) create mode 100644 Quick.Core.Extensions.HealthChecks.Entity.pas create mode 100644 Quick.Core.Extensions.HealthChecks.Redis.pas create mode 100644 Quick.Core.Extensions.HealthChecks.SqlServer.pas create mode 100644 Quick.Core.Extensions.HealthChecks.pas create mode 100644 Quick.Core.Mvc.Extensions.HealthChecks.pas diff --git a/Quick.Core.Extensions.HealthChecks.Entity.pas b/Quick.Core.Extensions.HealthChecks.Entity.pas new file mode 100644 index 0000000..73326a1 --- /dev/null +++ b/Quick.Core.Extensions.HealthChecks.Entity.pas @@ -0,0 +1,104 @@ +{ *************************************************************************** + + Copyright (c) 2016-2021 Kike Pérez + + Unit : Quick.Core.Extensions.HealthChecks.Entity + Description : Core Extensions Entity Health Checks + Author : Kike Pérez + Version : 1.0 + Created : 12/02/2021 + Modified : 21/02/2021 + + This file is part of QuickCore: https://github.com/exilon/QuickCore + + *************************************************************************** + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + *************************************************************************** } + +unit Quick.Core.Extensions.HealthChecks.Entity; + +{$i QuickCore.inc} + +interface + +uses + System.SysUtils, + System.TypInfo, + System.TimeSpan, + Quick.Commons, + Quick.Core.Entity, + Quick.Core.DependencyInjection, + Quick.Core.Extensions.HealthChecks; + +type + TEntityHealthCheck = class(THealthCheck) + private + fDBContext : TDBContext; + public + constructor Create(aDBContext : TDBContext; aTimeSpan : TTimeSpan); + destructor Destroy; override; + procedure Check; override; + end; + + TEntityHealthChecksExtension = class(THealthChecksExtension) + class function AddDBContextCheck(const aName : string; aTimeSpan : TTimeSpan) : THealthChecksService; + end; + +implementation + +{ TEntityHealthChecksExtension } + +class function TEntityHealthChecksExtension.AddDBContextCheck(const aName : string; aTimeSpan : TTimeSpan) : THealthChecksService; +var + check : IHealthCheck; + db : T; +begin + Result := HealthChecksService; + db := HealthChecksService.ServiceCollection.Resolve(); + //db := (PTypeInfo(TypeInfo(T)).TypeData.ClassType.Create) as T; + //TDBContext(db).Database := HealthChecksService.ServiceCollection.Resolve().Database.Clone; + //TDBContext(db).Connection.FromConnectionString(Integer(TDBContext(db).Connection.Provider),TDBContext(db).Connection.GetCustomConnectionString); + //TDBContext(db).Connect; + check := TEntityHealthCheck.Create(db,aTimeSpan); + check.Name := aName; + Result := HealthChecksService.AddCheck(check); +end; + +{ TEntityHealthCheck } + +procedure TEntityHealthCheck.Check; +begin + inherited; + try + fDBContext.Database.GetTableNames; + except + on E : Exception do raise Exception.CreateFmt('Error connection to "%s" database!',[fDBContext.Connection.Database]); + end; +end; + +constructor TEntityHealthCheck.Create(aDBContext : TDBContext; aTimeSpan : TTimeSpan); +begin + inherited Create(aTimeSpan); + fName := 'Entity'; + fDBContext := aDBContext; +end; + +destructor TEntityHealthCheck.Destroy; +begin + inherited; +end; + +end. + diff --git a/Quick.Core.Extensions.HealthChecks.Redis.pas b/Quick.Core.Extensions.HealthChecks.Redis.pas new file mode 100644 index 0000000..f81332f --- /dev/null +++ b/Quick.Core.Extensions.HealthChecks.Redis.pas @@ -0,0 +1,140 @@ +{ *************************************************************************** + + Copyright (c) 2016-2021 Kike Pérez + + Unit : Quick.Core.Extensions.HealthChecks.Redis + Description : Core Extensions Entity Health Checks + Author : Kike Pérez + Version : 1.0 + Created : 14/02/2021 + Modified : 21/02/2021 + + This file is part of QuickCore: https://github.com/exilon/QuickCore + + *************************************************************************** + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + *************************************************************************** } + +unit Quick.Core.Extensions.HealthChecks.Redis; + +{$i QuickCore.inc} + +interface + +uses + System.SysUtils, + System.TypInfo, + System.TimeSpan, + Quick.Commons, + Quick.Options, + Quick.Data.Redis, + Quick.Core.DependencyInjection, + Quick.Core.Extensions.HealthChecks; + +type + TRedisHealthCheckOptions = class(TOptions) + private + fHost : string; + fPort : Integer; + fPassword : string; + fDatabaseNumber : Integer; + fConnectionTimeout: Integer; + fReadTimeout: Integer; + public + constructor Create; override; + published + property Host : string read fHost write fHost; + property Port : Integer read fPort write fPort; + property Password : string read fPassword write fPassword; + property DatabaseNumber : Integer read fDatabaseNumber write fDatabaseNumber; + property ConnectionTimeout : Integer read fConnectionTimeout write fConnectionTimeout; + property ReadTimeout : Integer read fReadTimeout write fReadTimeout; + end; + + TRedisHealthCheck = class(THealthCheck) + private + fRedisClient : TRedisClient; + fRedisOptions : TRedisHealthCheckOptions; + public + constructor Create(aRedisOptions : TRedisHealthCheckOptions; aTimeSpan : TTimeSpan); + destructor Destroy; override; + procedure Check; override; + end; + + TRedisHealthChecksExtension = class(THealthChecksExtension) + class function AddRedisCheck(const aName : string; aRedisOptionsProc : TConfigureOptionsProc; aTimeSpan : TTimeSpan) : THealthChecksService; + end; + +implementation + +{ TRedisHealthChecksExtension } + +class function TRedisHealthChecksExtension.AddRedisCheck(const aName : string; aRedisOptionsProc : TConfigureOptionsProc; aTimeSpan : TTimeSpan) : THealthChecksService; +var + check : IHealthCheck; +begin + if not Assigned(aRedisOptionsProc) then raise Exception.Create('RedisOptions param cannot be nil!'); + + var redisOptions := TRedisHealthCheckOptions.Create; + aRedisOptionsProc(redisOptions); + check := TRedisHealthCheck.Create(redisOptions,aTimeSpan); + check.Name := aName; + Result := HealthChecksService.AddCheck(check); +end; + +{ TEntityHealthCheck } + +procedure TRedisHealthCheck.Check; +begin + inherited; + fRedisClient.Disconnect; + try + fRedisClient.Connect; + finally + fRedisClient.Disconnect; + end; +end; + +constructor TRedisHealthCheck.Create(aRedisOptions : TRedisHealthCheckOptions; aTimeSpan : TTimeSpan); +begin + inherited Create(aTimeSpan); + fName := 'Redis'; + fRedisOptions := aRedisOptions; + fRedisClient := TRedisClient.Create; + fRedisClient.Host := aRedisOptions.Host; + fRedisClient.Port := aRedisOptions.Port; + fRedisClient.DataBaseNumber := aRedisOptions.DatabaseNumber; + fRedisClient.Password := aRedisOptions.Password; + fRedisClient.ConnectionTimeout := aRedisOptions.ConnectionTimeout; + fRedisClient.ReadTimeout := aRedisOptions.ReadTimeout; +end; + +destructor TRedisHealthCheck.Destroy; +begin + fRedisClient.Free; + inherited; +end; + +{ TRedisHealthCheckOptions } + +constructor TRedisHealthCheckOptions.Create; +begin + inherited; + fReadTimeout := 3000; + fConnectionTimeout := 2000; +end; + +end. + diff --git a/Quick.Core.Extensions.HealthChecks.SqlServer.pas b/Quick.Core.Extensions.HealthChecks.SqlServer.pas new file mode 100644 index 0000000..6a2b0bf --- /dev/null +++ b/Quick.Core.Extensions.HealthChecks.SqlServer.pas @@ -0,0 +1,94 @@ +{ *************************************************************************** + + Copyright (c) 2016-2021 Kike Pérez + + Unit : Quick.Core.Extensions.HealthChecks.SqlServer + Description : Core Extensions SqlServer Health Checks + Author : Kike Pérez + Version : 1.0 + Created : 12/02/2021 + Modified : 21/02/2021 + + This file is part of QuickCore: https://github.com/exilon/QuickCore + + *************************************************************************** + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + *************************************************************************** } + +unit Quick.Core.Extensions.HealthChecks.SqlServer; + +{$i QuickCore.inc} + +interface + +uses + System.SysUtils, + System.TimeSpan, + Quick.Commons, + Quick.Core.Entity, + Quick.Core.DependencyInjection, + Quick.Core.Extensions.HealthChecks; + +type + TSqlServerHealthCheck = class(THealthCheck) + private + fEntityDatabase : TEntityDatabase; + public + constructor Create(aDataBase : TEntityDatabase; aTimeSpan : TTimeSpan); + destructor Destroy; override; + procedure Check; override; + end; + + TSqlServerHealthChecksExtension = class(THealthChecksExtension) + class function AddSqlServerCheck(const aName : string; aTimeSpan : TTimeSpan) : THealthChecksService; + end; + +implementation + +{ TSqlServerHealthChecksExtension } + +class function TSqlServerHealthChecksExtension.AddSqlServerCheck(const aName : string; aTimeSpan : TTimeSpan) : THealthChecksService; +var + check : IHealthCheck; + db : TEntityDatabase; +begin + check := TSqlServerHealthCheck.Create(db,aTimeSpan); + check.Name := aName; + Result := HealthChecksService.AddCheck(check); +end; + +{ TSqlServerHealthCheck } + +procedure TSqlServerHealthCheck.Check; +begin + inherited; + fEntityDatabase.Connect; + if not fEntityDatabase.IsConnected then raise Exception.CreateFmt('Error connection to "%s" database!',[fEntityDatabase.Connection.Database]); +end; + +constructor TSqlServerHealthCheck.Create(aDataBase : TEntityDatabase; aTimeSpan : TTimeSpan); +begin + inherited Create(aTimeSpan); + fName := 'SqlServer'; + fEntityDatabase := aDataBase.Clone; +end; + +destructor TSqlServerHealthCheck.Destroy; +begin + fEntityDatabase.Free; + inherited; +end; + +end. diff --git a/Quick.Core.Extensions.HealthChecks.pas b/Quick.Core.Extensions.HealthChecks.pas new file mode 100644 index 0000000..b879908 --- /dev/null +++ b/Quick.Core.Extensions.HealthChecks.pas @@ -0,0 +1,528 @@ +{ *************************************************************************** + + Copyright (c) 2016-2021 Kike Pérez + + Unit : Quick.Core.Extensions.HealthChecks + Description : Core Extensions Health Checks + Author : Kike Pérez + Version : 1.0 + Created : 12/02/2021 + Modified : 21/02/2021 + + This file is part of QuickCore: https://github.com/exilon/QuickCore + + *************************************************************************** + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + *************************************************************************** } + +unit Quick.Core.Extensions.HealthChecks; + +{$i QuickCore.inc} + +interface + +uses + {$IFDEF DEBUG_HEALTHCHECKS} + Quick.Debug.Utils, + {$ENDIF} + System.JSON, + System.SysUtils, + System.TimeSpan, + System.Net.HttpClient, + System.Generics.Collections, + Quick.Collections, + Quick.Core.Serialization.Abstractions, + Quick.Options, + Quick.Threads, + Quick.Chrono, + Quick.Core.DependencyInjection, + Quick.Core.Logging.Abstractions; + +type + THealthCheckOptions = class(TOptions) + private + fLogFails : Boolean; + fRetryTimes : Integer; + fMaxSize : Integer; + published + constructor Create; override; + property LogFails : Boolean read fLogFails write fLogFails; + property RetryTimes : Integer read fRetryTimes write fRetryTimes; + property MaxSize : Integer read fMaxSize write fMaxSize; + end; + + THealthStatus = (hsNotChecked, hsPassed, hsFailed); + + IHealthCheck = interface + ['{7FA7D505-1C60-443C-A126-3103B69BA3CC}'] + function GetStatus: THealthStatus; + procedure SetStatus(const Value: THealthStatus); + function GetLastCheck: TDateTime; + function GetName: string; + procedure SetName(const Value: string); + function GetTimeElapsed: string; + procedure SetTimeElapsed(const Value: string); + function GetErrorMsg: string; + procedure SetErrorMsg(const Value: string); + function GetLastStatusChange: TDateTime; + function GetCheckEveryMSecs : Int64; + //public + property Name : string read GetName write SetName; + property LastCheck : TDateTime read GetLastCheck; + property LastStatusChange : TDateTime read GetLastStatusChange; + property TimeElapsed : string read GetTimeElapsed write SetTimeElapsed; + property Status : THealthStatus read GetStatus write SetStatus; + property CheckEveryMSecs : Int64 read GetCheckEveryMSecs; + property ErrorMsg : string read GetErrorMsg write SetErrorMsg; + procedure Check; + end; + + THealthCheck = class(TInterfacedObject,IHealthCheck) + private + function GetStatus: THealthStatus; + procedure SetStatus(const Value: THealthStatus); + function GetLastCheck: TDateTime; + function GetName: string; + procedure SetName(const Value: string); + function GetTimeElapsed: string; + procedure SetTimeElapsed(const Value: string); + function GetErrorMsg: string; + procedure SetErrorMsg(const Value: string); + function GetLastStatusChange: TDateTime; + function GetCheckEveryMSecs : Int64; + protected + fName : string; + fLastCheck : TDateTime; + fLastStatusChange : TDateTime; + fTimeElapsed : string; + fCheckEveryMSecs : Int64; + fStatus : THealthStatus; + fErrorMsg : string; + public + constructor Create(aTimeSpan : TTimeSpan); + property Name : string read GetName write SetName; + property LastCheck : TDateTime read GetLastCheck; + property TimeElapsed : string read GetTimeElapsed write SetTimeElapsed; + property Status : THealthStatus read GetStatus; + property LastStatusChange : TDateTime read GetLastStatusChange; + property CheckEveryMSecs : Int64 read GetCheckEveryMSecs; + property ErrorMsg : string read GetErrorMsg write SetErrorMsg; + procedure Check; virtual; + end; + + TUrlHealthCheck = class(THealthCheck) + private + fUrl : string; + public + constructor Create(const aUrl: string; aTimeSpan : TTimeSpan); + destructor Destroy; override; + procedure Check; override; + end; + + THealthCheckFailEvent = reference to procedure(aHealtCheck : IHealthCheck); + + {$M+} + THealthCheckMetric = class + private + fName : string; + fLastCheck : TDateTime; + fTimeElapsed : string; + fCheckEveryMSecs : Int64; + fStatus : THealthStatus; + fLastStatusChange : TDateTime; + fErrorMsg : string; + published + property Name : string read fName write fName; + property LastCheck : TDateTime read fLastCheck write fLastCheck; + property TimeElapsed : string read fTimeElapsed write fTimeElapsed; + property Status : THealthStatus read fStatus write fStatus; + property LastStatusChange : TDateTime read fLastStatusChange write fLastStatusChange; + property ErrorMsg : string read fErrorMsg write fErrorMsg; + end; + {$M-} + + IHealthChecksService = interface + ['{BC78D855-4E19-4DBD-869A-10B423B08076}'] + function GetMetrics : IList; + end; + + IHealthChecksStore = interface + ['{9B16807B-FF16-4FBF-AB36-85D30364D70C}'] + procedure Add(aHealthCheck : IHealthCheck); + function Last : IList; + end; + + THealthCheckStore = class(TInterfacedObject,IHealthChecksStore) + protected + function MapMetric(aHealthCheck : IHealthCheck) : THealthCheckMetric; + public + procedure Add(aHealthCheck : IHealthCheck); virtual; abstract; + function Last : IList; virtual; abstract; + end; + + TMemoryHealthCheckStore = class(THealthCheckStore) + private type + THealthCheckMetrics = TObjectList; + private + fCheckMetrics : TObjectDictionary; + public + constructor Create(aMaxSize : Integer); + destructor Destroy; override; + procedure Add(aHealthCheck : IHealthCheck); override; + function Last : IList; override; + end; + + THealthChecksService = class(TInterfacedObject,IHealthChecksService) + private + fServiceCollection : TServiceCollection; + fHistory : IHealthChecksStore; + fOptions : THealthCheckOptions; + fLogger : ILogger; + fHealthCheckList : TList; + fScheduler : TScheduledTasks; + fHealthCheckFailEvent : THealthCheckFailEvent; + fNumChecks : Integer; + function GetMetrics : IList; + public + constructor Create(aServiceCollection : TServiceCollection; aOptions : THealthCheckOptions; aLogger : ILogger); + destructor Destroy; override; + property ServiceCollection : TServiceCollection read fServiceCollection; + function OnCheckFail(aHealthFailProc : THealthCheckFailEvent) : THealthChecksService; + function AddCheck(aHealthCheck : IHealthCheck) : THealthChecksService; + function AddUrlCheck(const aName, aUrl : string; aTimeSpan : TTimeSpan) : THealthChecksService; + function AddInMemoryStorage : THealthChecksService; + end; + + THealthChecksServiceExtension = class(TServiceCollectionExtension) + class function AddHealthChecks(aConfigureOptions : TConfigureOptionsProc = nil) : THealthChecksService; + end; + + THealthChecksExtension = class + private class var + fHealthChecksService : THealthChecksService; + class function SetService(aHealthChecksService : THealthChecksService) : THealthChecksExtension; + public + class property HealthChecksService : THealthChecksService read fHealthChecksService; + end; + + THealthChecksHelper = class helper for THealthChecksService + function Extension : T; + end; + +implementation + +{ THealthChecksServiceExtension } + +class function THealthChecksServiceExtension.AddHealthChecks(aConfigureOptions : TConfigureOptionsProc) : THealthChecksService; +var + options : THealthCheckOptions; +begin + if not ServiceCollection.IsRegistered then + begin + options := THealthCheckOptions.Create; + if Assigned(aConfigureOptions) then + begin + aConfigureOptions(options); + end; + Result := THealthChecksService.Create(ServiceCollection, options,ServiceCollection.AppServices.Logger); + ServiceCollection.AddSingleton(Result); + end + else raise Exception.Create('Already registered HealthChecks extension!'); +end; + +{ THealthChecksService } + +constructor THealthChecksService.Create(aServiceCollection : TServiceCollection; aOptions : THealthCheckOptions; aLogger : ILogger); +begin + fServiceCollection := aServiceCollection; + fOptions := aOptions; + fLogger := aLogger; + fHealthCheckList := TList.Create; + fScheduler := TScheduledTasks.Create; + fScheduler.Start; +end; + +destructor THealthChecksService.Destroy; +begin + fScheduler.Stop; + fScheduler.Free; + fHealthCheckList.Free; + inherited; +end; + +function THealthChecksService.AddCheck(aHealthCheck: IHealthCheck) : THealthChecksService; +begin + Result := Self; + fHealthCheckList.Add(aHealthCheck); + fScheduler.AddTask('',procedure(task : ITask) + var + chrono : TChronometer; + begin + {$IFDEF DEBUG_HEALTHCHECKS} + TDebugger.Trace(Self,'HealthCheck %s...',[aHealthCheck.Name]); + {$ENDIF} + chrono := TChronometer.Create(True); + try + aHealthCheck.Check; + aHealthCheck.Status := THealthStatus.hsPassed; + chrono.Stop; + aHealthCheck.TimeElapsed := chrono.ElapsedTime(False); + {$IFDEF DEBUG_HEALTHCHECKS} + TDebugger.Trace(Self,'HealthCheck %s status ok (%s)',[aHealthCheck.Name,aHealthCheck.TimeElapsed]); + {$ENDIF} + finally + chrono.Free; + end; + end) + .OnException(procedure(task : ITask; aException : Exception) + begin + //mark health as failed + aHealthCheck.Status := THealthStatus.hsFailed; + aHealthCheck.ErrorMsg := aException.Message; + {$IFDEF DEBUG_HEALTHCHECKS} + TDebugger.Trace(Self,'HealthCheck %s status failed (%s)',[aHealthCheck.Name,aHealthCheck.ErrorMsg]); + {$ENDIF} + if fOptions.LogFails then fLogger.Critical('HealthCheck %s status failed (%s)',[aHealthCheck.Name,aHealthCheck.ErrorMsg]); + if Assigned(fHealthCheckFailEvent) then fHealthCheckFailEvent(aHealthCheck); + end) + .OnTerminated(procedure(task : ITask) + begin + if fHistory <> nil then fHistory.Add(aHealthCheck); + end) + .Retry(fOptions.RetryTimes) + .StartInSeconds(5).RepeatEvery(aHealthCheck.CheckEveryMSecs,TTimeMeasure.tmMilliseconds); +end; + +function THealthChecksService.AddInMemoryStorage: THealthChecksService; +begin + Result := Self; + fHistory := TMemoryHealthCheckStore.Create(fOptions.MaxSize); +end; + +function THealthChecksService.AddUrlCheck(const aName, aUrl : string; aTimeSpan : TTimeSpan) : THealthChecksService; +var + check : IHealthCheck; +begin + Result := Self; + check := TUrlHealthCheck.Create(aUrl,aTimeSpan); + check.Name := aName; + AddCheck(check); +end; + +function THealthChecksService.GetMetrics : IList; +//var +// healthcheck : IHealthCheck; +begin + {$IFDEF DEBUG_HEALTHCHECKS} + TDebugger.TimeIt(Self,'GetMetrics','Getting HealthChecks Metric'); + {$ENDIF} + Result := fHistory.Last; +// jarr := TJSONArray.Create; +// for healthcheck in fHealthCheckList do +// begin +// var json := TJsonObject.Create; +// json.AddPair('Name',healthcheck.Name); +// json.AddPair('Status',TJsonNumber.Create(Integer(healthcheck.Status))); +// json.AddPair('LastCheck',DateTimeToStr(healthcheck.LastCheck)); +// json.AddPair('Error',healthcheck.ErrorMsg); +// json.AddPair('TimeElapsed',healthcheck.TimeElapsed); +// jarr.AddElement(json); +// end; +// Result := TJsonObject(jarr); +end; + + +function THealthChecksService.OnCheckFail(aHealthFailProc: THealthCheckFailEvent): THealthChecksService; +begin + Result := Self; + fHealthCheckFailEvent := aHealthFailProc; +end; + +{ THealthCheck } + +procedure THealthCheck.Check; +begin + fLastCheck := Now(); +end; + +function THealthCheck.GetCheckEveryMSecs: Int64; +begin + Result := fCheckEveryMSecs; +end; + +constructor THealthCheck.Create(aTimeSpan: TTimeSpan); +begin + fName := ''; + fStatus := THealthStatus.hsNotChecked; + fCheckEveryMSecs := Round(aTimeSpan.TotalMilliseconds); +end; + +function THealthCheck.GetErrorMsg: string; +begin + Result := fErrorMsg; +end; + +function THealthCheck.GetLastCheck: TDateTime; +begin + Result := fLastCheck; +end; + +function THealthCheck.GetLastStatusChange: TDateTime; +begin + Result := fLastStatusChange; +end; + +function THealthCheck.GetName: string; +begin + if not fName.IsEmpty then Result := fName + else Result := Self.ClassName.Substring(1); +end; + +function THealthCheck.GetStatus: THealthStatus; +begin + Result := fStatus; +end; + +function THealthCheck.GetTimeElapsed: string; +begin + Result := fTimeElapsed; +end; + +procedure THealthCheck.SetErrorMsg(const Value: string); +begin + fErrorMsg := Value; +end; + +procedure THealthCheck.SetName(const Value: string); +begin + fName := Value; +end; + +procedure THealthCheck.SetStatus(const Value: THealthStatus); +begin + if fStatus <> Value then fLastStatusChange := Now(); + fStatus := Value; +end; + +procedure THealthCheck.SetTimeElapsed(const Value: string); +begin + fTimeElapsed := Value; +end; + +{ TUrlHealthCheck } + +procedure TUrlHealthCheck.Check; +var + http : THttpClient; + statuscode : Integer; +begin + inherited; + http := THTTPClient.Create; + try + statuscode := http.Get(fUrl).StatusCode; + if (statuscode < 200) or (statuscode > 299) then raise Exception.CreateFmt('Url returned %d StatusCode',[statuscode]); + finally + http.Free; + end; +end; + +constructor TUrlHealthCheck.Create(const aUrl: string; aTimeSpan : TTimeSpan); +begin + inherited Create(aTimeSpan); + fName := 'Url'; + fUrl := aUrl; +end; + +destructor TUrlHealthCheck.Destroy; +begin + + inherited; +end; + +{ THealthCheckOptions } + +constructor THealthCheckOptions.Create; +begin + fLogFails := True; + fRetryTimes := 0; +end; + +{ THealthChecksExtension } + +class function THealthChecksExtension.SetService(aHealthChecksService: THealthChecksService): THealthChecksExtension; +begin + Result := THealthChecksExtension(Self); + fHealthChecksService := aHealthChecksService; +end; + +{ THealthChecksHelper } + +function THealthChecksHelper.Extension: T; +begin + Result := T(THealthChecksExtension.SetService(Self)); +end; + +{ THealthCheckStore } + +function THealthCheckStore.MapMetric(aHealthCheck: IHealthCheck): THealthCheckMetric; +begin + Result := THealthCheckMetric.Create; + Result.Name := aHealthCheck.Name; + Result.Status := aHealthCheck.Status; + Result.LastStatusChange := aHealthCheck.LastStatusChange; + Result.LastCheck := aHealthCheck.LastCheck; + Result.TimeElapsed := aHealthCheck.TimeElapsed; + Result.ErrorMsg := aHealthCheck.ErrorMsg; +end; + +{ TMemoryHealthCheckStore } + +constructor TMemoryHealthCheckStore.Create(aMaxSize: Integer); +begin + fCheckMetrics := TObjectDictionary.Create([doOwnsValues]); +end; + +destructor TMemoryHealthCheckStore.Destroy; +begin + fCheckMetrics.Free; + inherited; +end; + +procedure TMemoryHealthCheckStore.Add(aHealthCheck: IHealthCheck); +var + metrics : THealthCheckMetrics; + metric : THealthCheckMetric; +begin + if not fCheckMetrics.TryGetValue(aHealthCheck.Name,metrics) then + begin + metrics := THealthCheckMetrics.Create(True); + fCheckMetrics.Add(aHealthCheck.Name,metrics) + end; + metric := MapMetric(aHealthCheck); + metrics.Add(metric); +end; + +function TMemoryHealthCheckStore.Last: IList; +var + metrics : THealthCheckMetrics; +begin + Result := TxList.Create; + for metrics in fCheckMetrics.Values do + begin + Result.Add(metrics.Last); + end; +end; + +end. diff --git a/Quick.Core.Mvc.Extensions.HealthChecks.pas b/Quick.Core.Mvc.Extensions.HealthChecks.pas new file mode 100644 index 0000000..504e421 --- /dev/null +++ b/Quick.Core.Mvc.Extensions.HealthChecks.pas @@ -0,0 +1,86 @@ +{ *************************************************************************** + + Copyright (c) 2016-2021 Kike Pérez + + Unit : Quick.Core.Mvc.Extensions.HealthChecks + Description : Core MVC Extensions TaskControl + Author : Kike Pérez + Version : 1.0 + Created : 12/02/2021 + Modified : 21/02/2021 + + This file is part of QuickCore: https://github.com/exilon/QuickCore + + *************************************************************************** + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + *************************************************************************** } + +unit Quick.Core.Mvc.Extensions.HealthChecks; + +{$i QuickCore.inc} + +interface + +uses + System.SysUtils, + Quick.Core.Extensions.HealthChecks, + Quick.Core.MVC, + Quick.HttpServer.Types, + Quick.Core.Mvc.Controller, + Quick.Core.Mvc.ActionResult; + +type + THealthChecksMVCServerExtension = class(TMVCServerExtension) + class function UseHealthChecks : TMVCServer; + end; + + [Route('HealthChecks')] + THealthChecksController = class(THttpController) + private + fHealthChecksService : IHealthChecksService; + public + constructor Create(aHealthCheckService : IHealthChecksService); + published + [HttpGet] + function Health : IActionResult; + end; + +implementation + +{ THealthChecksMVCServerExtension } + +class function THealthChecksMVCServerExtension.UseHealthChecks: TMVCServer; +begin + Result := MVCServer; + if MVCServer.Services.IsRegistered('') then + begin + MVCServer.AddController(THealthChecksController); + end + else raise Exception.Create('HealthChecks dependency not found. Need to be added before!'); +end; + +{ THealthChecksController } + +constructor THealthChecksController.Create(aHealthCheckService : IHealthChecksService); +begin + fHealthChecksService := aHealthCheckService; +end; + +function THealthChecksController.Health: IActionResult; +begin + Result := Json(fHealthChecksService.GetMetrics.ToList); +end; + +end. From 8d0250e1131d601c8aacd5a16594c6d56083b482 Mon Sep 17 00:00:00 2001 From: Exilon Date: Tue, 20 Feb 2024 23:25:39 +0100 Subject: [PATCH 2/5] Updated info --- Delphinus.Info.json | 4 ++-- QuickCore.inc | 9 ++++++++- README.md | 2 +- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/Delphinus.Info.json b/Delphinus.Info.json index 7d7537c..cfee2e8 100644 --- a/Delphinus.Info.json +++ b/Delphinus.Info.json @@ -6,9 +6,9 @@ "license_file": "LICENSE.txt", "platforms": "Win32;Win64;OSX32;Android;IOSDevice32;IOSDevice64;Linux64", "package_compiler_min": 22, - "package_compiler_max": 35, + "package_compiler_max": 36, "compiler_min": 22, - "compiler_max": 35, + "compiler_max": 36, "first_version": "1.0", "report_url": "", "dependencies": diff --git a/QuickCore.inc b/QuickCore.inc index 04af99f..f5f23f2 100644 --- a/QuickCore.inc +++ b/QuickCore.inc @@ -1,7 +1,7 @@ { This file is part of QuickCore: https://github.com/exilon/QuickCore - QuickCore. Copyright (C) 2020 Kike Pérez + QuickCore. Copyright (C) 2024 Kike Pérez Exilon - https://www.exilon.es *************************************************************************** @@ -139,6 +139,13 @@ {$define NEXTGEN} //compatibility with older delphis {$endif} {$ifend} + {$if CompilerVersion >= 36.0} //Delphi RX12 Athens + {$define DELPHIRX12_UP} + {$define DELPHIATHENS_UP} + {$if defined(ANDROID) OR defined(IOS)} + {$define NEXTGEN} //compatibility with older delphis + {$endif} + {$ifend} {$else} //Delphi 5 or older {$define DELPHI6OROLDER} diff --git a/README.md b/README.md index 1f6454d..b2f38f3 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ ![alt text](docs/QuickCore.png "QuickCore") -Delphi Framework (Windows/Linux/Android/MACOSX/IOS) to build high-performance and scalable desktop, mobile and web applications easily. +Delphi Framework (Windows/Linux/Android/MACOSX/IOS) to build high-performance and scalable desktop, mobile and web applications easily. Delphi 10 to 12 Athens supported. **Areas of functionality:** ---------- From 875545bf9603d0e5f38d312061f55a4ec6a201bf Mon Sep 17 00:00:00 2001 From: Exilon Date: Tue, 20 Feb 2024 23:26:03 +0100 Subject: [PATCH 3/5] MessageQueue fixes --- Quick.Core.Extensions.MessageQueue.Redis.pas | 15 ++++++++++----- Quick.Core.MessageQueue.Abstractions.pas | 2 +- Quick.Core.MessageQueue.pas | 6 +++--- 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/Quick.Core.Extensions.MessageQueue.Redis.pas b/Quick.Core.Extensions.MessageQueue.Redis.pas index f3c9c19..5013665 100644 --- a/Quick.Core.Extensions.MessageQueue.Redis.pas +++ b/Quick.Core.Extensions.MessageQueue.Redis.pas @@ -1,13 +1,13 @@ { *************************************************************************** - Copyright (c) 2016-2021 Kike Pérez + Copyright (c) 2016-2023 Kike Pérez Unit : Quick.Core.Extensions.MessageQueue.Redis Description : Core Redis MessageQueue Extension Author : Kike Pérez Version : 1.0 Created : 07/07/2020 - Modified : 18/10/2021 + Modified : 12/06/2023 This file is part of QuickCore: https://github.com/exilon/QuickCore @@ -118,7 +118,7 @@ TRedisMessageQueue = class(TMessageQueue) public constructor Create(aOptions : IOptions; aLogger : ILogger); destructor Destroy; override; - function Push(const aMessage : T) : TMSQWaitResult; override; + function Push(const aMessage : T; aMaxPriority : Boolean) : TMSQWaitResult; override; function Pop(out oMessage : T) : TMSQWaitResult; override; function Remove(const aMessage : T) : Boolean; override; function Remove(const aCurrentMessage, aProcessedMessage : T) : Boolean; override; @@ -299,10 +299,15 @@ procedure TRedisMessageQueue.EnqueueFailedMessages; end; end; -function TRedisMessageQueue.Push(const aMessage: T) : TMSQWaitResult; +function TRedisMessageQueue.Push(const aMessage: T; aMaxPriority : Boolean) : TMSQWaitResult; +var + done : Boolean; begin try - if fPushRedisPool.Get.Item.RedisLPUSH(fOptions.Key,Serialize(aMessage)) then Result := TMSQWaitResult.wrOk + if aMaxPriority then done := fPushRedisPool.Get.Item.RedisRPUSH(fOptions.Key,Serialize(aMessage)) + else done := fPushRedisPool.Get.Item.RedisLPUSH(fOptions.Key,Serialize(aMessage)); + + if done then Result := TMSQWaitResult.wrOk else Result := TMSQWaitResult.wrTimeout; except Result := TMSQWaitResult.wrError; diff --git a/Quick.Core.MessageQueue.Abstractions.pas b/Quick.Core.MessageQueue.Abstractions.pas index 3cb4619..212cf9b 100644 --- a/Quick.Core.MessageQueue.Abstractions.pas +++ b/Quick.Core.MessageQueue.Abstractions.pas @@ -41,7 +41,7 @@ interface IMessageQueue = interface ['{0E859677-5431-4D2E-9E3F-F288AECDA75E}'] - function Push(const aMessage : T) : TMSQWaitResult; + function Push(const aMessage : T; aMaxPriority : Boolean) : TMSQWaitResult; overload; function Pop(out oMessage : T) : TMSQWaitResult; function Remove(const aMessage : T) : Boolean; overload; function Remove(const aCurrentMessage, aProcessedMessage : T) : Boolean; overload; diff --git a/Quick.Core.MessageQueue.pas b/Quick.Core.MessageQueue.pas index 3c86c78..235a85a 100644 --- a/Quick.Core.MessageQueue.pas +++ b/Quick.Core.MessageQueue.pas @@ -1,13 +1,13 @@ { *************************************************************************** - Copyright (c) 2016-2020 Kike Pérez + Copyright (c) 2016-2023 Kike Pérez Unit : Quick.Core.MessageQueue Description : Core MessageQueue Author : Kike Pérez Version : 1.0 Created : 07/07/2020 - Modified : 10/07/2020 + Modified : 12/06/2023 This file is part of QuickCore: https://github.com/exilon/QuickCore @@ -54,7 +54,7 @@ TMessageQueue = class(TInterfacedObject,IMessageQueue< public constructor Create; destructor Destroy; override; - function Push(const aMessage : T) : TMSQWaitResult; virtual; abstract; + function Push(const aMessage : T; aMaxPriority : Boolean) : TMSQWaitResult; virtual; abstract; function Pop(out oMessage : T) : TMSQWaitResult; virtual; abstract; function Remove(const aMessage : T) : Boolean; overload; virtual; abstract; function Remove(const aCurrentMessage, aProcessedMessage : T) : Boolean; overload; virtual; abstract; From ae49e9716a07bdbe4905ef09147c17af3863886e Mon Sep 17 00:00:00 2001 From: Exilon Date: Wed, 21 Feb 2024 00:19:32 +0100 Subject: [PATCH 4/5] Updated readme --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index b2f38f3..8a8d82b 100644 --- a/README.md +++ b/README.md @@ -19,6 +19,10 @@ Delphi Framework (Windows/Linux/Android/MACOSX/IOS) to build high-performance an Please "star" this project in GitHub! It costs nothing but helps to reference the code. ![alt text](docs/githubstartme.jpg "Give it a star") +## Star History + +[![Star History Chart](https://api.star-history.com/svg?repos=exilon/quickcore&type=Date)](https://star-history.com/#exilon/quickcore&Date) + ## Support If you find this project useful, please consider making a donation. From 768b96175862c8d8c2d2a40e240facef8b74e861 Mon Sep 17 00:00:00 2001 From: "Turrican (E. Fuentes)" Date: Fri, 3 Oct 2025 10:31:12 +0200 Subject: [PATCH 5/5] Add support for valid file extensions in StaticFilesMiddleware --- Quick.Core.Mvc.Middleware.StaticFiles.pas | 28 +++++++++++++++++++--- Quick.Core.Mvc.pas | 29 +++++++++++++++++++++++ 2 files changed, 54 insertions(+), 3 deletions(-) diff --git a/Quick.Core.Mvc.Middleware.StaticFiles.pas b/Quick.Core.Mvc.Middleware.StaticFiles.pas index 69166c8..1fc9e77 100644 --- a/Quick.Core.Mvc.Middleware.StaticFiles.pas +++ b/Quick.Core.Mvc.Middleware.StaticFiles.pas @@ -47,25 +47,45 @@ interface type TStaticFilesMiddleware = class(TRequestDelegate) private + fValidExtensions : TStringList; function CanHandleExtension(const aFilename : string) : Boolean; public destructor Destroy; override; + constructor Create; procedure Invoke(aContext : THttpContextBase); override; + procedure AddValidExtension(const aExtension: string); end; implementation { TStaticFilesMiddleware } +procedure TStaticFilesMiddleware.AddValidExtension(const aExtension: string); +begin + fValidExtensions.Add(aExtension); +end; + function TStaticFilesMiddleware.CanHandleExtension(const aFilename: string): Boolean; begin - //check extensionless - Result := not ExtractFileExt(aFilename).IsEmpty; + //check extensionless and valid extensions + + var currentExtension := ExtractFileExt(aFilename); + + var validExtension := not currentExtension.IsEmpty; + + if not fValidExtensions.IsEmpty then validExtension := validExtension and fValidExtensions.Contains(currentExtension); + + Result := validExtension; +end; + +constructor TStaticFilesMiddleware.Create; +begin + fValidExtensions := TStringList.Create; end; destructor TStaticFilesMiddleware.Destroy; begin - + fValidExtensions.Free; inherited; end; @@ -100,4 +120,6 @@ procedure TStaticFilesMiddleware.Invoke(aContext: THttpContextBase); else Next(aContext); end; +initialization + end. diff --git a/Quick.Core.Mvc.pas b/Quick.Core.Mvc.pas index 5a49254..029a126 100644 --- a/Quick.Core.Mvc.pas +++ b/Quick.Core.Mvc.pas @@ -125,6 +125,8 @@ TMVCServer = class(TInterfacedObject,IMVCServer) function UseMiddleware(aCustomMiddleware: TRequestDelegate): TMVCServer; overload; function Use(aDelegateFunction : TRequestDelegateFunc) : TMVCServer; function UseStaticFiles : TMVCServer; + function UseStaticFilesValidExtension(const aExtension: string): TMVCServer; + function UseStaticFilesValidExtensions(const aExtensions: string): TMVCServer; function UseRouting : TMVCServer; function UseAuthentication : TMVCServer; function UseAuthorization : TMVCServer; @@ -485,6 +487,33 @@ function TMVCServer.UseStaticFiles: TMVCServer; fMiddlewares.Add(TStaticFilesMiddleware.Create(nil)); end; +function TMVCServer.UseStaticFilesValidExtension(const aExtension: string): TMVCServer; +begin + Result := Self; + for var middleware in fMiddlewares do + begin + if middleware is TStaticFilesMiddleware then + begin + TStaticFilesMiddleware(middleware).AddValidExtension(aExtension); + end; + end; +end; + +function TMVCServer.UseStaticFilesValidExtensions(const aExtensions: string): TMVCServer; +begin + Result := Self; + for var middleware in fMiddlewares do + begin + if middleware is TStaticFilesMiddleware then + begin + for var extension in aExtensions.Split([',',';',':']) do + begin + TStaticFilesMiddleware(middleware).AddValidExtension(extension); + end; + end; + end; +end; + function TMVCServer.UseWebRoot(const aPath: string): TMVCServer; begin Result := Self;