Improve handling of too-costly operations

library/fhir/fhir_objects.pas

@@ -162,7 +162,13 @@ EFHIRException = class (EFslException)
  Constructor Create(place : String);
  End;
 
- ETooCostly = class (EFHIRException);
+ ETooCostly = class (EFHIRException)
+ private
+ FDiagnostics : String;
+ public
+ property Diagnostics : String read FDiagnostics write FDiagnostics;
+ end;
+
  EFinished = class (EFHIRException);
  EUnsafeOperation = class (EFHIRException);
  EDefinitionException = class (EFHIRException);

library/fhir/fhir_tx.pas

@@ -214,7 +214,9 @@ TTerminologyWorker = class (TFslObject)
  FParams : TFHIRTxOperationParams;
  FRequiredSupplements : TStringList;
 
+ function costDiags(e : ETooCostly) : ETooCostly;
  function sizeInBytesV(magic : integer) : cardinal; override;
+ function vsHandle : TFHIRValueSetW; virtual; abstract;
  procedure deadCheck(place : String); virtual;
  function findInAdditionalResources(url, version, resourceType : String; error : boolean) : TFHIRMetadataResourceW;
  function findCodeSystem(url, version : String; params : TFHIRTxOperationParams; kinds : TFhirCodeSystemContentModeSet; nullOk : boolean) : TCodeSystemProvider;
@@ -318,7 +320,7 @@ procedure TTerminologyOperationContext.addNote(vs : TFHIRValueSetW; note: String
 var
  s : string;
 begin
- s := vs.vurl+': '+note;
+ s := DescribePeriodMS(GetTickCount64 - FStartTime)+' '+vs.vurl+': '+note;
  Logging.log(s);
  FNotes.add(s);
 end;
@@ -511,6 +513,12 @@ function TTerminologyWorker.findCodeSystem(url, version: String; params: TFHIRTx
  end;
 end;
 
+function TTerminologyWorker.costDiags(e: ETooCostly): ETooCostly;
+begin
+ e.diagnostics := FOpContext.notes;
+ result := e;
+end;
+
 function TTerminologyWorker.sizeInBytesV(magic : integer) : cardinal;
 begin
  result := inherited sizeInBytesV(magic);
@@ -526,8 +534,8 @@ procedure TTerminologyWorker.deadCheck(place: String);
  SetThreadStatus(ClassName+'.'+place);
  if FOpContext.deadCheck(time) then
  begin
- logging.log('Operation took too long ('+className+')');
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_TIME', FParams.HTTPlanguages, ['??', inttostr(time)]));
+ FOpContext.addNote(vsHandle, 'Operation took too long @ '+place+' ('+className+')');
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_TIME', FParams.HTTPlanguages, ['??', inttostr(time)])));
  end;
 end;
 

library/ftx/fhir_valuesets.pas

@@ -100,6 +100,7 @@ TValueSetWorker = class (TTerminologyWorker)
  FAllAltCodes : TAlternateCodeOptions;
 
  procedure seeValueSet(vs : TFHIRValueSetW);
+ function vsHandle : TFHIRValueSetW; override;
 
  function sizeInBytesV(magic : integer) : cardinal; override;
  procedure listDisplays(displays : TConceptDesignations; cs : TCodeSystemProvider; c: TCodeSystemProviderContext); overload;
@@ -315,6 +316,11 @@ procedure TValueSetWorker.seeValueSet(vs: TFHIRValueSetW);
  FParams.HTTPLanguages := THTTPLanguageList.create(vs.language, not isValidating);
 end;
 
+function TValueSetWorker.vsHandle: TFHIRValueSetW;
+begin
+ result := FValueSet;
+end;
+
 function TValueSetWorker.findValueSet(url, version: String): TFHIRValueSetW;
 var
  r : TFHIRMetadataResourceW;
@@ -2548,7 +2554,7 @@ function TFHIRValueSetExpander.expand(source: TFHIRValueSetW;
 
  if (offset + count < 0) and (FFullList.count > limit) then
  begin
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_COUNT', FParams.HTTPLanguages, [source.vurl, '>'+inttostr(limit), inttostr(FFullList.count)]));
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_COUNT', FParams.HTTPLanguages, [source.vurl, '>'+inttostr(limit), inttostr(FFullList.count)])));
  end
  else
  begin
@@ -2834,7 +2840,7 @@ procedure TValueSetWorker.deadCheck(place: String);
  {$ELSE}
  logging.log('Expansion took too long');
  {$ENDIF}
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_TIME', FParams.HTTPLanguages, [FValueSet.vurl, inttostr(time)]));
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_TIME', FParams.HTTPLanguages, [FValueSet.vurl, inttostr(time)])));
  end;
 end;
 
@@ -3013,7 +3019,7 @@ function TFHIRValueSetExpander.includeCode(cs : TCodeSystemProvider; parent : TF
  begin
  if (srcUrl = '') then
  srcUrl := '??';
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [srcUrl, '>'+inttostr(FLimitCount)]));
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [srcUrl, '>'+inttostr(FLimitCount)])));
  end;
  end;
 
@@ -3211,7 +3217,7 @@ procedure TFHIRValueSetExpander.excludeCode(cs : TCodeSystemProvider; system, ve
  begin
  if (srcUrl = '') then
  srcUrl := '??';
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [srcUrl, '>'+inttostr(FLimitCount)]));
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [srcUrl, '>'+inttostr(FLimitCount)])));
  end;
  end;
 
