diff --git a/server/endpoint_txregistry.pas b/server/endpoint_txregistry.pas index 36896bae4..af6ef5670 100644 --- a/server/endpoint_txregistry.pas +++ b/server/endpoint_txregistry.pas @@ -78,21 +78,6 @@ TFHIRTxRegistryWebServer = class (TFhirWebServerEndpoint) procedure populate(json: TJsonObject; srvr: TServerInformation; ver: TServerVersionInformation); function status : String; - //function getVersion(v : String) : String; - //function interpretVersion(v : String) : String; - // - //function genTable(url : String; list: TFslList; sort : TMatchTableSort; rev, inSearch, secure, packageLevel: boolean): String; - // - //function serveCreatePackage(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo) : String; - // - //procedure servePage(fn : String; request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo; secure : boolean); - //procedure serveDownload(id, version : String; response : TIdHTTPResponseInfo); - //procedure serveVersions(id, sort : String; secure : boolean; request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo); - //procedure serveSearch(name, canonicalPkg, canonicalUrl, FHIRVersion, dependency, sort : String; secure : boolean; request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo); - //procedure serveUpdates(date : TFslDateTime; secure : boolean; response : TIdHTTPResponseInfo); - //procedure serveProtectForm(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo; id : String); - //procedure serveUpload(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo; secure : boolean; id : String); - //procedure processProtectForm(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo; id, pword : String); procedure SetScanning(const Value: boolean); procedure sortJson(json : TJsonObject; sort : String); @@ -100,6 +85,7 @@ TFHIRTxRegistryWebServer = class (TFhirWebServerEndpoint) procedure sendHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; json : TJsonObject; reg, srvr, ver, tx : String); function listRows(reg, srvr, ver, tx : String) : TJsonObject; function resolve(version, tx : String) : TJsonObject; + function renderInfo : String; function doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id: String; secure: boolean): String; public @@ -489,6 +475,8 @@ procedure TFHIRTxRegistryWebServer.sendHtml(request: TIdHTTPRequestInfo; respons vars.add('fhirVersion', TFHIRObjectText.Create(ver)); vars.add('url', TFHIRObjectText.Create(tx)); vars.add('status', TFHIRObjectText.Create(status)); + vars.add('tx-reg-doco', TFHIRObjectText.Create(FInfo.doco)); + vars.add('tx-reg-view', TFHIRObjectText.Create(renderInfo)); returnFile(request, response, nil, request.Document, 'tx-registry.html', false, vars); finally vars.free; @@ -569,6 +557,40 @@ function TFHIRTxRegistryWebServer.resolve(version, tx: String): TJsonObject; end; end; +function TFHIRTxRegistryWebServer.renderInfo: String; +var + b : TFslStringBuilder; + r : TServerRegistry; + s : TServerInformation; + v : TServerVersionInformation; +begin + b := TFslStringBuilder.create(); + try + b.Append(''); + b.append(''); + for r in FInfo.Registries do + begin + if (r.error <> '') then + b.append('') + else + b.append(''); + for s in r.Servers do + begin + if (s.AuthList.Count > 0) then + b.append('') + else + b.append(''); + for v in s.Versions do + b.append(''); + end; + end; + b.Append('
 Registries'+FInfo.Address+' ('+FormatTextToHTML(FInfo.Outcome)+')
  '+r.Code+''+FormatTextToHTML(r.Address)+'. Error: '+FormatTextToHTML(r.Error)+'
   '+r.Code+''+FormatTextToHTML(r.Address)+'
     '+s.Code+''+FormatTextToHTML(s.Address)+'. Authoritative for:'+s.csAuth+'
     '+s.Code+''+FormatTextToHTML(s.Address)+'
       v'+TSemanticVersion.getMajMin(v.Version)+''+FormatTextToHTML(v.Address)+'. Status: '+FormatTextToHTML(v.Details)+'. '+inttostr(v.Terminologies.Count)+' Items
