paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 10:09:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Add webclient and OAuth2 handler

Browse Source 
git-svn-id: trunk@30791 -
This commit is contained in:
michael 2015-05-03 20:30:32 +00:00
parent c1f926b502
commit 4dde5f7258
9 changed files with 3569 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -3172,11 +3172,18 @@ packages/fcl-web/src/base/fphttpapp.pp svneol=native#text/plain
packages/fcl-web/src/base/fphttpclient.pp svneol=native#text/plain
packages/fcl-web/src/base/fphttpserver.pp svneol=native#text/plain
packages/fcl-web/src/base/fphttpstatus.pas svneol=native#text/plain
packages/fcl-web/src/base/fphttpwebclient.pp svneol=native#text/plain
packages/fcl-web/src/base/fpjwt.pp svneol=native#text/plain
packages/fcl-web/src/base/fpoauth2.pp svneol=native#text/plain
packages/fcl-web/src/base/fpoauth2ini.pp svneol=native#text/plain
packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
packages/fcl-web/src/base/fpwebclient.pp svneol=native#text/plain
packages/fcl-web/src/base/fpwebfile.pp svneol=native#text/plain
packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain
packages/fcl-web/src/base/httpprotocol.pp svneol=native#text/plain
packages/fcl-web/src/base/iniwebsession.pp svneol=native#text/plain
packages/fcl-web/src/base/restbase.pp svneol=native#text/plain
packages/fcl-web/src/base/restcodegen.pp svneol=native#text/plain
packages/fcl-web/src/base/webpage.pp svneol=native#text/plain
packages/fcl-web/src/base/websession.pp svneol=native#text/plain
packages/fcl-web/src/base/webutil.pp svneol=native#text/plain

11
packages/fcl-web/fpmake.pp
View File

@ -230,6 +230,17 @@ begin
AddUnit('webjsonrpc');
AddUnit('httpdefs');
end;
T:=P.Targets.AddUnit('fpwebclient.pp');
T:=P.Targets.AddUnit('fpjwt.pp');
T:=P.Targets.AddUnit('fpoauth2.pp');
T.Dependencies.AddUnit('fpwebclient');
T.Dependencies.AddUnit('fpjwt');
T:=P.Targets.AddUnit('fpoauth2ini.pp');
T.Dependencies.AddUnit('fpoauth2');
T:=P.Targets.AddUnit('fphttpwebclient.pp');
T.Dependencies.AddUnit('fpwebclient');
T:=P.Targets.AddUnit('restbase.pp');
T:=P.Targets.AddUnit('restcodegen.pp');
{$ifndef ALLPACKAGES}
Run;
end;

150
packages/fcl-web/src/base/fphttpwebclient.pp Normal file
View File

