|
|
@@ -0,0 +1,416 @@
|
|
|
+{
|
|
|
+ This file is part of the Free Pascal run time library.
|
|
|
+ Copyright (c) 2019 by Michael Van Canneyt, member of the
|
|
|
+ Free Pascal development team
|
|
|
+
|
|
|
+ Simple SQLDBRESTBridge JSON dataset component and connection.
|
|
|
+
|
|
|
+ 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 sqldbrestdataset;
|
|
|
+
|
|
|
+{$mode objfpc}
|
|
|
+
|
|
|
+interface
|
|
|
+
|
|
|
+uses
|
|
|
+ Classes, SysUtils, JS, web, db, JSONDataset, restconnection;
|
|
|
+
|
|
|
+Type
|
|
|
+
|
|
|
+ { TSQLDBRestConnection }
|
|
|
+
|
|
|
+ TSQLDBRestConnection = Class(TRestConnection)
|
|
|
+ private
|
|
|
+ FDataProperty: String;
|
|
|
+ FmetaDataProperty: String;
|
|
|
+ FMetaDataResourceName: String;
|
|
|
+ FonGetResources: TNotifyEvent;
|
|
|
+ FPassword: String;
|
|
|
+ FResourceList: TStrings;
|
|
|
+ FUserName: String;
|
|
|
+ procedure DoResources(Sender: TObject);
|
|
|
+ function DoStoreDataProp: Boolean;
|
|
|
+ function DoStoreMetadata: Boolean;
|
|
|
+ function DoStoreMetadataProp: Boolean;
|
|
|
+ Protected
|
|
|
+ Procedure SetupRequest(aXHR : TJSXMLHttpRequest); override;
|
|
|
+ Function GetUpdateBaseURL(aRequest: TRecordUpdateDescriptor): String; override;
|
|
|
+ Function GetReadBaseURL(aRequest: TDataRequest): String; Override;
|
|
|
+ Public
|
|
|
+ Constructor create(aOwner : TComponent); override;
|
|
|
+ Destructor Destroy; override;
|
|
|
+ Procedure GetResources(OnResult : TNotifyEvent = Nil);
|
|
|
+ Property ResourceList : TStrings Read FResourceList;
|
|
|
+ Published
|
|
|
+ Property OnGetResources : TNotifyEvent Read FonGetResources Write FOnGetResources;
|
|
|
+ Property metaDataProperty : String read FmetaDataProperty Write FmetaDataProperty Stored DoStoreMetadataProp;
|
|
|
+ Property DataProperty : String read FDataProperty Write FDataProperty Stored DoStoreDataProp;
|
|
|
+ Property MetaDataResourceName : String Read FMetaDataResourceName Write FMetaDataResourceName Stored DoStoreMetadata;
|
|
|
+ Property UserName : String Read FUserName Write FUserName;
|
|
|
+ Property Password : String Read FPassword Write FPassword;
|
|
|
+ end;
|
|
|
+
|
|
|
+ { TSQLDBRestDataset }
|
|
|
+
|
|
|
+ TSQLDBRestDataset = Class(TJSONDataset)
|
|
|
+ private
|
|
|
+ FConnection: TSQLDBRestConnection;
|
|
|
+ FResourceName: String;
|
|
|
+ procedure SetConnection(AValue: TSQLDBRestConnection);
|
|
|
+ procedure SetResourceName(AValue: String);
|
|
|
+ Protected
|
|
|
+ function DataPacketReceived(ARequest: TDataRequest): Boolean; override;
|
|
|
+ function GetStringFieldLength(F: TJSObject; AName: String; AIndex: Integer): integer;virtual;
|
|
|
+ function StringToFieldType(S: String): TFieldType; virtual;
|
|
|
+ Function DoGetDataProxy: TDataProxy; override;
|
|
|
+ Procedure MetaDataToFieldDefs; override;
|
|
|
+ Public
|
|
|
+ Property Connection: TSQLDBRestConnection Read FConnection Write SetConnection;
|
|
|
+ Property ResourceName : String Read FResourceName Write SetResourceName;
|
|
|
+ end;
|
|
|
+
|
|
|
+implementation
|
|
|
+
|
|
|
+Type
|
|
|
+
|
|
|
+ { TServiceRequest }
|
|
|
+
|
|
|
+ TServiceRequest = Class(TObject)
|
|
|
+ Private
|
|
|
+ FOnMyDone,
|
|
|
+ FOnDone : TNotifyEvent;
|
|
|
+ FXHR: TJSXMLHttpRequest;
|
|
|
+ function GetResult: String;
|
|
|
+ function GetResultJSON: TJSObject;
|
|
|
+ function GetStatusCode: Integer;
|
|
|
+ function onLoad(Event{%H-}: TEventListenerEvent): boolean;
|
|
|
+ Public
|
|
|
+ Constructor Create(Const aMethod,aURL,aUserName,aPassword : String; aOnDone1 : TNotifyEvent; aOnDone2 : TNotifyEvent = Nil);
|
|
|
+ Procedure Execute;
|
|
|
+ Property RequestResult : String read GetResult;
|
|
|
+ Property ResultJSON : TJSObject read GetResultJSON;
|
|
|
+ Property OnDone : TNotifyEvent Read FOnDone;
|
|
|
+ Property StatusCode : Integer Read GetStatusCode;
|
|
|
+ end;
|
|
|
+
|
|
|
+{ TServiceRequest }
|
|
|
+
|
|
|
+constructor TServiceRequest.Create(const aMethod,aURL, aUserName, aPassword: String; aOnDone1 : TNotifyEvent; aOnDone2 : TNotifyEvent = Nil);
|
|
|
+begin
|
|
|
+ FOnMyDone:=aOnDone1;
|
|
|
+ FOnDone:=aOnDone2;
|
|
|
+ FXHR:=TJSXMLHttpRequest.New;
|
|
|
+ FXHR.AddEventListener('load',@onLoad);
|
|
|
+ FXHR.open(aMethod,aURL,true);
|
|
|
+(* else
|
|
|
+ begin
|
|
|
+// FXHR.withCredentials := true;
|
|
|
+ FXHR.open(aMethod,aURL,true,aUserName,aPassword);
|
|
|
+ end;*)
|
|
|
+ FXHR.setRequestHeader('Content-Type', 'application/json');
|
|
|
+ FXHR.setRequestHeader('Authorization', 'Basic '+window.btoa(aUserName+':'+aPassword));
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TServiceRequest.Execute;
|
|
|
+begin
|
|
|
+ FXHR.send;
|
|
|
+end;
|
|
|
+
|
|
|
+function TServiceRequest.GetResult: String;
|
|
|
+begin
|
|
|
+ Result:=FXHR.responseText;
|
|
|
+end;
|
|
|
+
|
|
|
+function TServiceRequest.GetResultJSON: TJSObject;
|
|
|
+begin
|
|
|
+ if SameText(FXHR.getResponseHeader('Content-Type'),'application/json') then
|
|
|
+ Result:=TJSJSON.parseObject(GetResult)
|
|
|
+ else
|
|
|
+ Result:=nil;
|
|
|
+end;
|
|
|
+
|
|
|
+function TServiceRequest.GetStatusCode: Integer;
|
|
|
+begin
|
|
|
+ Result:=FXHR.Status;
|
|
|
+end;
|
|
|
+
|
|
|
+function TServiceRequest.onLoad(Event: TEventListenerEvent): boolean;
|
|
|
+begin
|
|
|
+ if Assigned(FOnMyDone) then
|
|
|
+ FOnMyDone(Self);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+{ TSQLDBRestConnection }
|
|
|
+
|
|
|
+function TSQLDBRestConnection.DoStoreMetadata: Boolean;
|
|
|
+begin
|
|
|
+ Result:=(FMetadataResourceName<>'metadata');
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestConnection.DoStoreMetadataProp: Boolean;
|
|
|
+begin
|
|
|
+ Result:=(FMetaDataProperty<>'metaData');
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TSQLDBRestConnection.SetupRequest(aXHR: TJSXMLHttpRequest);
|
|
|
+begin
|
|
|
+ inherited SetupRequest(aXHR);
|
|
|
+ aXHR.setRequestHeader('Content-Type', 'application/json');
|
|
|
+ aXHR.setRequestHeader('Accept', 'application/json');
|
|
|
+ if (UserName<>'') then
|
|
|
+ aXHR.setRequestHeader('Authorization', 'Basic '+window.btoa(UserName+':'+Password));
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestConnection.GetUpdateBaseURL(aRequest: TRecordUpdateDescriptor): String;
|
|
|
+begin
|
|
|
+ Result:=inherited GetUpdateBaseURL(aRequest);
|
|
|
+ Result:=IncludeTrailingPathDelimiter(Result)+TSQLDBRestDataset(aRequest.Dataset).ResourceName;
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestConnection.GetReadBaseURL(aRequest: TDataRequest): String;
|
|
|
+begin
|
|
|
+ Result:=inherited GetReadBaseURL(aRequest);
|
|
|
+ Result:=IncludeTrailingPathDelimiter(Result)+TSQLDBRestDataset(aRequest.Dataset).ResourceName;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TSQLDBRestConnection.DoResources(Sender: TObject);
|
|
|
+
|
|
|
+Var
|
|
|
+ R : TServiceRequest absolute Sender;
|
|
|
+ J,Res : TJSObject;
|
|
|
+ A : TJSArray;
|
|
|
+ i : Integer;
|
|
|
+
|
|
|
+begin
|
|
|
+ FResourceList.Clear;
|
|
|
+ if (R.StatusCode=200) then
|
|
|
+ begin
|
|
|
+ J:=R.ResultJSON;
|
|
|
+ if J=Nil then
|
|
|
+ exit;
|
|
|
+ A:=TJSArray(J.Properties['data']);
|
|
|
+ For I:=0 to A.Length-1 do
|
|
|
+ begin
|
|
|
+ Res:=TJSObject(A[i]);
|
|
|
+ FResourceList.Add(String(Res.Properties['name']));
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ If Assigned(R.OnDone) then
|
|
|
+ R.OnDone(Self);
|
|
|
+ If Assigned(OnGetResources) then
|
|
|
+ OnGetResources(Self);
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestConnection.DoStoreDataProp: Boolean;
|
|
|
+begin
|
|
|
+ Result:=(FDataProperty<>'data');
|
|
|
+end;
|
|
|
+
|
|
|
+constructor TSQLDBRestConnection.create(aOwner: TComponent);
|
|
|
+begin
|
|
|
+ inherited create(aOwner);
|
|
|
+ FResourceList:=TStringList.Create;
|
|
|
+ FMetaDataResourceName:='metadata';
|
|
|
+ FmetaDataProperty:='metaData';
|
|
|
+ FDataProperty:='data';
|
|
|
+ TStringList(FResourceList).Sorted:=true;
|
|
|
+end;
|
|
|
+
|
|
|
+destructor TSQLDBRestConnection.Destroy;
|
|
|
+begin
|
|
|
+ FreeAndNil(FResourceList);
|
|
|
+ inherited Destroy;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TSQLDBRestConnection.GetResources(OnResult: TNotifyEvent);
|
|
|
+
|
|
|
+Var
|
|
|
+ aURL : String;
|
|
|
+ R : TServiceRequest;
|
|
|
+
|
|
|
+begin
|
|
|
+ aURL:=IncludeTrailingPathDelimiter(BaseURL)+MetaDataResourceName+'?fmt=json';
|
|
|
+ R:=TServiceRequest.Create('GET',aURL,Self.UserName,Self.Password,@DoResources,OnResult);
|
|
|
+ R.Execute;
|
|
|
+end;
|
|
|
+
|
|
|
+{ TSQLDBRestDataset }
|
|
|
+
|
|
|
+procedure TSQLDBRestDataset.SetConnection(AValue: TSQLDBRestConnection);
|
|
|
+begin
|
|
|
+ if FConnection=AValue then Exit;
|
|
|
+ if Assigned(FConnection) then
|
|
|
+ FConnection.RemoveFreeNotification(Self);
|
|
|
+ FConnection:=AValue;
|
|
|
+ if Assigned(FConnection) then
|
|
|
+ FConnection.FreeNotification(Self);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TSQLDBRestDataset.SetResourceName(AValue: String);
|
|
|
+begin
|
|
|
+ if FResourceName=AValue then Exit;
|
|
|
+ CheckInactive;
|
|
|
+ FResourceName:=AValue;
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestDataset.DoGetDataProxy: TDataProxy;
|
|
|
+begin
|
|
|
+ Result:=Connection.DataProxy;
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestDataset.StringToFieldType(S: String): TFieldType;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (s='int') then
|
|
|
+ Result:=ftInteger
|
|
|
+ else if (s='bigint') then
|
|
|
+ Result:=ftLargeInt
|
|
|
+ else if (s='float') then
|
|
|
+ Result:=ftFloat
|
|
|
+ else if (s='bool') then
|
|
|
+ Result:=ftBoolean
|
|
|
+ else if (s='date') then
|
|
|
+ Result:=ftDate
|
|
|
+ else if (s='datetime') then
|
|
|
+ Result:=ftDateTime
|
|
|
+ else if (s='time') then
|
|
|
+ Result:=ftTime
|
|
|
+ else if (s='blob') then
|
|
|
+ Result:=ftBlob
|
|
|
+ else if (s='string') then
|
|
|
+ Result:=ftString
|
|
|
+ else
|
|
|
+ if MapUnknownToStringType then
|
|
|
+ Result:=ftString
|
|
|
+ else
|
|
|
+ Raise EJSONDataset.CreateFmt('Unknown JSON data type : %s',[s]);
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestDataset.GetStringFieldLength(F: TJSObject; AName: String;
|
|
|
+ AIndex: Integer): integer;
|
|
|
+
|
|
|
+Var
|
|
|
+ I,L : Integer;
|
|
|
+ D : JSValue;
|
|
|
+
|
|
|
+begin
|
|
|
+ Result:=0;
|
|
|
+ D:=F.Properties['maxLen'];
|
|
|
+ if Not jsIsNan(toNumber(D)) then
|
|
|
+ begin
|
|
|
+ Result:=Trunc(toNumber(D));
|
|
|
+ if (Result<=0) then
|
|
|
+ Raise EJSONDataset.CreateFmt('Invalid maximum length specifier for field %s',[AName])
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ For I:=0 to Rows.Length-1 do
|
|
|
+ begin
|
|
|
+ D:=FieldMapper.GetJSONDataForField(Aname,AIndex,Rows[i]);
|
|
|
+ if isString(D) then
|
|
|
+ begin
|
|
|
+ l:=Length(String(D));
|
|
|
+ if L>Result then
|
|
|
+ Result:=L;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ if (Result=0) then
|
|
|
+ Result:=20;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TSQLDBRestDataset.MetaDataToFieldDefs;
|
|
|
+Var
|
|
|
+ A : TJSArray;
|
|
|
+ F : TJSObject;
|
|
|
+ I,FS : Integer;
|
|
|
+ N: String;
|
|
|
+ ft: TFieldType;
|
|
|
+ D : JSValue;
|
|
|
+
|
|
|
+begin
|
|
|
+ FieldDefs.Clear;
|
|
|
+ D:=Metadata.Properties['fields'];
|
|
|
+ if Not IsArray(D) then
|
|
|
+ Raise EJSONDataset.Create('Invalid metadata object');
|
|
|
+ A:=TJSArray(D);
|
|
|
+ For I:=0 to A.Length-1 do
|
|
|
+ begin
|
|
|
+ If Not isObject(A[i]) then
|
|
|
+ Raise EJSONDataset.CreateFmt('Field definition %d in metadata is not an object',[i]);
|
|
|
+ F:=TJSObject(A[i]);
|
|
|
+ D:=F.Properties['name'];
|
|
|
+ If Not isString(D) then
|
|
|
+ Raise EJSONDataset.CreateFmt('Field definition %d in has no or invalid name property',[i]);
|
|
|
+ N:=String(D);
|
|
|
+ D:=F.Properties['type'];
|
|
|
+ If IsNull(D) or isUndefined(D) then
|
|
|
+ ft:=ftstring
|
|
|
+ else If Not isString(D) then
|
|
|
+ begin
|
|
|
+ Raise EJSONDataset.CreateFmt('Field definition %d in has invalid type property',[i])
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ ft:=StringToFieldType(String(D));
|
|
|
+ end;
|
|
|
+ if (ft=ftString) then
|
|
|
+ fs:=GetStringFieldLength(F,N,I)
|
|
|
+ else
|
|
|
+ fs:=0;
|
|
|
+ FieldDefs.Add(N,ft,fs);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TSQLDBRestDataset.DataPacketReceived(ARequest: TDataRequest): Boolean;
|
|
|
+
|
|
|
+Var
|
|
|
+ O : TJSObject;
|
|
|
+ A : TJSArray;
|
|
|
+ smetadata,sroot : String;
|
|
|
+begin
|
|
|
+ Result:=False;
|
|
|
+ If isNull(aRequest.Data) then
|
|
|
+ exit;
|
|
|
+ If isString(aRequest.Data) then
|
|
|
+ O:=TJSOBject(TJSJSON.Parse(String(aRequest.Data)))
|
|
|
+ else if isObject(aRequest.Data) then
|
|
|
+ O:=TJSOBject(aRequest.Data)
|
|
|
+ else
|
|
|
+ DatabaseError('Cannot handle data packet');
|
|
|
+ sRoot:=Connection.DataProperty;
|
|
|
+ sMetaData:=Connection.metaDataProperty;
|
|
|
+ if (sroot='') then
|
|
|
+ sroot:='data';
|
|
|
+ if (smetadata='') then
|
|
|
+ smetadata:='metaData';
|
|
|
+{ if (IDField='') then
|
|
|
+ idField:='id';}
|
|
|
+ if O.hasOwnProperty(sMetaData) and isObject(o[sMetaData]) then
|
|
|
+ begin
|
|
|
+ if not Active then // Load fields from metadata
|
|
|
+ metaData:=TJSObject(o[SMetaData]);
|
|
|
+{ if metaData.hasOwnProperty('idField') and isString(metaData['idField']) then
|
|
|
+ IDField:=string(metaData['idField']);}
|
|
|
+ end;
|
|
|
+ if O.hasOwnProperty(sRoot) and isArray(o[sRoot]) then
|
|
|
+ begin
|
|
|
+ A:=TJSArray(o[sRoot]);
|
|
|
+ Result:=A.Length>0;
|
|
|
+ AddToRows(A);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+end.
|
|
|
+
|
michael