Skip to content

Commit 60e2fb8

Browse files
author
Grahame Grieve
committed
Upgrade SHL server to support VHL
1 parent b4bc2fa commit 60e2fb8

2 files changed

Lines changed: 163 additions & 37 deletions

File tree

‎library/web/fsl_crypto.pas‎

Lines changed: 61 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -284,13 +284,14 @@ TJWTUtils = class (TFslObject)
284284
class function loadRSAPublicKey(contents : TBytes) : PRSA; overload;
285285
class function loadDSAPublicKey(pemfile, pempassword : AnsiString) : PDSA;
286286

287-
class function Sign_Hmac_SHA256(input : TBytes; key: TJWK) : TBytes;
288-
class function Sign_Hmac_RSA256(input : TBytes; key: TJWK) : TBytes; overload;
289-
class function Sign_ES256(input : TBytes; key: TJWK) : TBytes; overload;
290287
class function checks(method: TJWTAlgorithm; key : TJWK): String;
291288

292289
public
293290
class function Sign_Hmac_RSA256(input : TBytes; pemfile, pempassword : String) : TBytes; overload;
291+
class function Sign_Hmac_SHA256(input : TBytes; key: TJWK) : TBytes;
292+
class function Sign_Hmac_RSA256(input : TBytes; key: TJWK) : TBytes; overload;
293+
class function Sign_ES256(input : TBytes; key: TJWK) : TBytes; overload;
294+
class function Sign_ES512(input : TBytes; key: TJWK) : TBytes; overload;
294295

295296
// general use: pack a JWT using the key speciifed. No key needed if method = none
296297
class function encodeJWT(jwt : TJWT; method : TJWTAlgorithm; key : TJWK; zip : String = '') : String; overload;
@@ -1574,6 +1575,63 @@ class function TJWTUtils.Sign_ES256(input: TBytes; key: TJWK): TBytes;
15741575
end;
15751576
end;
15761577

1578+
class function TJWTUtils.Sign_ES512(input: TBytes; key: TJWK): TBytes;
1579+
var
1580+
ctx : PEVP_MD_CTX;
1581+
keysize : integer;
1582+
len, l : QWord;
1583+
p : System.PByte;
1584+
pkey: PEVP_PKEY;
1585+
PkeyCtx: PEVP_PKEY_CTX;
1586+
rkey: PEC_KEY;
1587+
keys : TJWKList;
1588+
keytype : integer;
1589+
{$IFDEF ALT}
1590+
Signature: array [0..8000] of byte;
1591+
{$ENDIF}
1592+
begin
1593+
check(key <> nil, 'A key must be provided for ES256');
1594+
len := 0;
1595+
p := @input[0];
1596+
l := length(input);
1597+
{$IFDEF ALT}
1598+
for keysize := 0 to 8000 do
1599+
Signature[keysize] := 0;
1600+
{$ENDIF}
1601+
1602+
// 1. Load the RSA private Key from FKey
1603+
rkey := key.LoadEC(true);
1604+
try
1605+
pkey := EVP_PKEY_new;
1606+
try
1607+
check(EVP_PKEY_set1_EC_KEY(pkey, rkey) = 1, 'openSSL EVP_PKEY_set1_RSA failed');
1608+
1609+
// 2. do the signing
1610+
keysize := EVP_PKEY_size(pkey);
1611+
len := keysize;
1612+
SetLength(result, keysize);
1613+
ctx := EVP_MD_CTX_new;
1614+
try
1615+
check(EVP_DigestSignInit(ctx, @PkeyCtx, EVP_sha512, nil, pKey) = 1, 'openSSL EVP_DigestInit_ex failed');
1616+
{$IFNDEF ALT}
1617+
check(EVP_DigestUpdate(ctx, p, l) = 1, 'openSSL EVP_DigestUpdate failed');
1618+
check(EVP_DigestSignFinal(ctx, @result[0], @len) = 1, 'openSSL EVP_DigestSignFinal failed');
1619+
{$ELSE}
1620+
check(EVP_DigestSign(ctx, @result[0], @len, p, l) = 1, 'openSSL EVP_DigestSign failed');
1621+
{$ENDIF}
1622+
SetLength(result, len);
1623+
finally
1624+
EVP_MD_CTX_free(ctx);
1625+
end;
1626+
result := DERTobase(result);
1627+
finally
1628+
EVP_PKEY_free(pKey);
1629+
end;
1630+
finally
1631+
EC_KEY_free(rkey);
1632+
end;
1633+
end;
1634+
15771635
class function TJWTUtils.Sign_Hmac_RSA256(input: TBytes; pemfile, pempassword: String): TBytes;
15781636
begin
15791637
result := nil;

