{ **********************************************************************
This file is part of the Free Component Library (FCL)
Copyright (c) 2015 by the Free Pascal development team
JSON Web Token implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit fpjwt;
{$mode objfpc}{$H+}
interface
uses
TypInfo, Classes, SysUtils, fpjson, base64;
Type
{ TBaseJWT }
TBaseJWT = Class(TPersistent)
private
Protected
// Override this to disable writing a property to the JSON.
function WriteProp(P: PPropInfo; All: Boolean): Boolean; virtual;
function GetAsEncodedString: String; virtual;
procedure SetAsEncodedString(AValue: String); virtual;
function GetAsString: TJSONStringType; virtual;
procedure SetAsString(AValue: TJSONStringType);virtual;
Procedure DoLoadFromJSON(JSON : TJSONObject);virtual;
Procedure DoSaveToJSON(JSON : TJSONObject; All : Boolean);virtual;
Public
Constructor Create; virtual;
Procedure LoadFromJSON(JSON : TJSONObject);
Procedure SaveToJSON(JSON : TJSONObject; All : Boolean);
// Base64url conversion functions (RFC7515)
class function Base64ToBase64URL(AValue: string): string;
class function Base64URLToBase64(AValue: string): string;
// Decode Base64url string.
Class Function DecodeString(S : String) : String;
// Decode Base64url string and return a JSON Object.
Class Function DecodeStringToJSON(S : String) : TJSONObject;
// Get/Set as string. This is normally the JSON form.
Property AsString : TJSONStringType Read GetAsString Write SetAsString;
// Set as string. This is normally the JSON form, encoded as Base64.
Property AsEncodedString : String Read GetAsEncodedString Write SetAsEncodedString;
end;
{ TJOSE }
TJOSE = Class(TBaseJWT)
private
Falg: String;
Fcrit: String;
Fcty: String;
Fjku: String;
Fjwk: String;
Fkid: String;
Ftyp: String;
Fx5c: String;
Fx5t: String;
Fx5ts256: String;
Fx5u: String;
Published
// Registered names. Keep the case lowercase, the RTTI must match the registered name.
Property cty : String Read Fcty Write Fcty;
Property typ : String Read Ftyp Write Ftyp;
Property alg : String Read Falg Write Falg;
Property jku : String Read Fjku Write fjku;
Property jwk : String Read Fjwk Write fjwk;
Property kid : String Read Fkid Write fkid;
Property x5u : String Read Fx5u Write fx5u;
Property x5c : String Read Fx5c Write fx5c;
Property x5t : String Read Fx5t Write fx5t;
Property x5ts256 : String Read Fx5ts256 Write fx5ts256;
Property crit : String Read Fcrit Write fcrit;
end;
TJOSEClass = Class of TJOSE;
{ TClaims }
TClaims = Class(TBaseJWT)
private
FAud: String;
FExp: Int64;
FIat: Int64;
FIss: String;
FJTI: String;
FNbf: Int64;
FSub: String;
Published
// Registered Claim Names. Keep the case lowercase, the RTTI must match the registered name.
Property iss : String Read FIss Write FIss;
Property sub : String Read FSub Write FSub;
Property aud : String Read FAud Write FAud;
Property exp : Int64 Read FExp Write FExp;
Property nbf : Int64 Read FNbf Write FNbf;
Property iat : Int64 Read FIat Write FIat;
Property jti : String Read FJTI Write FJTI;
end;
TClaimsClass = Class of TClaims;
{ TJWT }
TJWT = Class(TBaseJWT)
private
FClaims: TClaims;
FJOSE: TJOSE;
FSignature: String;
procedure SetClaims(AValue: TClaims);
procedure SetJOSE(AValue: TJOSE);
Protected
Function CreateJOSE : TJOSE; Virtual;
Function CreateClaims : TClaims; Virtual;
// AsString and AsEncodedString are the same in this case.
function GetAsString: TJSONStringType; override;
procedure SetAsString(AValue: TJSONStringType);override;
function GetAsEncodedString: String;override;
Procedure SetAsEncodedString (AValue : String);override;
Public
Constructor Create; override;
Destructor Destroy; override;
// Owned by the JWT. The JSON header.
Property JOSE : TJOSE Read FJOSE Write SetJOSE;
// Owned by the JWT. The set of claims. The actuall class will depend on the descendant.
Property Claims : TClaims Read FClaims Write SetClaims;
Property Signature : String Read FSignature Write FSignature;
end;
implementation
uses strutils;
{ TJWT }
procedure TJWT.SetClaims(AValue: TClaims);
begin
if FClaims=AValue then Exit;
FClaims:=AValue;
end;
procedure TJWT.SetJOSE(AValue: TJOSE);
begin
if FJOSE=AValue then Exit;
FJOSE:=AValue;
end;
function TJWT.CreateJOSE: TJOSE;
begin
Result:=TJOSE.Create;
end;
function TJWT.CreateClaims: TClaims;
begin
Result:=TClaims.Create;
end;
function TJWT.GetAsString: TJSONStringType;
begin
Result:=Base64ToBase64URL(EncodeStringBase64(JOSE.AsString));
Result:=Result+'.'+Base64ToBase64URL(EncodeStringBase64(Claims.AsString));
If (Signature<>'') then
Result:=Result+'.'+Signature;
end;
function TJWT.GetAsEncodedString: String;
begin
Result:=GetAsString;
end;
procedure TJWT.SetAsEncodedString(AValue: String);
begin
SetAsString(AValue);
end;
constructor TJWT.Create;
begin
Inherited;
FJOSE:=CreateJOSE;
FClaims:=CreateCLaims;
end;
destructor TJWT.Destroy;
begin
FreeAndNil(FJOSE);
FreeAndNil(FClaims);
Inherited;
end;
procedure TJWT.SetAsString(AValue: TJSONStringType);
Var
J,C,S : String;
begin
J:=ExtractWord(1,AValue,['.']);
C:=ExtractWord(2,AValue,['.']);
S:=ExtractWord(3,AValue,['.']);
JOSE.AsEncodedString:=J;
Claims.AsEncodedString:=C;
Signature:=S;
end;
{ TBaseJWT }
function TBaseJWT.GetAsEncodedString: String;
begin
Result:=Base64ToBase64URL(EncodeStringBase64(AsString));
end;
procedure TBaseJWT.SetAsEncodedString(AValue: String);
begin
AsString:=DecodeString(AValue);
end;
function TBaseJWT.GetAsString: TJSONStringType;
Var
O : TJSONObject;
begin
O:=TJSONObject.Create;
try
SaveToJSON(O,False);
Result:=O.AsJSON;
finally
O.Free;
end;
end;
procedure TBaseJWT.SetAsString(AValue: TJSONStringType);
Var
D : TJSONData;
O : TJSONObject absolute D;
begin
D:=GetJSON(AValue);
try
if D is TJSONObject then
LoadFromJSON(O);
finally
D.Free;
end;
end;
procedure TBaseJWT.DoLoadFromJSON(JSON: TJSONObject);
Var
D : TJSONEnum;
P : PPropinfo;
begin
For D in JSON Do
begin
P:=GetPropInfo(Self,D.Key);
if (P<>Nil) and not D.Value.IsNull then
Case P^.PropType^.Kind of
tkInteger : SetOrdProp(Self,P,D.Value.AsInteger);
tkChar :
if D.Value.AsString<>'' then
SetOrdProp(Self,P,Ord(D.Value.AsString[1]));
tkEnumeration :
if (D.Value.JSONType=jtNumber) and (TJSONNumber(D.Value).NumberType=ntInteger) then
SetOrdProp(Self,P,D.Value.AsInteger)
else
SetOrdProp(Self,P,GetEnumValue(p^.PropType,D.Value.AsString));
tkFloat :
SetFloatProp(Self,P,D.Value.AsFloat);
tkSString,tkLString,tkAString :
SetStrProp(Self,P,D.Value.AsString);
tkWChar, tkUString,tkWString,tkUChar:
SetWideStrProp(Self,P,D.Value.AsString);
tkBool :
SetOrdProp(Self,P,Ord(D.Value.AsBoolean));
tkInt64,tkQWord:
SetInt64Prop(Self,P,Ord(D.Value.AsInt64));
end;
end;
end;
function TBaseJWT.WriteProp(P: PPropInfo; All: Boolean): Boolean;
begin
Result:=True;
end;
procedure TBaseJWT.DoSaveToJSON(JSON: TJSONObject; All: Boolean);
Var
D : TJSONEnum;
P : PPropinfo;
PL : PPropList;
I,VI,Count : Integer;
VF : Double;
C : Char;
CW : WideChar;
I64 : Int64;
W : UnicodeString;
S : String;
begin
Count:=GetPropList(Self,PL);
try
For I:=0 to Count-1 do
begin
P:=PL^[i];
if WriteProp(P,All) then
Case P^.PropType^.Kind of
tkInteger :
begin
VI:=GetOrdProp(Self,P);
if All or (VI<>0) then
JSON.Add(P^.Name,VI);
end;
tkChar :
begin
C:=Char(GetOrdProp(Self,P));
if All or (C<>#0) then
if C=#0 then
JSON.Add(p^.Name,'')
else
JSON.Add(p^.Name,C);
end;
tkEnumeration :
begin
vi:=GetOrdProp(Self,P);
JSON.Add(P^.Name,GetEnumName(p^.PropType,VI));
end;
tkFloat :
begin
VF:=GetFloatProp(Self,P);
If All or (VF<>0) then
JSON.Add(P^.Name,VF);
end;
tkSString,tkLString,tkAString :
begin
S:=GetStrProp(Self,P);
if All or (S<>'') then
JSON.Add(P^.Name,S);
end;
tkWChar:
begin
CW:=WideChar(GetOrdProp(Self,P));
if All or (CW<>#0) then
if CW=#0 then
JSON.Add(p^.Name,'')
else
JSON.Add(p^.Name,Utf8Encode(WideString(CW)));
end;
tkUString,tkWString,tkUChar:
begin
W:=GetWideStrProp(Self,P);
if All or (W<>'') then
JSON.Add(P^.Name,Utf8Encode(W));
end;
tkBool :
JSON.Add(P^.Name,(GetOrdProp(Self,P)<>0));
tkInt64,tkQWord:
begin
I64:=GetInt64Prop(Self,P);
if All or (I64<>0) then
JSON.Add(p^.Name,I64);
end;
end;
end;
finally
FreeMem(PL);
end;
end;
constructor TBaseJWT.Create;
begin
Inherited Create;
end;
procedure TBaseJWT.LoadFromJSON(JSON: TJSONObject);
begin
DoLoadFromJSon(JSON);
end;
procedure TBaseJWT.SaveToJSON(JSON: TJSONObject; All: Boolean);
begin
DoSaveToJSon(JSON,All);
end;
class function TBaseJWT.Base64ToBase64URL(AValue: string): string;
begin
Result := StringsReplace(AValue, ['+', '/'], ['-', '_'], [rfReplaceAll]);
Result := TrimRightSet(Result, ['=']);
end;
class function TBaseJWT.Base64URLToBase64(AValue: string): string;
var
i,l: integer;
begin
Result := StringsReplace(AValue, ['-', '_'], ['+', '/'], [rfReplaceAll]);
l := length(Result) mod 4;
if l > 0 then
Result:=Result+StringOfChar('=',4-l);
end;
class function TBaseJWT.DecodeString(S: String): String;
begin
Result:=DecodeStringBase64(Base64URLToBase64(S), True);
end;
class function TBaseJWT.DecodeStringToJSON(S: String): TJSONObject;
Var
D : TJSONData;
begin
D:=GetJSON(DecodeString(S));
if not (D is TJSONData) then
FreeAndNil(D);
Result:=TJSONObject(D);
end;
end.