From 61ec58f9ff5a00fa6234f144593c719ba15eca09 Mon Sep 17 00:00:00 2001
From: Grahame Grieve <grahameg@gmail.ccom>
Date: Tue, 24 Sep 2024 19:18:44 -0400
Subject: [PATCH] more performance / validation time out issues

---
 library/fhir/fhir_tx.pas       | 41 +++++++++++++++++++++-------------
 library/ftx/fhir_valuesets.pas |  3 ++-
 2 files changed, 27 insertions(+), 17 deletions(-)

diff --git a/library/fhir/fhir_tx.pas b/library/fhir/fhir_tx.pas
index aeba98516..b95ea404c 100644
--- a/library/fhir/fhir_tx.pas
+++ b/library/fhir/fhir_tx.pas
@@ -27,12 +27,12 @@   TTerminologyOperationContext = class (TFslObject)
     FContexts : TStringList;
     FLangList : THTTPLanguageList;
     FI18n : TI18nSupport;
-    FDeadTime : Cardinal;
+    FTimeLimit : Cardinal;
     FNotes : TStringList;
     FOwnsNotes : boolean;
     FOnGetCurrentRequestCount: TGetCurrentRequestCountEvent;
   public
-    constructor Create(i18n : TI18nSupport; id : String; langList : THTTPLanguageList; deadTime : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
+    constructor Create(i18n : TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
     destructor Destroy; override;
 
     property reqId : String read FId;
@@ -246,7 +246,7 @@ implementation
 
 { TTerminologyOperationContext }
 
-constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String; langList : THTTPLanguageList; deadTime : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
+constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
 begin
   inherited create;
   FI18n := i18n;
@@ -255,7 +255,7 @@ constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String;
   FContexts := TStringList.create;
   FStartTime := GetTickCount64;
   FOnGetCurrentRequestCount := getRequestCount;
-  FDeadTime := deadTime;
+  FTimeLimit := timeLimit;
   FNotes := TStringList.create;
   FOwnsNotes := true;
 end;
@@ -272,7 +272,7 @@ destructor TTerminologyOperationContext.Destroy;
 
 function TTerminologyOperationContext.copy: TTerminologyOperationContext;
 begin
-  result := TTerminologyOperationContext.create(FI18n.link, FId, FLangList.link, FDeadTime, OnGetCurrentRequestCount);
+  result := TTerminologyOperationContext.create(FI18n.link, FId, FLangList.link, FTimeLimit, OnGetCurrentRequestCount);
   result.FContexts.assign(FContexts);
   result.FStartTime := FStartTime;
   result.FNotes.free;
@@ -282,19 +282,27 @@ function TTerminologyOperationContext.copy: TTerminologyOperationContext;
 
 function TTerminologyOperationContext.deadCheck(var time : integer): boolean;
 var
-  dt : UInt64;
+  timeToDie : UInt64;
   rq : integer;
 begin
-  time := FDeadTime;
-  if UnderDebugger then
-    exit(false);
+  time := FTimeLimit;
+  //if UnderDebugger then
+  //  exit(false);
 
-  // once timelimit is hit, living on borrowed time until request counts build
-  if assigned(OnGetCurrentRequestCount) and (OnGetCurrentRequestCount > 10) then
-    time := time * 5;
-
-  dt := FStartTime + (time * 1000);
-  result := GetTickCount64 > dt;
+  timeToDie := FStartTime + (time * 1000);
+  if (GetTickCount64 > timeToDie) then
+    exit(true)
+  else
+  begin
+    if assigned(OnGetCurrentRequestCount) and (OnGetCurrentRequestCount < 10) then
+    begin
+      // once timelimit is hit, living on borrowed time until request counts build
+      time := time + (time div 2);
+      // but we only give it so much time
+    end;
+    timeToDie := FStartTime + (time * 1000);
+    result := GetTickCount64 > timeToDie;
+  end;
 end;
 
 procedure TTerminologyOperationContext.seeContext(vurl: String);
@@ -322,7 +330,7 @@ procedure TTerminologyOperationContext.addNote(vs : TFHIRValueSetW; note: String
   s : string;
 begin
   s := DescribePeriodMS(GetTickCount64 - FStartTime)+' '+vs.vurl+': '+note;
-  if UnderDebugger then
+  if false and UnderDebugger then
     Logging.log(s);
   FNotes.add(s);
 end;
@@ -542,6 +550,7 @@ procedure TTerminologyWorker.deadCheck(place: String);
   if FOpContext.deadCheck(time) then
   begin
     FOpContext.addNote(vsHandle, 'Operation took too long @ '+place+' ('+className+')');
+    Logging.log('Operation took too long @ '+place+' ('+className+')');
     raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_TIME', FParams.HTTPlanguages, ['??', inttostr(time), opName])));
   end;
 end;
diff --git a/library/ftx/fhir_valuesets.pas b/library/ftx/fhir_valuesets.pas
index 38043aa8b..a7310ca97 100644
--- a/library/ftx/fhir_valuesets.pas
+++ b/library/ftx/fhir_valuesets.pas
@@ -48,7 +48,7 @@ interface
   FHIR_VERSION_CANONICAL_SPLIT_3p = '|';
 
   EXPANSION_DEAD_TIME_SECS = 30;
-  VALIDATION_DEAD_TIME_SECS = 30;
+  VALIDATION_DEAD_TIME_SECS = 60;
 
 
 Type
@@ -2569,6 +2569,7 @@ function TFHIRValueSetExpander.expand(source: TFHIRValueSetW;
 
     if (offset + count < 0) and (FFullList.count > limit) then
     begin
+      Logging.log('Operation took too long @ expand ('+className+')');
       raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_COUNT', FParams.HTTPLanguages, [source.vurl, '>'+inttostr(limit), inttostr(FFullList.count)])));
     end
     else