* Add webclient and OAuth2 handler

git-svn-id: trunk@30791 -

.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

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;

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.
+

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.
+

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<Session.AuthExpires);
+    // Expired, but have refresh token ?
+    if (not Result) and (Session.RefreshToken<>'') then
+      Result:=RefreshToken;
+    end
+  else if (Session.RefreshToken<>'') then
+    begin
+    // No access token, but have refresh token
+    Result:=RefreshToken;
+    end
+  else  if (Session.AuthCode<>'') then
+    // No access or refresh token, but have auth code.
+      Result:=RefreshToken;
+end;
+
+
+{ TOAuth2Handler }
+
+
+procedure TOAuth2Handler.DoAuthConfigChange;
+begin
+  If Assigned(FOnAuthConfigChange) then
+    FOnAuthConfigChange(Self,Config);
+  SaveConfig;
+end;
+
+procedure TOAuth2Handler.DoAuthSessionChange;
+begin
+  If Assigned(FOnAuthSessionChange) then
+    FOnAuthSessionChange(Self,Session);
+  SaveSession;
+end;
+
+procedure TOAuth2Handler.DoSignRequest(ARequest: TWebClientRequest);
+
+Var
+  TT,AT : String;
+begin
+  if Authenticate=aaContinue then
+    begin
+    TT:=Session.AuthTokenType;
+    AT:=Session.AccessToken;
+    Arequest.Headers.Add('Authorization: '+TT+' '+HTTPEncode(AT));
+    end
+  else
+    Raise EOAuth2.Create('Cannot sign request: not authorized');
+end;
+
+constructor TOAuth2Handler.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FConfig:=CreateOauth2Config;
+  FSession:=CreateOauth2Session;
+end;
+
+destructor TOAuth2Handler.Destroy;
+begin
+  FreeAndNil(FIDToken);
+  FreeAndNil(FConfig);
+  FreeAndNil(FSession);
+  inherited Destroy;
+end;
+
+class function TOAuth2Handler.AuthScopeVariableName: String;
+begin
+  Result:='scope';
+end;
+
+
+{ TOAuth2Config }
+
+procedure TOAuth2Handler.SetStore(AValue: TAbstracTOAuth2ConfigStore);
+begin
+  if FStore=AValue then Exit;
+  if Assigned(FStore) then
+    FStore.RemoveFreeNotification(Self);
+  FStore:=AValue;
+  if Assigned(FStore) then
+    FStore.FreeNotification(Self);
+end;
+
+class function TOAuth2Session.AuthExpiryMargin: Integer;
+begin
+  Result:=10;
+end;
+
+procedure TOAuth2Session.SetAuthExpiryPeriod(AValue: Integer);
+begin
+  if FAuthExpiryPeriod=AValue then Exit;
+  FAuthExpiryPeriod:=AValue;
+  AuthExpires:=Now+AValue/SecsPerDay;
+end;
+
+
+procedure TOAuth2Config.Assign(Source: TPersistent);
+
+Var
+  C : TOAuth2Config;
+
+begin
+  if Source is TOAuth2Config then
+    begin
+    C:=Source as TOAuth2Config;
+    FAuthURL:=C.AuthURL;
+    FTokenURL:=C.TokenURL;
+    FClientID:=C.ClientID;
+    FClientSecret:=C.ClientSecret;
+    FRedirectURI:=C.RedirectURI;
+    FAccessType:=C.AccessType;
+    FDeveloperKey:=C.DeveloperKey;
+    FHostedDomain:=C.HostedDomain;
+    FIncludeGrantedScopes:=C.IncludeGrantedScopes;
+    FOpenIDRealm:=C.OpenIDRealm;
+    FAuthScope:=C.AuthScope;
+    end
+  else
+    inherited Assign(Source);
+end;
+
+procedure TOAuth2Config.SaveToStrings(L: TStrings);
+  Procedure W(N,V : String);
+
+  begin
+    L.Add(N+'='+V);
+  end;
+
+begin
+  W('AuthURL',AuthURL);
+  W('TokenURL',TokenURL);
+  W('ClientID',ClientID);
+  W('ClientSecret',ClientSecret);
+  W('RedirectURI',RedirectURI);
+  W('AccessType',GetEnumName(TypeInfo(TAccessType),Ord(AccessType)));
+  W('DeveloperKey',DeveloperKey);
+  W('HostedDomain',HostedDomain);
+  W('IncludeGrantedScopes',BoolToStr(IncludeGrantedScopes,True));
+  W('OpenIDRealm',OpenIDRealm);
+  W('AuthScope',AuthScope);
+end;
+
+procedure TOAuth2Session.SaveToStrings(L: TStrings);
+
+  Procedure W(N,V : String);
+
+  begin
+    L.Add(N+'='+V);
+  end;
+
+begin
+  W('AuthCode',AuthCode);
+  W('RefreshToken',RefreshToken);
+  W('LoginHint',LoginHint);
+  W('IDToken',IDToken);
+  W('AccessToken',AccessToken);
+  W('AuthExpiryPeriod',IntToStr(AuthExpiryPeriod));
+  W('AuthExpires',DateTimeToStr(AuthExpires));
+  W('State',State);
+  W('AuthTokenType',AuthTokenType);
+end;
+
+procedure TOAuth2Session.Assign(Source: TPersistent);
+
+Var
+  C : TOAuth2Session;
+
+begin
+  if Source is TOAuth2Session then
+    begin
+    C:=Source as TOAuth2Session;
+    FAuthCode:=C.AuthCode;
+    FRefreshToken:=C.RefreshToken;
+    FLoginHint:=C.LoginHint;
+    FIDToken:=C.IDToken;
+    FAccessToken:=C.AccessToken;
+    FAuthExpiryPeriod:=C.AuthExpiryPeriod;
+    FAuthExpires:=C.AuthExpires;
+    FState:=C.State;
+    FAuthTokenType:=C.AuthTokenType;
+    end
+  else
+    inherited Assign(Source);
+end;
+
+
+procedure TOAuth2Session.DoLoadFromJSON(AJSON: TJSONObject);
+
+  Function Get(Const AName,ADefault : String) : String;
+
+  begin
+    Result:=AJSON.Get(AName,ADefault);
+  end;
+
+Var
+  i : Integer;
+
+begin
+  AccessToken:=Get('access_token',AccessToken);
+  RefreshToken:=Get('refresh_token',RefreshToken);
+  AuthTokenType:=Get('token_type',AuthTokenType);
+  IDToken:=Get('id_token',IDToken);
+  // Microsoft sends expires_in as String !!
+  I:=AJSON.IndexOfName('expires_in');
+  if (I<>-1) then
+    begin
+    I:=AJSON.Items[i].AsInteger;
+    if (I>0) then
+      AuthExpiryPeriod:=I;
+    end;
+end;
+
+procedure TOAuth2Session.LoadTokensFromJSONResponse(const AJSON: String);
+
+Var
+  D : TJSONData;
+
+begin
+  D:=GetJSON(AJSON);
+  try
+    DoLoadFromJSON(D as TJSONObject);
+  finally
+    D.Free;
+  end;
+end;
+
+procedure TOAuth2Session.LoadStartTokensFromVariables(const Variables: TStrings);
+
+  Function Get(Const AName,ADefault : String) : String;
+
+  Var
+    I : Integer;
+
+  begin
+    I:=Variables.IndexOfName(AName);
+    if I=-1 then
+      Result:=ADefault
+    else
+      Result:=Variables.ValueFromIndex[i];
+  end;
+
+begin
+  AuthCode:=Get('code',AuthCode);
+  LoginHint:=Get('login_hint',LoginHint);
+end;
+
+
+initialization
+  TOAuth2Handler.DefaultConfigClass:=TOAuth2Config;
+  TOAuth2Handler.DefaultSessionClass:=TOAuth2Session;
+end.
+

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.
+

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.
+

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 (V<EnumTypData^.MinValue) or (V>EnumTypData^.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.
+

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.
+