diff --git a/.gitattributes b/.gitattributes index ef4680565d..0fffe849f7 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/packages/fcl-web/fpmake.pp b/packages/fcl-web/fpmake.pp index 440f0bc48e..d678e7f578 100644 --- a/packages/fcl-web/fpmake.pp +++ b/packages/fcl-web/fpmake.pp @@ -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; diff --git a/packages/fcl-web/src/base/fphttpwebclient.pp b/packages/fcl-web/src/base/fphttpwebclient.pp new file mode 100644 index 0000000000..4d62ce6513 --- /dev/null +++ b/packages/fcl-web/src/base/fphttpwebclient.pp @@ -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. + diff --git a/packages/fcl-web/src/base/fpjwt.pp b/packages/fcl-web/src/base/fpjwt.pp new file mode 100644 index 0000000000..689971fa4a --- /dev/null +++ b/packages/fcl-web/src/base/fpjwt.pp @@ -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. + diff --git a/packages/fcl-web/src/base/fpoauth2.pp b/packages/fcl-web/src/base/fpoauth2.pp new file mode 100644 index 0000000000..e9cbf3d8e3 --- /dev/null +++ b/packages/fcl-web/src/base/fpoauth2.pp @@ -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'') 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. + diff --git a/packages/fcl-web/src/base/fpoauth2ini.pp b/packages/fcl-web/src/base/fpoauth2ini.pp new file mode 100644 index 0000000000..fc303829f0 --- /dev/null +++ b/packages/fcl-web/src/base/fpoauth2ini.pp @@ -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. + diff --git a/packages/fcl-web/src/base/fpwebclient.pp b/packages/fcl-web/src/base/fpwebclient.pp new file mode 100644 index 0000000000..e8561019e3 --- /dev/null +++ b/packages/fcl-web/src/base/fpwebclient.pp @@ -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. + diff --git a/packages/fcl-web/src/base/restbase.pp b/packages/fcl-web/src/base/restbase.pp new file mode 100644 index 0000000000..4d1ab410c9 --- /dev/null +++ b/packages/fcl-web/src/base/restbase.pp @@ -0,0 +1,1267 @@ +{ ********************************************************************** + This file is part of the Free Component Library (FCL) + Copyright (c) 2015 by the Free Pascal development team + + Base for REST 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 restbase; + +{$mode objfpc}{$H+} +{ $DEFINE DEBUGBASEOBJMEMLEAK} + +interface + +uses + typinfo, fpjson, Classes, SysUtils, contnrs; + +Type + ERESTAPI = Class(Exception); + TStringArray = Array of string; + TUnicodeStringArray = Array of UnicodeString; + TIntegerArray = Array of Integer; + TInt64Array = Array of Int64; + TInt32Array = Array of Integer; + TFloatArray = Array of TJSONFloat; + TDoubleArray = Array of TJSONFloat; + TDateTimeArray = Array of TDateTime; + TBooleanArray = Array of boolean; + TChildType = (ctArray,ctObject); + TChildTypes = Set of TChildType; + + { TBaseObject } + TObjectOption = (ooStartRecordingChanges,ooCreateObjectOnGet); + TObjectOptions = set of TObjectOption; + TDateTimeType = (dtNone,dtDateTime,dtDate,dtTime); + +Const + DefaultObjectOptions = [ooStartRecordingChanges]; // Default for constructor. + IndexShift = 3; // Number of bits reserved for flags. + +Type +{$M+} + + TBaseObject = CLass(TObject) + Private + FObjectOptions : TObjectOptions; + fadditionalProperties : TJSONObject; + FBits : TBits; + Function GetDynArrayProp(P: PPropInfo) : Pointer; virtual; + procedure SetDynArrayProp(P: PPropInfo; AValue : Pointer); virtual; + procedure SetObjectOptions(AValue: TObjectOptions); + Function GetAdditionalProperties : TJSONObject; + protected + Procedure MarkPropertyChanged(AIndex : Integer); + Function IsDateTimeProp(Info : PTypeInfo) : Boolean; + Function DateTimePropType(Info : PTypeInfo) : TDateTimeType; + // Load properties + Procedure ClearProperty(P: PPropInfo); virtual; + Procedure SetBooleanProperty(P: PPropInfo; AValue: Boolean); virtual; + Procedure SetFloatProperty(P: PPropInfo; AValue: Extended); virtual; + Procedure SetInt64Property(P: PPropInfo; AValue: Int64); virtual; + {$ifndef ver2_6} + Procedure SetQWordProperty(P: PPropInfo; AValue: QWord); virtual; + {$endif} + Procedure SetIntegerProperty(P: PPropInfo; AValue: Integer); virtual; + Procedure SetStringProperty(P: PPropInfo; AValue: String); virtual; + Procedure SetArrayProperty(P: PPropInfo; AValue : TJSONArray); virtual; + Procedure SetObjectProperty(P: PPropInfo; AValue : TJSONObject); virtual; + Procedure SetSetProperty(P: PPropInfo; AValue : TJSONArray); virtual; + Procedure SetEnumProperty(P: PPropInfo; AValue : TJSONData); virtual; + // Save properties + Function GetBooleanProperty(P: PPropInfo) : TJSONData; virtual; + Function GetIntegerProperty(P: PPropInfo) : TJSONData; virtual; + Function GetInt64Property(P: PPropInfo) : TJSONData; virtual; + Function GetQwordProperty(P: PPropInfo) : TJSONData; virtual; + Function GetFloatProperty(P: PPropInfo) : TJSONData; virtual; + Function GetStringProperty(P: PPropInfo) : TJSONData; virtual; + Function GetSetProperty(P: PPropInfo) : TJSONData; virtual; + Function GetEnumeratedProperty(P: PPropInfo) : TJSONData; virtual; + Function GetArrayProperty(P: PPropInfo) : TJSONData; virtual; + Function GetObjectProperty(P: PPropInfo) : TJSONData; virtual; + // Clear properties on + Procedure ClearChildren(ChildTypes : TChildTypes); virtual; + Class Function ClearChildTypes : TChildTypes; virtual; + Public + Constructor Create(AOptions : TObjectOptions = DefaultObjectOptions); Virtual; + Destructor Destroy; override; + Procedure StartRecordPropertyChanges; + Procedure ClearPropertyChanges; + Procedure StopRecordPropertyChanges; + Function IsPropertyModified(Info : PPropInfo) : Boolean; + Function IsPropertyModified(const AName : String) : Boolean; + Class Function AllowAdditionalProperties : Boolean; virtual; + Class Function GetTotalPropCount : Integer; virtual; + Class Function GetCurrentPropCount : Integer; virtual; + Class Function GetParentPropCount : Integer; virtual; + Class Function ExportPropertyName(Const AName : String) : string; virtual; + Class Function CleanPropertyName(Const AName : String) : string; + Class Function CreateObject(Const AKind : String) : TBaseObject; + Class Procedure RegisterObject; + Class Function ObjectRestKind : String; virtual; + Procedure LoadPropertyFromJSON(Const AName : String; JSON : TJSONData); virtual; + Function SavePropertyToJSON(Info : PPropInfo) : TJSONData; virtual; + Procedure LoadFromJSON(JSON : TJSONObject); virtual; + Procedure SaveToJSON(JSON : TJSONObject); virtual; + Function SaveToJSON : TJSONObject; + Property ObjectOptions : TObjectOptions Read FObjectOptions Write SetObjectOptions; + Property additionalProperties : TJSONObject Read GetAdditionalProperties; + end; + TBaseObjectClass = Class of TBaseObject; + TObjectArray = Array of TBaseObject; + + { TBaseObjectList } + + TBaseObjectList = Class(TBaseObject) + private + FList : TFPObjectList; + Protected + function GetO(Aindex : Integer): TBaseObject; + procedure SetO(Aindex : Integer; AValue: TBaseObject); + Class Function ObjectClass : TBaseObjectClass; virtual; + Public + Constructor Create(AOptions : TObjectOptions = DefaultObjectOptions); Override; + Destructor Destroy; override; + Function AddObject(Const AKind : String) : TBaseObject; virtual; + Property Objects [Aindex : Integer] : TBaseObject Read GetO Write SetO; default; + end; + + { TBaseObjectList } + + { TBaseNamedObjectList } + + TBaseNamedObjectList = Class(TBaseObject) + private + FList : TStringList; + function GetN(Aindex : Integer): String; + function GetO(Aindex : Integer): TBaseObject; + function GetON(AName : String): TBaseObject; + procedure SetN(Aindex : Integer; AValue: String); + procedure SetO(Aindex : Integer; AValue: TBaseObject); + procedure SetON(AName : String; AValue: TBaseObject); + Protected + Class Function ObjectClass : TBaseObjectClass; virtual; + Public + Constructor Create(AOptions : TObjectOptions = DefaultObjectOptions); Override; + Destructor Destroy; override; + Function AddObject(Const AName,AKind : String) : TBaseObject; virtual; + Property Names [Aindex : Integer] : String Read GetN Write SetN; + Property Objects [Aindex : Integer] : TBaseObject Read GetO Write SetO; + Property ObjectByName [AName : String] : TBaseObject Read GetON Write SetON; default; + end; + + // used to catch a general JSON schema. + { TJSONSchema } + + TJSONSchema = Class(TBaseObject) + private + FSchema: String; + Public + Procedure SetArrayProperty(P: PPropInfo; AValue : TJSONArray); override; + Procedure LoadFromJSON(JSON : TJSONObject); override; + Property Schema : String Read FSchema Write FSchema; + end; + TJSONSchemaArray = Array of TJSONSchema; + TTJSONSchemaArray = TJSONSchemaArray; + + { TObjectFactory } + + TObjectFactory = Class(TComponent) + Private + FList : TClassList; + Public + Constructor Create(AOwner : TComponent); override; + Destructor Destroy; override; + Procedure RegisterObject(A : TBaseObjectClass); + Function GetObjectClass(Const AKind : String) : TBaseObjectClass; + end; + +Function RESTFactory : TObjectFactory; + +Function DateTimeToRFC3339(ADate :TDateTime):string; +Function DateToRFC3339(ADate :TDateTime):string; +Function TimeToRFC3339(ADate :TDateTime):string; +Function TryRFC3339ToDateTime(const Avalue: String; out ADateTime: TDateTime): Boolean; +Function RFC3339ToDateTime(const Avalue: String): TDateTime; + +implementation + +Var + Fact : TObjectFactory; + +function DateTimeToRFC3339(ADate :TDateTime):string; + +begin + Result:=FormatDateTime('yyyy-mm-dd"T"hh:nn:ss.zzz"Z"',ADate); +end; + +function DateToRFC3339(ADate: TDateTime): string; +begin + Result:=FormatDateTime('yyyy-mm-dd',ADate); +end; + +function TimeToRFC3339(ADate :TDateTime):string; + +begin + Result:=FormatDateTime('hh:nn:ss.zzz',ADate); +end; + + +Function TryRFC3339ToDateTime(const Avalue: String; out ADateTime: TDateTime): Boolean; + +// 1 2 +// 12345678901234567890123 +// yyyy-mm-ddThh:nn:ss.zzz + +Type + TPartPos = (ppTime,ppYear,ppMonth,ppDay,ppHour,ppMinute,ppSec); + TPos = Array [TPartPos] of byte; + +Const + P : TPos = (11,1,6,9,12,15,18); + +var + lY, lM, lD, lH, lMi, lS: Integer; + +begin + if Trim(AValue) = '' then + begin + Result:=True; + ADateTime:=0; + end; + lY:=StrToIntDef(Copy(AValue,P[ppYear],4),-1); + lM:=StrToIntDef(Copy(AValue,P[ppMonth],2),-1); + lD:=StrToIntDef(Copy(AValue,P[ppDay],2),-1); + if (Length(AValue)>=P[ppTime]) then + begin + lH:=StrToIntDef(Copy(AValue,P[ppHour],2),-1); + lMi:=StrToIntDef(Copy(AValue,P[ppMinute],2),-1); + lS:=StrToIntDef(Copy(AValue,P[ppSec],2),-1); + end + else + begin + lH:=0; + lMi:=0; + lS:=0; + end; + Result:=(lY>=0) and (lM>=00) and (lD>=0) and (lH>=0) and (lMi>=0) and (ls>=0); + if Not Result then + ADateTime:=0 + else + { Cannot EncodeDate if any part equals 0. EncodeTime is okay. } + if (lY = 0) or (lM = 0) or (lD = 0) then + ADateTime:=EncodeTime(lH, lMi, lS, 0) + else + ADateTime:=EncodeDate(lY, lM, lD) + EncodeTime(lH, lMi, lS, 0); +end; + +Function CountProperties(TypeInfo : PTypeInfo; Recurse : Boolean): Integer; + + function aligntoptr(p : pointer) : pointer;inline; + + begin +{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + result:=align(p,sizeof(p)); +{$else FPC_REQUIRES_PROPER_ALIGNMENT} + result:=p; +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + end; + +var + hp : PTypeData; + pd : ^TPropData; + +begin + Result:=0; + while Assigned(TypeInfo) do + begin + // skip the name + hp:=GetTypeData(Typeinfo); + // the class info rtti the property rtti follows immediatly + pd:=aligntoptr(pointer(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1)); + Result:=Result+Pd^.PropCount; + if Recurse then + TypeInfo:=HP^.ParentInfo + else + TypeInfo:=Nil; + end; +end; + + +Function RFC3339ToDateTime(const Avalue: String): TDateTime; + +begin + if Not TryRFC3339ToDateTime(AValue,Result) then + Result:=0; +end; + +Function RESTFactory : TObjectFactory; + +begin + if Fact=Nil then + Fact:=TObjectfactory.Create(Nil); + Result:=Fact; +end; + +{ TObjectFactory } + +Constructor TObjectFactory.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FList:=TClassList.Create; +end; + +Destructor TObjectFactory.Destroy; +begin + FreeAndNil(FList); + inherited Destroy; +end; + +Procedure TObjectFactory.RegisterObject(A: TBaseObjectClass); +begin + Flist.Add(A); +end; + +Function TObjectFactory.GetObjectClass(Const AKind: String): TBaseObjectClass; + +Var + I : Integer; + N : String; + +begin + I:=FList.Count-1; + Result:=Nil; + While (Result=Nil) and (I>=0) do + begin + Result:=TBaseObjectClass(FList[i]); + N:=Result.ObjectRestKind; + if CompareText(N,AKind)<>0 then + Result:=nil; + Dec(I); + end; +end; + + +{ TBaseNamedObjectList } + +function TBaseNamedObjectList.GetN(Aindex : Integer): String; +begin + Result:=Flist[AIndex]; +end; + +function TBaseNamedObjectList.GetO(Aindex: Integer): TBaseObject; +begin + Result:=TBaseObject(Flist.Objects[AIndex]); +end; + +function TBaseNamedObjectList.GetON(AName : String): TBaseObject; + +Var + I : Integer; + +begin + I:=FList.IndexOf(AName); + if I<>-1 then + Result:=GetO(I) + else + Result:=Nil; +end; + +procedure TBaseNamedObjectList.SetN(Aindex : Integer; AValue: String); +begin + Flist[AIndex]:=Avalue +end; + +procedure TBaseNamedObjectList.SetO(Aindex: Integer; AValue: TBaseObject); +begin + Flist.Objects[AIndex]:=Avalue +end; + +procedure TBaseNamedObjectList.SetON(AName : String; AValue: TBaseObject); +Var + I : Integer; + +begin + I:=FList.IndexOf(AName); + if I<>-1 then + SetO(I,AValue) + else + Flist.AddObject(AName,AValue); +end; + +Class Function TBaseNamedObjectList.ObjectClass: TBaseObjectClass; +begin + Result:=TBaseObject; +end; + +Constructor TBaseNamedObjectList.Create(AOptions : TObjectOptions = DefaultObjectOptions); +begin + inherited Create(AOptions); + FList:=TStringList.Create; + Flist.OwnsObjects:=True; +end; + +Destructor TBaseNamedObjectList.Destroy; +begin + FreeAndNil(Flist); + inherited Destroy; +end; + +Function TBaseNamedObjectList.AddObject(Const AName, AKind: String + ): TBaseObject; +begin + Result:=CreateObject(AKind); + ObjectByName[AName]:=Result; +end; +{ TJSONSchema } + +Procedure TJSONSchema.SetArrayProperty(P: PPropInfo; AValue: TJSONArray); +begin + Schema:=AValue.asJSON +end; + +Procedure TJSONSchema.LoadFromJSON(JSON: TJSONObject); +begin + Schema:=JSON.AsJSON; +end; + +{ TBaseObjectList } + +function TBaseObjectList.GetO(Aindex : Integer): TBaseObject; +begin + Result:=TBaseObject(FList[AIndex]); +end; + +procedure TBaseObjectList.SetO(Aindex : Integer; AValue: TBaseObject); +begin + FList[AIndex]:=AValue; +end; + +Class Function TBaseObjectList.ObjectClass: TBaseObjectClass; +begin + Result:=TBaseObject; +end; + +Constructor TBaseObjectList.Create(AOptions : TObjectOptions = DefaultObjectOptions); +begin + inherited Create(AOptions); + FList:=TFPObjectList.Create; +end; + +Destructor TBaseObjectList.Destroy; +begin + FreeAndNil(FList); + inherited Destroy; +end; + +Function TBaseObjectList.AddObject(const AKind : String): TBaseObject; + +Var + C : TBaseObjectClass; +begin + if (AKind<>'') then + begin + C:=RestFactory.GetObjectClass(AKind); + if Not C.InheritsFrom(ObjectClass) then + Raise ERestAPI.CreateFmt('Cannot add object of kind "%s" to list, associated class "%s" is not a descendent of list class "%s"',[AKind,C.ClassName,ObjectClass.ClassName]); + end; + Result:=ObjectClass.Create; + FList.Add(Result); +end; + +{ TBaseObject } + +function TBaseObject.GetDynArrayProp(P: PPropInfo): Pointer; +begin + Result:=Pointer(GetObjectProp(Self,P)); +end; + +procedure TBaseObject.SetDynArrayProp(P: PPropInfo; AValue: Pointer); +begin + SetObjectProp(Self,P,TObject(AValue)); +end; + +procedure TBaseObject.SetObjectOptions(AValue: TObjectOptions); +begin + if FObjectOptions=AValue then Exit; + FObjectOptions:=AValue; + if ooStartRecordingChanges in FObjectOptions then + StartRecordPropertyChanges +end; + +procedure TBaseObject.MarkPropertyChanged(AIndex: Integer); +begin + If Assigned(FBits) then + FBits.SetOn(GetParentPropCount+(AIndex shr IndexShift)); +end; + +function TBaseObject.IsDateTimeProp(Info: PTypeInfo): Boolean; +begin + Result:=DateTimePropType(Info)<>dtNone; +end; + +function TBaseObject.DateTimePropType(Info: PTypeInfo): TDateTimeType; +begin + Result:=dtNone; + if (Info=TypeInfo(TDateTime)) then + Result:=dtDateTime + else if (Info=TypeInfo(TDate)) then + Result:=dtDate + else if (Info=TypeInfo(TTime)) then + Result:=dtTime +end; + +procedure TBaseObject.ClearProperty(P: PPropInfo); +begin + Case P^.PropType^.Kind of + tkInteger, + tkChar, + tkEnumeration, + tkBool, + tkSet : SetOrdProp(Self,P,0); + tkFloat : SetFloatProp(Self,P,0.0); + tkSString, + tkLString, + tkUChar, + tkAString: SetStrProp(Self,P,''); + tkWChar, + tkWString: SetWideStrProp(Self,P,''); + tkUString: SetUnicodeStrProp(Self,P,''); + tkInt64, + tkQWord : SetInt64Prop(Self,P,0); + tkClass : + begin + GetObjectProp(Self,P).Free; + SetObjectProp(Self,P,Nil); + end + else + // Do nothing + end; +end; + +procedure TBaseObject.SetBooleanProperty(P: PPropInfo; AValue: Boolean); +begin + SetOrdProp(Self,P,Ord(AValue)); +end; + +procedure TBaseObject.SetFloatProperty(P: PPropInfo; AValue: Extended); + +begin + SetFloatProp(Self,P,AValue); +end; + +procedure TBaseObject.SetIntegerProperty(P: PPropInfo; AValue: Integer); + +begin + SetOrdProp(Self,P,AValue); +end; + +procedure TBaseObject.SetInt64Property(P: PPropInfo; AValue: Int64); + +begin + SetInt64Prop(Self,P,AValue); +end; + +{$ifndef ver2_6} +procedure TBaseObject.SetQWordProperty(P: PPropInfo; AValue: QWord); + +begin + SetInt64Prop(Self,P,Int64(AValue)); +end; +{$endif} + +procedure TBaseObject.SetStringProperty(P: PPropInfo; AValue: String); +Var + D : TDateTime; +begin + if not IsDateTimeProp(P^.PropType) then + SetStrProp(Self,P,AValue) + else if TryRFC3339ToDateTime(AValue,D) then + SetFloatProp(Self,P,D) + else + SetFloatProp(Self,P,0) +end; + +procedure TBaseObject.SetArrayProperty(P: PPropInfo; AValue: TJSONArray); + +Var + T : PTypeData; + L : TBaseObjectList; + D : TJSONEnum; + O : TObjectArray; + I : Integer; + PA : ^pdynarraytypeinfo; + ET : PTypeInfo; + AN : String; + AP : Pointer; + S : TJSONSchema; + +begin + if P^.PropType^.Kind=tkClass then + begin + T:=GetTypeData(P^.PropType); + if T^.ClassType.InheritsFrom(TBaseObjectList) then + begin + L:=TBaseObjectList(TBaseObjectClass(T^.ClassType).Create); + SetObjectProp(Self,P,L); + For D in AValue do + L.AddObject('').LoadFromJSON(D.Value as TJSONObject); + end + else if T^.ClassType.InheritsFrom(TJSONSchema) then + begin + S:=TJSONSchema.Create; + S.SetArrayProperty(P,AValue); + SetObjectProp(Self,P,S); + end + else + Raise ERESTAPI.CreateFmt('Unsupported class %s for property %s',[T^.ClassType.ClassName,P^.Name]); + end + else if P^.PropType^.Kind=tkDynArray then + begin + // Get array value + AP:=GetObjectProp(Self,P); + i:=Length(P^.PropType^.name); + PA:=@(pdynarraytypeinfo(P^.PropType)^.elesize)+i; + PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+i; + ET:=PTYpeInfo(PA^); + if ET^.Kind=tkClass then + begin + // get object type name + AN:=PTYpeInfo(PA^)^.Name; + // Free all objects + O:=TObjectArray(AP); + For I:=0 to Length(O)-1 do + FreeAndNil(O[i]); + end; + // Clear array + I:=0; + DynArraySetLength(AP,P^.PropType,1,@i); + // Now, set new length + I:=AValue.Count; + // Writeln(ClassName,' (Array) Setting length of array property ',P^.Name,' (type: ',P^.PropType^.Name,') to ',AValue.Count); + DynArraySetLength(AP,P^.PropType,1,@i); + SetDynArrayProp(P,AP); + // Fill in all elements + For I:=0 to AValue.Count-1 do + begin + Case ET^.Kind of + tkClass : + begin + // Writeln(ClassName,' Adding instance of type: ',AN); + TObjectArray(AP)[I]:=CreateObject(AN); + TObjectArray(AP)[I].LoadFromJSON(AValue.Objects[i]); + end; + tkFloat : + if IsDateTimeProp(ET) then + TDateTimeArray(AP)[I]:=RFC3339ToDateTime(AValue.Strings[i]) + else + TFloatArray(AP)[I]:=AValue.Floats[i]; + tkInt64 : + TInt64Array(AP)[I]:=AValue.Int64s[i]; + tkBool : + begin + TBooleanArray(AP)[I]:=AValue.Booleans[i]; + end; + tkInteger : + TIntegerArray(AP)[I]:=AValue.Integers[i]; + tkUstring, + tkWstring : + TUnicodeStringArray(AP)[I]:=UTF8Decode(AValue.Strings[i]); + tkString, + tkAstring, + tkLString : + begin + // Writeln('Setting String ',i,': ',AValue.Strings[i]); + TStringArray(AP)[I]:=AValue.Strings[i]; + end; + else + Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]); + end; + end; + end; +end; + +procedure TBaseObject.SetObjectProperty(P: PPropInfo; AValue: TJSONObject); +Var + O : TBaseObject; + A: Pointer; + T : PTypeData; + D : TJSONEnum; + AN : String; + I : Integer; + L : TBaseObjectList; + NL : TBaseNamedObjectList; + PA : ^pdynarraytypeinfo; + +begin + if P^.PropType^.Kind=tkDynArray then + begin + A:=GetDynArrayProp(P); + For I:=0 to Length(TObjectArray(A))-1 do + FreeAndNil(TObjectArray(A)[i]); + // Writeln(ClassName,' (Object) Setting length of array property ',P^.Name,'(type: ',P^.PropType^.Name,') to ',AValue.Count,' (current: ',Length(TObjectArray(A)),')'); + SetLength(TObjectArray(A),AValue.Count); + i:=Length(P^.PropType^.name); + PA:=@(pdynarraytypeinfo(P^.PropType)^.elesize)+i; + PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+i; + AN:=PTYpeInfo(PA^)^.Name; + I:=0; + For D in AValue do + begin + O:=CreateObject(AN); + TObjectArray(A)[I]:=O; + // Writeln(ClassName,' Adding instance of type: ',AN,' for key ',D.Key); + if IsPublishedProp(O,'name') then + SetStrProp(O,'name',D.Key); + O.LoadFromJSON(D.Value as TJSONObject); + Inc(I); + end; + // Writeln(ClassName,' Done with array ',P^.Name,', final array length: ', Length(TObjectArray(A))); + SetDynArrayProp(P,A); + { + For I:=0 to Length(TObjectArray(A))-1 do + if IsPublishedProp(TObjectArray(A)[i],'name') then + SetDynArrayProp(P,AP); + // Writeln(ClassName,'.',P^.name,'[',i,'] : ',getStrProp(TObjectArray(A)[I],'name')); + B:=GetDynArrayProp(P); + If Pointer(B)<>Pointer(A) then + // Writeln(ClassName,': Array ',P^.Name,'was not set correctly'); + } + Exit; + end; + if Not (P^.PropType^.Kind=tkClass) then + Raise ERESTAPI.CreateFmt('%s: Unsupported type for property %s',[ClassName,P^.Name]); + T:=GetTypeData(P^.PropType); + if T^.ClassType.InheritsFrom(TBaseObject) then + begin + O:=TBaseObject(GetObjectProp(Self,P,TBaseObject)); + if O=Nil then + begin + O:=TBaseObjectClass(T^.ClassType).Create; + SetObjectProp(Self,P,O); + end; + O.LoadFromJSON(AValue); + end + else if T^.ClassType.InheritsFrom(TBaseObjectList) then + begin + L:=TBaseObjectList(TBaseObjectClass(T^.ClassType).Create); + SetObjectProp(Self,P,L); + For D in AValue do + L.AddObject('').LoadFromJSON(D.Value as TJSONObject); + end + else if T^.ClassType.InheritsFrom(TBaseNamedObjectList) then + begin + NL:=TBaseNamedObjectList(TBaseObjectClass(T^.ClassType).Create); + SetObjectProp(Self,P,L); + For D in AValue do + NL.AddObject(D.Key,'').LoadFromJSON(D.Value as TJSONObject); + end + else + Raise ERESTAPI.CreateFmt('%s: unsupported class %s for property %s',[ClassName, T^.ClassType.ClassName,P^.Name]); +end; + +procedure TBaseObject.SetSetProperty(P: PPropInfo; AValue: TJSONArray); + +type + TSet = set of 0..31; + +var + S,I,V : Integer; + CurValue: string; + EnumTyp: PTypeInfo; + EnumTypData: PTypeData; + +begin + S:=0; + EnumTyp:=GetTypeData(P^.PropType)^.CompType; + EnumTypData:=GetTypeData(EnumTyp); + For I:=0 to AValue.Count-1 do + begin + CurValue:=AValue.Strings[i]; + if Not TryStrToInt(CurValue,V) then + V:=GetEnumValue(EnumTyp,CurValue); + if (VEnumTypData^.MaxValue) or (V>31) then + Raise ERESTAPI.CreateFmt('%s: Invalid value %s for property %s',[ClassName, CurValue,P^.Name]); + Include(TSet(S),V); + end; + SetOrdProp(Self,P,S); +end; + +procedure TBaseObject.SetEnumProperty(P: PPropInfo; AValue: TJSONData); +Var + I : Integer; + +begin + I:=GetEnumValue(P^.PropType,AValue.AsString); + if (I=-1) then + Raise ERESTAPI.CreateFmt('%s: Invalid value %s for property %s',[ClassName, AValue.AsString,P^.Name]); + SetOrdProp(Self,P,I); +end; + +function TBaseObject.GetBooleanProperty(P: PPropInfo): TJSONData; +begin + Result:=TJSONBoolean.Create(GetOrdProp(Self,P)<>0); +end; + +function TBaseObject.GetIntegerProperty(P: PPropInfo): TJSONData; +begin + Result:=TJSONIntegerNumber.Create(GetOrdProp(Self,P)); +end; + +function TBaseObject.GetInt64Property(P: PPropInfo): TJSONData; +begin + Result:=TJSONInt64Number.Create(GetInt64Prop(Self,P)); +end; + +function TBaseObject.GetQwordProperty(P: PPropInfo): TJSONData; +begin + Result:=TJSONInt64Number.Create(Int64(GetInt64Prop(Self,P))); +end; + +function TBaseObject.GetFloatProperty(P: PPropInfo): TJSONData; +begin + Case DateTimePropType(P^.PropType) of + dtDateTime: + Result:=TJSONString.Create(DateTimeToRFC3339(GetFloatProp(Self,P))); + dtDate: + Result:=TJSONString.Create(DateToRFC3339(GetFloatProp(Self,P))); + dtTime: + Result:=TJSONString.Create(TimeToRFC3339(GetFloatProp(Self,P))) ; + else + Result:=TJSONFloatNumber.Create(GetFloatProp(Self,P)); + end; +end; + +function TBaseObject.GetStringProperty(P: PPropInfo): TJSONData; +begin + Result:=TJSONString.Create(GetStrProp(Self,P)); +end; + +function TBaseObject.GetSetProperty(P: PPropInfo): TJSONData; + +type + TSet = set of 0..31; +var + Typ: PTypeInfo; + S, i: integer; +begin + Result:=TJSONArray.Create; + Typ:=GetTypeData(P^.PropType)^.CompType; + S:=GetOrdProp(Self,P); + for i:=Low(TSet) to High(TSet) do + if (i in TSet(S)) then + TJSONArray(Result).Add(TJSONString.Create(GetEnumName(Typ,i))); +end; + + +function TBaseObject.GetEnumeratedProperty(P: PPropInfo): TJSONData; +begin + Result:=TJSONString.Create(GetEnumProp(Self,P)); +end; + +function TBaseObject.GetArrayProperty(P: PPropInfo): TJSONData; + +Var + AO : TObject; + I : Integer; + PA : ^pdynarraytypeinfo; + ET : PTypeInfo; + AP : Pointer; + A : TJSONArray; + O : TJSONObject; + +begin + A:=TJSONArray.Create; + Result:=A; + // Get array value type + AP:=GetObjectProp(Self,P); + i:=Length(P^.PropType^.name); + PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+i; + ET:=PTYpeInfo(PA^); + // Fill in all elements + Case ET^.Kind of + tkClass: + For I:=0 to Length(TObjectArray(AP))-1 do + begin + // Writeln(ClassName,' Adding instance of type: ',AN); + AO:=TObjectArray(AP)[I]; + if AO.InheritsFrom(TBaseObject) then + begin + O:=TJSONObject.Create; + A.Add(O); + TBaseObject(AO).SaveToJSON(O); + end; + end; + tkFloat: + if IsDateTimeProp(ET) then + For I:=0 to Length(TDateTimeArray(AP))-1 do + A.Add(TJSONString.Create(DateTimeToRFC3339(TDateTimeArray(AP)[I]))) + else + For I:=0 to Length(TFloatArray(AP))-1 do + A.Add(TJSONFloatNumber.Create(TFloatArray(AP)[I])); + tkInt64: + For I:=0 to Length(TInt64Array(AP))-1 do + A.Add(TJSONInt64Number.Create(TInt64Array(AP)[I])); + tkBool: + For I:=0 to Length(TInt64Array(AP))-1 do + A.Add(TJSONBoolean.Create(TBooleanArray(AP)[I])); + tkInteger : + For I:=0 to Length(TIntegerArray(AP))-1 do + A.Add(TJSONIntegerNumber.Create(TIntegerArray(AP)[I])); + tkUstring, + tkWstring : + For I:=0 to Length(TUnicodeStringArray(AP))-1 do + A.Add(TJSONString.Create(TUnicodeStringArray(AP)[I])); + tkString, + tkAstring, + tkLString : + For I:=0 to Length(TStringArray(AP))-1 do + A.Add(TJSONString.Create(TStringArray(AP)[I])); + else + Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]); + end; +end; + +function TBaseObject.GetObjectProperty(P: PPropInfo): TJSONData; + +Var + O : TObject; + +begin + O:=GetObjectProp(Self,P); + if (O is TBaseObject) then + Result:=TBaseObject(O).SaveToJSON + else + Result:=Nil; // maybe we need to add an option to return null ? +end; + +procedure TBaseObject.ClearChildren(ChildTypes: TChildTypes); + +Type + TObjectArr = Array of TObject; + +var + PL: PPropList; + P : PPropInfo; + i,j,count,len:integer; + A : pointer; + PA : ^pdynarraytypeinfo; + O : TObject; + +begin + Count:=GetPropList(Self,PL); + try + for i:=0 to Count-1 do + begin + P:=PL^[I]; + case P^.PropType^.Kind of + tkClass: + if (ctObject in ChildTypes) then + begin + // Writeln(ClassName,' Examining object: ',P^.Name); + O:=GetObjectProp(Self,P); + O.Free; + SetObjectProp(Self,P,Nil); + end; + tkDynArray: + if (ctArray in ChildTypes) then + begin + len:=Length(P^.PropType^.Name); + PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+len; + if PTYpeInfo(PA^)^.Kind=tkClass then + begin + A:=GetDynArrayProp(P); +// Writeln(ClassName,' Examining array: ',P^.Name,'Count:',Length(TObjectArr(A))); + For J:=0 to Length(TObjectArr(A))-1 do + begin + FreeAndNil(TObjectArr(A)[J]); + end; + end; + // Length is set to nil by destructor + end; + end; + end; + finally + FreeMem(PL); + end; +end; + +class function TBaseObject.ClearChildTypes: TChildTypes; +begin + Result:=[ctArray,ctObject] +end; + + +{$IFDEF DEBUGBASEOBJMEMLEAK} +Var + ObjCounter : TStrings; +{$ENDIF} +constructor TBaseObject.Create(AOptions: TObjectOptions); +begin +{$IFDEF DEBUGBASEOBJMEMLEAK} + if ObjCounter=Nil then + ObjCounter:=TStringList.Create; + ObjCounter.Values[ClassName]:=IntToStr(StrToIntDef(ObjCounter.Values[ClassName],0)+1); +{$ENDIF} + ObjectOptions:=AOptions; + // Do nothing +end; + +destructor TBaseObject.Destroy; + +begin + StopRecordPropertyChanges; +{$IFDEF DEBUGBASEOBJMEMLEAK} + ObjCounter.Values[ClassName]:=IntToStr(StrToIntDef(ObjCounter.Values[ClassName],0)-1); +{$ENDIF} + FreeAndNil(fadditionalProperties); + if ClearChildTypes<>[] then + ClearChildren(ClearChildTypes); + inherited; +end; + +procedure TBaseObject.StartRecordPropertyChanges; +begin + if Assigned(FBits) then + FBits.ClearAll + else + FBits:=TBits.Create(GetTotalPropCount); +end; + +procedure TBaseObject.ClearPropertyChanges; +begin + FBits.ClearAll; +end; + +procedure TBaseObject.StopRecordPropertyChanges; +begin + FreeAndNil(FBits); +end; + +function TBaseObject.IsPropertyModified(Info: PPropInfo): Boolean; +begin + Result:=Not Assigned(FBits) or FBits.Bits[Info^.NameIndex] +end; + +function TBaseObject.IsPropertyModified(const AName: String): Boolean; +begin + Result:=IsPropertyModified(GetPropInfo(Self,AName)); +end; + +function TBaseObject.GetAdditionalProperties: TJSONObject; +begin + if (fAdditionalProperties=Nil) and AllowAdditionalProperties then + fAdditionalProperties:=TJSONObject.Create; + Result:=fAdditionalProperties +end; + +class function TBaseObject.AllowAdditionalProperties: Boolean; +begin + Result:=False; +end; + +class function TBaseObject.ExportPropertyName(const AName: String): string; +begin + Result:=AName; +end; + +class function TBaseObject.CleanPropertyName(const AName: String): string; + +Const + KW=';absolute;and;array;asm;begin;case;const;constructor;destructor;div;do;'+ + 'downto;else;end;file;for;function;goto;if;implementation;in;inherited;'+ + 'inline;interface;label;mod;nil;not;object;of;on;operator;or;packed;'+ + 'procedure;program;record;reintroduce;repeat;self;set;shl;shr;string;then;'+ + 'to;type;unit;until;uses;var;while;with;xor;dispose;exit;false;new;true;'+ + 'as;class;dispinterface;except;exports;finalization;finally;initialization;'+ + 'inline;is;library;on;out;packed;property;raise;resourcestring;threadvar;try;'+ + 'private;published;'; +Var + I : Integer; + +begin + Result:=Aname; + For I:=Length(Result) downto 1 do + If Not ((Upcase(Result[i]) in ['_','A'..'Z']) + or ((I>1) and (Result[i] in (['0'..'9'])))) then + Delete(Result,i,1); + if Pos(';'+lowercase(Result)+';',KW)<>0 then + Result:='_'+Result +end; + +class function TBaseObject.CreateObject(const AKind: String): TBaseObject; + +Var + C : TBaseObjectClass; + +begin + C:=RESTFactory.GetObjectClass(AKind); + if C<>Nil then + Result:=C.Create + else + Raise ERESTAPI.CreateFmt('Unknown class : "%s"',[AKind]); + // Do nothing +end; + +class procedure TBaseObject.RegisterObject; +begin + RESTFactory.RegisterObject(Self); +end; + +class function TBaseObject.ObjectRestKind: String; +begin + Result:=ClassName; +end; + +class function TBaseObject.GetTotalPropCount: Integer; +begin + Result:=GetTypeData(ClassInfo)^.PropCount; +end; + +class function TBaseObject.GetCurrentPropCount: Integer; +begin + Result:=CountProperties(ClassInfo,False); +end; + +class function TBaseObject.GetParentPropCount: Integer; + +begin + if (ClassParent=TBaseObject) or (ClassParent=Nil) then + Result:=0 + else + Result:=TBaseObjectClass(ClassParent).GetTotalPropCount; +end; + +procedure TBaseObject.LoadPropertyFromJSON(const AName: String; JSON: TJSONData + ); + +Var + P : PPropInfo; + o : TJSONObject; + +begin + // Writeln(ClassName,' loading : ',ANAme,' -> ',CleanPropertyName(aName)); + P:=GetPropInfo(Self,CleanPropertyName(aName)); + if (P=Nil) then + begin + o:=additionalProperties; + if o=Nil then + Raise ERESTAPI.CreateFmt('%s : Unknown property "%s"',[ClassName,AName]); + o.Add(aName,JSON.Clone); + end + else + case JSON.JSONType of + jtstring : + if (P^.PropType^.Kind=tkEnumeration) then + SetEnumProperty(P,JSON) + else + SetStringproperty(P,JSON.AsString); + jtNumber : + case TJSONNumber(JSON).NumberType of + ntFloat : SetFloatProperty(P,JSON.asFloat); + ntInteger : SetIntegerProperty(P,JSON.asInteger); + ntInt64 : SetInt64Property(P,JSON.asInt64); +{$ifndef ver2_6} + ntqword : SetQWordProperty(P,JSON.asQWord); +{$endif} + end; + jtNull : ClearProperty(P); + jtBoolean : SetBooleanProperty(P,json.AsBoolean); + jtArray : + if P^.PropType^.Kind=tkSet then + SetSetProperty(P,TJSONArray(json)) + else + SetArrayProperty(P,TJSONArray(json)); + jtObject : SetObjectProperty(P,TJSONObject(json)); + end; +end; + +function TBaseObject.SavePropertyToJSON(Info: PPropInfo): TJSONData; + +begin + Result:=Nil; + if Not IsPropertyModified(Info) then + Exit; + Case Info^.PropType^.Kind of + tkSet : Result:=GetSetProperty(Info); + tkEnumeration : Result:=GetEnumeratedProperty(Info); + tkAstring, + tkUstring, + tkWString, + tkwchar, + tkuchar, + tkString : Result:=GetStringProperty(Info); + tkFloat : Result:=GetFloatProperty(Info); + tkBool : Result:=GetBooleanProperty(Info); + tkClass : Result:=GetObjectProperty(Info); + tkDynArray : Result:=GetArrayProperty(Info); + tkQWord : Result:=GetQWordProperty(Info); + tkInt64 : Result:=GetInt64Property(Info); + tkInteger : Result:=GetIntegerProperty(Info); + end; +end; + +procedure TBaseObject.LoadFromJSON(JSON: TJSONObject); + +Var + D : TJSONEnum; + +begin + StopRecordPropertyChanges; + For D in JSON Do + LoadPropertyFromJSON(D.Key,D.Value); + StartRecordPropertyChanges; +end; + +procedure TBaseObject.SaveToJSON(JSON: TJSONObject); + +var + PL: PPropList; + P : PPropInfo; + I,Count : integer; + D : TJSONData; + +begin + Count:=GetPropList(Self,PL); + try + for i:=0 to Count-1 do + begin + P:=PL^[I]; + D:=SavePropertyToJSON(P); + if (D<>Nil) then + JSON.add(ExportPropertyName(P^.Name),D); + end; + finally + FreeMem(PL); + end; +end; + +function TBaseObject.SaveToJSON: TJSONObject; +begin + Result:=TJSONObject.Create; + try + SaveToJSON(Result); + except + FreeAndNil(Result); + Raise; + end; +end; + +finalization +{$IFDEF DEBUGBASEOBJMEMLEAK} + if Assigned(ObjCounter) then + begin + Writeln(StdErr,'Object allocate-free count: '); + Writeln(StdErr,ObjCounter.Text); + FreeAndNil(ObjCounter); + end; +{$ENDIF} + FreeAndNil(Fact); +end. + diff --git a/packages/fcl-web/src/base/restcodegen.pp b/packages/fcl-web/src/base/restcodegen.pp new file mode 100644 index 0000000000..ea4deecb8d --- /dev/null +++ b/packages/fcl-web/src/base/restcodegen.pp @@ -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. +