@@ -3377,12 +3383,12 @@ procedure TFHIRValueSetExpander.checkSource(cset: TFhirValueSetComposeIncludeW;
  begin
  if cs.isNotClosed(filter) then
  if cs.SpecialEnumeration <> '' then
- raise ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly. If an incomplete expansion is requested, a limited enumeration will be returned')
+ raise costDiags(ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly. If an incomplete expansion is requested, a limited enumeration will be returned'))
  else
- raise ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly');
+ raise costDiags(ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly'));
 
  if not imp and (FLimitCount > 0) and (cs.TotalCount > FLimitCount) and not (FParams.limitedExpansion) then
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [srcUrl, '>'+inttostr(FLimitCount)]));
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [srcUrl, '>'+inttostr(FLimitCount)])));
  end
  end;
 
@@ -3524,14 +3530,14 @@ procedure TFHIRValueSetExpander.includeCodes(cset: TFhirValueSetComposeIncludeW;
  begin
  if cs.isNotClosed(filter) then
  if cs.SpecialEnumeration <> '' then
- raise ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly. If an incomplete expansion is requested, a limited enumeration will be returned')
+ raise costDiags(ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly. If an incomplete expansion is requested, a limited enumeration will be returned'))
  else
- raise ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly');
+ raise costDiags(ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly'));
 
  iter := cs.getIterator(nil);
  try
  if valueSets.Empty and (FLimitCount > 0) and (iter.count > FLimitCount) and not (FParams.limitedExpansion) then
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [vsSrc.url, '>'+inttostr(FLimitCount)]));
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [vsSrc.url, '>'+inttostr(FLimitCount)])));
  tcount := 0;
  while iter.more do
  begin 
@@ -3846,14 +3852,14 @@ procedure TFHIRValueSetExpander.excludeCodes(cset: TFhirValueSetComposeIncludeW;
  begin
  if cs.isNotClosed(filter) then
  if cs.SpecialEnumeration <> '' then
- raise ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly. If an incomplete expansion is requested, a limited enumeration will be returned')
+ raise costDiags(ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly. If an incomplete expansion is requested, a limited enumeration will be returned'))
  else
- raise ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly');
+ raise costDiags(ETooCostly.create('The code System "'+cs.systemUri+'" has a grammar, and cannot be enumerated directly'));
 
  iter := cs.getIterator(nil);
  try
  if valueSets.Empty and (FLimitCount > 0) and (iter.count > FLimitCount) and not (FParams.limitedExpansion) then
- raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [vsSrc.url, '>'+inttostr(FLimitCount)]));
+ raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.HTTPLanguages, [vsSrc.url, '>'+inttostr(FLimitCount)])));
  while iter.more do
  begin
  deadCheck('processCodes#3a');

server/endpoint_storage.pas

@@ -170,7 +170,7 @@ TStorageWebEndpoint = class (TFhirWebServerEndpoint)
  sCookie, provenance, sBearer: String; oPostStream: TStream; oResponse: TFHIRResponse; var aFormat: TFHIRFormat; var redirect: boolean; form: TMimeMessage;
  bAuth, secure: boolean; out relativeReferenceAdjustment: integer; var style : TFHIROutputStyle; Session: TFHIRSession; cert: TIdOpenSSLX509; tt : TTimeTracker): TFHIRRequest;
  Procedure ProcessOutput(start : UInt64; oRequest: TFHIRRequest; oResponse: TFHIRResponse; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; relativeReferenceAdjustment: integer; style : TFHIROutputStyle; gzip, cache: boolean; summary : String);
- procedure SendError(response: TIdHTTPResponseInfo; logid : string; status: word; format: TFHIRFormat; langList : THTTPLanguageList; message, url: String; e: exception; Session: TFHIRSession; addLogins: boolean; path: String; relativeReferenceAdjustment: integer; code: TFHIRIssueType);
+ procedure SendError(response: TIdHTTPResponseInfo; logid : string; status: word; format: TFHIRFormat; langList : THTTPLanguageList; message, url: String; e: exception; Session: TFHIRSession; addLogins: boolean; path: String; relativeReferenceAdjustment: integer; code: TFHIRIssueType; diagnostics : String = '');
  function processProvenanceHeader(header : String; langList : THTTPLanguageList): TFhirProvenanceW;
  function EncodeVersionsJson(r: TFHIRResourceV): TBytes;
  function EncodeVersionsXml(r: TFHIRResourceV): TBytes;
@@ -1562,10 +1562,10 @@ function TStorageWebEndpoint.HandleRequest(AContext: TIdContext; request: TIdHTT
  begin
  result := result + ' (msg: Too-Costly)';
  if noErrCode then
- SendError(response, logId, 200, aFormat, langList, e.message, sPath, e, Session, false, path, relativeReferenceAdjustment, itTooCostly)
+ SendError(response, logId, 200, aFormat, langList, e.message, sPath, e, Session, false, path, relativeReferenceAdjustment, itTooCostly, e.Diagnostics)
  else
  SendError(response, logId, HTTP_ERR_BUSINESS_RULES_FAILED, aFormat, langList, e.message, sPath, e, Session, false, path, relativeReferenceAdjustment,
- itTooCostly);
+ itTooCostly, e.Diagnostics);
  end;
  on e: ERestfulException do
  begin
@@ -2241,7 +2241,7 @@ procedure TStorageWebEndpoint.ProcessOutput(start: UInt64;
 end;
 
 procedure TStorageWebEndpoint.SendError(response: TIdHTTPResponseInfo; logid: string; status: word; format: TFHIRFormat; langList : THTTPLanguageList;
- message, url: String; e: exception; Session: TFHIRSession; addLogins: boolean; path: String; relativeReferenceAdjustment: integer; code: TFHIRIssueType);
+ message, url: String; e: exception; Session: TFHIRSession; addLogins: boolean; path: String; relativeReferenceAdjustment: integer; code: TFHIRIssueType; diagnostics : String);
 var
  issue: TFhirOperationOutcomeW;
  oComp: TFHIRComposer;