// ***************************************************************************
//
// Delphi MVC Framework
//
// Copyright (c) 2010-2020 Daniele Teti and the DMVCFramework Team
//
// https://github.com/danieleteti/delphimvcframework
//
// ***************************************************************************
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
//
// *************************************************************************** }
unit MVCFramework.JWT;
{$I dmvcframework.inc}
interface
uses
System.Generics.Collections,
JsonDataObjects,
MVCFramework,
MVCFramework.Patches;
type
{$SCOPEDENUMS ON}
TJWTCheckableClaim = (ExpirationTime, NotBefore, IssuedAt);
TJWTCheckableClaims = set of TJWTCheckableClaim;
TJWTRegisteredClaimNames = class sealed
public
const
///
/// The "iss" (issuer) claim identifies the principal that issued the
/// JWT. The processing of this claim is generally application specific.
/// The "iss" value is a case-sensitive string containing a StringOrURI
/// value. Use of this claim is OPTIONAL.
///
Issuer: string = 'iss';
///
/// The "sub" (subject) claim identifies the principal that is the
/// subject of the JWT. The claims in a JWT are normally statements
/// about the subject. The subject value MUST either be scoped to be
/// locally unique in the context of the issuer or be globally unique.
/// The processing of this claim is generally application specific. The
/// "sub" value is a case-sensitive string containing a StringOrURI
/// value. Use of this claim is OPTIONAL.
///
Subject: string = 'sub';
///
/// The "aud" (audience) claim identifies the recipients that the JWT is
/// intended for. Each principal intended to process the JWT MUST
/// identify itself with a value in the audience claim. If the principal
/// processing the claim does not identify itself with a value in the
/// "aud" claim when this claim is present, then the JWT MUST be
/// rejected. In the general case, the "aud" value is an array of case-
/// sensitive strings, each containing a StringOrURI value. In the
/// special case when the JWT has one audience, the "aud" value MAY be a
/// single case-sensitive string containing a StringOrURI value. The
/// interpretation of audience values is generally application specific.
/// Use of this claim is OPTIONAL.
///
Audience: string = 'aud';
///
/// The "exp" (expiration time) claim identifies the expiration time on
/// or after which the JWT MUST NOT be accepted for processing. The
/// processing of the "exp" claim requires that the current date/time
/// MUST be before the expiration date/time listed in the "exp" claim.
/// Implementers MAY provide for some small leeway, usually no more than
/// a few minutes, to account for clock skew. Its value MUST be a number
/// containing a NumericDate value. Use of this claim is OPTIONAL.
///
ExpirationTime: string = 'exp';
///
/// The "nbf" (not before) claim identifies the time before which the JWT
/// MUST NOT be accepted for processing. The processing of the "nbf"
/// claim requires that the current date/time MUST be after or equal to
/// the not-before date/time listed in the "nbf" claim. Implementers MAY
/// provide for some small leeway, usually no more than a few minutes, to
/// account for clock skew. Its value MUST be a number containing a
/// NumericDate value. Use of this claim is OPTIONAL.
///
NotBefore: string = 'nbf';
///
/// The "iat" (issued at) claim identifies the time at which the JWT was
/// issued. This claim can be used to determine the age of the JWT. Its
/// value MUST be a number containing a NumericDate value. Use of this
/// claim is OPTIONAL.
///
IssuedAt: string = 'iat';
///
/// The "jti" (JWT ID) claim provides a unique identifier for the JWT.
/// The identifier value MUST be assigned in a manner that ensures that
/// there is a negligible probability that the same value will be
/// accidentally assigned to a different data object; if the application
/// uses multiple issuers, collisions MUST be prevented among values
/// produced by different issuers as well. The "jti" claim can be used
/// to prevent the JWT from being replayed. The "jti" value is a case-
/// sensitive string. Use of this claim is OPTIONAL.
///
JWT_ID: string = 'jti';
Names: array [0 .. 6] of string = (
'iss',
'sub',
'aud',
'exp',
'nbf',
'iat',
'jti');
end;
TJWTDictionaryObject = class
private
FClaims: TDictionary;
function GetItem(const Index: string): string;
procedure SetItem(const Index, Value: string);
function GetItemAsDateTime(const Index: string): TDateTime;
procedure SetItemAsDateTime(const Index: string; const Value: TDateTime);
property ItemsAsDateTime[const index: string]: TDateTime read GetItemAsDateTime write SetItemAsDateTime;
property Items[const index: string]: string read GetItem write SetItem; default;
protected
function Contains(const Index: string): Boolean;
function Keys: TArray;
public
constructor Create; virtual;
destructor Destroy; override;
end;
///
/// https://tools.ietf.org/html/rfc7519#section-4.1.1
///
TJWTRegisteredClaims = class(TJWTDictionaryObject)
private
procedure SetAudience(const Value: string);
procedure SetExpirationTime(const Value: TDateTime);
procedure SetIssuedAt(const Value: TDateTime);
procedure SetISSUER(const Value: string);
procedure SetJWT_ID(const Value: string);
procedure SetNotBefore(const Value: TDateTime);
procedure SetSubject(const Value: string);
function GetAudience: string;
function GetExpirationTime: TDateTime;
function GetIssuedAt: TDateTime;
function GetJWT_ID: string;
function GetNotBefore: TDateTime;
function GetSubject: string;
function GetIssuer: string;
public
///
/// "iss" (Issuer) Claim
/// The " iss "(issuer) claim identifies The principal that issued The
/// JWT. The processing of this claim is generally application specific.
/// The " iss " value is a case-sensitive string containing a StringOrURI
/// value.Use of this claim is OPTIONAL.
///
property Issuer: string read GetIssuer write SetISSUER;
///
/// "sub" (Subject) Claim
/// The "sub" (subject) claim identifies the principal that is the
/// subject of the JWT. The claims in a JWT are normally statements
/// about the subject. The subject value MUST either be scoped to be
/// locally unique in the context of the issuer or be globally unique.
/// The processing of this claim is generally application specific. The
/// "sub" value is a case-sensitive string containing a StringOrURI
/// value. Use of this claim is OPTIONAL.
///
property Subject: string read GetSubject write SetSubject;
///
/// "aud" (Audience) Claim
/// The "aud" (audience) claim identifies the recipients that the JWT is
/// intended for. Each principal intended to process the JWT MUST
/// identify itself with a value in the audience claim. If the principal
/// processing the claim does not identify itself with a value in the
/// "aud" claim when this claim is present, then the JWT MUST be
/// rejected. In the general case, the "aud" value is an array of case-
/// sensitive strings, each containing a StringOrURI value. In the
/// special case when the JWT has one audience, the "aud" value MAY be a
/// single case-sensitive string containing a StringOrURI value. The
/// interpretation of audience values is generally application specific.
/// Use of this claim is OPTIONAL.
///
property Audience: string read GetAudience write SetAudience;
///
/// "exp" (Expiration Time) Claim
/// The "exp" (expiration time) claim identifies the expiration time on
/// or after which the JWT MUST NOT be accepted for processing. The
/// processing of the "exp" claim requires that the current date/time
/// MUST be before the expiration date/time listed in the "exp" claim.
/// Implementers MAY provide for some small leeway, usually no more than
/// a few minutes, to account for clock skew. Its value MUST be a number
/// containing a NumericDate value. Use of this claim is OPTIONAL.
///
property ExpirationTime: TDateTime read GetExpirationTime write SetExpirationTime;
///
/// "nbf" (Not Before) Claim
/// The "nbf" (not before) claim identifies the time before which the JWT
/// MUST NOT be accepted for processing. The processing of the "nbf"
/// claim requires that the current date/time MUST be after or equal to
/// the not-before date/time listed in the "nbf" claim. Implementers MAY
/// provide for some small leeway, usually no more than a few minutes, to
/// account for clock skew. Its value MUST be a number containing a
/// NumericDate value. Use of this claim is OPTIONAL.
///
property NotBefore: TDateTime read GetNotBefore write SetNotBefore;
///
/// "iat" (Issued At) Claim
/// The "iat" (issued at) claim identifies the time at which the JWT was
/// issued. This claim can be used to determine the age of the JWT. Its
/// value MUST be a number containing a NumericDate value. Use of this
/// claim is OPTIONAL.
///
property IssuedAt: TDateTime read GetIssuedAt write SetIssuedAt;
///
/// "jti" (JWT ID) Claim
/// The "jti" (JWT ID) claim provides a unique identifier for the JWT.
/// The identifier value MUST be assigned in a manner that ensures that
/// there is a negligible probability that the same value will be
/// accidentally assigned to a different data object; if the application
/// uses multiple issuers, collisions MUST be prevented among values
/// produced by different issuers as well. The "jti" claim can be used
/// to prevent the JWT from being replayed. The "jti" value is a case-
/// sensitive string. Use of this claim is OPTIONAL.
///
property JWT_ID: string read GetJWT_ID write SetJWT_ID;
end;
TJWTCustomClaims = class(TJWTDictionaryObject)
public
property Items; default;
function AsCustomData: TMVCCustomData;
end;
TJWT = class
private
FSecretKey: string;
FRegisteredClaims: TJWTRegisteredClaims;
FCustomClaims: TJWTCustomClaims;
FHMACAlgorithm: string;
FRegClaimsToChecks: TJWTCheckableClaims;
FLeewaySeconds: Cardinal;
procedure SetHMACAlgorithm(const Value: string);
procedure SetChecks(const Value: TJWTCheckableClaims);
function CheckExpirationTime(Payload: TJDOJSONObject; out Error: string): Boolean;
function CheckNotBefore(Payload: TJDOJSONObject; out Error: string): Boolean;
function CheckIssuedAt(Payload: TJDOJSONObject; out Error: string): Boolean;
procedure SetLiveValidityWindowInSeconds(const Value: Cardinal);
function GetLiveValidityWindowInSeconds: Cardinal;
function IsValidToken(const Token: string; out Header, Payload: TJDOJSONObject; out Error: string): Boolean;
public
constructor Create(const SecretKey: string; const ALeewaySeconds: Cardinal = 300); virtual;
destructor Destroy; override;
function GetToken: string;
function LoadToken(const Token: string; out Error: string): Boolean;
property Claims: TJWTRegisteredClaims read FRegisteredClaims;
property CustomClaims: TJWTCustomClaims read FCustomClaims;
property HMACAlgorithm: string read FHMACAlgorithm write SetHMACAlgorithm;
property LeewaySeconds: Cardinal read FLeewaySeconds;
property RegClaimsToChecks: TJWTCheckableClaims read FRegClaimsToChecks write SetChecks;
///
/// Use LiveValidityWindowInSeconds to make the ExpirationTime dynamic at each request.
/// ExpirationTime will be incremented by LiveValidityWindowInSeconds seconds automatically
/// if the remaining seconds are less than the LiveValidityWindowInSeconds.
///
property LiveValidityWindowInSeconds: Cardinal read GetLiveValidityWindowInSeconds
write SetLiveValidityWindowInSeconds;
end;
implementation
uses
System.SysUtils,
MVCFramework.Commons,
MVCFramework.HMAC,
System.DateUtils,
IdGlobal;
{ TJWTRegisteredClaims }
function TJWTRegisteredClaims.GetAudience: string;
begin
Result := Items[TJWTRegisteredClaimNames.Audience];
end;
function TJWTRegisteredClaims.GetExpirationTime: TDateTime;
begin
Result := ItemsAsDateTime[TJWTRegisteredClaimNames.ExpirationTime];
end;
function TJWTRegisteredClaims.GetIssuedAt: TDateTime;
begin
Result := ItemsAsDateTime[TJWTRegisteredClaimNames.IssuedAt];
end;
function TJWTRegisteredClaims.GetIssuer: string;
begin
Result := Items[TJWTRegisteredClaimNames.Issuer];
end;
function TJWTRegisteredClaims.GetJWT_ID: string;
begin
Result := Items[TJWTRegisteredClaimNames.JWT_ID];
end;
function TJWTRegisteredClaims.GetNotBefore: TDateTime;
begin
Result := ItemsAsDateTime[TJWTRegisteredClaimNames.NotBefore];
end;
function TJWTRegisteredClaims.GetSubject: string;
begin
Result := Items[TJWTRegisteredClaimNames.Subject];
end;
procedure TJWTRegisteredClaims.SetAudience(const Value: string);
begin
Items[TJWTRegisteredClaimNames.Audience] := Value;
end;
procedure TJWTRegisteredClaims.SetExpirationTime(const Value: TDateTime);
begin
ItemsAsDateTime[TJWTRegisteredClaimNames.ExpirationTime] := Value;
end;
procedure TJWTRegisteredClaims.SetIssuedAt(const Value: TDateTime);
begin
ItemsAsDateTime[TJWTRegisteredClaimNames.IssuedAt] := Value;
end;
procedure TJWTRegisteredClaims.SetISSUER(const Value: string);
begin
Items[TJWTRegisteredClaimNames.Issuer] := Value;
end;
procedure TJWTRegisteredClaims.SetJWT_ID(const Value: string);
begin
Items[TJWTRegisteredClaimNames.JWT_ID] := Value;
end;
procedure TJWTRegisteredClaims.SetNotBefore(const Value: TDateTime);
begin
ItemsAsDateTime[TJWTRegisteredClaimNames.NotBefore] := Value;
end;
procedure TJWTRegisteredClaims.SetSubject(const Value: string);
begin
Items[TJWTRegisteredClaimNames.Subject] := Value;
end;
{ TJWTCustomClaims }
function TJWTDictionaryObject.Contains(const Index: string): Boolean;
begin
Result := FClaims.ContainsKey(index);
end;
constructor TJWTDictionaryObject.Create;
begin
inherited;
FClaims := TDictionary.Create;
end;
destructor TJWTDictionaryObject.Destroy;
begin
FClaims.Free;
inherited;
end;
function TJWTDictionaryObject.GetItem(const Index: string): string;
begin
if not FClaims.TryGetValue(index, Result) then
Result := '';
end;
function TJWTDictionaryObject.GetItemAsDateTime(const Index: string): TDateTime;
var
lIntValue: Int64;
begin
Result := -693594;
if Trim(Items[index]) <> EmptyStr then
begin
if not TryStrToInt64(Items[index], lIntValue) then
raise Exception.Create('Item cannot be converted as Unix Epoch');
Result := UnixToDateTime(lIntValue, False);
end;
end;
function TJWTDictionaryObject.Keys: TArray;
begin
Result := FClaims.Keys.ToArray;
end;
procedure TJWTDictionaryObject.SetItem(const Index, Value: string);
begin
FClaims.AddOrSetValue(index, Value);
end;
procedure TJWTDictionaryObject.SetItemAsDateTime(const Index: string;
const Value: TDateTime);
begin
Items[index] := IntToStr(DateTimeToUnix(Value, False));
end;
{ TJWTCustomClaims }
function TJWTCustomClaims.AsCustomData: TMVCCustomData;
begin
Result := TMVCCustomData.Create(FClaims);
end;
{ TJWT }
function TJWT.CheckExpirationTime(Payload: TJDOJSONObject; out Error: string): Boolean;
var
lIntValue: Int64;
lValue: string;
lExpirationTimeAsDateTime: TDateTime;
begin
if not Payload.Contains(TJWTRegisteredClaimNames.ExpirationTime) then
begin
Error := TJWTRegisteredClaimNames.ExpirationTime + ' not set';
Exit(False);
end;
lValue := Payload.S[TJWTRegisteredClaimNames.ExpirationTime];
if not TryStrToInt64(lValue, lIntValue) then
begin
Error := TJWTRegisteredClaimNames.ExpirationTime + ' is not an integer';
Exit(False);
end;
lExpirationTimeAsDateTime := UnixToDateTime(lIntValue, False);
if lExpirationTimeAsDateTime <= Now - FLeewaySeconds * OneSecond then
begin
Error := 'Token expired';
Exit(False);
end;
Result := True;
end;
function TJWT.CheckIssuedAt(Payload: TJDOJSONObject; out Error: string): Boolean;
var
lIntValue: Int64;
lValue: string;
begin
if not Payload.Contains(TJWTRegisteredClaimNames.IssuedAt) then
begin
Error := TJWTRegisteredClaimNames.IssuedAt + ' not set';
Exit(False);
end;
lValue := Payload.S[TJWTRegisteredClaimNames.IssuedAt];
if not TryStrToInt64(lValue, lIntValue) then
begin
Error := TJWTRegisteredClaimNames.IssuedAt + ' is not an integer';
Exit(False);
end;
if UnixToDateTime(lIntValue, False) >= Now + FLeewaySeconds * OneSecond then
begin
Error := 'Token is issued in the future';
Exit(False);
end;
Result := True;
end;
function TJWT.CheckNotBefore(Payload: TJDOJSONObject; out Error: string): Boolean;
var
lIntValue: Int64;
lValue: string;
begin
if not Payload.Contains(TJWTRegisteredClaimNames.NotBefore) then
begin
Error := TJWTRegisteredClaimNames.NotBefore + ' not set';
Exit(False);
end;
lValue := Payload.S[TJWTRegisteredClaimNames.NotBefore];
if not TryStrToInt64(lValue, lIntValue) then
begin
Error := TJWTRegisteredClaimNames.NotBefore + ' is not an integer';
Exit(False);
end;
if UnixToDateTime(lIntValue, False) >= Now + FLeewaySeconds * OneSecond then
begin
Error := 'Token still not valid';
Exit(False);
end;
Result := True;
end;
constructor TJWT.Create(const SecretKey: string; const ALeewaySeconds: Cardinal = 300);
begin
inherited Create;
FSecretKey := SecretKey;
FRegisteredClaims := TJWTRegisteredClaims.Create;
FCustomClaims := TJWTCustomClaims.Create;
FHMACAlgorithm := HMAC_HS512;
FLeewaySeconds := ALeewaySeconds;
FRegClaimsToChecks := [TJWTCheckableClaim.ExpirationTime, TJWTCheckableClaim.NotBefore, TJWTCheckableClaim.IssuedAt];
end;
destructor TJWT.Destroy;
begin
FRegisteredClaims.Free;
FCustomClaims.Free;
inherited;
end;
function TJWT.GetLiveValidityWindowInSeconds: Cardinal;
begin
Result := StrToIntDef(FCustomClaims.Items['lvw'], 0);
end;
function TJWT.GetToken: string;
var
lHeader, lPayload: TJDOJSONObject;
lHeaderEncoded, lPayloadEncoded, lToken, lHash: string;
lBytes: TBytes;
lRegClaimName: string;
lCustomClaimName: string;
begin
lHeader := TJDOJSONObject.Create;
try
lPayload := TJDOJSONObject.Create;
try
lHeader.S['alg'] := HMACAlgorithm;
lHeader.S['typ'] := 'JWT';
for lRegClaimName in TJWTRegisteredClaimNames.Names do
begin
if FRegisteredClaims.Contains(lRegClaimName) then
begin
if (lRegClaimName = TJWTRegisteredClaimNames.ExpirationTime) or
(lRegClaimName = TJWTRegisteredClaimNames.NotBefore) or
(lRegClaimName = TJWTRegisteredClaimNames.IssuedAt) then
lPayload.L[lRegClaimName] := StrToInt64(FRegisteredClaims[lRegClaimName])
else
lPayload.S[lRegClaimName] := FRegisteredClaims[lRegClaimName];
end;
end;
for lCustomClaimName in FCustomClaims.Keys do
begin
lPayload.S[lCustomClaimName] := FCustomClaims[lCustomClaimName];
end;
lHeaderEncoded := URLSafeB64encode(lHeader.ToString, False, IndyTextEncoding_UTF8);
lPayloadEncoded := URLSafeB64encode(lPayload.ToString, False, IndyTextEncoding_UTF8);
lToken := lHeaderEncoded + '.' + lPayloadEncoded;
lBytes := HMAC(HMACAlgorithm, lToken, FSecretKey);
lHash := URLSafeB64encode(lBytes, False);
Result := lToken + '.' + lHash;
finally
lPayload.Free;
end;
finally
lHeader.Free;
end;
end;
function TJWT.IsValidToken(const Token: string; out Header, Payload: TJDOJSONObject; out Error: string): Boolean;
var
lPieces: TArray;
lAlgName: string;
begin
Result := False;
Error := '';
lPieces := Token.Split(['.']);
if Length(lPieces) <> 3 then
begin
Error := 'Invalid Token';
Exit(False);
end;
Header := TJDOJsonBaseObject.Parse(URLSafeB64Decode(lPieces[0], IndyTextEncoding_UTF8)) as TJDOJSONObject;
try
if not Assigned(Header) then
begin
Error := 'Invalid Token';
Exit(False);
end;
Payload := TJDOJsonBaseObject.Parse(URLSafeB64Decode(lPieces[1], IndyTextEncoding_UTF8)) as TJDOJSONObject;
try
if not Assigned(Payload) then
begin
Error := 'Invalid Token';
Exit(False);
end;
if not Header.Contains('alg') then
begin
Error := 'Invalid Token';
Exit(False);
end;
lAlgName := Header.S['alg'];
Result := Token = lPieces[0] + '.' + lPieces[1] + '.' +
URLSafeB64encode(HMAC(lAlgName, lPieces[0] + '.' + lPieces[1], FSecretKey), False);
// if the token is correctly signed and has not been tampered,
// let's check it's validity usinf nbf, exp, iat as configured in
// the RegClaimsToCheck property
if Result then
begin
if TJWTCheckableClaim.ExpirationTime in RegClaimsToChecks then
begin
if not CheckExpirationTime(Payload, Error) then
begin
Exit(False);
end;
end;
if TJWTCheckableClaim.NotBefore in RegClaimsToChecks then
begin
if not CheckNotBefore(Payload, Error) then
begin
Exit(False);
end;
end;
if TJWTCheckableClaim.IssuedAt in RegClaimsToChecks then
begin
if not CheckIssuedAt(Payload, Error) then
begin
Exit(False);
end;
end;
end;
finally
if not Result then
FreeAndNil(Payload);
end;
finally
if not Result then
FreeAndNil(Header);
end;
end;
function TJWT.LoadToken(const Token: string; out Error: string): Boolean;
var
lPieces: TArray;
lJHeader: TJDOJSONObject;
lJPayload: TJDOJSONObject;
i: Integer;
lName: string;
j: Integer;
lIsRegistered: Boolean;
lValue: string;
begin
lJHeader := nil;
lJPayload := nil;
Result := IsValidToken(Token, lJHeader, lJPayload, Error);
try
if not Result then
Exit(False);
lPieces := Token.Split(['.']);
// loading data from token into self
FHMACAlgorithm := lJHeader.Values['alg'].Value;
// registered claims
FRegisteredClaims.FClaims.Clear;
// custom claims
FCustomClaims.FClaims.Clear;
for i := 0 to lJPayload.Count - 1 do
begin
lIsRegistered := False;
lName := lJPayload.Names[i];
lValue := lJPayload.Items[i].Value;
// if is a registered claim, load it in the proper dictionary...
for j := 0 to high(TJWTRegisteredClaimNames.Names) do
begin
if lName = TJWTRegisteredClaimNames.Names[j] then
begin
FRegisteredClaims.FClaims.AddOrSetValue(lName, lValue);
lIsRegistered := True;
Break;
end;
end;
if not lIsRegistered then
FCustomClaims.FClaims.AddOrSetValue(lName, lValue);
end;
FCustomClaims.FClaims.TrimExcess;
FRegisteredClaims.FClaims.TrimExcess;
finally
FreeAndNil(lJHeader);
FreeAndNil(lJPayload);
end;
end;
procedure TJWT.SetChecks(const Value: TJWTCheckableClaims);
begin
FRegClaimsToChecks := Value;
end;
procedure TJWT.SetHMACAlgorithm(const Value: string);
begin
FHMACAlgorithm := Value;
end;
procedure TJWT.SetLiveValidityWindowInSeconds(const Value: Cardinal);
begin
FCustomClaims.Items['lvw'] := Value.ToString;
end;
end.