Skip to content

Commit

Permalink
Add support for usage
Browse files Browse the repository at this point in the history
  • Loading branch information
Grahame Grieve committed Jan 11, 2024
1 parent 050306b commit 6deabf7
Show file tree
Hide file tree
Showing 3 changed files with 58 additions and 27 deletions.
57 changes: 36 additions & 21 deletions server/endpoint_txregistry.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -84,7 +84,7 @@ TFHIRTxRegistryWebServer = class (TFhirWebServerEndpoint)
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 resolve(version, tx, usage : String; var matches : String) : TJsonObject;
function renderInfo : String;

function doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id: String; secure: boolean): String;
Expand Down Expand Up @@ -522,45 +522,61 @@ procedure TFHIRTxRegistryWebServer.populate(json : TJsonObject; srvr : TServerIn
if (ssCert in ver.Security) then json.bool[CODES_TServerSecurity[ssCert]] := true;
end;

function TFHIRTxRegistryWebServer.resolve(version, tx: String): TJsonObject;
function TFHIRTxRegistryWebServer.resolve(version, tx, usage: String; var matches : String): TJsonObject;
var
reg : TServerRegistry;
srvr : TServerInformation;
ver : TServerVersionInformation;
added : boolean;
begin
if (version = '') then
raise EFslException.Create('A version is required');
if (tx = '') then
raise EFslException.Create('A code system url is required');

matches := '';
result := TJsonObject.Create;
try
result.str['formatVersion'] := '1';
result.str['registry-url'] := FInfo.address;
for reg in FInfo.Registries do
for srvr in reg.Servers do
begin
if (srvr.isAuth(tx)) then
added := false;
if (srvr.UsageList.Count = 0) or (srvr.UsageList.IndexOf(usage) > -1) then
begin
for ver in srvr.Versions do
if (srvr.isAuth(tx)) then
begin
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingCodeSystem(tx, ver.Terminologies, false) then
populate(result.forceArr['authoritative'].addObject, srvr, ver);
for ver in srvr.Versions do
begin
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingCodeSystem(tx, ver.Terminologies, false) then
begin
populate(result.forceArr['authoritative'].addObject, srvr, ver);
added := true;
end;
end;
end
else
begin
for ver in srvr.Versions do
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingCodeSystem(tx, ver.Terminologies, false) then
begin
populate(result.forceArr['candidates'].addObject, srvr, ver);
added := true;
end;
end;
end
else
begin
for ver in srvr.Versions do
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingCodeSystem(tx, ver.Terminologies, false) then
populate(result.forceArr['candidates'].addObject, srvr, ver);
if (added) then
CommaAdd(matches, srvr.Code);
end;
end;
result.link;
finally
result.free;
end;
if matches = '' then
matches := '--';
end;

function TFHIRTxRegistryWebServer.renderInfo: String;
Expand All @@ -582,8 +598,8 @@ function TFHIRTxRegistryWebServer.renderInfo: String;
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>')
if (s.AuthList.Count > 0) or (s.UsageList.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)+'. '+s.details+'</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
Expand Down Expand Up @@ -674,9 +690,7 @@ function TFHIRTxRegistryWebServer.PlainRequest(AContext: TIdContext; ip : String
function TFHIRTxRegistryWebServer.doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id : String; secure : boolean) : String;
var
pm : THTTPParameters;
reg, srvr, ver, tx : String;
//s : TArray<String>;
//sId : string;
reg, srvr, ver, tx, desc : String;
json : TJsonObject;
begin
pm := THTTPParameters.Create(request.UnparsedParams);
Expand Down Expand Up @@ -708,12 +722,13 @@ function TFHIRTxRegistryWebServer.doRequest(AContext: TIdContext; request: TIdHT
end
else if request.document = PathWithSlash+'resolve' then
begin
result := 'Resolve '+pm.Value['fhirVersion']+' server for '+pm.Value['url'];
json := resolve(pm.Value['fhirVersion'], pm.Value['url']);
result := 'Resolve '+pm.Value['fhirVersion']+' server for '+pm.Value['url']+' (usage = '+pm.Value['usage']+')';
json := resolve(pm.Value['fhirVersion'], pm.Value['url'], pm.Value['usage'], desc);
try
response.ResponseNo := 200;
response.ContentType := 'application/json';
response.ContentText := TJSONWriter.writeObjectStr(json, true);
result := result+'('+desc+')';
finally
json.free;
end;
Expand Down
26 changes: 20 additions & 6 deletions server/tx_registry_model.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,6 +51,7 @@ TServerInformation = class (TFslObject)
FAddress : String;
FAccessInfo : String;
FAuthlist : TStringList;
FUsageList : TStringList;
FVersions : TFslList<TServerVersionInformation>;
public
constructor Create; override;
Expand All @@ -61,13 +62,14 @@ TServerInformation = class (TFslObject)
property Address : String read FAddress write FAddress;
property AccessInfo : String read FAccessInfo write FAccessInfo;
property AuthList : TStringList read FAuthList;
property UsageList : TStringList read FUsageList;
property Versions : TFslList<TServerVersionInformation> read FVersions;
function version(ver : String) : TServerVersionInformation;
procedure update(source : TServerInformation);

function Details : String;
function isAuth(tx : String) : boolean;
function csAuth : String;
function Description : String;
end;

{ TServerRegistry }
Expand Down Expand Up @@ -618,10 +620,12 @@ constructor TServerInformation.Create;
inherited Create;
FVersions := TFslList<TServerVersionInformation>.Create;
FAuthlist := TStringList.Create;
FUsageList := TStringList.create;
end;

destructor TServerInformation.Destroy;
begin
FUsageList.free;
FAuthlist.free;
FVersions.free;
inherited Destroy;
Expand Down Expand Up @@ -649,6 +653,8 @@ procedure TServerInformation.update(source: TServerInformation);
FName := source.FName;
FAddress := source.FAddress;
FAccessInfo := source.FAccessInfo;
FAuthlist.Assign(source.FAuthlist);
FUsagelist.Assign(source.FUsagelist);
for t in source.Versions do
begin
v := version(t.Version);
Expand All @@ -674,14 +680,22 @@ function TServerInformation.isAuth(tx: String): boolean;
exit(true);
end;

function TServerInformation.csAuth: String;
function TServerInformation.description: String;
var
s : String;
begin
result := '<ul>';
for s in FAuthlist do
result := result + '<li>'+FormatTextToHtml(s)+'</li>';
result := result + '</ul>';
result := '';
if (FusageList.count > 0) then
result := 'Usage Tags: '+FUsageList.CommaText;
if (FAuthList.count > 0) then
begin
if (result <> '') then
result := result+'. ';
result := result + 'Authoritative for: <ul>';
for s in FAuthlist do
result := result + '<li>'+FormatTextToHtml(s)+'</li>';
result := result + '</ul>';
end;
end;

{ TServerVersionInformation }
Expand Down
2 changes: 2 additions & 0 deletions server/tx_registry_spider.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -296,6 +296,8 @@ procedure TTxRegistryScanner.processServer(source : String; obj: TJsonObject; sr
raise EFslException.Create('No url provided for '+srvr.Name);
obj.forceArr['authoritative'].readStrings(srvr.AuthList);
srvr.AuthList.sort;
obj.forceArr['usage'].readStrings(srvr.UsageList);
srvr.UsageList.sort;

arr := obj.arr['fhirVersions'];
for i := 0 to arr.Count - 1 do
Expand Down

0 comments on commit 6deabf7

Please sign in to comment.