@ -0,0 +1,150 @@
{ **********************************************************************
This file is part of the Free Component Library (FCL)
Copyright (c) 2015 by the Free Pascal development team
FPHTTPClient implementation of TFPWebclient.
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 fphttpwebclient;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpwebclient, fphttpclient;
Type
{ TFPHTTPRequest }
TFPHTTPRequest = Class(TWebClientRequest)
Private
FHTTP : TFPHTTPClient;
Public
Constructor Create(AHTTP : TFPHTTPClient);
Destructor Destroy; override;
end;
{ TFPHTTPRequest }
TFPHTTPResponse = Class(TWebClientResponse)
Private
FHTTP : TFPHTTPClient;
Protected
function GetHeaders: TStrings;override;
Function GetStatusCode : Integer; override;
Function GetStatusText : String; override;
Public
Constructor Create(AHTTP : TFPHTTPRequest);
Destructor Destroy; override;
end;
{ TFPHTTPWebClient }
TFPHTTPWebClient = Class(TAbstractWebClient)
Protected
Function DoCreateRequest: TWebClientRequest; override;
Function DoHTTPMethod(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse; override;
end;
implementation
uses dateutils;
{ TFPHTTPRequest }
constructor TFPHTTPRequest.Create(AHTTP: TFPHTTPClient);
begin
FHTTP:=AHTTP;
end;
destructor TFPHTTPRequest.Destroy;
begin
FreeAndNil(FHTTP);
inherited Destroy;
end;
{ TFPHTTPResponse }
function TFPHTTPResponse.GetHeaders: TStrings;
begin
if Assigned(FHTTP) then
Result:=FHTTP.ResponseHeaders
else
Result:=Inherited GetHeaders;
end;
Function TFPHTTPResponse.GetStatusCode: Integer;
begin
if Assigned(FHTTP) then
Result:=FHTTP.ResponseStatusCode
else
Result:=0;
end;
Function TFPHTTPResponse.GetStatusText: String;
begin
if Assigned(FHTTP) then
Result:=FHTTP.ResponseStatusText
else
Result:='';
end;
Constructor TFPHTTPResponse.Create(AHTTP: TFPHTTPRequest);
begin
Inherited Create(AHTTP);
FHTTP:=AHTTP.FHTTP;
end;
Destructor TFPHTTPResponse.Destroy;
begin
FreeAndNil(FHTTP);
inherited Destroy;
end;
{ TFPHTTPWebClient }
Function TFPHTTPWebClient.DoCreateRequest: TWebClientRequest;
begin
Result:=TFPHTTPRequest.Create(TFPHTTPClient.Create(Self));
end;
Function TFPHTTPWebClient.DoHTTPMethod(Const AMethod, AURL: String;
ARequest: TWebClientRequest): TWebClientResponse;
Var
U,S : String;
h : TFPHTTPClient;
Res : Boolean;
begin
U:=AURL;
H:=TFPHTTPRequest(ARequest).FHTTP;
TFPHTTPRequest(ARequest).FHTTP:=Nil;
S:=ARequest.ParamsAsQuery;
if (S<>'') then
begin
if Pos('?',U)=0 then
U:=U+'?';
U:=U+S;
end;
Result:=TFPHTTPResponse.Create(ARequest as TFPHTTPRequest);
try
H.HTTPMethod(AMethod,U,Result.Content,[]); // Will rais an exception
except
FreeAndNil(Result);
Raise;
end;
end;
end.

416
packages/fcl-web/src/base/fpjwt.pp Normal file
View File

@ -0,0 +1,416 @@
{ **********************************************************************
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);
// Decode Base64 string. Padds the String with = to a multiple of 4
Class Function DecodeString(S : String) : String;
// Decode Base64 string and return a JSON Object. Padds the String with = to a multiple of 4
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:=EncodeStringBase64(JOSE.AsString);
Result:=Result+'.'+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:=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.DecodeString(S: String): String;
Var
R : Integer;
begin
R:=(length(S) mod 4);
if R<>0 then
S:=S+StringOfChar('=',4-r);
Result:=DecodeStringBase64(S);
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.

779
packages/fcl-web/src/base/fpoauth2.pp Normal file
View File

@ -0,0 +1,779 @@
{ **********************************************************************
This file is part of the Free Component Library (FCL)
Copyright (c) 2015 by the Free Pascal development team
OAuth2 web request handler classes
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 fpoauth2;
{$mode objfpc}{$H+}
interface
uses
Typinfo,Classes, SysUtils, fpjson, fpjwt, fpwebclient;
Type
{ TOAuth2Config }
TAccessType = (atOnline,atOffline);
TAbstracTOAuth2ConfigStore = Class;
EOAuth2 = Class(Exception);
{ TOAuth2Config }
{ TJWTIDToken }
TJWTIDToken = Class(TJWT)
private
FClaimsClass: TClaimsClass;
FJOSEClass: TJOSEClass;
Protected
Function CreateClaims : TClaims; override;
Function CreateJOSE : TJOSE; override;
Property ClaimsClass: TClaimsClass Read FClaimsClass;
Property JOSEClass: TJOSEClass Read FJOSEClass;
Public
// Pass on the actual Claims/JOSE class to be used. When Nil, defaults are used.
Constructor CreateWithClasses(AClaims: TClaimsClass; AJOSE : TJOSEClass);
// Extract a unique user ID from the claims. By default, this calls GetUniqueUserName
Function GetUniqueUserID : String; virtual;
// Extract a unique user name from the claims. Must be overridden by descendents.
Function GetUniqueUserName : String; virtual;
// Extract a user display name from the claims. By default, this calls GetUniqueUserName
Function GetUserDisplayName : String; virtual;
end;
// OAuth2 client and server settings.
TOAuth2Config = Class(TPersistent)
private
FAuthScope: String;
FAuthURL: String;
FClientID: String;
FClientSecret: String;
FRedirectURI: String;
FDeveloperKey: String;
FHostedDomain: String;
FIncludeGrantedScopes: Boolean;
FOpenIDRealm: String;
FTokenURL: String;
FAccessType: TAccessType;
Protected
Public
Procedure Assign(Source : TPersistent); override;
Procedure SaveToStrings(L : TStrings);
Published
//
// Local OAuth2 client config part.
//
Property ClientID : String Read FClientID Write FClientID;
Property ClientSecret : String Read FClientSecret Write FClientSecret;
Property RedirectURI : String Read FRedirectURI Write FRedirectURI;
Property AccessType : TAccessType Read FAccessType Write FAccessType;
// Specific for google.
Property DeveloperKey : String Read FDeveloperKey Write FDeveloperKey;
Property OpenIDRealm : String Read FOpenIDRealm Write FOpenIDRealm;
//
// Auth Provider part
//
// Domain part, can be substituted on URL to refresh access token
Property HostedDomain : String Read FHostedDomain Write FHostedDomain;
// URL to authenticate a user. used in creating the redirect URL. Can contain %HostedDomain%
Property AuthURL: String Read FAuthURL Write FAuthURL;
// URL To exchange authorization code for access token. Can contain %HostedDomain%
Property TokenURL: String Read FTokenURL Write FTokenURL;
// Authorized Scopes (Google parlance) or resources (Microsoft parlance)
Property AuthScope: String Read FAuthScope Write FAuthScope;
// Google specific: adds AuthScope to existing scopes (incremental increase of authorization).
Property IncludeGrantedScopes : Boolean Read FIncludeGrantedScopes Write FIncludeGrantedScopes;
end;
TOAuth2ConfigClass = Class of TOAuth2Config;
{ TOAuth2Session }
//
// User config part
//
TOAuth2Session = Class(TPersistent)
Private
FRefreshToken: String;
FLoginHint: String;
FIDToken: String;
FState: String;
FAccessToken: String;
FAuthTokenType: String;
FAuthCode: String;
FAuthExpires: TDateTime;
FAuthExpiryPeriod: Integer;
procedure SetAuthExpiryPeriod(AValue: Integer);
Protected
Class Function AuthExpiryMargin : Integer; virtual;
procedure DoLoadFromJSON(AJSON: TJSONObject); virtual;
Public
Procedure LoadTokensFromJSONResponse(Const AJSON : String);
Procedure LoadStartTokensFromVariables(Const Variables : TStrings);
Procedure SaveToStrings(L : TStrings);
procedure Assign(Source: TPersistent); override;
Published
// Authentication code received at the first step of the OAuth2 sequence
Property AuthCode: String Read FAuthCode Write FAuthCode;
// Access token to be used for authorized scopes. Received in step 2 of the OAuth2 sequence;
Property AccessToken: String Read FAccessToken Write FAccessToken;
// Refresh token to renew Access token. received in step 2 of the OAuth2 sequence;
Property RefreshToken : String Read FRefreshToken Write FRefreshToken;
// When does the authentication end, local time.
Property AuthExpires : TDateTime Read FAuthExpires Write FAuthExpires;
// Seconds till access token expires. Setting this will set the AuthExpires property to Now+(AuthExpiryPeriod-AuthExpiryMargin)
Property AuthExpiryPeriod : Integer Read FAuthExpiryPeriod Write SetAuthExpiryPeriod;
// Token type (Bearer)
Property AuthTokenType: String Read FAuthTokenType Write FAuthTokenType;
// State, saved as part of the user config.
Property State : String Read FState Write FState;
// Login hint
Property LoginHint : String Read FLoginHint Write FLoginHint;
// IDToken
Property IDToken : String Read FIDToken Write FIDToken;
end;
TOAuth2SessionClass = Class of TOAuth2Session;
TAbstractOAuth2ConfigStore = CLass(TComponent)
Public
Procedure SaveConfig(AConfig : TOAuth2Config); virtual; abstract;
Procedure LoadConfig(AConfig : TOAuth2Config); virtual; abstract;
Procedure SaveSession(ASession : TOAuth2Session; Const AUser : String); virtual; abstract;
Procedure LoadSession(ASession : TOAuth2Session; Const AUser : String); virtual; abstract;
end;
TAbstractOAuth2ConfigStoreClass = Class of TAbstractOAuth2ConfigStore;
TUserConsentHandler = Procedure (Const AURL : String; Out AAuthCode : String) of object;
TOnAuthConfigChangeHandler = Procedure (Const Sender : TObject; Const AConfig : TOAuth2Config) of object;
TOnAuthSessionChangeHandler = Procedure (Const Sender : TObject; Const ASession : TOAuth2Session) of object;
TOnIDTokenChangeHandler = Procedure (Const Sender : TObject; Const AToken : TJWTIDToken) of object;
TSignRequestHandler = Procedure (Const Sender : TObject; Const ARequest : TWebClientRequest)of object;
TAuthenticateAction = (aaContinue,aaRedirect,aaFail);
{ TOAuth2Handler }
TOAuth2Handler = Class(TAbstractRequestSigner)
private
FAutoStore: Boolean;
FClaimsClass: TClaimsClass;
FConfig: TOAuth2Config;
FConfigLoaded: Boolean;
FIDToken: TJWTIDToken;
FOnAuthSessionChange: TOnAuthSessionChangeHandler;
FOnIDTokenChange: TOnIDTokenChangeHandler;
FSession: TOAuth2Session;
FOnAuthConfigChange: TOnAuthConfigChangeHandler;
FOnSignRequest: TOnAuthSessionChangeHandler;
FOnUserConsent: TUserConsentHandler;
FSessionLoaded: Boolean;
FWebClient: TAbstractWebClient;
FStore : TAbstracTOAuth2ConfigStore;
procedure SetConfig(AValue: TOAuth2Config);
procedure SetSession(AValue: TOAuth2Session);
procedure SetStore(AValue: TAbstracTOAuth2ConfigStore);
Protected
Function RefreshToken: Boolean; virtual;
Function CreateOauth2Config : TOAuth2Config; virtual;
Function CreateOauth2Session : TOAuth2Session; virtual;
Function CreateIDToken : TJWTIDToken; virtual;
Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
Procedure DoAuthConfigChange; virtual;
Procedure DoAuthSessionChange; virtual;
Procedure DoSignRequest(ARequest: TWebClientRequest); override;
Property ConfigLoaded : Boolean Read FConfigLoaded;
Property SessionLoaded : Boolean Read FSessionLoaded;
Public
Class Var DefaultConfigClass : TOAuth2ConfigClass;
Class Var DefaultSessionClass : TOAuth2SessionClass;
Public
Constructor Create(AOwner : TComponent);override;
Destructor Destroy; override;
// Variable name for AuthScope in authentication URL.
// Default = scope. Descendents can override this to provide correct behaviour.
Class Function AuthScopeVariableName : String; virtual;
// Check if config is authenticated.
Function IsAuthenticated : Boolean; virtual;
// Generate an authentication URL
Function AuthenticateURL : String; virtual;
// Check what needs to be done for authentication.
// Do whatever is necessary to mark the request as 'authenticated'.
Function Authenticate: TAuthenticateAction; virtual;
// Load config from store
procedure LoadConfig;
// Save config to store
procedure SaveConfig;
// Load Session from store.If AUser is empty, then ID Token.GetUniqueUser is used.
procedure LoadSession(Const AUser : String = '');
// Save session in store. If AUser is empty, then ID Token.GetUniqueUser is used. Will call OnAuthSessionChange
procedure SaveSession(Const AUser : String = '');
// Refresh ID token from Session.IDToken. Called after token is refreshed or session is loaded.
// This will change the actual IDToken instance.
procedure RefreshIDToken;
// This is populated from Config.IDToken if it is not empty. Do not cache this instance. It is recreated after a call to RefreshIDToken
Property IDToken : TJWTIDToken Read FIDToken;
// Set this to initialize the claims for the ID token. By default, it is TClaims
Property ClaimsClass : TClaimsClass Read FClaimsClass Write FClaimsClass;
Published
// Must be set prior to calling
Property Config : TOAuth2Config Read FConfig Write SetConfig;
// Session info.
Property Session : TOAuth2Session Read FSession Write SetSession;
// Webclient used to do requests to authorization service
Property WebClient : TAbstractWebClient Read FWebClient Write FWebClient;
// Event handler to get user consent if no access token or refresh token is available
Property OnUserConsent : TUserConsentHandler Read FOnUserConsent Write FOnUserConsent;
// Called when the auth config informaion changes
Property OnAuthConfigChange : TOnAuthConfigChangeHandler Read FOnAuthConfigChange Write FOnAuthConfigChange;
// Called when the auth sesson information changes
Property OnAuthSessionChange : TOnAuthSessionChangeHandler Read FOnAuthSessionChange Write FOnAuthSessionChange;
// Called when the IDToken information changes
Property OnIDTokenChange : TOnIDTokenChangeHandler Read FOnIDTokenChange Write FOnIDTokenChange;
// Called when a request is signed
Property OnSignRequest : TOnAuthSessionChangeHandler Read FOnSignRequest Write FOnSignRequest;
// User to load/store parts of the config store.
Property Store : TAbstracTOAuth2ConfigStore Read FStore Write SetStore;
// Call storing automatically when needed.
Property AutoStore : Boolean Read FAutoStore Write FAutoStore;
end;
TOAuth2HandlerClass = Class of TOAuth2Handler;
implementation
uses httpdefs;
Resourcestring
SErrFailedToRefreshToken = 'Failed to refresh access token: Status %d, Error: %s';
{ TOAuth2Handler }
{ Several possibilities:
1. Acess token is available.
A) Access token is not yet expired
-> All is well, continue.
B) Access token is available, but is expired.
Refresh token is
i) Available
-> get new access token using refresh token.
(may fail -> fail)
ii) Not available
-> error.
3. No access token is available.
A) Offline
-> Need to get user consent using callback.
i) User consent results in Access token (AConfig.AuthToken)
-> Auth token is exchanged for a refresh token & access token
ii) User consent failed or no callback.
-> Fail
B) Online: Need to redirect to get access token and auth token.
}
{ TTWTIDToken }
constructor TJWTIDToken.CreateWithClasses(AClaims: TClaimsClass;
AJOSE: TJOSEClass);
begin
FClaimsClass:=AClaims;
FJOSEClass:=AJOSE;
Inherited Create;
end;
function TJWTIDToken.GetUniqueUserID: String;
begin
Result:=GetUniqueUserName;
end;
function TJWTIDToken.GetUniqueUserName: String;
begin
Result:='';
end;
function TJWTIDToken.GetUserDisplayName: String;
begin
Result:=GetUniqueUserName;
end;
function TJWTIDToken.CreateClaims: TClaims;
begin
if FClaimsClass=Nil then
Result:=Inherited CreateClaims
else
Result:=FClaimsClass.Create;
end;
function TJWTIDToken.CreateJOSE: TJOSE;
begin
if FJOSEClass=Nil then
Result:=Inherited CreateJOSE
else
Result:=FJOSEClass.Create;
end;
function TOAuth2Handler.Authenticate: TAuthenticateAction;
Var
S : String;
begin
if IsAuthenticated then
result:=aaContinue
else
Case Config.AccessType of
atonline :
Result:=aaRedirect; // we need to let the user authenticate himself.
atoffline :
if Not Assigned(FOnUserConsent) then
result:=aaFail
else
begin
FOnUserConsent(AuthenticateURL,S);
Session.AuthCode:=S;
// Exchange authcode for access code.
if IsAuthenticated then
result:=aaContinue
else
result:=aaFail
end;
end;
end;
function TOAuth2Handler.AuthenticateURL: String;
begin
Result:=Config.AuthURL
+ '?'+ AuthScopeVariableName+'='+HTTPEncode(Config.AuthScope)
+'&redirect_uri='+HTTPEncode(Config.RedirectUri)
+'&client_id='+HTTPEncode(Config.ClientID)
+'&response_type=code'; // Request refresh token.
if Assigned(Session) then
begin
if (Session.LoginHint<>'') then
Result:=Result +'&login_hint='+HTTPEncode(Session.LoginHint);
if (Session.State<>'') then
Result:=Result +'&state='+HTTPEncode(Session.State);
end;
end;
procedure TOAuth2Handler.SetConfig(AValue: TOAuth2Config);
begin
if FConfig=AValue then Exit;
FConfig.Assign(AValue);
end;
procedure TOAuth2Handler.SetSession(AValue: TOAuth2Session);
begin
if FSession=AValue then Exit;
FSession.Assign(AValue);
end;
procedure TOAuth2Handler.LoadConfig;
begin
if Assigned(Store) and not ConfigLoaded then
begin
Store.LoadConfig(Config);
FConfigLoaded:=True;
end;
end;
procedure TOAuth2Handler.SaveConfig;
begin
if Assigned(Store) then
begin
Store.SaveConfig(Config);
FConfigLoaded:=True;
end;
end;
procedure TOAuth2Handler.LoadSession(const AUser: String);
Var
U : String;
begin
if Assigned(Store) then
begin
U:=AUser;
If (U='') and Assigned(FIDToken) then
U:=FIDToken.GetUniqueUserID;
Store.LoadSession(Session,AUser);
FSessionLoaded:=True;
if (Session.IDToken<>'') then
RefreshIDToken;
end;
end;
procedure TOAuth2Handler.SaveSession(const AUser: String);
Var
U : String;
begin
if Assigned(FOnAuthSessionChange) then
FOnAuthSessionChange(Self,Session);
if Assigned(Store) then
begin
Store.SaveSession(Session,AUser);
FSessionLoaded:=True;
end;
end;
procedure TOAuth2Handler.RefreshIDToken;
begin
FreeAndNil(FIDToken);
if (Session.IDToken<>'') then
begin
FIDtoken:=CreateIDToken;
FIDToken.AsEncodedString:=Session.IDToken;
If Assigned(FOnIDTokenChange) then
FOnIDTokenChange(Self,FIDToken);
end;
end;
function TOAuth2Handler.RefreshToken: Boolean;
Var
URL,Body : String;
D : TJSONData;
Req: TWebClientRequest;
Resp: TWebClientResponse;
begin
LoadConfig;
Req:=Nil;
Resp:=Nil;
D:=Nil;
try
Req:=WebClient.CreateRequest;
Req.Headers.Values['Content-Type']:='application/x-www-form-urlencoded';
url:=Config.TOKENURL;
Body:='client_id='+HTTPEncode(Config.ClientID)+
'&client_secret='+ HTTPEncode(Config.ClientSecret);
if (Session.RefreshToken<>'') then
body:=Body+'&refresh_token='+HTTPEncode(Session.RefreshToken)+
'&grant_type=refresh_token'
else
begin
body:=Body+
'&grant_type=authorization_code'+
'&redirect_uri='+HTTPEncode(Config.RedirectUri)+
'&code='+HTTPEncode(Session.AuthCode);
end;
Req.SetContentFromString(Body);
Resp:=WebClient.ExecuteRequest('POST',url,Req);
Result:=(Resp.StatusCode=200);
if Result then
begin
Session.LoadTokensFromJSONResponse(Resp.GetContentAsString);
If (Session.IDToken)<>'' then
begin
RefreshIDToken;
DoAuthSessionChange;
end;
end
else
Raise EOAuth2.CreateFmt(SErrFailedToRefreshToken,[Resp.StatusCode,Resp.StatusText]);
Result:=True;
finally
D.Free;
Resp.Free;
Req.Free;
end;
end;
function TOAuth2Handler.CreateOauth2Config: TOAuth2Config;
begin
Result:=DefaultConfigClass.Create;
end;
function TOAuth2Handler.CreateOauth2Session: TOAuth2Session;
begin
Result:=DefaultSessionClass.Create;
end;
function TOAuth2Handler.CreateIDToken: TJWTIDToken;
begin
Result:=TJWTIDToken.CreateWithClasses(ClaimsClass,Nil);
end;
procedure TOAuth2Handler.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation=opRemove) then
if AComponent=FStore then
FStore:=Nil;
end;
function TOAuth2Handler.IsAuthenticated: Boolean;
begin
LoadConfig;
// See if we need to load the session
if (Session.RefreshToken='') then
LoadSession;
Result:=(Session.AccessToken<>'');
If Result then
// have access token. Check if it is still valid.
begin
// Not expired ?
Result:=(Now<Session.AuthExpires);
// Expired, but have refresh token ?
if (not Result) and (Session.RefreshToken<>'') then
Result:=RefreshToken;
end
else if (Session.RefreshToken<>'') then
begin
// No access token, but have refresh token
Result:=RefreshToken;
end
else if (Session.AuthCode<>'') then
// No access or refresh token, but have auth code.
Result:=RefreshToken;
end;
{ TOAuth2Handler }
procedure TOAuth2Handler.DoAuthConfigChange;
begin
If Assigned(FOnAuthConfigChange) then
FOnAuthConfigChange(Self,Config);
SaveConfig;
end;
procedure TOAuth2Handler.DoAuthSessionChange;
begin
If Assigned(FOnAuthSessionChange) then
FOnAuthSessionChange(Self,Session);
SaveSession;
end;
procedure TOAuth2Handler.DoSignRequest(ARequest: TWebClientRequest);
Var
TT,AT : String;
begin
if Authenticate=aaContinue then
begin
TT:=Session.AuthTokenType;
AT:=Session.AccessToken;
Arequest.Headers.Add('Authorization: '+TT+' '+HTTPEncode(AT));
end
else
Raise EOAuth2.Create('Cannot sign request: not authorized');
end;
constructor TOAuth2Handler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FConfig:=CreateOauth2Config;
FSession:=CreateOauth2Session;
end;
destructor TOAuth2Handler.Destroy;
begin
FreeAndNil(FIDToken);
FreeAndNil(FConfig);
FreeAndNil(FSession);
inherited Destroy;
end;
class function TOAuth2Handler.AuthScopeVariableName: String;
begin
Result:='scope';
end;
{ TOAuth2Config }
procedure TOAuth2Handler.SetStore(AValue: TAbstracTOAuth2ConfigStore);
begin
if FStore=AValue then Exit;
if Assigned(FStore) then
FStore.RemoveFreeNotification(Self);
FStore:=AValue;
if Assigned(FStore) then
FStore.FreeNotification(Self);
end;
class function TOAuth2Session.AuthExpiryMargin: Integer;
begin
Result:=10;
end;
procedure TOAuth2Session.SetAuthExpiryPeriod(AValue: Integer);
begin
if FAuthExpiryPeriod=AValue then Exit;
FAuthExpiryPeriod:=AValue;
AuthExpires:=Now+AValue/SecsPerDay;
end;
procedure TOAuth2Config.Assign(Source: TPersistent);
Var
C : TOAuth2Config;
begin
if Source is TOAuth2Config then
begin
C:=Source as TOAuth2Config;
FAuthURL:=C.AuthURL;
FTokenURL:=C.TokenURL;
FClientID:=C.ClientID;
FClientSecret:=C.ClientSecret;
FRedirectURI:=C.RedirectURI;
FAccessType:=C.AccessType;
FDeveloperKey:=C.DeveloperKey;
FHostedDomain:=C.HostedDomain;
FIncludeGrantedScopes:=C.IncludeGrantedScopes;
FOpenIDRealm:=C.OpenIDRealm;
FAuthScope:=C.AuthScope;
end
else
inherited Assign(Source);
end;
procedure TOAuth2Config.SaveToStrings(L: TStrings);
Procedure W(N,V : String);
begin
L.Add(N+'='+V);
end;
begin
W('AuthURL',AuthURL);
W('TokenURL',TokenURL);
W('ClientID',ClientID);
W('ClientSecret',ClientSecret);
W('RedirectURI',RedirectURI);
W('AccessType',GetEnumName(TypeInfo(TAccessType),Ord(AccessType)));
W('DeveloperKey',DeveloperKey);
W('HostedDomain',HostedDomain);
W('IncludeGrantedScopes',BoolToStr(IncludeGrantedScopes,True));
W('OpenIDRealm',OpenIDRealm);
W('AuthScope',AuthScope);
end;
procedure TOAuth2Session.SaveToStrings(L: TStrings);
Procedure W(N,V : String);
begin
L.Add(N+'='+V);
end;
begin
W('AuthCode',AuthCode);
W('RefreshToken',RefreshToken);
W('LoginHint',LoginHint);
W('IDToken',IDToken);
W('AccessToken',AccessToken);
W('AuthExpiryPeriod',IntToStr(AuthExpiryPeriod));
W('AuthExpires',DateTimeToStr(AuthExpires));
W('State',State);
W('AuthTokenType',AuthTokenType);
end;
procedure TOAuth2Session.Assign(Source: TPersistent);
Var
C : TOAuth2Session;
begin
if Source is TOAuth2Session then
begin
C:=Source as TOAuth2Session;
FAuthCode:=C.AuthCode;
FRefreshToken:=C.RefreshToken;
FLoginHint:=C.LoginHint;
FIDToken:=C.IDToken;
FAccessToken:=C.AccessToken;
FAuthExpiryPeriod:=C.AuthExpiryPeriod;
FAuthExpires:=C.AuthExpires;
FState:=C.State;
FAuthTokenType:=C.AuthTokenType;
end
else
inherited Assign(Source);
end;
procedure TOAuth2Session.DoLoadFromJSON(AJSON: TJSONObject);
Function Get(Const AName,ADefault : String) : String;
begin
Result:=AJSON.Get(AName,ADefault);
end;
Var
i : Integer;
begin
AccessToken:=Get('access_token',AccessToken);
RefreshToken:=Get('refresh_token',RefreshToken);
AuthTokenType:=Get('token_type',AuthTokenType);
IDToken:=Get('id_token',IDToken);
// Microsoft sends expires_in as String !!
I:=AJSON.IndexOfName('expires_in');
if (I<>-1) then
begin
I:=AJSON.Items[i].AsInteger;
if (I>0) then
AuthExpiryPeriod:=I;
end;
end;
procedure TOAuth2Session.LoadTokensFromJSONResponse(const AJSON: String);
Var
D : TJSONData;
begin
D:=GetJSON(AJSON);
try
DoLoadFromJSON(D as TJSONObject);
finally
D.Free;
end;
end;
procedure TOAuth2Session.LoadStartTokensFromVariables(const Variables: TStrings);
Function Get(Const AName,ADefault : String) : String;
Var
I : Integer;
begin
I:=Variables.IndexOfName(AName);
if I=-1 then
Result:=ADefault
else
Result:=Variables.ValueFromIndex[i];
end;
begin
AuthCode:=Get('code',AuthCode);
LoginHint:=Get('login_hint',LoginHint);
end;
initialization
TOAuth2Handler.DefaultConfigClass:=TOAuth2Config;
TOAuth2Handler.DefaultSessionClass:=TOAuth2Session;
end.

