Skip to content

Commit

Permalink
tx-registry-fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
Grahame Grieve committed Jan 11, 2024
1 parent 5dd19ae commit fbdce62
Show file tree
Hide file tree
Showing 8 changed files with 149 additions and 54 deletions.
52 changes: 37 additions & 15 deletions server/endpoint_txregistry.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -78,28 +78,14 @@ 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<TJsonObject>; 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);
function renderJson(json : TJsonObject; path, reg, srvr, ver : String) : String;
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
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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('<table class="grid">');
b.append('<tr><td width="130px"><img src="/assets/images/tx-registry-root.gif">&nbsp;Registries</td><td>'+FInfo.Address+' ('+FormatTextToHTML(FInfo.Outcome)+')</td></tr>');
for r in FInfo.Registries do
begin
if (r.error <> '') then
b.append('<tr><td title='+FormatTextToHTML(r.Name)+'">&nbsp;<img src="/assets/images/tx-registry.png">&nbsp;'+r.Code+'</td><td>'+FormatTextToHTML(r.Address)+'. Error: '+FormatTextToHTML(r.Error)+'</td></tr>')
else
b.append('<tr><td title='+FormatTextToHTML(r.Name)+'">&nbsp;&nbsp;<img src="/assets/images/tx-registry.png">&nbsp;'+r.Code+'</td><td>'+FormatTextToHTML(r.Address)+'</td></tr>');
for s in r.Servers do
begin
if (s.AuthList.Count > 0) then
b.append('<tr><td title='+FormatTextToHTML(s.Name)+'">&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-server.png">&nbsp;'+s.Code+'</td><td>'+FormatTextToHTML(s.Address)+'. Authoritative for:'+s.csAuth+'</td></tr>')
else
b.append('<tr><td title='+FormatTextToHTML(s.Name)+'">&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-server.png">&nbsp;'+s.Code+'</td><td>'+FormatTextToHTML(s.Address)+'</td></tr>');
for v in s.Versions do
b.append('<tr><td>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-version.png">&nbsp;v'+TSemanticVersion.getMajMin(v.Version)+'</td><td>'+FormatTextToHTML(v.Address)+'. Status: '+FormatTextToHTML(v.Details)+'. '+inttostr(v.Terminologies.Count)+' Items</td></tr>');
end;
end;
b.Append('</table>');
result := b.ToString;
finally
b.free;
end;
end;

function TFHIRTxRegistryWebServer.status: String;
begin
if FScanning then
Expand Down
63 changes: 61 additions & 2 deletions server/tx_registry_model.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 }
Expand All @@ -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 }
Expand Down Expand Up @@ -95,6 +100,7 @@ TServerRegistry = class (TFslObject)
TServerRegistries = class (TFslObject)
private
FAddress : String;
FDoco: String;
FLastRun : TFslDateTime;
FOutcome : String;
FRegistries: TFslList<TServerRegistry>;
Expand All @@ -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<TServerRegistry> read FRegistries;
Expand Down Expand Up @@ -362,13 +369,30 @@ class procedure TServerRegistryUtilities.addRow(rows: TFslList<TServerRow>; 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<TServerRow>);
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;

Expand Down Expand Up @@ -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);
Expand Down Expand Up @@ -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
Expand All @@ -633,6 +663,16 @@ function TServerInformation.isAuth(tx: String): boolean;
exit(true);
end;

function TServerInformation.csAuth: String;
var
s : String;
begin
result := '<ul>';
for s in FAuthlist do
result := result + '<li>'+FormatTextToHtml(s)+'</li>';
result := result + '</ul>';
end;

{ TServerVersionInformation }

constructor TServerVersionInformation.Create;
Expand Down Expand Up @@ -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 := '<ul>';
for s in FTerminologies do
result := result + '<li>'+FormatTextToHtml(s)+'</li>';
result := result + '</ul>';
end;


end.

79 changes: 44 additions & 35 deletions server/tx_registry_spider.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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;

Expand Down
Binary file added server/web/assets/images/tx-registry-root.gif
View file
Loading
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
Binary file added server/web/assets/images/tx-registry.png
View file
Loading
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
Binary file added server/web/assets/images/tx-server.png
View file
Loading
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
Binary file added server/web/assets/images/tx-version.png
View file
Loading
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
9 changes: 7 additions & 2 deletions server/web/tx-registry.html
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,12 +97,17 @@ <h3>FHIR Tx Server Registry</h3>

<hr/>
<p>
[%count%] Servers found. Status = [%status%]. <a href="[%prefix%]/catalog?lastUpdated=-30">Package History last 30 days</a>
[%count%] matching Servers found. Status = [%status%]. <a href="[%prefix%]/catalog?lastUpdated=-30">Package History last 30 days</a>
</p>

<p>
How to add tx servers to this registry: <i>to do</i>
Registry View:
</p>
[%tx-reg-view%]
<p>
How to add tx servers to this registry: <i>[%tx-reg-doco%]</i>
</p>


</div>

Expand Down

0 comments on commit fbdce62

Please sign in to comment.