Skip to content

Commit

Permalink
Merge branch 'HealthIntersections:master' into makelinuxinstallscript
Browse files Browse the repository at this point in the history
  • Loading branch information
@costateixeira
costateixeira authored Sep 7, 2024
2 parents 3f5a154 + b2056d4 commit a49bb2d
Show file tree
Hide file tree
Showing 14 changed files with 313 additions and 89 deletions.
3 changes: 2 additions & 1 deletion .gitignore
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,6 @@ terminology
# files to ignore
tests.ini
exec/fhir.dev.local.cfg
exec/pack/fhirserver.web
server/fhirserver.testing.ini
testcases/v2dict/hl7_94Jul2018.mdb
testcases/snomed/snomed.cache
Expand Down Expand Up @@ -99,3 +98,5 @@ exec/cert/
*.fpc

up_props.sh

server/web/fhirserver.web
Binary file added exec/pack/fhirserver.web
View file
Binary file not shown.
8 changes: 4 additions & 4 deletions install/install-tk.iss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,11 +3,11 @@
; AppID can never be changed as subsequent installations require the same installation ID each time
AppID=FHIRToolkit
AppName=Health Intersections FHIR Toolkit
AppVerName=FHIRToolkit v3.4.10
AppVerName=FHIRToolkit v3.4.11

; compilation control
OutputDir=..\install\build
OutputBaseFilename=fhirtoolkit-win64-3.4.10
OutputBaseFilename=fhirtoolkit-win64-3.4.11
Compression=lzma2/ultra64

; 64 bit
Expand All @@ -32,11 +32,11 @@ UninstallFilesDir={app}\uninstall
; win2000+ add/remove programs support
AppPublisher=Health Intersections P/L
AppPublisherURL=http://www.healthintersections.com.au
AppVersion=3.4.10
AppVersion=3.4.11
AppSupportURL=https://github.com/grahamegrieve/fhirserver
AppUpdatesURL=https://github.com/grahamegrieve/fhirserver
AppCopyright=Copyright (c) Health Intersections Pty Ltd 2020+
VersionInfoVersion=3.4.10.0
VersionInfoVersion=3.4.11.0

; dialog support
LicenseFile=..\license
Expand Down
8 changes: 4 additions & 4 deletions install/install.iss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,11 +3,11 @@
; AppID can never be changed as subsequent installations require the same installation ID each time
AppID=FHIRServer
AppName=Health Intersections FHIR Server
AppVerName=FHIRServer v3.4.10
AppVerName=FHIRServer v3.4.11

; compilation control
OutputDir=..\install\build
OutputBaseFilename=fhirserver-win64-3.4.10
OutputBaseFilename=fhirserver-win64-3.4.11
Compression=lzma2/ultra64

; 64 bit
Expand All @@ -34,11 +34,11 @@ UninstallFilesDir={app}\uninstall
; win2000+ add/remove programs support
AppPublisher=Health Intersections P/L
AppPublisherURL=http://www.healthintersections.com.au
AppVersion=3.4.10
AppVersion=3.4.11
AppSupportURL=https://github.com/grahamegrieve/fhirserver
AppUpdatesURL=https://github.com/grahamegrieve/fhirserver
AppCopyright=Copyright (c) Health Intersections Pty Ltd 2011+
VersionInfoVersion=3.4.10.0
VersionInfoVersion=3.4.11.0

; dialog support
LicenseFile=..\license
Expand Down
6 changes: 3 additions & 3 deletions library/version.inc
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,3 @@
FHIR_CODE_FULL_VERSION = '3.4.10';
FHIR_CODE_RELEASE_DATE = '2024-09-05';
FHIR_CODE_RELEASE_DATETIME = '20240905110448.596Z';
FHIR_CODE_FULL_VERSION = '3.4.11';
FHIR_CODE_RELEASE_DATE = '2024-09-07';
FHIR_CODE_RELEASE_DATETIME = '20240907131149.520Z';
214 changes: 199 additions & 15 deletions server/endpoint_packages.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -77,7 +77,7 @@ TFHIRPackageWebServer = class (TFhirWebServerEndpoint)
FNextScan : TDateTIme;
FScanning: boolean;
FSystemToken : String;
FCrawlerLog : String;
FCrawlerLog : TJsonObject;