'); + result := b.ToString; + finally + b.free; + end; +end; + function TFHIRTxRegistryWebServer.status: String; begin if FScanning then diff --git a/server/tx_registry_model.pas b/server/tx_registry_model.pas index 1569a01e7..5fa9b712a 100644 --- a/server/tx_registry_model.pas +++ b/server/tx_registry_model.pas @@ -37,6 +37,9 @@ TServerVersionInformation = class (TFslObject) property LastSuccess : TFslDateTime read FLastSuccess write FLastSuccess; property Terminologies : TStringList read FTerminologies; procedure update(source : TServerVersionInformation); + + function Details : String; + function cslist : String; end; { TServerInformation } @@ -62,7 +65,9 @@ TServerInformation = class (TFslObject) function version(ver : String) : TServerVersionInformation; procedure update(source : TServerInformation); - function isAuth(tx : String) : boolean; + function Details : String; + function isAuth(tx : String) : boolean; + function csAuth : String; end; { TServerRegistry } @@ -95,6 +100,7 @@ TServerRegistry = class (TFslObject) TServerRegistries = class (TFslObject) private FAddress : String; + FDoco: String; FLastRun : TFslDateTime; FOutcome : String; FRegistries: TFslList; @@ -103,6 +109,7 @@ TServerRegistries = class (TFslObject) destructor Destroy; override; function Link : TServerRegistries; overload; property Address : String read FAddress write FAddress; + property doco : String read FDoco write FDoco; property LastRun : TFslDateTime read FLastRun write FLastRun; property Outcome : String read FOutcome write FOutcome; property Registries : TFslList read FRegistries; @@ -362,13 +369,30 @@ class procedure TServerRegistryUtilities.addRow(rows: TFslList; reg: end; end; +function hasMatchingCodeSystem(cs : String; list : TStringList) : boolean; +var + s, r : String; +begin + r := cs; + if r.contains('|') then + r := r.subString(0, r.indexOf('|')); + result := false; + for s in list do + begin + if (s = cs) or (r = cs) then + exit(true); + end; +end; + class procedure TServerRegistryUtilities.buildRows(reg: TServerRegistry; srvr: TServerInformation; version, tx: String; rows: TFslList); var ver : TServerVersionInformation; + auth : boolean; begin + auth := hasMatchingCodeSystem(tx, srvr.AuthList); for ver in srvr.Versions do if (version = '') or (TSemanticVersion.matches(version, ver.version, semverAuto)) then - if (tx = '') or (ver.Terminologies.IndexOf(tx) > -1) then + if auth or (tx = '') or hasMatchingCodeSystem(tx, ver.Terminologies) then addRow(rows, reg, srvr, ver); end; @@ -510,6 +534,7 @@ procedure TServerRegistries.update(source: TServerRegistries); begin FLastRun := source.FLastRun; FOutcome := source.FOutcome; + FDoco := source.doco; for t in source.Registries do begin sr := registry(t.Name); @@ -615,6 +640,11 @@ procedure TServerInformation.update(source: TServerInformation); end; end; +function TServerInformation.Details: String; +begin + result := FAccessInfo; +end; + function passesMask(mask, tx : string) : Boolean; begin if mask.EndsWith('*') then @@ -633,6 +663,16 @@ function TServerInformation.isAuth(tx: String): boolean; exit(true); end; +function TServerInformation.csAuth: String; +var + s : String; +begin + result := '
    '; + for s in FAuthlist do + result := result + '
  • '+FormatTextToHtml(s)+'
    • '; + result := result + '
'; +end; + { TServerVersionInformation } constructor TServerVersionInformation.Create; @@ -664,6 +704,25 @@ procedure TServerVersionInformation.update(source: TServerVersionInformation); end; end; +function TServerVersionInformation.Details: String; +begin + if FError = '' then + result := 'All Ok' + else + result := FError; + result := result + ' (last seen '+LastSuccess.toXML()+')'; +end; + +function TServerVersionInformation.cslist: String; +var + s : String; +begin + result := '
    '; + for s in FTerminologies do + result := result + '
  • '+FormatTextToHtml(s)+'
    • '; + result := result + '
