{ This file is part of the Free Pascal run time library. Copyright (c) 2019 by the Free Pascal development team SQLDB REST bridge : REST Schema. 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. **********************************************************************} {$IFNDEF FPC_DOTTEDUNITS} unit sqldbrestschema; {$ENDIF FPC_DOTTEDUNITS} {$mode objfpc} {$H+} {$modeswitch typehelpers} {$modeswitch advancedrecords} interface {$IFDEF FPC_DOTTEDUNITS} uses System.Classes, System.SysUtils, System.Contnrs, Data.Db, Data.Sqldb, FpJson.Data; {$ELSE FPC_DOTTEDUNITS} uses Classes, SysUtils, contnrs, db, sqldb, fpjson; {$ENDIF FPC_DOTTEDUNITS} Type TRestFieldType = (rftUnknown,rftInteger,rftLargeInt,rftFloat,rftDate,rftTime,rftDateTime,rftString,rftBoolean,rftBlob); TRestFieldTypes = set of TRestFieldType; TRestFieldOption = (foInKey,foInInsert, foInUpdate,foRequired,foFilter,foOrderBy,foOrderByDesc); TRestFieldOptions = Set of TRestFieldOption; TRestFieldFilter = (rfEqual,rfLessThan,rfGreaterThan,rfLessThanEqual,rfGreaterThanEqual,rfNull); TRestFieldFilters = set of TRestFieldFilter; TSQLKind = (skSelect,skInsert,skUpdate,skDelete); // Must follow Index used below. TSQLKinds = set of TSQLKind; TRestOperation = (roUnknown,roGet,roPost,roPut,roDelete,roOptions,roHead,roPatch); TRestOperations = Set of TRestOperation; TFieldListKind = (flSelect,flInsert,flInsertParams,flUpdate,flWhereKey,flFilter,flOrderby); TFieldListKinds = set of TFieldListKind; TVariableSource = (vsNone,vsQuery,vsContent,vsRoute,vsHeader,vsData,vsParam); TVariableSources = Set of TVariableSource; Const AllRestOperations = [Succ(Low(TRestOperation))..High(TRestOperation)]; AllFieldFilters = [Low(TRestFieldFilter)..High(TRestFieldFilter)]; JSONSchemaRoot = 'schema'; JSONResourcesRoot = 'resources'; JSONConnectionsRoot = 'connections'; JSONConnectionName = 'connectionName'; Type { TBaseRestContext } TBaseRestContext = Class(TObject) private FData: TObject; FUserID: UTF8String; FFreeList : TFPObjectList; Protected Procedure AddToFreeList(aData : TJSONData); // The result of this function will be freed. function DoGetInputData(const aName: UTF8string): TJSONData; virtual; abstract; Procedure DoSetInputData(aName: UTF8string; aValue: TJSONData); virtual; abstract; Function GetConnection : TSQLConnection; virtual; abstract; Function GetTransaction : TSQLTransaction; virtual; abstract; Function GetUpdateData : TDataset; virtual; abstract; Public Destructor Destroy; override; // Call this to get a HTTP Query variable, header,... Function GetVariable(Const aName : UTF8String; aSources : TVariableSources; Out aValue : UTF8String) : Boolean; virtual; abstract; // Get data from input data. Do not free the result ! Function GetInputData(aName : UTF8string) : TJSONData; // Set data from input data. Do not free the result ! Procedure SetInputData(aName : UTF8string; aValue : TJSONData); // This will be set when calling. Property UserID : UTF8String Read FUserID Write FUserID; // You can attach data to this if you want to. It will be kept for the duration of the request. // You are responsible for freeing this data, though. Property Data : TObject Read FData Write FData; // Get connection in use Property Connection : TSQLConnection Read GetConnection; // Get transaction in use Property Transaction : TSQLTransaction Read GetTransaction; // Updated data after PUT/POST/PATCH Property UpdatedData : TDataset Read GetUpdateData; // Property access to input data. You can set this as well in before update handlers. // The value you set will be set Property InputData[aName : UTF8String] : TJSONData Read GetInputData Write SetInputData; end; { ESQLDBRest } ESQLDBRest = Class(Exception) private FResponseCode: Integer; Public Constructor Create(aCode : Integer; Const aMessage : String); Constructor CreateFmt(aCode : Integer; Const Fmt : String; COnst Args: Array of const); Property ResponseCode : Integer Read FResponseCode Write FResponseCode; end; TRestSQLQuery = Class(TSQLQuery) Public Property TableName; end; TSQLDBRestSchema = Class; TSQLDBRestCustomBusinessProcessor = Class; TSQLDBRestBusinessProcessor = Class; { TSQLDBRestField } TSQLDBRestField = class(TCollectionItem) private FFieldName: UTF8String; FFieldType: TRestFieldType; FFilters: TRestFieldFilters; fGeneratorName: String; FMaxLen: Integer; FNativeFieldType: TFieldType; FOptions: TRestFieldOptions; FPublicName: UTF8String; function GetPublicName: UTF8String; Protected Function GetDisplayName: string; override; Public Constructor Create(ACollection: TCollection); override; Procedure Assign(Source: TPersistent); override; Function UseInFieldList(aListKind : TFieldListKind) : Boolean; virtual; Published Property FieldName : UTF8String Read FFieldName Write FFieldName; Property PublicName : UTF8String Read GetPublicName Write FPublicName; Property GeneratorName : String Read fGeneratorName Write FGeneratorName; Property FieldType : TRestFieldType Read FFieldType Write FFieldType; Property NativeFieldType : TFieldType Read FNativeFieldType Write FNativeFieldType; Property Options : TRestFieldOptions Read FOptions Write FOptions; Property Filters : TRestFieldFilters Read FFilters Write FFilters default AllFieldFilters; Property MaxLen : Integer Read FMaxLen Write FMaxLen; end; TSQLDBRestFieldClass = Class of TSQLDBRestField; TSQLDBRestFieldArray = Array of TSQLDBRestField; { TSQLDBRestFieldArrayHelper } TSQLDBRestFieldArrayHelper = type helper for TSQLDBRestFieldArray Function IndexOf(aField : TSQLDBRestField) : Integer; Function Has(aField : TSQLDBRestField) : Boolean; end; TRestFieldPair = Record DBField : TField; RestField :TSQLDBRestField; end; TRestFieldPairArray = Array of TRestFieldPair; TRestFieldOrderPair = Record RestField :TSQLDBRestField; Desc : Boolean; end; TRestFieldOrderPairArray = Array of TRestFieldOrderPair; { TSQLDBRestFieldList } { TSQLDBRestFieldListEnumerator } TSQLDBRestFieldListEnumerator = Class(TCollectionEnumerator) Public function GetCurrent: TSQLDBRestField; reintroduce; property Current: TSQLDBRestField read GetCurrent; end; TSQLDBRestFieldList = class(TCollection) private function GetFields(aIndex : Integer): TSQLDBRestField; procedure SetFields(aIndex : Integer; AValue: TSQLDBRestField); Public Function GetEnumerator: TSQLDBRestFieldListEnumerator; Function AddField(Const aFieldName : UTF8String; aFieldType : TRestFieldType; aOptions : TRestFieldOptions) : TSQLDBRestField; function indexOfFieldName(const aFieldName: UTF8String): Integer; Function FindByFieldName(const aFieldName: UTF8String):TSQLDBRestField; function indexOfPublicName(const aPublicName: UTF8String): Integer; Function FindByPublicName(const aFieldName: UTF8String):TSQLDBRestField; Property Fields[aIndex : Integer] : TSQLDBRestField read GetFields write SetFields; default; end; TSQLDBRestFieldListClass = Class of TSQLDBRestFieldList; { TSQLDBRestParam } TSQLDBRestParam = class(TCollectionItem) private FName: UTF8String; FDefault: UTF8String; FDataType : TFieldType; Protected Function GetDisplayName: string; override; Public Procedure Assign(Source: TPersistent); override; Published Property Name : UTF8String Read FName Write FName; Property DataType : TFieldType Read FDataType Write FDataType; Property DefaultValue : UTF8String Read FDefault Write FDefault; end; TSQLDBRestParamClass = Class of TSQLDBRestParam; TSQLDBRestParamArray = Array of TSQLDBRestParam; { TSQLDBRestParamListEnumerator } TSQLDBRestParamListEnumerator = Class(TCollectionEnumerator) Public function GetCurrent: TSQLDBRestParam; reintroduce; property Current: TSQLDBRestParam read GetCurrent; end; { TSQLDBRestParameterList } TSQLDBRestParameterList = class(TCollection) private function GetParam(aIndex : Integer): TSQLDBRestParam; procedure SetParam(aIndex : Integer; AValue: TSQLDBRestParam); Public Function GetEnumerator: TSQLDBRestParamListEnumerator; Function IndexOf(Const aName : string) : Integer; Function Find(Const aName : string) : TSQLDBRestParam; Function ParamByName(Const aName : string) : TSQLDBRestParam; Function AddParam(Const aName : string) : TSQLDBRestParam; Property Params[aIndex : Integer] : TSQLDBRestParam Read GetParam Write SetParam;default; end; TSQLDBRestParameterListClass = Class of TSQLDBRestParameterList; { TSQLDBRestResource } TSQLDBRestGetDatasetEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64; Var aDataset : TDataset) of object; TSQLDBRestCheckParamsEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; aOperation : TRestOperation; Params : TParams) of object; TSQLDBRestAllowRecordEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; aDataSet : TDataset; var allowRecord : Boolean) of object; TSQLDBRestAllowResourceEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; var allowResource : Boolean) of object; TSQLDBRestAllowedOperationsEvent = Procedure (aSender : TObject; aContext : TBaseRestContext; var aOperations : TRestOperations) of object; TSQLDBRestOnGetWhere = Procedure(Sender : TObject; aContext : TBaseRestContext; aKind : TSQLKind; var aWhere : UTF8String) of object; TProcessIdentifier = Function (const S: UTF8String): UTF8String of object; TSQLDBRestResource = class(TCollectionItem) private FBusinessProcessor: TSQLDBRestCustomBusinessProcessor; FAllowedOperations: TRestOperations; FConnectionName: UTF8String; FEnabled: Boolean; FFields: TSQLDBRestFieldList; FInMetadata: Boolean; FOnAllowedOperations: TSQLDBRestAllowedOperationsEvent; FOnAllowRecord: TSQLDBRestAllowRecordEvent; FOnCheckParams: TSQLDBRestCheckParamsEvent; FOnGetDataset: TSQLDBRestGetDatasetEvent; FOnGetWhere: TSQLDBRestOnGetWhere; FOnResourceAllowed: TSQLDBRestAllowResourceEvent; FParameters: TSQLDBRestParameterList; FResourceName: UTF8String; FTableName: UTF8String; FSQL : Array[TSQLKind] of TStrings; function GetResourceName: UTF8String; function GetSQL(AIndex: Integer): TStrings; function GetSQLTyped(aKind : TSQLKind): TStrings; procedure SetAllowedOperations(AValue: TRestOperations); procedure SetFields(AValue: TSQLDBRestFieldList); procedure SetParameters(AValue: TSQLDBRestParameterList); procedure SetSQL(AIndex: Integer; AValue: TStrings); Protected Function GetDisplayName: string; override; Public Class var DefaultFieldListClass : TSQLDBRestFieldListClass; DefaultFieldClass: TSQLDBRestFieldClass; DefaultParameterListClass : TSQLDBRestParameterListClass; DefaultParamClass : TSQLDBRestParamClass; Class function CreateFieldList : TSQLDBRestFieldList; virtual; Class function CreateParamList : TSQLDBRestParameterList; virtual; Class function FieldTypeToRestFieldType(aFieldType: TFieldType): TRestFieldType; virtual; Class Constructor Init; Public Constructor Create(ACollection: TCollection); override; Destructor Destroy; override; Procedure CheckParams(aContext : TBaseRestContext; aOperation : TRestoperation; P : TParams); Function GetDataset(aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64) : TDataset; Function GetSchema : TSQLDBRestSchema; function GenerateDefaultSQL(aKind: TSQLKind; OnlyFields: TSQLDBRestFieldArray = nil): UTF8String; virtual; Procedure Assign(Source: TPersistent); override; Function AllowRecord(aContext : TBaseRestContext; aDataset : TDataset) : Boolean; Function AllowResource(aContext : TBaseRestContext) : Boolean; Function GetAllowedOperations(aContext : TBaseRestContext) : TRestOperations; Function GetHTTPAllow : String; virtual; function GetFieldList(aListKind: TFieldListKind; const ASep : String = ''; OnlyFields : TSQLDBRestFieldArray = Nil): UTF8String; function GetFieldArray(aListKind: TFieldListKind): TSQLDBRestFieldArray; Function GetResolvedSQl(aKind : TSQLKind; Const AWhere : UTF8String; Const aOrderBy : UTF8String = ''; const aLimit : UTF8String = ''; OnlyFields : TSQLDBRestFieldArray = nil) : UTF8String; Function ProcessSQl(const aSQL : String; Const AWhere : UTF8String; Const aOrderBy : UTF8String = ''; const aLimit : UTF8String = '') : UTF8String; Procedure PopulateFieldsFromFieldDefs(Defs : TFieldDefs; aIndexFields : TStringArray; aProcessIdentifier : TProcessIdentifier; aMinFieldOpts : TRestFieldOptions); Procedure PopulateParametersFromSQL(const SQL : String; DoClear : Boolean = True); function DoCompleteWhere(aContext : TBaseRestContext; aKind: TSQLKind; const aWhere: UTF8String ): UTF8String; Property SQL [aKind : TSQLKind] : TStrings Read GetSQLTyped; Property BusinessProcessor : TSQLDBRestCustomBusinessProcessor Read FBusinessProcessor; Published Property Fields : TSQLDBRestFieldList Read FFields Write SetFields; Property Parameters : TSQLDBRestParameterList Read FParameters Write SetParameters; Property Enabled : Boolean Read FEnabled Write FEnabled default true; Property InMetadata : Boolean Read FInMetadata Write FInMetadata default true; Property ConnectionName : UTF8String read FConnectionName Write FConnectionName; Property TableName : UTF8String read FTableName Write FTableName; Property ResourceName : UTF8String read GetResourceName Write FResourceName; Property AllowedOperations : TRestOperations Read FAllowedOperations Write SetAllowedOperations; Property SQLSelect : TStrings Index 0 Read GetSQL Write SetSQL; Property SQLInsert : TStrings Index 1 Read GetSQL Write SetSQL; Property SQLUpdate : TStrings Index 2 Read GetSQL Write SetSQL; Property SQLDelete : TStrings Index 3 Read GetSQL Write SetSQL; Property OnResourceAllowed : TSQLDBRestAllowResourceEvent Read FOnResourceAllowed Write FOnResourceAllowed; Property OnAllowedOperations : TSQLDBRestAllowedOperationsEvent Read FOnAllowedOperations Write FOnAllowedOperations; Property OnGetDataset : TSQLDBRestGetDatasetEvent Read FOnGetDataset Write FOnGetDataset; Property OnCheckParams : TSQLDBRestCheckParamsEvent Read FOnCheckParams Write FOnCheckParams; Property OnAllowRecord : TSQLDBRestAllowRecordEvent Read FOnAllowRecord Write FOnAllowRecord; Property OnGetWhere : TSQLDBRestOnGetWhere Read FOnGetWhere Write FOnGetWhere; end; { TSQLDBRestResourceList } TSQLDBRestResourceList = Class(TOwnedCollection) private function GetResource(aIndex : Integer): TSQLDBRestResource; procedure SetResource(aIndex : Integer; AValue: TSQLDBRestResource); Public Function Schema : TSQLDBRestSchema; Function AddResource(Const aTableName : UTF8String; Const aResourceName : UTF8String) : TSQLDBRestResource; Function indexOfTableName(Const aTableName : UTF8String) : Integer; Function indexOfResourceName(Const aResourceName : UTF8String) : Integer; Function FindResourceByName(Const aResourceName : UTF8String) : TSQLDBRestResource; Function FindResourceByTableName(Const aTableName : UTF8String) : TSQLDBRestResource; Procedure SaveToFile(Const aFileName : UTF8String); Procedure SaveToStream(Const aStream : TStream); function AsJSON(const aPropName: UTF8String=''): TJSONData; Procedure LoadFromFile(Const aFileName : UTF8String); Procedure LoadFromStream(Const aStream : TStream); Procedure FromJSON(aData: TJSONData;const aPropName: UTF8String=''); Property Resources[aIndex : Integer] : TSQLDBRestResource read GetResource write SetResource; default; end; { TSQLDBRestSchema } TSQLDBRestSchema = Class(TComponent) private FConnectionName: UTF8String; FResources: TSQLDBRestResourceList; FProcessors : TFPList; procedure SetResources(AValue: TSQLDBRestResourceList); Protected function CreateResourceList: TSQLDBRestResourceList; virtual; function ProcessIdentifier(const S: UTF8String): UTF8String; virtual; Function AttachProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor) : Boolean; Virtual; Function DetachProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor) : Boolean; Virtual; Procedure AttachAllProcessors; virtual; Procedure DetachAllProcessors; virtual; Public Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; Procedure RemoveBusinessProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor); Procedure AddBusinessProcessor(aProcessor : TSQLDBRestCustomBusinessProcessor); Procedure SaveToFile(Const aFileName : UTF8String); Procedure SaveToStream(Const aStream : TStream); function AsJSON(const aPropName: UTF8String=''): TJSONData; Procedure LoadFromFile(Const aFileName : UTF8String); Procedure LoadFromStream(Const aStream : TStream); Procedure FromJSON(aData: TJSONData;const aPropName: UTF8String=''); Class function GetPrimaryIndexFields(Q: TSQLQuery): TStringArray; virtual; procedure PopulateResourceFields(aConn: TSQLConnection; aRes: TSQLDBRestResource; aMinFieldOpts : TRestFieldOptions = []); virtual; procedure PopulateResources(aConn: TSQLConnection; aTables: array of string; aMinFieldOpts: TRestFieldOptions= []); Procedure PopulateResources(aConn : TSQLConnection; aTables : TStrings = Nil; aMinFieldOpts : TRestFieldOptions = []); Published Property Resources : TSQLDBRestResourceList Read FResources Write SetResources; Property ConnectionName : UTF8String Read FConnectionName Write FConnectionName; end; TCustomViewResource = Class(TSQLDBRestResource) end; { TSQLDBRestCustomBusinessProcessor } TSQLDBRestCustomBusinessProcessor = Class(TComponent) private FResource: TSQLDBRestResource; FResourceName: UTF8String; procedure SetResourceName(AValue: UTF8String); Protected Function GetSchema : TSQLDBRestSchema; virtual; Function GetAllowedOperations(aContext : TBaseRestContext; aDefault : TRestOperations) : TRestOperations; virtual; abstract; Function AllowResource(aContext : TBaseRestContext) : Boolean; virtual; abstract; Procedure CheckParams(aContext : TBaseRestContext; aOperation : TRestoperation; P : TParams); virtual; abstract; Function GetDataset(aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64) : TDataset; virtual;abstract; Function AllowRecord(aContext : TBaseRestContext;aDataset : TDataset) : Boolean; virtual; abstract; Function ProcessWhereSQL(aContext : TBaseRestContext; aKind : TSQLKind; const aWhere : UTF8String) : UTF8String; virtual; Public Property Resource : TSQLDBRestResource Read FResource; Property ResourceName : UTF8String Read FResourceName Write SetResourceName; end; { TSQLDBRestBusinessProcessor } TOnGetHTTPAllow = Procedure(Sender : TObject; Var aHTTPAllow) of object; TRestDatabaseEvent = Procedure(Sender : TObject; aOperation : TRestOperation; aContext: TBaseRestContext; aResource : TSQLDBRestResource) of object; TSQLDBRestBusinessProcessor = class(TSQLDBRestCustomBusinessProcessor) private FOnAllowedOperations: TSQLDBRestAllowedOperationsEvent; FOnAllowRecord: TSQLDBRestAllowRecordEvent; FOnCheckParams: TSQLDBRestCheckParamsEvent; FOnGetDataset: TSQLDBRestGetDatasetEvent; FOnGetWhere: TSQLDBRestOnGetWhere; FOnResourceAllowed: TSQLDBRestAllowResourceEvent; FSchema: TSQLDBRestSchema; FAfterDatabaseRead: TRestDatabaseEvent; FAfterDatabaseUpdate: TRestDatabaseEvent; FBeforeDatabaseRead: TRestDatabaseEvent; FBeforeDatabaseUpdate: TRestDatabaseEvent; procedure SetSchema(AValue: TSQLDBRestSchema); Protected Function GetSchema : TSQLDBRestSchema; override; Function AllowResource(aContext : TBaseRestContext) : Boolean; override; Function GetAllowedOperations(aContext : TBaseRestContext; aDefault : TRestOperations) : TRestOperations; override; Procedure CheckParams(aContext : TBaseRestContext; aOperation : TRestoperation; P : TParams); override; Function GetDataset(aContext : TBaseRestContext; aFieldList : TRestFieldPairArray; aOrderBy : TRestFieldOrderPairArray; aLimit, aOffset : Int64) : TDataset; override; Function AllowRecord(aContext : TBaseRestContext; aDataset : TDataset) : Boolean; override; Function ProcessWhereSQL(aContext : TBaseRestContext; aKind : TSQLKind; const aWhere : UTF8String) : UTF8String; override; Published Property Schema : TSQLDBRestSchema Read GetSchema Write SetSchema; Property ResourceName; Property OnGetDataset : TSQLDBRestGetDatasetEvent Read FOnGetDataset Write FOnGetDataset; Property OnCheckParams : TSQLDBRestCheckParamsEvent Read FOnCheckParams Write FOnCheckParams; Property OnAllowResource : TSQLDBRestAllowResourceEvent Read FOnResourceAllowed Write FOnResourceAllowed; Property OnAllowedOperations : TSQLDBRestAllowedOperationsEvent Read FOnAllowedOperations Write FOnAllowedOperations; Property OnAllowRecord : TSQLDBRestAllowRecordEvent Read FOnAllowRecord Write FOnAllowRecord; Property OnGetWhere : TSQLDBRestOnGetWhere Read FOnGetWhere Write FOnGetWhere; Published Property BeforeDatabaseUpdate : TRestDatabaseEvent Read FBeforeDatabaseUpdate Write FBeforeDatabaseUpdate; Property AfterDatabaseUpdate : TRestDatabaseEvent Read FAfterDatabaseUpdate Write FAfterDatabaseUpdate; Property BeforeDatabaseRead: TRestDatabaseEvent Read FBeforeDatabaseRead Write FBeforeDatabaseRead; Property AfterDatabaseRead : TRestDatabaseEvent Read FAfterDatabaseRead Write FAfterDatabaseRead; end; Const TypeNames : Array[TRestFieldType] of string = ('?','int','bigint','float','date','time','datetime','string','bool','blob'); RestMethods : Array[TRestOperation] of string = ('','GET','POST','PUT','DELETE','OPTIONS','HEAD','PATCH'); implementation {$IFDEF FPC_DOTTEDUNITS} uses System.StrUtils, FpJson.Rtti,Data.Consts, FpWeb.RestBridge.Consts; {$ELSE FPC_DOTTEDUNITS} uses strutils, fpjsonrtti,dbconst, sqldbrestconst; {$ENDIF FPC_DOTTEDUNITS} { TSQLDBRestParam } function TSQLDBRestParam.GetDisplayName: string; begin Result:=Name; if Result='' then Result:=inherited GetDisplayName; end; procedure TSQLDBRestParam.Assign(Source: TPersistent); var P : TSQLDBRestParam absolute Source; begin if Source is TSQLDBRestParam then begin FName:=P.Name; FDataType:=P.DataType; FDefault:=P.DefaultValue; end else inherited Assign(Source); end; { TSQLDBRestParamListEnumerator } function TSQLDBRestParamListEnumerator.GetCurrent: TSQLDBRestParam; begin Result:=TSQLDBRestParam(Inherited GetCurrent); end; { TSQLDBRestParameterList } function TSQLDBRestParameterList.GetParam(aIndex : Integer): TSQLDBRestParam; begin Result:=Items[aIndex] as TSQLDBRestParam; end; procedure TSQLDBRestParameterList.SetParam(aIndex : Integer; AValue: TSQLDBRestParam); begin Items[aIndex]:=aValue; end; function TSQLDBRestParameterList.GetEnumerator: TSQLDBRestParamListEnumerator; begin Result:=TSQLDBRestParamListEnumerator.Create(Self); end; function TSQLDBRestParameterList.IndexOf(const aName: string): Integer; begin Result:=Count-1; While (Result>=0) and Not SameText(aName,GetParam(Result).Name) do Dec(Result); end; function TSQLDBRestParameterList.Find(const aName: string): TSQLDBRestParam; var Idx : Integer; begin Result:=Nil; Idx:=IndexOf(aName); if (Idx<>-1) then Result:=GetParam(Idx); end; function TSQLDBRestParameterList.ParamByName(const aName: string): TSQLDBRestParam; begin Result:=Find(aName); if Result=Nil then Raise ESQLDBRest.CreateFmt(500,SErrUnknownParam,[aName]); end; function TSQLDBRestParameterList.AddParam(const aName: string): TSQLDBRestParam; begin if IndexOf(aName)<>-1 then Raise ESQLDBRest.CreateFmt(500,SErrDuplicateParam,[aName]); Result:=Add as TSQLDBRestParam; Result.Name:=aName; Result.DataType:=ftString; end; { TSQLDBRestFieldListEnumerator } function TSQLDBRestFieldListEnumerator.GetCurrent: TSQLDBRestField; begin Result:=TSQLDBRestField(Inherited GetCurrent); end; { TSQLDBRestFieldArrayHelper } function TSQLDBRestFieldArrayHelper.IndexOf(aField: TSQLDBRestField): Integer; begin Result:=Length(Self)-1; While (Result>=0) and (Self[Result]<>aField) do Dec(Result); end; function TSQLDBRestFieldArrayHelper.Has(aField: TSQLDBRestField): Boolean; begin Result:=IndexOf(aField)<>-1; end; { TBaseRestContext } destructor TBaseRestContext.Destroy; begin FreeAndNil(FFreeList); inherited Destroy; end; procedure TBaseRestContext.AddToFreeList(aData: TJSONData); begin If Not Assigned(FFreeList) then FFreeList:=TFPObjectList.Create(True); FFreeList.Add(aData) end; function TBaseRestContext.GetInputData(aName: UTF8string): TJSONData; begin Result:=DoGetInputData(aName); // Don't burden the user with freeing this. if Assigned(Result) then AddToFreeList(Result); end; procedure TBaseRestContext.SetInputData(aName: UTF8string; aValue: TJSONData); begin DoSetInputData(aName,aValue); end; { TSQLDBRestCustomBusinessProcessor } procedure TSQLDBRestCustomBusinessProcessor.SetResourceName(AValue: UTF8String); Var S : TSQLDBRestSchema; begin if FResourceName=AValue then Exit; // Reregister, so the attachment happens to the correct resource S:=GetSchema; If (FResourceName<>'') and Assigned(S) then S.RemoveBusinessProcessor(Self); FResourceName:=AValue; S:=GetSchema; If (FResourceName<>'') and Assigned(S) then S.AddBusinessProcessor(Self); end; function TSQLDBRestCustomBusinessProcessor.GetSchema: TSQLDBRestSchema; begin Result:=Nil; end; function TSQLDBRestCustomBusinessProcessor.ProcessWhereSQL(aContext : TBaseRestContext; aKind : TSQLKind; const aWhere: UTF8String ): UTF8String; begin Result:=aWhere; // Silence compiler if aKind<>skSelect then ; end; { TSQLDBRestBusinessProcessor } procedure TSQLDBRestBusinessProcessor.SetSchema(AValue: TSQLDBRestSchema); begin if FSchema=AValue then Exit; if Assigned(FSchema) and (ResourceName<>'') then begin FSchema.RemoveBusinessProcessor(Self); FSchema.RemoveFreeNotification(Self); end; FSchema:=AValue; if Assigned(FSchema) and (ResourceName<>'') then begin FSchema.AddBusinessProcessor(Self); FSchema.FreeNotification(Self); end end; function TSQLDBRestBusinessProcessor.GetSchema: TSQLDBRestSchema; begin Result:=FSchema; end; function TSQLDBRestBusinessProcessor.AllowResource(aContext: TBaseRestContext ): Boolean; begin Result:=True; if Assigned(FOnResourceAllowed) then FOnResourceAllowed(Self,aContext,Result); end; function TSQLDBRestBusinessProcessor.GetAllowedOperations( aContext: TBaseRestContext; aDefault: TRestOperations): TRestOperations; begin Result:=aDefault; if Assigned(FOnAllowedOperations) then FOnAllowedOperations(Self,aContext,Result); end; procedure TSQLDBRestBusinessProcessor.CheckParams(aContext: TBaseRestContext; aOperation: TRestoperation; P: TParams); begin if Assigned(FOnCheckParams) then FOnCheckParams(Self,aContext,aOperation,P); end; function TSQLDBRestBusinessProcessor.GetDataset(aContext : TBaseRestContext; aFieldList: TRestFieldPairArray; aOrderBy: TRestFieldOrderPairArray; aLimit, aOffset: Int64): TDataset; begin Result:=nil; if Assigned(FOnGetDataset) then FOnGetDataset(Self,aContext,aFieldList,aOrderBy,aLimit,aOffset,Result); end; function TSQLDBRestBusinessProcessor.AllowRecord(aContext : TBaseRestContext; aDataset: TDataset): Boolean; begin Result:=True; if Assigned(FOnAllowRecord) then FOnAllowRecord(Self,acontext,aDataset,Result); end; function TSQLDBRestBusinessProcessor.ProcessWhereSQL(aContext : TBaseRestContext; aKind: TSQLKind; const aWhere: UTF8String): UTF8String; begin Result:=inherited ProcessWhereSQL(aContext, aKind, aWhere); if Assigned(FOnGetWhere) then FOnGetWhere(Self,aContext,aKind,Result); end; { ESQLDBRest } constructor ESQLDBRest.Create(aCode: Integer; const aMessage: String); begin FResponseCode:=aCode; HelpContext:=aCode; Inherited create(aMessage); end; constructor ESQLDBRest.CreateFmt(aCode: Integer; const Fmt: String; const Args: array of const); begin FResponseCode:=aCode; HelpContext:=aCode; Inherited CreateFmt(Fmt,Args); end; { TSQLDBRestSchema } procedure TSQLDBRestSchema.SetResources(AValue: TSQLDBRestResourceList); begin if FResources=AValue then Exit; FResources.Assign(AValue); end; constructor TSQLDBRestSchema.Create(AOwner: TComponent); begin inherited Create(AOwner); FResources:=CreateResourceList; FProcessors:=TFPList.Create; end; function TSQLDBRestSchema.CreateResourceList: TSQLDBRestResourceList; begin Result:=TSQLDBRestResourceList.Create(Self,TSQLDBRestResource); end; destructor TSQLDBRestSchema.Destroy; begin FreeAndNil(FProcessors); FreeAndNil(FResources); inherited Destroy; end; procedure TSQLDBRestSchema.RemoveBusinessProcessor( aProcessor: TSQLDBRestCustomBusinessProcessor); begin DetachProcessor(aProcessor); FProcessors.Remove(aProcessor); end; procedure TSQLDBRestSchema.AddBusinessProcessor( aProcessor: TSQLDBRestCustomBusinessProcessor); begin FProcessors.Remove(aProcessor); AttachProcessor(aProcessor); end; procedure TSQLDBRestSchema.SaveToFile(const aFileName: UTF8String); Var F : TFileStream; begin F:=TFileStream.Create(aFileName,fmCreate); try SaveToStream(F); finally F.Free; end; end; procedure TSQLDBRestSchema.SaveToStream(const aStream: TStream); Var D : TJSONData; S : TJSONStringType; begin D:=asJSON(JSONSchemaRoot); try S:=D.FormatJSON(); finally D.Free; end; aStream.WriteBuffer(S[1],Length(S)*SizeOf(TJSONCharType)); end; function TSQLDBRestSchema.AsJSON(const aPropName: UTF8String): TJSONData; begin Result:=TJSONObject.Create([JSONResourcesRoot,Resources.AsJSON(),JSONConnectionName,ConnectionName]); if (aPropName<>'') then Result:=TJSONObject.Create([aPropName,Result]); end; procedure TSQLDBRestSchema.LoadFromFile(const aFileName: UTF8String); Var F : TFileStream; begin F:=TFileStream.Create(aFileName,fmOpenRead or fmShareDenyWrite); try LoadFromStream(F); finally F.Free; end; end; procedure TSQLDBRestSchema.LoadFromStream(const aStream: TStream); Var D : TJSONData; begin D:=GetJSON(aStream); try FromJSON(D,JSONSchemaRoot); finally D.Free; end; end; procedure TSQLDBRestSchema.FromJSON(aData: TJSONData; const aPropName: UTF8String); Var J : TJSONObject; begin J:=aData as TJSONObject; if (aPropName<>'') then J:=J.Objects[aPropName]; Resources.FromJSON(J,JSONResourcesRoot); ConnectionName:=J.Get(JSONConnectionName,''); AttachAllProcessors; end; function TSQLDBRestSchema.ProcessIdentifier(const S: UTF8String): UTF8String; begin Result:=S; end; function TSQLDBRestSchema.AttachProcessor(aProcessor: TSQLDBRestCustomBusinessProcessor): Boolean; Var Res : TSQLDBRestResource; begin if aProcessor.ResourceName='' then exit; Res:=FResources.FindResourceByName(aProcessor.ResourceName); Result:=Assigned(Res); if Result then begin Res.FBusinessProcessor:=aProcessor; aProcessor.FResource:=Res; end; end; function TSQLDBRestSchema.DetachProcessor(aProcessor: TSQLDBRestCustomBusinessProcessor): Boolean; Var Res : TSQLDBRestResource; begin if aProcessor.ResourceName='' then exit; Res:=FResources.FindResourceByName(aProcessor.ResourceName); Result:=Assigned(Res); if Result then begin Res.FBusinessProcessor:=Nil; aProcessor.FResource:=Nil; end; end; procedure TSQLDBRestSchema.AttachAllProcessors; Var I : integer; begin For I:=0 to FProcessors.Count-1 do AttachProcessor(TSQLDBRestCustomBusinessProcessor(FProcessors[i])); end; procedure TSQLDBRestSchema.DetachAllProcessors; Var I : integer; begin For I:=0 to FProcessors.Count-1 do DetachProcessor(TSQLDBRestCustomBusinessProcessor(FProcessors[i])); end; class function TSQLDBRestSchema.GetPrimaryIndexFields(Q: TSQLQuery): TStringArray; Var C,I : Integer; Fields : UTF8String; begin Result:=Default(TStringArray); Q.ServerIndexDefs.Update; I:=0; Fields:=''; With Q.ServerIndexDefs do While (Fields='') and (i'') then IndexFields:=GetPrimaryIndexFields(Q); aRes.PopulateFieldsFromFieldDefs(Q.FieldDefs,IndexFields,@ProcessIdentifier,aMinFieldOpts) finally Q.Free; end; end; procedure TSQLDBRestSchema.PopulateResources(aConn: TSQLConnection; aTables: array of string; aMinFieldOpts: TRestFieldOptions); Var L : TStringList; S : String; begin L:=TStringList.Create; try L.Capacity:=Length(aTables); For S in aTables do L.Add(S); L.Sorted:=True; PopulateResources(aConn,L,aMinFieldOpts); finally l.Free; end; end; procedure TSQLDBRestSchema.PopulateResources(aConn: TSQLConnection; aTables : TStrings = Nil; aMinFieldOpts : TRestFieldOptions = []); Var L : TStrings; S,N : UTF8String; R : TSQLDBRestResource; begin L:=TStringList.Create; try aConn.Connected:=True; aConn.GetTableNames(L); For S in L do begin N:=ProcessIdentifier(S); if SameStr(N,S) then // No SameText, Allow to change case N:=''; if (aTables=Nil) or (aTables.IndexOf(S)=-1) then begin R:=Resources.AddResource(S,N); PopulateResourceFields(aConn,R,aMinFieldOpts); end; end; finally L.Free; end; end; { TSQLDBRestResourceList } function TSQLDBRestResourceList.GetResource(aIndex : Integer): TSQLDBRestResource; begin Result:=TSQLDBRestResource(Items[aIndex]) end; procedure TSQLDBRestResourceList.SetResource(aIndex : Integer; AValue: TSQLDBRestResource); begin Items[aIndex]:=aValue; end; function TSQLDBRestResourceList.Schema: TSQLDBRestSchema; begin If (Owner is TSQLDBRestSchema) then Result:=Owner as TSQLDBRestSchema else Result:=Nil; end; function TSQLDBRestResourceList.AddResource(const aTableName: UTF8String; const aResourceName: UTF8String): TSQLDBRestResource; Var N : UTF8String; begin N:=aResourceName; if N='' then N:=aTableName; if (N='') then Raise ESQLDBRest.Create(500,SErrResourceNameEmpty); if indexOfResourceName(N)<>-1 then Raise ESQLDBRest.CreateFmt(500,SErrDuplicateResource,[N]); Result:=add as TSQLDBRestResource; Result.TableName:=aTableName; Result.ResourceName:=aResourceName; end; function TSQLDBRestResourceList.indexOfTableName(const aTableName: UTF8String): Integer; begin Result:=Count-1; While (Result>=0) and not SameText(aTableName,GetResource(Result).TableName) do Dec(Result); end; function TSQLDBRestResourceList.indexOfResourceName(const aResourceName: UTF8String): Integer; begin Result:=Count-1; While (Result>=0) and not SameText(aResourceName,GetResource(Result).ResourceName) do Dec(Result); end; function TSQLDBRestResourceList.FindResourceByName(const aResourceName: UTF8String): TSQLDBRestResource; Var Idx : Integer; begin idx:=indexOfResourceName(aResourceName); if Idx=-1 then Result:=nil else Result:=GetResource(Idx); end; function TSQLDBRestResourceList.FindResourceByTableName(const aTableName: UTF8String): TSQLDBRestResource; Var Idx : Integer; begin idx:=indexOfTableName(aTableName); if Idx=-1 then Result:=nil else Result:=GetResource(Idx); end; procedure TSQLDBRestResourceList.SaveToFile(const aFileName: UTF8String); Var F : TFileStream; begin F:=TFileStream.Create(aFileName,fmCreate); try SaveToStream(F); finally F.Free; end; end; procedure TSQLDBRestResourceList.SaveToStream(const aStream: TStream); Var D : TJSONData; S : TJSONStringType; begin D:=asJSON(JSONResourcesRoot); try S:=D.FormatJSON(); finally D.Free; end; aStream.WriteBuffer(S[1],Length(S)*SizeOf(TJSONCharType)); end; function TSQLDBRestResourceList.AsJSON(const aPropName: UTF8String = ''): TJSONData; Var S : TJSONStreamer; A : TJSONArray; begin S:=TJSONStreamer.Create(Nil); try A:=S.StreamCollection(Self); finally S.Free; end; if aPropName='' then Result:=A else Result:=TJSONObject.Create([aPropName,A]); end; procedure TSQLDBRestResourceList.LoadFromFile(const aFileName: UTF8String); Var F : TFileStream; begin F:=TFileStream.Create(aFileName,fmOpenRead or fmShareDenyWrite); try LoadFromStream(F); finally F.Free; end; end; procedure TSQLDBRestResourceList.LoadFromStream(const aStream: TStream); Var D : TJSONData; begin D:=GetJSON(aStream); try FromJSON(D,JSONResourcesRoot); finally D.Free; end; end; procedure TSQLDBRestResourceList.FromJSON(aData: TJSONData; const aPropName: UTF8String); Var A : TJSONArray; D : TJSONDestreamer; begin if (aPropName<>'') then A:=(aData as TJSONObject).Arrays[aPropName] else A:=aData as TJSONArray; D:=TJSONDestreamer.Create(Nil); try Clear; D.JSONToCollection(A,Self); finally D.Free; end; end; { TSQLDBRestResource } function TSQLDBRestResource.GetResourceName: UTF8String; begin Result:=FResourceName; if Result='' then Result:=FTableName; end; function TSQLDBRestResource.GetSQL(AIndex: Integer): TStrings; begin Result:=FSQL[TSQLKind(aIndex)]; end; function TSQLDBRestResource.GetSQLTyped(aKind : TSQLKind): TStrings; begin Result:=FSQL[aKind]; end; procedure TSQLDBRestResource.SetAllowedOperations(AValue: TRestOperations); begin if FAllowedOperations=AValue then Exit; FAllowedOperations:=AValue; end; procedure TSQLDBRestResource.SetFields(AValue: TSQLDBRestFieldList); begin if FFields=AValue then Exit; FFields.Assign(AValue); end; procedure TSQLDBRestResource.SetParameters(AValue: TSQLDBRestParameterList); begin if FParameters=AValue then Exit; FParameters.Assign(AValue); end; procedure TSQLDBRestResource.SetSQL(AIndex: Integer; AValue: TStrings); begin FSQL[TSQLKind(aIndex)].Assign(aValue); end; function TSQLDBRestResource.GetDisplayName: string; begin Result:=ResourceName; end; constructor TSQLDBRestResource.Create(ACollection: TCollection); Var K : TSQLKind; begin inherited Create(ACollection); FFields:=CreateFieldList; FParameters:=CreateParamList; FEnabled:=True; FInMetadata:=True; for K in TSQLKind do FSQL[K]:=TStringList.Create; FAllowedOperations:=AllRestOperations; end; destructor TSQLDBRestResource.Destroy; Var K : TSQLKind; begin If Assigned(FBusinessProcessor) then FBusinessProcessor.FResource:=Nil; FreeAndNil(FFields); for K in TSQLKind do FreeAndNil(FSQL[K]); inherited Destroy; end; procedure TSQLDBRestResource.CheckParams(aContext : TBaseRestContext; aOperation: TRestoperation; P: TParams); begin if Assigned(FOnCheckParams) then FOnCheckParams(Self,aContext,aOperation,P) else if Assigned(FBusinessProcessor) then FBusinessProcessor.CheckParams(aContext,aOperation,P) end; function TSQLDBRestResource.GetDataset(aContext : TBaseRestContext; aFieldList: TRestFieldPairArray; aOrderBy: TRestFieldOrderPairArray; aLimit, aOffset: Int64): TDataset; begin Result:=Nil; If Assigned(FOnGetDataset) then FOnGetDataset(Self,aContext,aFieldList,aOrderBy,aLimit,aOffset,Result) else if Assigned(FBusinessProcessor) then Result:=FBusinessProcessor.GetDataset(aContext,aFieldList,aOrderBy,aLimit,aOffset); end; function TSQLDBRestResource.GetSchema: TSQLDBRestSchema; begin If Assigned(Collection) and (Collection is TSQLDBRestResourceList) then Result:=TSQLDBRestResourceList(Collection).Schema else Result:=Nil; end; procedure TSQLDBRestResource.Assign(Source: TPersistent); Var R : TSQLDBRestResource; K : TSQLKind; begin if (Source is TSQLDBRestResource) then begin R:=Source as TSQLDBRestResource; for K in TSQLKind do SQL[K].Assign(R.SQL[K]); Fields.Assign(R.Fields); Parameters.Assign(R.Parameters); TableName:=R.TableName; FResourceName:=R.FResourceName; ConnectionName:=R.ConnectionName; Enabled:=R.Enabled; InMetadata:=R.InMetadata; FAllowedOperations:=R.AllowedOperations; OnResourceAllowed:=R.OnResourceAllowed; OnAllowedOperations:=R.OnAllowedOperations; OnGetDataset:=R.OnGetDataset; OnCheckParams:=R.OnCheckParams; OnAllowRecord:=R.OnAllowRecord; end else inherited Assign(Source); end; function TSQLDBRestResource.AllowRecord(aContext : TBaseRestContext; aDataset: TDataset): Boolean; begin Result:=True; if Assigned(FOnAllowRecord) then FOnAllowRecord(Self,aContext,aDataset,Result) else if Assigned(FBusinessProcessor) then Result:=FBusinessProcessor.AllowRecord(aContext,aDataset); end; function TSQLDBRestResource.AllowResource(aContext : TBaseRestContext): Boolean; begin Result:=True; If Assigned(FOnResourceAllowed) then FOnResourceAllowed(Self,aContext,Result) else If Assigned(FBusinessProcessor) then Result:=FBusinessProcessor.AllowResource(aContext); end; function TSQLDBRestResource.GetAllowedOperations(aContext: TBaseRestContext ): TRestOperations; begin Result:=AllowedOperations; if Assigned(FOnAllowedOperations) then FOnAllowedOperations(Self,aContext,Result) else if Assigned(FBusinessProcessor) then Result:=FBusinessProcessor.GetAllowedOperations(aContext,Result); end; function TSQLDBRestResource.GetHTTPAllow: String; Procedure AddR(const s : String); begin if (Result<>'') then Result:=Result+', '; Result:=Result+S; end; Var O : TRestOperation; begin Result:=''; For O in TRestOperation do if (O<>roUnknown) and (O in AllowedOperations) then AddR(RestMethods[O]); end; function TSQLDBRestResource.GetFieldList(aListKind: TFieldListKind; const ASep: String; OnlyFields: TSQLDBRestFieldArray): UTF8String; Const SepComma = ', '; SepAND = ' AND '; SepSpace = ' '; Const DefaultSeps : Array[TFieldListKind] of string = (sepComma,sepComma,sepComma,sepComma,sepAnd,sepSpace,sepComma); Const Wheres = [flWhereKey]; Colons = Wheres + [flInsertParams,flUpdate]; UseEqual = Wheres+[flUpdate]; Function AllowField (F :TSQLDBRestField) : Boolean; inline; begin Result:=F.UseInFieldList(aListKind) and ((Length(OnlyFields)=0) or (OnlyFields.Has(F))); end; Var Sep,Term,Res,Prefix : UTF8String; I : Integer; F : TSQLDBRestField; begin Prefix:=''; Sep:=aSep; if Sep='' then begin Sep:=DefaultSeps[aListKind]; If aListKind in Colons then Prefix:=':'; end; Res:=''; For I:=0 to Fields.Count-1 do begin Term:=''; F:=Fields[i]; if allowfield(F) then begin Term:=Prefix+F.FieldName; if (aSep='') and (aListKind in UseEqual) then begin Term := F.FieldName+' = '+Term; if (aListKind in Wheres) then Term:='('+Term+')'; end; end; if (Term<>'') then begin If (Res<>'') then Res:=Res+Sep; Res:=Res+Term; end; end; Result:=Res; end; function TSQLDBRestResource.GetFieldArray(aListKind: TFieldListKind ): TSQLDBRestFieldArray; Var I,aCount : Integer; F : TSQLDBRestField; begin Result:=Default(TSQLDBRestFieldArray); aCount:=0; SetLength(Result,Fields.Count); For I:=0 to Fields.Count-1 do begin F:=Fields[i]; if F.UseInFieldList(aListKind) then begin Result[aCount]:=F; Inc(aCount); end; end; SetLength(Result,aCount); end; function TSQLDBRestResource.GenerateDefaultSQL(aKind: TSQLKind; OnlyFields : TSQLDBRestFieldArray = nil) : UTF8String; begin Case aKind of skSelect : Result:='SELECT '+GetFieldList(flSelect,'',OnlyFields)+' FROM '+TableName+' %FULLWHERE% %FULLORDERBY% %LIMIT%'; skInsert : Result:='INSERT INTO '+TableName+' ('+GetFieldList(flInsert,'',OnlyFields)+') VALUES ('+GetFieldList(flInsertParams)+')'; skUpdate : Result:='UPDATE '+TableName+' SET '+GetFieldList(flUpdate,'',OnlyFields)+' %FULLWHERE%'; skDelete : Result:='DELETE FROM '+TableName+' %FULLWHERE%'; else Raise ESQLDBRest.CreateFmt(500,SErrUnknownStatement,[Ord(aKind)]); end; end; function TSQLDBRestResource.GetResolvedSQl(aKind: TSQLKind; const AWhere: UTF8String; const aOrderBy: UTF8String; const aLimit: UTF8String; OnlyFields: TSQLDBRestFieldArray): UTF8String; begin Result:=SQL[aKind].Text; if (Result='') then Result:=GenerateDefaultSQL(aKind,OnlyFields); Result:=ProcessSQL(Result,aWhere,aOrderBy,aLimit); end; function TSQLDBRestResource.DoCompleteWhere(aContext : TBaseRestContext; aKind: TSQLKind;const aWhere : UTF8String) : UTF8String; begin Result:=aWhere; if Assigned(OnGetWhere) then FOnGetWhere(Self,aContext, aKind,Result); if Assigned(BusinessProcessor) then Result:=BusinessProcessor.ProcessWhereSQL(aContext, aKind, Result); end; function TSQLDBRestResource.ProcessSQl(const aSQL: String; const AWhere: UTF8String; const aOrderBy: UTF8String; const aLimit: UTF8String): UTF8String; Var S : UTF8String; begin Result:=aSQL; // from tables %FULLWHERE% if (aWhere<>'') then S:='WHERE '+aWhere else S:=''; Result:=StringReplace(Result,'%FULLWHERE%',S,[rfReplaceAll]); // from tables WHERE %REQUIREDWHERE% if (aWhere<>'') then S:=aWhere else S:='(1=0)'; Result:=StringReplace(Result,'%REQUIREDWHERE%',S,[rfReplaceAll]); // from tables WHERE X=Y %OPTIONALWHERE% if (aWhere<>'') then S:='AND ('+aWhere+')' else S:=''; Result:=StringReplace(Result,'%OPTIONALWHERE%',S,[rfReplaceAll]); // from tables WHERE X=Y AND %WHERE% if (aWhere<>'') then S:='('+aWhere+')' else S:=''; Result:=StringReplace(Result,'%WHERE%',S,[rfReplaceAll]); if (aOrderBy<>'') then S:='ORDER BY '+AOrderBy else S:=''; Result:=StringReplace(Result,'%FULLORDERBY%',S,[rfReplaceAll]); Result:=StringReplace(Result,'%ORDERBY%',aOrderBy,[rfReplaceAll]); Result:=StringReplace(Result,'%LIMIT%',aLimit,[rfReplaceAll]); end; class function TSQLDBRestResource.FieldTypeToRestFieldType( aFieldType: TFieldType): TRestFieldType; Const Map : Array[TFieldType] of TRestFieldType = (rftUnknown, rftString, rftInteger, rftInteger, rftInteger, // ftUnknown, ftString, ftSmallint, ftInteger, ftWord, rftBoolean, rftFloat, rftFloat, rftFloat, rftDate, rftTime, rftDateTime, // ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, rftBlob, rftBlob, rftInteger, rftBlob, rftString, rftUnknown, rftString, // ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, rftUnknown, rftUnknown, rftUnknown, rftUnknown, rftString, // ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, rftString, rftLargeInt, rftUnknown, rftUnknown, rftUnknown, // ftWideString, ftLargeint, ftADT, ftArray, ftReference, rftUnknown, rftBlob, rftBlob, rftUnknown, rftUnknown, // ftDataSet, ftOraBlob, ftOraClob, ftVariant, ftInterface, rftUnknown, rftString, rftDateTime, rftFloat, rftString, rftString // ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd, ftFixedWideChar, ftWideMemo {$IFNDEF VER3_2_2} ,rftDateTime, rftDateTime, rftInteger, rftInteger, rftInteger, rftFloat, // ftOraTimeStamp, ftOraInterval, ftLongWord, ftShortint, ftByte, ftExtended rftFloat // Single {$ENDIF} ); begin Result:=Map[aFieldType]; end; class constructor TSQLDBRestResource.Init; begin DefaultFieldListClass:=TSQLDBRestFieldList; DefaultFieldClass:=TSQLDBRestField; DefaultParameterListClass:=TSQLDBRestParameterList; DefaultParamClass:=TSQLDBRestParam; end; procedure TSQLDBRestResource.PopulateFieldsFromFieldDefs(Defs: TFieldDefs; aIndexFields: TStringArray; aProcessIdentifier: TProcessIdentifier; aMinFieldOpts: TRestFieldOptions); Var I : Integer; F : TSQLDBRestField; FN,PN : UTF8String; O : TRestFieldOptions; RFT : TRestFieldType; FD : TFieldDef; begin For I:=0 to Defs.Count-1 do begin FD:=Defs[i]; RFT:=FieldTypeToRestFieldType(FD.DataType); if RFT=rftUnknown then Continue; FN:=FD.Name; if Assigned(aProcessIdentifier) then PN:=aProcessIdentifier(FN); if SameStr(PN,FN) then // No SameText, Allow to change case PN:=''; O:=aMinFieldOpts; if FD.Required then Include(O,foRequired); If IndexStr(FN,aIndexFields)<>-1 then begin Include(O,foInKey); Exclude(O,foFilter); end; F:=Fields.AddField(FN,RFT,O); F.NativeFieldType:=FD.DataType; if F.FieldType=rftString then F.MaxLen:=FD.Size; F.PublicName:=PN; end; end; procedure TSQLDBRestResource.PopulateParametersFromSQL(const SQL: String; DoClear: Boolean); Var Parms : TParams; P : TParam; SRP : TSQLDBRestParam; begin if DoClear then Parameters.Clear; Parms:=TParams.Create(Nil); try Parms.ParseSQL(SQL,True); for P in Parms do If Parameters.IndexOf(P.Name)=-1 then begin SRP:=Parameters.AddParam(P.Name); SRP.DataType:=ftString; end; finally Parms.Free; end; end; class function TSQLDBRestResource.CreateFieldList: TSQLDBRestFieldList; begin Result:=DefaultFieldListClass.Create(DefaultFieldClass); end; class function TSQLDBRestResource.CreateParamList: TSQLDBRestParameterList; begin Result:=DefaultParameterListClass.Create(DefaultParamClass); end; { TSQLDBRestFieldList } function TSQLDBRestFieldList.GetFields(aIndex: Integer): TSQLDBRestField; begin Result:=TSQLDBRestField(Items[aIndex]) end; procedure TSQLDBRestFieldList.SetFields(aIndex : Integer; AValue: TSQLDBRestField); begin Items[aIndex]:=aValue; end; function TSQLDBRestFieldList.GetEnumerator: TSQLDBRestFieldListEnumerator; begin Result:=TSQLDBRestFieldListEnumerator.Create(Self); end; function TSQLDBRestFieldList.AddField(const aFieldName: UTF8String; aFieldType: TRestFieldType; aOptions: TRestFieldOptions ): TSQLDBRestField; begin if IndexOfFieldName(aFieldName)<>-1 then Raise ESQLDBRest.CreateFmt(500,SDuplicateFieldName,[aFieldName]); Result:=Add as TSQLDBRestField; Result.FieldName:=aFieldName; Result.FieldType:=aFieldType; Result.Options:=aOptions; end; function TSQLDBRestFieldList.indexOfFieldName(const aFieldName : UTF8String): Integer; begin Result:=Count-1; While (Result>=0) and not SameText(aFieldName,GetFields(Result).FieldName) do Dec(Result); end; function TSQLDBRestFieldList.FindByFieldName(const aFieldName: UTF8String ): TSQLDBRestField; Var I : Integer; begin I:=indexOfFieldName(aFieldName); if (I=-1) then Result:=Nil else Result:=GetFields(I); end; function TSQLDBRestFieldList.indexOfPublicName(const aPublicName : UTF8String): Integer; begin Result:=Count-1; While (Result>=0) and not SameText(aPublicName,GetFields(Result).PublicName) do Dec(Result); end; function TSQLDBRestFieldList.FindByPublicName(const aFieldName: UTF8String ): TSQLDBRestField; Var I : Integer; begin I:=indexOfPublicName(aFieldName); if (I=-1) then Result:=Nil else Result:=GetFields(I); end; { TSQLDBRestField } function TSQLDBRestField.GetPublicName: UTF8String; begin Result:=FPublicName; if (Result='') then Result:=FFieldName; end; constructor TSQLDBRestField.Create(ACollection: TCollection); begin inherited Create(ACollection); FFilters:=AllFieldFilters; end; procedure TSQLDBRestField.Assign(Source: TPersistent); Var F : TSQLDBRestField; begin if (Source is TSQLDBRestField) then begin F:=source as TSQLDBRestField; FieldName:=F.FieldName; FPublicName:=F.FPublicName; FieldType:=F.FieldType; NativeFieldType:=F.NativeFieldType; Options:=F.Options; Filters:=F.Filters; MaxLen:=F.MaxLen; GeneratorName:=F.GeneratorName; end else inherited Assign(Source); end; function TSQLDBRestField.GetDisplayName: string; begin Result:=PublicName; end; function TSQLDBRestField.UseInFieldList(aListKind: TFieldListKind): Boolean; begin Result:=True; Case aListKind of flSelect : Result:=True; flInsert : Result:=foInInsert in Options; flInsertParams : Result:=(foInInsert in Options) and not (NativeFieldType=ftAutoInc); flUpdate : Result:=foInUpdate in Options; flWhereKey : Result:=foInKey in Options; flFilter : Result:=foFilter in Options; flOrderby : Result:=([foOrderBy,foOrderByDesc]*options)<>[]; end; end; end.