procedure setDB(value : TFDBManager);
function status : String;
Expand All @@ -95,7 +95,8 @@ TFHIRPackageWebServer = class (TFhirWebServerEndpoint)
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 serveLog(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo; id : String);
procedure serveLog(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo);
procedure serveBroken(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo; filter : 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);
Expand Down Expand Up @@ -421,7 +422,6 @@ procedure TPackageUpdaterThread.RunUpdater;
try
upd := TPackageUpdater.Create(FZulip.link);
try
upd.CrawlerLog := TFslStringBuilder.create;
upd.OnSendEmail := doSendEmail;
try
upd.update(conn);
Expand All @@ -437,7 +437,7 @@ procedure TPackageUpdaterThread.RunUpdater;
Logging.log('Exception updating packages: '+e.Message);
end;
end;
FEndPoint.FPackageServer.FCrawlerLog := upd.CrawlerLog.AsString;
FEndPoint.FPackageServer.FCrawlerLog := upd.CrawlerLog.Link;
finally
upd.free;
end;
Expand Down Expand Up @@ -811,20 +811,98 @@ procedure TFHIRPackageWebServer.serveProtectForm(request : TIdHTTPRequestInfo; r
end;
end;

procedure TFHIRPackageWebServer.serveLog(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id: String);
function colorForStatus(s : String) : String;
begin
if s = 'error' then
result := 'maroon'
else if s = 'warning' then
result := 'navy'
else
result := 'black'
end;

procedure TFHIRPackageWebServer.serveLog(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo);
var
vars : TFslMap<TFHIRObject>;
html : TFslStringBuilder;
feed, item : TJsonObject;
msgs : TJsonArray;
allOK : boolean;
i : integer;
begin
response.ResponseNo := 200;
response.ResponseText := 'OK';
vars := TFslMap<TFHIRObject>.Create;
try
vars.add('prefix', TFHIRObjectText.Create(AbsoluteUrl(false)));
vars.add('ver', TFHIRObjectText.Create('4.0.1'));
vars.add('log', TFHIRObjectText.Create(FCrawlerLog));
returnFile(request, response, nil, request.Document, 'packages-log.html', false, vars);
finally
vars.free;

if (request.Accept.contains('/html')) then
begin
html := TFslStringBuilder.create;
try
if FCrawlerLog.has('status') then
html.append('<p>The Crawler has not yet completed processing the feeds</p>'#13#10)
else
begin
html.append('<p>Feeds from '+FormatTextToHTML(FCrawlerLog['master'])+' ('+FormatTextToHTML(FCrawlerLog['run-time'])+')</p>'#13#10);
for feed in FCrawlerLog.arr['feeds'].asObjects do
begin
html.append('<p><b>'+FormatTextToHTML(feed['url'])+'</b> ('+FormatTextToHTML(feed['fetch-time'])+')</p>'#13#10);
html.append('<ul>'#13#10);
allOk := true;
for item in feed.arr['items'].asObjects do
begin
if item['status'] = 'Already Processed' then
begin
// nothing
end
else
begin
html.append('<li style="color: Black">'+item['guid']+': ');

if item['status'] = 'Fetched' then
html.append('<span style="color: DarkGreen>')
else
begin
allOK := false;
html.append('<span style="color: Maroon">');
end;
html.append(item['status']+'</span>');
if (item.has('messages')) then
begin
msgs := item.arr['messages'];
if (msgs.Count = 1) then
html.append('. <span style="color: '+colorForStatus(msgs.Obj[0]['type'])+'">'+FormatTextToHTML(msgs.Obj[0]['message'])+'</span>')
else
begin
html.append('<ul>');
for i := 0 to msgs.Count - 1 do
html.append('<li style="color: '+colorForStatus(msgs.Obj[0]['type'])+'">'+FormatTextToHTML(msgs.Obj[0]['message'])+'</li>');
html.append('</ul>'#13#10);
end
end;
html.append('</li>'#13#10);
end;
end;
if (allOK) then
html.append('<li style="color: Black">All OK</li>'#13#10);
html.append('</ul>'#13#10);
end;
end;
vars := TFslMap<TFHIRObject>.Create;
try
vars.add('prefix', TFHIRObjectText.Create(AbsoluteUrl(false)));
vars.add('ver', TFHIRObjectText.Create('4.0.1'));
vars.add('log', TFHIRObjectText.Create(html.ToString));
returnFile(request, response, nil, request.Document, 'packages-log.html', false, vars);
finally
vars.free;
end
finally
html.free;
end;
end
else
begin
response.ContentType := 'application/json';
response.ContentText := TJsonWriterDirect.writeObjectStr(FCrawlerLog, true);
end;
end;

Expand Down Expand Up @@ -930,6 +1008,107 @@ procedure TFHIRPackageWebServer.serveVersions(id, sort : String; secure : boolea
end;
end;

procedure TFHIRPackageWebServer.serveBroken(request : TIdHTTPRequestInfo; response : TIdHTTPResponseInfo; filter : String);
var
conn : TFDBConnection;
json, v, dist: TJsonObject;
src, name, dep, ver : String;
vars : TFslMap<TFHIRObject>;
list : TJsonArray;
html : TFslStringBuilder;
i : integer;
ids : TStringList;
begin
conn := FDB.getConnection('Package.server.broken');
try
// conn.sql := 'select Id || ''#'' || version as Source, Dependency from PackageDependencies, PackageVersions where PackageDependencies.PackageVersionKey = PackageVersions.PackageVersionKey and Dependency not in (select Id || ''#'' || version from PackageVersions) order by Source';
json := TJsonObject.Create;
try
ids := TStringList.create;
try
conn.sql := 'select Id, Version from PackageVersions';
conn.prepare;
conn.Execute;
while conn.FetchNext do
ids.add(conn.ColStringByName['Id']+'#'+ TSemanticVersion.getMajMin(conn.ColStringByName['Version']));
conn.terminate;
ids.sort;
conn.sql := 'select Id || ''#'' || version as Source, Dependency from PackageDependencies, PackageVersions where PackageDependencies.PackageVersionKey = PackageVersions.PackageVersionKey';
conn.prepare;
conn.Execute;
while conn.FetchNext do
begin
if (filter = '') or (conn.ColStringByName['Source'].contains(filter)) then
begin
dep := conn.ColStringByName['Dependency'];
ver := TSemanticVersion.getMajMin(dep.substring(dep.indexOf('#')+1));
if ids.IndexOf(dep.substring(0, dep.indexOf('#')+1)+ver) = -1 then
begin
list := json.forceArr[conn.ColStringByName['Source']];
list.add(conn.ColStringByName['Dependency']);
end;
end;
end;
finally
ids.free;
end;

response.ResponseNo := 200;
response.ResponseText := 'OK';
if (request.Accept.contains('/html')) then
begin
html := TFslStringBuilder.create;
try
html.Append('<table class="grid">'#13#10);
html.Append('<tr><td><b>Source Package</b></td><td><b>Broken Dependencies</b></td></tr>'#13#10);
for name in json.properties.SortedKeys do
begin
list := json.arr[name];
html.Append('<tr><td>'+name+'</td><td>');
for i := 0 to list.Count - 1 do
begin
if i > 0 then
html.append(', ');
html.append(list.Value[i]);
end;
html.append('</td></tr>'#13#10);
end;
html.Append('</table>'#13#10);
vars := TFslMap<TFHIRObject>.Create('vars');
try
vars.add('prefix', TFHIRObjectText.Create(AbsoluteUrl(false)));
vars.add('ver', TFHIRObjectText.Create('4.0.1'));
vars.add('filter', TFHIRObjectText.Create(FormatTextToHTML(filter)));
vars.add('table', TFHIRObjectText.Create(html.ToString));
vars.add('status', TFHIRObjectText.Create(status));
returnFile(request, response, nil, request.Document, 'packages-broken.html', false, vars);
finally
vars.free;
end;
finally
html.free;
end;
end
else
begin
json.str['date'] := FormatDateTime('c', now);
response.ContentType := 'application/json';
response.ContentText := TJsonWriterDirect.writeObjectStr(json, true);
end;
finally
json.free;
end;
conn.terminate;
conn.release;
except
on e : Exception do
begin
conn.error(e);
raise;
end;
end;
end;

function sel(this, that : String) : string;
begin
if (this = that) then
Expand Down Expand Up @@ -1374,7 +1553,11 @@ function TFHIRPackageWebServer.doRequest(AContext: TIdContext; request: TIdHTTPR
end
else if (request.CommandType = hcGET) and (request.Document = '/packages/log') then
begin
serveLog(request, response, pm['id']);
serveLog(request, response);
end
else if (request.CommandType = hcGET) and (request.Document = '/packages/broken') then
begin
serveBroken(request, response, pm['filter']);
end
else if (request.CommandType = hcGET) and (request.Document = '/packages/protect') then
begin
Expand Down Expand Up @@ -1436,7 +1619,8 @@ function TFHIRPackageWebServer.doRequest(AContext: TIdContext; request: TIdHTTPR
constructor TFHIRPackageWebServer.Create(code, path: String; common: TFHIRWebServerCommon);
begin
inherited Create(code, path, common);
FCrawlerLog := 'The Crawler has not yet completed processing the feed';
FCrawlerLog := TJsonObject.create;
FCrawlerLog['status'] := 'No crawl has completed yet';
end;

function TFHIRPackageWebServer.SecureRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; cert: TIdOpenSSLX509; id: String; tt : TTimeTracker): String;
Expand Down
2 changes: 1 addition & 1 deletion server/fhirconsole.lpi
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@
<VersionInfo>
<MajorVersionNr Value="3"/>
<MinorVersionNr Value="4"/>
<RevisionNr Value="10"/>
<RevisionNr Value="11"/>
<Attributes pvaDebug="False"/>
</VersionInfo>
<BuildModes Count="8">
Expand Down
4 changes: 2 additions & 2 deletions server/fhirserver.dproj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -92,7 +92,7 @@
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_MajorVer>3</VerInfo_MajorVer>
<VerInfo_MinorVer>4</VerInfo_MinorVer>
<VerInfo_Release>10</VerInfo_Release>
<VerInfo_Release>11</VerInfo_Release>
<VerInfo_Debug>false</VerInfo_Debug>
</PropertyGroup>
<PropertyGroup Condition="&apos;$(Base_Win32)&apos;!=&apos;&apos;">
Expand Down Expand Up @@ -167,7 +167,7 @@
<DCC_RangeChecking>true</DCC_RangeChecking>
<DCC_DebugDCUs>false</DCC_DebugDCUs>
<VerInfo_MajorVer>3</VerInfo_MajorVer>
<VerInfo_Release>10</VerInfo_Release>
<VerInfo_Release>11</VerInfo_Release>
<AppDPIAwarenessMode>none</AppDPIAwarenessMode>
<VerInfo_MinorVer>4</VerInfo_MinorVer>
<VerInfo_Debug>false</VerInfo_Debug>
Expand Down
2 changes: 1 addition & 1 deletion server/fhirserver.lpi
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@
<UseVersionInfo Value="True"/>
<MajorVersionNr Value="3"/>
<MinorVersionNr Value="4"/>
<RevisionNr Value="10"/>
<RevisionNr Value="11"/>
<Attributes pvaDebug="False"/>
</VersionInfo>
<BuildModes Count="8">
Expand Down
Loading

0 comments on commit a49bb2d

Please sign in to comment.