311
packages/fcl-web/src/base/fpoauth2ini.pp Normal file
View File

@ -0,0 +1,311 @@
{ **********************************************************************
This file is part of the Free Component Library (FCL)
Copyright (c) 2015 by the Free Pascal development team
OAuth2 store using an .ini file.
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 fpoauth2ini;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpoauth2, inifiles;
Type
{ TFPOAuth2IniStore }
TFPOAuth2IniStore = Class(TAbstracTOAuth2ConfigStore)
private
FApplicationSection: String;
FConfigFileName: String;
FFileName: String;
FProviderSection: String;
FSessionFileName: String;
FUserSection: String;
procedure EnsureFileName;
Procedure EnsureConfigSections;
Protected
Function DetectSessionFileName : String;
Function EnsureUserSession(ASession: TOAuth2Session): Boolean; virtual;
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Procedure SaveConfigToIni(AIni : TCustomIniFile;AConfig : TOAuth2Config); virtual;
Procedure LoadConfigFromIni(AIni : TCustomIniFile;AConfig : TOAuth2Config); virtual;
Procedure SaveSessionToIni(AIni : TCustomIniFile;ASession : TOAuth2Session); virtual;
Procedure LoadSessionFromIni(AIni : TCustomIniFile;ASession : TOAuth2Session); virtual;
Procedure SaveConfig(AConfig : TOAuth2Config); override;
Procedure LoadConfig(AConfig : TOAuth2Config); override;
Procedure LoadSession(ASession : TOAuth2Session;Const AUser : String); override;
Procedure SaveSession(Asession : TOAuth2Session;Const AUser : String); override;
Published
// Static configuration, readable by web process. Default is app config file.
Property ConfigFileName: String Read FConfigFileName Write FConfigFileName;
// Per-user (session) configuration, writeable by webprocess. Default is temp dir+'oauth-'+ConfigFileName
Property SessionFileName: String Read FSessionFileName Write FSessionFileName;
// Name of application section (Application)
Property ApplicationSection : String Read FApplicationSection Write FApplicationSection;
// Name of provider section (Provider)
Property ProviderSection : String Read FProviderSection Write FProviderSection;
// Name of User session section (username from ID)
Property UserSessionSection : String Read FUserSection Write FUserSection;
end;
implementation
uses typinfo;
Const
// Default sections.
SApplication = 'Application';
SProvider = 'Provider';
Const
SClient = 'Client';
SAuth = 'Authorization';
KeyenableGZIP = 'EnableGZIP';
KeyApplicationName = 'ApplicationName';
KeyMethod = 'Method';
// Application keys
KeyClientID = 'client_id';
KeyClientSecret = 'client_secret';
KeyRedirectURI = 'redirect_uri';
KeyAccessType = 'access_type';
KeyDeveloperKey = 'DeveloperKey';
KeyOpenIDRealm = 'OpenIDRealm';
// Provider keys
KeyHostedDomain = 'HostedDomain';
KeyTokenURL = 'TokenURL';
KeyAuthURL = 'AuthURL';
KeyAuthScope = 'AuthScope';
// User keys
KeyAccessToken = 'access_token';
KeyRefreshToken = 'refresh_token';
KeyTokenType = 'token_type';
KeyExpiresAt = 'expires_at';
KeyExpiresIn = 'expires_in';
KeyLoginHint = 'login_hint';
KeyIDToken = 'id_token';
{ TFPOAuth2IniStore }
Procedure Touch(FN : String);
begin
// FileClose(FileCreate('/tmp/logs/'+fn));
end;
procedure TFPOAuth2IniStore.EnsureFileName;
begin
If (ConfigFileName='') then
ConfigFileName:=GetAppConfigFile(True);
if SessionFIleName='' then
SessionFileName:=GetTempDir(True)+'oauth-'+ExtractFileName(GetAppConfigFile(True));
end;
procedure TFPOAuth2IniStore.EnsureConfigSections;
begin
if (ApplicationSection='') then
ApplicationSection:=SApplication;
if (ProviderSection='') then
ProviderSection:=SProvider;
end;
function TFPOAuth2IniStore.DetectSessionFileName: String;
begin
Result:=FSessionFileName;
If Result='' then
Result:=ConfigFileName
end;
procedure TFPOAuth2IniStore.SaveConfigToIni(AIni: TCustomIniFile; AConfig: TOAuth2Config);
begin
EnsureConfigSections;
Touch('saveconfigfomini');
Touch('saveconfigfomini-app-'+ApplicationSection);
Touch('saveconfigfomini-provider-'+ProviderSection);
With AIni,AConfig do
begin
WriteString(ApplicationSection,KeyClientID,ClientID);
WriteString(ApplicationSection,KeyClientSecret,ClientSecret);
WriteString(ApplicationSection,KeyRedirectURI,RedirectURI);
WriteString(ApplicationSection,KeyDeveloperKey,DeveloperKey);
WriteString(ApplicationSection,KeyOpenIDRealm,OpenIDRealm);
WriteString(ApplicationSection,KeyAccessType,GetEnumName(Typeinfo(TAccessType),Ord(AccessType)));
WriteString(ProviderSection,KeyHostedDomain,HostedDomain);
WriteString(ProviderSection,KeyTokenURL,TokenURL);
WriteString(ProviderSection,KeyAuthURL,AuthURL);
WriteString(ProviderSection,KeyAuthScope,AuthScope);
end;
end;
procedure TFPOAuth2IniStore.LoadConfigFromIni(AIni: TCustomIniFile;
AConfig: TOAuth2Config);
Var
S : String;
i : Integer;
begin
EnsureConfigSections;
Touch('Loadconfigfomini');
Touch('Loadconfigfomini-app-'+ApplicationSection);
Touch('Loadconfigfomini-provider-'+ProviderSection);
With AIni,AConfig do
begin
ClientID:=ReadString(ApplicationSection,KeyClientID,ClientID);
ClientSecret:=ReadString(ApplicationSection,KeyClientSecret,ClientSecret);
RedirectURI:=AIni.ReadString(ApplicationSection,KeyRedirectURI,RedirectURI);
DeveloperKey:=AIni.ReadString(ApplicationSection,KeyDeveloperKey,DeveloperKey);
OpenIDRealm:=AIni.ReadString(ApplicationSection,KeyOpenIDRealm,OpenIDRealm);
S:=AIni.ReadString(ApplicationSection,KeyAccessType,GetEnumName(Typeinfo(TAccessType),Ord(AccessType)));
i:= GetEnumValue(TYpeinfo(TAccessType),S);
if (I<>-1) then
AccessType:=TAccessType(i);
HostedDomain:=ReadString(ProviderSection,KeyHostedDomain,HostedDomain);
TokenURL:=ReadString(ProviderSection,KeyTokenURL,TokenURL);
AuthURL:=ReadString(ProviderSection,KeyAuthURL,AuthURL);
AuthScope:=ReadString(ProviderSection,KeyAuthScope,AuthScope);
end;
end;
procedure TFPOAuth2IniStore.SaveSessionToIni(AIni: TCustomIniFile;
ASession: TOAuth2Session);
begin
Touch('savesessiontoini'+usersessionsection);
With AIni,ASession do
begin
WriteString(UserSessionSection,KeyLoginHint,LoginHint);
WriteString(UserSessionSection,KeyAccessToken,AccessToken);
WriteString(UserSessionSection,KeyRefreshToken,RefreshToken);
WriteString(UserSessionSection,KeyTokenType,AuthTokenType);
WriteInteger(UserSessionSection,KeyExpiresIn,AuthExpiryPeriod);
WriteDateTime(UserSessionSection,KeyExpiresAt,AuthExpires);
WriteString(UserSessionSection,KeyIDToken,IDToken);
end;
end;
procedure TFPOAuth2IniStore.LoadSessionFromIni(AIni: TCustomIniFile;
ASession: TOAuth2Session);
begin
Touch('loadsessionini-'+usersessionsection);
With AIni,ASession do
begin
LoginHint:=ReadString(UserSessionSection,KeyLoginHint,LoginHint);
AccessToken:=ReadString(UserSessionSection,KeyAccessToken,AccessToken);
RefreshToken:=ReadString(UserSessionSection,KeyRefreshToken,RefreshToken);
AuthTokenType:=ReadString(UserSessionSection,KeyTokenType,AuthTokenType);
AuthExpiryPeriod:=ReadInteger(UserSessionSection,KeyExpiresIn,0);
AuthExpires:=ReadDateTime(UserSessionSection,KeyExpiresAt,AuthExpires);
IDToken:=ReadString(UserSessionSection,KeyIDToken,'');
end;
end;
procedure TFPOAuth2IniStore.SaveConfig(AConfig: TOAuth2Config);
Var
Ini : TMemIniFile;
begin
Touch('saveconfig');
EnsureFileName;
Ini:=TMemIniFile.Create(ConfigFileName);
try
SaveConfigToIni(Ini,AConfig);
Ini.UpdateFile;
finally
Ini.Free;
end;
end;
procedure TFPOAuth2IniStore.LoadConfig(AConfig: TOAuth2Config);
Var
Ini : TMemIniFile;
begin
Touch('loadconfig');
EnsureFileName;
Ini:=TMemIniFile.Create(ConfigFileName);
try
LoadConfigFromIni(Ini,AConfig);
finally
Ini.Free;
end;
end;
function TFPOAuth2IniStore.EnsureUserSession(ASession: TOAuth2Session): Boolean;
begin
Result:=(UserSessionSection<>'');
end;
constructor TFPOAuth2IniStore.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
EnsureConfigSections;
end;
destructor TFPOAuth2IniStore.Destroy;
begin
inherited Destroy;
end;
procedure TFPOAuth2IniStore.LoadSession(ASession: TOAuth2Session;
const AUser: String);
Var
Ini : TMemIniFile;
begin
Touch('loadsession');
EnsureFileName;
If not EnsureUserSession(ASession) then
Exit;
Ini:=TMemIniFile.Create(SessionFileName);
try
LoadSessionFromIni(Ini,ASession);
finally
Ini.Free;
end;
end;
procedure TFPOAuth2IniStore.SaveSession(Asession: TOAuth2Session;
const AUser: String);
Var
Ini : TMemIniFile;
begin
EnsureFileName;
If not EnsureUserSession(ASession) then
Exit;
Ini:=TMemIniFile.Create(SessionFileName);
try
SaveSessionToIni(Ini,ASession);
Ini.UpdateFile;
finally
Ini.Free;
end;
end;
end.

343
packages/fcl-web/src/base/fpwebclient.pp Normal file
View File

@ -0,0 +1,343 @@
{ **********************************************************************
This file is part of the Free Component Library (FCL)
Copyright (c) 2015 by the Free Pascal development team
FPWebclient - abstraction for client execution of HTTP requests.
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 fpwebclient;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
{ TRequestResponse }
TRequestResponse = Class(TObject)
private
FHeaders : TStrings;
FStream : TStream;
FOwnsStream : Boolean;
Protected
function GetHeaders: TStrings;virtual;
function GetStream: TStream;virtual;
Public
Destructor Destroy; override;
Procedure SetContentFromString(Const S : String) ;
Function GetContentAsString : String;
// Request headers or response headers
Property Headers : TStrings Read GetHeaders;
// Request content or response content
Property Content: TStream Read GetStream;
end;
{ TWebClientRequest }
TWebClientRequest = Class(TRequestResponse)
Private
FExtraParams : TStrings;
Protected
function GetExtraParams: TStrings; virtual;
Public
Destructor Destroy; override;
Function ParamsAsQuery : String;
// Query Parameters to include in request
Property Params : TStrings Read GetExtraParams;
// If you want the response to go to this stream, set this in the request
Property ResponseContent : TStream Read FStream Write FStream;
end;
{ TResponse }
{ TWebClientResponse }
TWebClientResponse = Class(TRequestResponse)
Protected
Function GetStatusCode : Integer; virtual;
Function GetStatusText : String; virtual;
Public
Constructor Create(ARequest : TWebClientRequest); virtual;
// Status code of request
Property StatusCode : Integer Read GetStatusCode;
// Status text of request
Property StatusText : String Read GetStatusText;
end;
{ TAbstractRequestSigner }
TAbstractRequestSigner = Class(TComponent)
Protected
Procedure DoSignRequest(ARequest : TWebClientRequest); virtual; abstract;
Public
Procedure SignRequest(ARequest : TWebClientRequest);
end;
{ TAbstractResponseExaminer }
TAbstractResponseExaminer = Class(TComponent)
Protected
Procedure DoExamineResponse(AResponse : TWebClientResponse); virtual; abstract;
Public
Procedure ExamineResponse(AResponse : TWebClientResponse);
end;
{ TAbstractWebClient }
TSSLVersion = (svAny,svSSLv2,svSSLv3,svTLSv1,svTLSv11,svTLSv12,svTLSv13);
TSSLVersions = Set of TSSLVersion;
TSSLVersionArray = Array of TSSLVersion;
TAbstractWebClient = Class(TComponent)
private
FExaminer: TAbstractResponseExaminer;
FSigner: TAbstractRequestSigner;
FLogFile : String;
FLogStream : TStream;
FTrySSLVersion: TSSLVersion;
Procedure LogRequest(AMethod, AURL: String; ARequest: TWebClientRequest);
Procedure LogResponse(AResponse: TWebClientResponse);
procedure SetLogFile(AValue: String);
protected
// Write a string to the log file
procedure StringToStream(str: string);
// Must execute the requested method using request/response. Must take ResponseCOntent stream into account
Function DoHTTPMethod(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse; virtual; abstract;
// Must create a request.
Function DoCreateRequest : TWebClientRequest; virtual; abstract;
Public
// Executes the HTTP method AMethod on AURL. Raises an exception on error.
// On success, TWebClientResponse is returned. It must be freed by the caller.
Function ExecuteRequest(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse;
// Same as HTTPMethod, but signs the request first using signer.
Function ExecuteSignedRequest(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse;
// Create a new request. The caller is responsible for freeing the request.
Function CreateRequest : TWebClientRequest;
// These can be set to sign/examine the request/response.
Property RequestSigner : TAbstractRequestSigner Read FSigner Write FSigner;
Property ResponseExaminer : TAbstractResponseExaminer Read FExaminer Write FExaminer;
Property LogFile : String Read FLogFile Write SetLogFile;
property SSLVersion : TSSLVersion Read FTrySSLVersion Write FTrySSLVersion;
end;
TAbstractWebClientClass = Class of TAbstractWebClient;
EFPWebClient = Class(Exception);
Var
DefaultWebClientClass : TAbstractWebClientClass = Nil;
implementation
uses httpdefs;
{ TAbstractRequestSigner }
Procedure TAbstractRequestSigner.SignRequest(ARequest: TWebClientRequest);
begin
DoSignRequest(ARequest);
end;
{ TAbstractResponseExaminer }
Procedure TAbstractResponseExaminer.ExamineResponse(
AResponse: TWebClientResponse);
begin
DoExamineResponse(AResponse);
end;
{ TWebClientRequest }
function TWebClientRequest.GetExtraParams: TStrings;
begin
if FExtraParams=Nil then
FExtraParams:=TStringList.Create;
Result:=FExtraParams;
end;
Destructor TWebClientRequest.Destroy;
begin
FreeAndNil(FExtraParams);
inherited Destroy;
end;
Function TWebClientRequest.ParamsAsQuery: String;
Var
N,V : String;
I : integer;
begin
Result:='';
if Assigned(FextraParams) then
For I:=0 to FextraParams.Count-1 do
begin
If Result<>'' then
Result:=Result+'&';
FextraParams.GetNameValue(I,N,V);
Result:=Result+N+'='+HttpEncode(V);
end;
end;
{ TWebClientResponse }
function TWebClientResponse.GetStatusCode: Integer;
begin
Result:=0;
end;
function TWebClientResponse.GetStatusText: String;
begin
Result:='';
end;
constructor TWebClientResponse.Create(ARequest: TWebClientRequest);
begin
FStream:=ARequest.ResponseContent;
end;
{ TAbstractWebClient }
procedure TAbstractWebClient.SetLogFile(AValue: String);
begin
if FLogFile=AValue then Exit;
if Assigned(FlogStream) then
FreeAndNil(FlogStream);
FLogFile:=AValue;
if (FLogFile<>'') then
if FileExists(FLogFile) then
FLogStream:=TFileStream.Create(FLogFile,fmOpenWrite or fmShareDenyWrite)
else
FLogStream:=TFileStream.Create(FLogFile,fmCreate or fmShareDenyWrite);
end;
procedure TAbstractWebClient.StringToStream(str: string);
begin
if Assigned(FLogStream) then
begin
Str:=Str+sLineBreak;
FlogStream.Write(str[1],length(str));
end;
end;
procedure TAbstractWebClient.LogRequest(AMethod, AURL: String;
ARequest: TWebClientRequest);
Var
I : Integer;
begin
StringToStream(StringOfChar('-',80));
StringToStream('Request : '+AMethod+' '+AURL);
StringToStream('Headers:');
For I:=0 to ARequest.Headers.Count-1 do
StringToStream(ARequest.Headers[I]);
StringToStream('Body:');
FLogStream.CopyFrom(ARequest.Content,0);
ARequest.Content.Position:=0;
StringToStream('');
end;
procedure TAbstractWebClient.LogResponse(AResponse: TWebClientResponse);
Var
I : Integer;
begin
StringToStream(StringOfChar('-',80));
StringToStream('Response : '+IntToStr(AResponse.StatusCode)+' : '+AResponse.StatusText);
StringToStream('Headers:');
For I:=0 to AResponse.Headers.Count-1 do
StringToStream(AResponse.Headers[I]);
StringToStream('Body:');
FLogStream.CopyFrom(AResponse.Content,0);
AResponse.Content.Position:=0;
StringToStream('');
end;
function TAbstractWebClient.ExecuteRequest(const AMethod, AURL: String;
ARequest: TWebClientRequest): TWebClientResponse;
begin
if Assigned(FLogStream) then
LogRequest(AMethod,AURL,ARequest);
Result:=DoHTTPMethod(AMethod,AURL,ARequest);
if Assigned(Result) then
begin
if Assigned(FLogStream) then
LogResponse(Result);
If Assigned(FExaminer) then
FExaminer.ExamineResponse(Result);
end;
end;
function TAbstractWebClient.ExecuteSignedRequest(const AMethod, AURL: String;
ARequest: TWebClientRequest): TWebClientResponse;
begin
If Assigned(FSigner) and Assigned(ARequest) then
FSigner.SignRequest(ARequest);
Result:=ExecuteRequest(AMethod,AURl,ARequest);
end;
function TAbstractWebClient.CreateRequest: TWebClientRequest;
begin
Result:=DoCreateRequest;
end;
{ TRequestResponse }
function TRequestResponse.GetHeaders: TStrings;
begin
if FHeaders=Nil then
begin
FHeaders:=TStringList.Create;
FHeaders.NameValueSeparator:=':';
end;
Result:=FHeaders;
end;
function TRequestResponse.GetStream: TStream;
begin
if (FStream=Nil) then
begin
FStream:=TMemoryStream.Create;
FOwnsStream:=True;
end;
Result:=FStream;
end;
Destructor TRequestResponse.Destroy;
begin
FreeAndNil(FHeaders);
If FOwnsStream then
FreeAndNil(FStream);
inherited Destroy;
end;
Procedure TRequestResponse.SetContentFromString(Const S: String);
begin
if (S<>'') then
Content.WriteBuffer(S[1],SizeOf(Char)*Length(S));
end;
Function TRequestResponse.GetContentAsString: String;
begin
SetLength(Result,Content.Size);
if (Length(Result)>0) then
Content.ReadBuffer(Result[1],Length(Result));
end;
end.

1267
packages/fcl-web/src/base/restbase.pp Normal file
View File

File diff suppressed because it is too large Load Diff

285
packages/fcl-web/src/base/restcodegen.pp Normal file
View File

@ -0,0 +1,285 @@
{ **********************************************************************
This file is part of the Free Component Library (FCL)
Copyright (c) 2015 by the Free Pascal development team
REST classes code generator base.
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 restcodegen;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
{ TRestCodeGenerator }
TRestCodeGenerator = Class(TComponent)
Private
FBaseClassName: String;
FClassPrefix: String;
FExtraUnits: String;
FLicenseText: TStrings;
FOutputUnitName: String;
FSource : TStrings;
Findent : String;
Protected
// Source manipulation
Procedure CreateHeader; virtual;
Procedure IncIndent;
Procedure DecIndent;
Function MakePascalString(S: String; AddQuotes: Boolean=False): String;
Function PrettyPrint(Const S: string): String;
Procedure AddLn(Const Aline: string);
Procedure AddLn(Const Alines : array of string);
Procedure AddLn(Const Alines : TStrings);
Procedure AddLn(Const Fmt: string; Args : Array of const);
Procedure Comment(Const AComment : String; Curly : Boolean = False);
Procedure Comment(Const AComment : Array of String);
Procedure Comment(Const AComment : TStrings);
Procedure ClassHeader(Const AClassName: String); virtual;
Procedure SimpleMethodBody(Lines: Array of string); virtual;
Function BaseUnits : String; virtual;
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
procedure SaveToStream(const AStream: TStream);
Procedure SaveToFile(Const AFileName : string);
Procedure LoadFromFile(Const AFileName : string);
Procedure LoadFromStream(Const AStream : TStream); virtual; abstract;
Procedure Execute; virtual; abstract;
Property Source : TStrings Read FSource;
Published
Property BaseClassName : String Read FBaseClassName Write FBaseClassName;
Property OutputUnitName : String Read FOutputUnitName Write FOutputUnitName;
Property ExtraUnits : String Read FExtraUnits Write FExtraUnits;
Property ClassPrefix : String Read FClassPrefix Write FClassPrefix;
Property LicenseText : TStrings Read FLicenseText;
end;
implementation
{ TRestCodeGenerator }
procedure TRestCodeGenerator.IncIndent;
begin
FIndent:=FIndent+StringOfChar(' ',2);
end;
procedure TRestCodeGenerator.DecIndent;
Var
L : Integer;
begin
L:=Length(Findent);
if L>0 then
FIndent:=Copy(FIndent,1,L-2)
end;
procedure TRestCodeGenerator.AddLn(const Aline: string);
begin
FSource.Add(FIndent+ALine);
end;
procedure TRestCodeGenerator.AddLn(const Alines: array of string);
Var
S : String;
begin
For s in alines do
Addln(S);
end;
procedure TRestCodeGenerator.AddLn(const Alines: TStrings);
Var
S : String;
begin
For s in alines do
Addln(S);
end;
procedure TRestCodeGenerator.AddLn(const Fmt: string; Args: array of const);
begin
AddLn(Format(Fmt,Args));
end;
procedure TRestCodeGenerator.Comment(const AComment: String; Curly: Boolean);
begin
if Curly then
AddLn('{ '+AComment+' }')
else
AddLn('//'+AComment);
end;
procedure TRestCodeGenerator.Comment(const AComment: array of String);
begin
AddLn('{');
IncIndent;
AddLn(AComment);
DecIndent;
AddLn('}');
end;
procedure TRestCodeGenerator.Comment(const AComment: TStrings);
begin
AddLn('{');
IncIndent;
AddLn(AComment);
DecIndent;
AddLn('}');
end;
constructor TRestCodeGenerator.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSource:=TstringList.Create;
FLicenseText:=TstringList.Create;
end;
destructor TRestCodeGenerator.Destroy;
begin
FreeAndNil(FLicenseText);
FreeAndNil(FSource);
inherited Destroy;
end;
procedure TRestCodeGenerator.LoadFromFile(const AFileName: string);
Var
F : TFileStream;
begin
F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(F);
finally
F.Free;
end;
end;
procedure TRestCodeGenerator.SaveToStream(const AStream : TStream);
begin
if (FSource.Count=0) then
Execute;
FSource.SaveToStream(AStream)
end;
procedure TRestCodeGenerator.SaveToFile(const AFileName: string);
Var
F : TFileStream;
B : Boolean;
begin
B:=False;
F:=Nil;
try
B:=(Source.Count=0) and (OutputUnitName='');
if B then
OutputUnitname:=ChangeFileExt(ExtractFileName(AFileName),'');
F:=TFileStream.Create(aFilename,fmCreate);
SaveToStream(F);
finally
F.Free;
if B then
OutputUnitName:='';
end;
end;
procedure TRestCodeGenerator.CreateHeader;
Var
B,S : String;
begin
if LicenseText.Count>0 then
Comment(LicenseText);
addln('{$MODE objfpc}');
addln('{$H+}');
addln('');
addln('interface');
addln('');
S:=ExtraUnits;
B:=BaseUnits;
if (B<>'') then
if (S<>'') then
begin
if (B[Length(B)]<>',') then
B:=B+',';
S:=B+S;
end
else
S:=B;
addln('uses sysutils, classes, %s;',[S]);
addln('');
end;
procedure TRestCodeGenerator.SimpleMethodBody(Lines: array of string);
Var
S : String;
begin
AddLn('');
AddLn('begin');
IncIndent;
For S in Lines do
AddLn(S);
DecIndent;
AddLn('end;');
AddLn('');
end;
function TRestCodeGenerator.BaseUnits: String;
begin
Result:='';
end;
function TRestCodeGenerator.MakePascalString(S: String; AddQuotes: Boolean
): String;
begin
Result:=StringReplace(S,'''','''''',[rfReplaceAll]);
if AddQuotes then
Result:=''''+Result+'''';
end;
function TRestCodeGenerator.PrettyPrint(const S: string): String;
begin
If (S='') then
Result:=''
else
Result:=Upcase(S[1])+Copy(S,2,Length(S)-1);
end;
procedure TRestCodeGenerator.ClassHeader(const AClassName: String);
begin
AddLn('');
AddLn('{ '+StringOfChar('-',68));
AddLn(' '+AClassName);
AddLn(' '+StringOfChar('-',68)+'}');
AddLn('');
end;
end.