'; +end; + end. diff --git a/server/tx_registry_spider.pas b/server/tx_registry_spider.pas index 0ded18b3e..eaaebe999 100644 --- a/server/tx_registry_spider.pas +++ b/server/tx_registry_spider.pas @@ -194,6 +194,8 @@ procedure TTxRegistryScanner.update(name : String; info : TServerRegistries); if s <> '1' then raise EFslException.Create('Unable to proceed: registries version is '+json.str['formatVersion']+' not "1"'); + info.doco := json.str['documentation']; + info.Address := FAddress; arr := json.arr['registries']; for i := 0 to arr.Count - 1 do begin @@ -293,6 +295,7 @@ procedure TTxRegistryScanner.processServer(source : String; obj: TJsonObject; sr if (srvr.Address = '') then raise EFslException.Create('No url provided for '+srvr.Name); obj.forceArr['authoritative'].readStrings(srvr.AuthList); + srvr.AuthList.sort; arr := obj.arr['fhirVersions']; for i := 0 to arr.Count - 1 do @@ -323,6 +326,7 @@ procedure TTxRegistryScanner.processServerVersion(source: String; srvr: TServerI else log('Exception processing server: '+srvr.Name+'@'+srvr.address+' : Version '+obj.str['version']+' not supported', source, false); end; + ver.Terminologies.sort; ver.LastSuccess := TFslDateTime.makeUTC; except on e : Exception do @@ -340,48 +344,53 @@ procedure TTxRegistryScanner.processServerVersionR4(version, source, url : Strin tcs : fhir4_resources_canonical.TFhirTerminologyCapabilitiesCodeSystem; tcsv : fhir4_resources_canonical.TFhirTerminologyCapabilitiesCodeSystemVersion; begin - client := TFhirClient4.Create(nil, nil, TFHIRHTTPCommunicator.Create(url)); try - client.format := ffJson; - cs := client.conformance(true); + client := TFhirClient4.Create(nil, nil, TFHIRHTTPCommunicator.Create(url)); try - ver.Version := cs.fhirVersionElement.ToString; - for csr in cs.restList do - if (csr.mode = fhir4_types.RestfulCapabilityModeServer) then + client.format := ffJson; + cs := client.conformance(true); + try + ver.Version := cs.fhirVersionElement.ToString; + for csr in cs.restList do + if (csr.mode = fhir4_types.RestfulCapabilityModeServer) then + begin + if csr.security <> nil then + for cc in csr.security.serviceList do + begin + if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'OAuth')) then + ver.Security := ver.Security + [ssOAuth] + else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'SMART-on-FHIR')) then + ver.Security := ver.Security + [ssSmart] + else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Basic')) then + ver.Security := ver.Security + [ssPassword] + else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Certificates')) then + ver.Security := ver.Security + [ssCert] + else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Token')) then + ver.Security := ver.Security + [ssToken] + else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Open')) then + ver.Security := ver.Security + [ssOpen]; + end; + end; + finally + cs.free; + end; + tc := client. terminologyCaps; + try + for tcs in tc.codeSystemList do begin - if csr.security <> nil then - for cc in csr.security.serviceList do - begin - if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'OAuth')) then - ver.Security := ver.Security + [ssOAuth] - else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'SMART-on-FHIR')) then - ver.Security := ver.Security + [ssSmart] - else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Basic')) then - ver.Security := ver.Security + [ssPassword] - else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Certificates')) then - ver.Security := ver.Security + [ssCert] - else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Token')) then - ver.Security := ver.Security + [ssToken] - else if (cc.hasCode('http://hl7.org/fhir/restful-security-service', 'Open')) then - ver.Security := ver.Security + [ssOpen]; - end; + ver.Terminologies.add(tcs.uri); + for tcsv in tcs.versionList do + ver.Terminologies.add(tcs.uri+'|'+tcsv.code); end; - finally - cs.free; - end; - tc := client. terminologyCaps; - try - for tcs in tc.codeSystemList do - begin - ver.Terminologies.add(tcs.uri); - for tcsv in tcs.versionList do - ver.Terminologies.add(tcs.uri+'|'+tcsv.code); + finally + tc.free; end; finally - tc.free; + client.free; end; - finally - client.free; + except + on e : Exception do + raise EFslException.create('Error getting server details from "'+url+': '+e.message); end; end; diff --git a/server/web/assets/images/tx-registry-root.gif b/server/web/assets/images/tx-registry-root.gif new file mode 100755 index 000000000..c6cadf3bb Binary files /dev/null and b/server/web/assets/images/tx-registry-root.gif differ diff --git a/server/web/assets/images/tx-registry.png b/server/web/assets/images/tx-registry.png new file mode 100755 index 000000000..da3c2a2d7 Binary files /dev/null and b/server/web/assets/images/tx-registry.png differ diff --git a/server/web/assets/images/tx-server.png b/server/web/assets/images/tx-server.png new file mode 100755 index 000000000..720a237c7 Binary files /dev/null and b/server/web/assets/images/tx-server.png differ diff --git a/server/web/assets/images/tx-version.png b/server/web/assets/images/tx-version.png new file mode 100755 index 000000000..b88c85789 Binary files /dev/null and b/server/web/assets/images/tx-version.png differ diff --git a/server/web/tx-registry.html b/server/web/tx-registry.html index deeb127d5..aef7fdcf5 100644 --- a/server/web/tx-registry.html +++ b/server/web/tx-registry.html @@ -97,12 +97,17 @@

FHIR Tx Server Registry

-[%count%] Servers found. Status = [%status%]. Package History last 30 days +[%count%] matching Servers found. Status = [%status%]. Package History last 30 days

-How to add tx servers to this registry: to do +Registry View:

+[%tx-reg-view%] +

+How to add tx servers to this registry: [%tx-reg-doco%] +

+