‎server/endpoint_shl.pas‎

Lines changed: 102 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,8 @@ interface
4747
{ TSHLWebServer }
4848
TSHLWebServer = class (TFhirWebServerEndpoint)
4949
private
50-
FPassword : String;
50+
FPassword : String;
51+
FVhlKey : TJWK;
5152
FDB : TFDBManager;
5253
procedure SetDB(AValue: TFDBManager);
5354
function processCreate(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; c : TFDBConnection) : String;
@@ -74,6 +75,7 @@ TSHLWebEndPoint = class (TFHIRServerEndPoint)
7475
private
7576
FSHLServer : TSHLWebServer;
7677
FPassword : String;
78+
FVhlKey : TJsonObject;
7779
procedure checkDatabase;
7880
public
7981
constructor Create(config : TFHIRServerConfigSection; settings : TFHIRServerSettings; i18n : TI18nSupport; db : TFDBManager);
@@ -101,10 +103,12 @@ function TSHLWebServer.processCreate(request: TIdHTTPRequestInfo; response: TIdH
101103
req, resp : TJsonObject;
102104
exp : TDateTime;
103105
days : integer;
106+
vhl : boolean;
104107
begin
105108
result := 'Create SHL context';
106109
req := TJsonParser.parse(request.PostStream);
107110
try
111+
vhl := req.bool['vhl'];
108112
if (req.str['password'] = FPassword) then
109113
begin
110114
days := req.int['days'];
@@ -116,12 +120,13 @@ function TSHLWebServer.processCreate(request: TIdHTTPRequestInfo; response: TIdH
116120
resp.str['pword'] := NewGuidId;
117121
resp.str['link'] := 'https://'+common.host+PathWithSlash+resp.str['uuid'];
118122

119-
c.SQL := 'Insert into SHL (uuid, pword, expiry, mimetype) values (:u, :p, :e, :m)';
123+
c.SQL := 'Insert into SHL (uuid, pword, expiry, mimetype, vhl) values (:u, :p, :e, :m, :v)';
120124
c.prepare;
121125
c.BindString('u', resp.str['uuid']);
122126
c.BindString('p', resp.str['pword']);
123127
c.BindTimeStamp('e', DateTimeToTS(exp));
124128
c.BindString('m', req.str['mimetype']);
129+
c.BindIntegerFromBoolean('v', vhl);
125130
c.execute;
126131
c.terminate;
127132
response.ResponseNo := 200;
@@ -146,41 +151,61 @@ function TSHLWebServer.processCreate(request: TIdHTTPRequestInfo; response: TIdH
146151
function TSHLWebServer.processUpload(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; c : TFDBConnection): String;
147152
var
148153
p : THTTPParameters;
149-
bytes : TBytes;
154+
bytes, hcert : TBytes;
155+
req, resp : TJsonObject;
150156
begin
151157
result := 'upload SHL content';
152158
p := THTTPParameters.create(request.QueryParams, true);
153159
try
154-
bytes := StreamToBytes(request.PostStream);
155-
if (p.has('uuid') and p.has('pword')) then
156-
begin
157-
c.sql := 'select pword from SHL where uuid = '''+SQLWrapString(p['uuid'])+'''';
158-
c.Prepare;
159-
c.Execute;
160-
if not c.FetchNext then
161-
raise ERestfulException.create('processCreate', 404, itSecurity, 'uuid "'+p['uuid']+'" not found', nil);
162-
if p['pword'] <> c.ColStringByName['pword'] then
163-
raise ERestfulException.create('processCreate', 404, itSecurity, 'password failure', nil);
164-
c.terminate;
165-
c.SQL := 'update SHL set blob = :b where uuid = '''+SQLWrapString(p['uuid'])+'''';
166-
c.prepare;
167-
c.BindBlob('b', bytes);
168-
c.Execute;
169-
c.terminate;
170-
response.ResponseNo := 200;
171-
response.ResponseText := 'OK';
172-
response.ContentText := '{ "msg": "OK" }';
173-
end
174-
else
175-
raise ERestfulException.create('processCreate', 404, itSecurity, 'uuid and/or pword not found', nil);
160+
req := TJSONParser.Parse(request.PostStream);
161+
try
162+
bytes := DecodeBase64(req.str['cnt']);
163+
hcert := DecodeBase64(req.str['hcert']);
164+
if (p.has('uuid') and p.has('pword')) then
165+
begin
166+
c.sql := 'select pword from SHL where uuid = '''+SQLWrapString(p['uuid'])+'''';
167+
c.Prepare;
168+
c.Execute;
169+
if not c.FetchNext then
170+
raise ERestfulException.create('processCreate', 404, itSecurity, 'uuid "'+p['uuid']+'" not found', nil);
171+
if p['pword'] <> c.ColStringByName['pword'] then
172+
raise ERestfulException.create('processCreate', 404, itSecurity, 'password failure', nil);
173+
c.terminate;
174+
c.SQL := 'update SHL set blob = :b where uuid = '''+SQLWrapString(p['uuid'])+'''';
175+
c.prepare;
176+
c.BindBlob('b', bytes);
177+
c.Execute;
178+
c.terminate;
179+
response.ResponseNo := 200;
180+
response.ResponseText := 'OK';
181+
if hcert <> nil then
182+
begin
183+
resp := TJsonObject.create;
184+
try
185+
bytes := TJWTUtils.Sign_ES256(hcert, FVhlKey);
186+
resp['signature'] := EncodeBase64(bytes);
187+
resp['kid'] := FVhlKey.id;
188+
response.ContentText := TJSONWriter.writeObjectStr(resp, true);
189+
finally
190+
resp.free;
191+
end;
192+
end
193+
else
194+
response.ContentText := '{ "msg": "OK" }';
195+
end
196+
else
197+
raise ERestfulException.create('processCreate', 404, itSecurity, 'uuid and/or pword not found', nil);
198+
finally
199+
req.free;
200+
end;
176201
finally
177202
p.free;
178203
end;
179204
end;
180205

181206
function TSHLWebServer.processManifest(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; c: TFDBConnection): String;
182207
var
183-
req, resp, f : TJsonObject;
208+
req, resp, f, l, r, m, cnt : TJsonObject;
184209
uuid, b64 : String;
185210
begin
186211
uuid := request.Document.subString(PathWithSlash.length);
@@ -192,28 +217,49 @@ function TSHLWebServer.processManifest(request: TIdHTTPRequestInfo; response: TI
192217
c.prepare;
193218
c.BindString('u', uuid);
194219
c.execute;
195-
if c.FetchNext then
220+
if not c.FetchNext then
221+
begin
222+
response.ResponseNo := 404;
223+
response.ResponseText:= 'Not Found';
224+
response.ContentText := 'SHL Not Found';
225+
end
226+
else if c.ColIntegerByName['vhl'] = 1 then
196227
begin
197228
f := resp.forceArr['files'].addObject;
198229
f.str['contentType'] := c.GetColStringByName('mimetype');
199230
f.str['location'] := 'https://'+common.host+PathWithSlash+'data/'+uuid;
200-
b64 := c.GetColStringByName('blob'); // it's already base64 encoded
201-
// EncodeBase64(c.GetColBlobByName('blob'));
231+
b64 := c.GetColStringByName('blob');
202232
if (not req.has('embeddedLengthMax')) or (b64.Length < req.int['embeddedLengthMax']) then
203233
f.str['embedded'] := b64;
204234
response.ResponseNo := 200;
205235
response.ResponseText:= 'OK';
206236
response.ContentText := TJSONWriter.writeObjectStr(resp, true);
207237
response.ContentType := 'application/json';
208-
c.Terminate;
209238
end
210239
else
211240
begin
212-
c.Terminate;
213-
response.ResponseNo := 404;
214-
response.ResponseText:= 'Not Found';
215-
response.ContentText := 'SHL Not Found';
241+
resp['resourceType'] := 'Bundle';
242+
resp['type'] := 'searchSet';
243+
l := resp.forceArr['link'].addObject;
244+
l['relation'] := 'self';
245+
l['url'] := 'https://'+common.host+request.URI;
246+
f := resp.forceArr['entry'].addObject;
247+
f['fullUrl'] := 'https://'+common.host+PathWithSlash+'DocumentReference/'+uuid;
248+
r := f.forceObj['resource'];
249+
r['resourceType'] := 'DocumentReference';
250+
r['id'] := uuid;
251+
m := r.forceObj['masterIdentifier'];
252+
m['system'] := 'urn:ietf:rfc:3986';
253+
m['value'] := f['fullUrl'];
254+
cnt := r.forceArr['content'].addObject;
255+
cnt['url'] := 'https://'+common.host+PathWithSlash+'data/'+uuid;
256+
cnt['contentType'] := c.GetColStringByName('mimetype');
257+
response.ResponseNo := 200;
258+
response.ResponseText:= 'OK';
259+
response.ContentText := TJSONWriter.writeObjectStr(resp, true);
260+
response.ContentType := 'application/json';
216261
end;
262+
c.Terminate;
217263
finally
218264
resp.free;
219265
end;
@@ -272,6 +318,7 @@ constructor TSHLWebServer.Create(code, path: String; common: TFHIRWebServerCommo
272318
destructor TSHLWebServer.Destroy;
273319
begin
274320
FDB.Free;
321+
FVhlKey.free;
275322
inherited Destroy;
276323
end;
277324

@@ -353,6 +400,7 @@ procedure TSHLWebEndPoint.checkDatabase;
353400
' pword nchar(40) '+ColCanBeNull(c.owner.platform, False)+', '+
354401
' mimetype nchar(60) '+ColCanBeNull(c.owner.platform, False)+', '+
355402
' expiry '+DBDateTimeType(c.owner.platform)+' '+ColCanBeNull(c.owner.platform, False)+', '+
403+
' vhl int '+ColCanBeNull(c.owner.platform, true)+', '+
356404
' blob '+DBBlobType(c.owner.platform)+' '+ColCanBeNull(c.owner.platform, true)+') '+
357405
CreateTableInfo(c.owner.platform));
358406
c.ExecSQL('Create INDEX SK_SHL_UUID ON SHL (uuid)');
@@ -369,10 +417,28 @@ procedure TSHLWebEndPoint.checkDatabase;
369417
end
370418
else
371419
begin
420+
t := m.GetTable('SHL');
421+
if not t.hasColumn('vhl') then
422+
begin
423+
c.StartTransact;
424+
try
425+
c.ExecSQL('ALTER TABLE SHL ADD vhl int '+ColCanBeNull(c.owner.platform, true));
426+
c.Commit;
427+
except
428+
on e:exception do
429+
begin
430+
Logging.log(e.message);
431+
c.Rollback;
432+
recordStack(e);
433+
raise;
434+
end;
435+
end;
436+
end;
372437
end;
373438
finally
374439
m.free;
375440
end;
441+
FVhlKey := TJSONParser.Parse(c.Lookup('Config', 'ConfigKey', 'jwk', 'Value', '{}'));
376442
c.Release;
377443
except
378444
on e: Exception do
@@ -389,6 +455,7 @@ constructor TSHLWebEndPoint.Create(config: TFHIRServerConfigSection; settings: T
389455

390456
destructor TSHLWebEndPoint.Destroy;
391457
begin
458+
FVhlKey.free;
392459
inherited Destroy;
393460
end;
394461

@@ -403,6 +470,7 @@ function TSHLWebEndPoint.makeWebEndPoint(common: TFHIRWebServerCommon): TFhirWeb
403470
FSHLServer := TSHLWebServer.Create(config.name, config['path'].value, common);
404471
FSHLServer.DB := Database.Link;
405472
FSHLServer.FPassword := FPassword;
473+
FSHLServer.FVhlKey := TJWK.create(FVhlKey.link);
406474
WebEndPoint := FSHLServer;
407475
result := FSHLServer.link;
408476
end;

0 commit comments

Comments
 (0)