diff --git a/library/fhir/fhir_objects.pas b/library/fhir/fhir_objects.pas index 43e4ec1cb..dae47d08d 100644 --- a/library/fhir/fhir_objects.pas +++ b/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); diff --git a/library/fhir/fhir_tx.pas b/library/fhir/fhir_tx.pas index bd3e1b7ea..2fc3afe71 100644 --- a/library/fhir/fhir_tx.pas +++ b/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; diff --git a/library/ftx/fhir_valuesets.pas b/library/ftx/fhir_valuesets.pas index 86e0497a8..5cbb5c3fb 100644 --- a/library/ftx/fhir_valuesets.pas +++ b/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'); diff --git a/server/endpoint_storage.pas b/server/endpoint_storage.pas index 7269b69dc..0ac18de11 100644 --- a/server/endpoint_storage.pas +++ b/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;