paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-04-06 07:07:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Merging revisions r356,r357,r358,r359,r365,r366,r373,r374,r376 from trunk:

Browse Source 
------------------------------------------------------------------------
    r356 | michael | 2019-03-07 09:46:06 +0100 (Thu, 07 Mar 2019) | 1 line
    
    * Auto-detect JSON type
    ------------------------------------------------------------------------
    r357 | michael | 2019-03-07 09:46:40 +0100 (Thu, 07 Mar 2019) | 1 line
    
    * Allow descendents to configure data requests
    ------------------------------------------------------------------------
    r358 | michael | 2019-03-07 09:51:16 +0100 (Thu, 07 Mar 2019) | 1 line
    
    * SQLDBRestBridge components and first demo
    ------------------------------------------------------------------------
    r359 | michael | 2019-03-07 09:55:15 +0100 (Thu, 07 Mar 2019) | 1 line
    
    * Small fix in html, add missing closing tr tag
    ------------------------------------------------------------------------
    r365 | michael | 2019-03-09 21:02:37 +0100 (Sat, 09 Mar 2019) | 1 line
    
    * Add logout method
    ------------------------------------------------------------------------
    r366 | michael | 2019-03-09 21:03:01 +0100 (Sat, 09 Mar 2019) | 1 line
    
    * Fix detection of push state api
    ------------------------------------------------------------------------
    r373 | michael | 2019-03-12 04:44:14 +0100 (Tue, 12 Mar 2019) | 1 line
    
    * Let TBlobField descend of TField
    ------------------------------------------------------------------------
    r374 | michael | 2019-03-12 09:11:52 +0100 (Tue, 12 Mar 2019) | 1 line
    
    * TBlobField must bet TBinaryField descendent, but needs to allow size 0
    ------------------------------------------------------------------------
    r376 | michael | 2019-03-12 19:24:17 +0100 (Tue, 12 Mar 2019) | 1 line
    
    * Fixes for working with the JSONStreamer
    ------------------------------------------------------------------------
This commit is contained in:
michael 2019-03-13 10:20:38 +00:00
parent bb16e3a85e
commit 8e46daef77
11 changed files with 887 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
demo/restbridge/simple/README.txt Normal file
View File

@ -0,0 +1,12 @@
In order to run this demo, you must run one of the SQLDB REST bridge demos
as a server:
fpc/packages/fcl-web/example/restbridge
lazarus/components/fpweb/demo/restbridge/
lazarus/components/fpweb/demo/restmodule/
You need to know how it is configured (The port, base URL)
The servers are by default set up so the client requires authentication,
so unless that was disabled, you need to know what user the demo is using to authenticate requests !

81
demo/restbridge/simple/restbridge.html Normal file
View File

@ -0,0 +1,81 @@
<html>
<head>
<title>REST Bridge</title>
<meta charset="utf-8"/>
<link href="https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0/css/bootstrap.min.css" rel="stylesheet">
<script src="https://code.jquery.com/jquery-3.2.1.slim.min.js" ></script>
<script src="https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.12.9/umd/popper.min.js"> </script>
<script src="https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0/js/bootstrap.min.js"></script>
<script type="application/javascript" src="restbridgeclient.js"></script>
</head>
<body>
<div class="container-fluid">
<div class="row">
<div class="col-md-12">
<div id="urlform" role="form" class="form-inline">
<div class="input-group col-md-6">
<label class="input-group-text" for="edtUrl">
Base URL
</label>
<input type="text" class="form-control" id="edtURL" value="http://localhost:8080/"/>
</div>
<div class="input-group col-md-2">
<label class="input-group-text" for="edtUserName">
UserName
</label>
<input type="text" class="form-control" id="edtUserName" value="Michael"/>
</div>
<div class="input-group col-md-2">
<label class="input-group-text" for="exampleInputPassword1">
Password
</label>
<input type="password" class="form-control" id="edtPassword" value="secret" />
</div>
<button id="btnResources" class="btn col-md-2">
Get Resource List
</button>
</div>
</div>
</div>
<div class="row">
<div class="col-md-12">
<form id="show" role="form" class="form-inline">
<div class="input-group col-md-3">
<label class="input-group-text " for="selResource">
Resource
</label>
<select class="custom-select col-md-auto" id="selResource" >
<option selected>Choose...</option>
<option value="1">One</option>
<option value="2">Two</option>
<option value="3">Three</option>
</select>
</div>
<div class="input-group col-md-7">
<label class="input-group-text " for="edtOptions">
Additional options:
</label>
<input type="text" class="form-control" id="edtOptions" />
</div>
<button id="btnFetch" type="submit" class="btn btn-primary col-md-2">
Get data
</button>
</form>
</div>
</div>
</div>
<div class="row">
<div class="col-md-12">
<table id="resulttable" class="table table-sm table-striped table-hover">
<thead id="datahead"></thead>
<tbody id="databody"></tbody>
</table>
</div>
</div>
<script type="application/javascript">
rtl.showUncaughtExceptions=true;
rtl.run();
</script>
</body>
</html>

85
demo/restbridge/simple/restbridgeclient.lpi Normal file
View File

@ -0,0 +1,85 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
<Runnable Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="restbridgeclient"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<CustomData Count="1">
<Item0 Name="PasJSWebBrowserProject" Value="1"/>
</CustomData>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<Units Count="2">
<Unit0>
<Filename Value="restbridgeclient.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="restbridge.html"/>
<IsPartOfProject Value="True"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="restbridgeclient.js" ApplyConventions="False"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="js"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<AllowLabel Value="False"/>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<TargetOS Value="browser"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
<UseLineInfoUnit Value="False"/>
</Debugging>
</Linking>
<Other>
<CustomOptions Value="-Jeutf-8 -Jirtl.js -Jc"/>
<CompilerPath Value="$(pas2js)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

182
demo/restbridge/simple/restbridgeclient.lpr Normal file
View File

@ -0,0 +1,182 @@
program restbridgeclient;
{$mode objfpc}
uses
JS, Classes, SysUtils, Web, db, jsondataset, sqldbrestdataset;
Type
{ TMainForm }
TMainForm = class(TComponent)
Private
FData: TSQLDBRestDataset;
FConn: TSQLDBRestConnection;
FBtnResources : TJSHTMLButtonElement;
FBtnData : TJSHTMLButtonElement;
FEdtURL : TJSHTMLInputElement;
FEdtUserName : TJSHTMLInputElement;
FEdtPassword : TJSHTMLInputElement;
FSelResource : TJSHTMLSelectElement;
FDataHead : TJSHTMLElement;
FDataBody : TJSHTMLElement;
function ConfigureConnection: Boolean;
function ConfigureDataset: Boolean;
procedure CreateDataHead(Dataset: TDataset);
function CreateDataRow(aRowNo: Integer; Dataset: TDataset): String;
procedure CreateDataTable(Dataset: TDataset);
procedure DoGetResources(Sender: TObject);
procedure DoOpen(DataSet: TDataSet);
function GetData(aEvent: TJSMouseEvent): boolean;
function GetElement(const aID: String): TJSHTMLElement;
function GetResources(aEvent: TJSMouseEvent): boolean;
Public
Constructor Create(aOwner : TComponent); override;
Procedure BindElements;
end;
{ TMainForm }
Function TMainForm.ConfigureDataset : Boolean;
begin
FData.ResourceName:=FSelResource.value;
Result:=(FData.ResourceName<>'');
if not Result then
Window.Alert('Dataset not correctly configured');
end;
Function TMainForm.ConfigureConnection : Boolean;
begin
FConn.BaseURL:=FedtURL.value;
FConn.Password:=FEdtPassword.value;
FConn.UserName:=FEdtUserName.value;
Result:=FConn.BaseURL<>'';
if not Result then
Window.Alert('Connection not correctly configured');
end;
function TMainForm.GetResources(aEvent: TJSMouseEvent): boolean;
begin
if ConfigureConnection then
FConn.GetResources
end;
procedure TMainForm.DoGetResources(Sender: TObject);
Var
S : String;
I : Integer;
begin
S:='<option selected>Choose...</option>';
For I:=0 to FConn.ResourceList.Count-1 do
S:=S+sLineBreak+'<option>'+FConn.ResourceList[i]+'</option>';
FSelResource.innerHTML:=S;
end;
procedure TMainForm.CreateDataHead(Dataset : TDataset);
Var
sHTML : String;
I : integer;
begin
sHTML:='<tr>';
sHTML:=sHTML+'<th>#</th>';
For I:=0 to Dataset.FieldDefs.Count-1 do
sHTML:=sHTML+'<th>'+Dataset.FieldDefs[i].Name+'</th>'+sLineBreak;
sHTML:=sHTML+'</tr>';
FDataHead.innerHTML:=sHTML;
end;
Function TMainForm.CreateDataRow(aRowNo : Integer; Dataset : TDataset) : String;
Var
I : integer;
sHTML : String;
begin
// Prepend dataset name to id?
sHtml:=Format('<tr id="row-%d"><td>%d</td>',[DataSet.RecNo,aRowNo]);
For I:=0 to Dataset.Fields.Count-1 do
sHTML:=sHTML+'<td>'+Dataset.Fields[i].AsString+'</td>'+sLineBreak;
sHTML:=sHtml+'</tr>';
Result:=sHTML;
end;
procedure TMainForm.CreateDataTable(Dataset : TDataset);
Var
sHTML : String;
I : integer;
begin
sHTML:='';
I:=0;
while not Dataset.EOF do
begin
inc(i);
sHtml:=SHTML+CreateDataRow(i,Dataset);
Dataset.Next;
end;
FDataBody.innerHTML:=sHTML;
end;
procedure TMainForm.DoOpen(DataSet: TDataSet);
begin
CreateDataHead(Dataset);
CreateDataTable(Dataset);
end;
function TMainForm.GetData(aEvent: TJSMouseEvent): boolean;
begin
If not ConfigureConnection then
exit;
if not ConfigureDataset then
exit;
FData.Load([],Nil);
end;
constructor TMainForm.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
// Ideally, this is done in an IDE
FConn:=TSQLDBRestConnection.Create(Self);
FCOnn.OnGetResources:=@DoGetResources;
FData:=TSQLDBRestDataset.Create(Self);
FData.AfterOpen:=@DoOpen;
FData.Connection:=FConn;
// This must always be done in code
BindElements;
end;
Function TMainForm.GetElement(Const aID : String): TJSHTMLElement;
begin
Result:=TJSHTMLElement(document.getElementById(aID));
if (Result=Nil) then
Console.Log('Could not find element '+aID);
end;
procedure TMainForm.BindElements;
begin
FBtnResources:=TJSHTMLButtonElement(getElement('btnResources'));
FBtnResources.OnClick:=@GetResources;
FBtnData:=TJSHTMLButtonElement(getElement('btnFetch'));
FBtnData.OnClick:=@GetData;
FSelResource:=TJSHTMLSelectElement(GetElement('selResource'));
FEdtURL:=TJSHTMLInputElement(getElement('edtURL'));
FEdtUserName:=TJSHTMLInputElement(getElement('edtUserName'));
FEdtPassword:=TJSHTMLInputElement(getElement('edtPassword'));
FDataHead:=getElement('datahead');
FDataBody:=getElement('databody');
end;
begin
TMainForm.Create(Nil);
end.

37
packages/dataabstract/dadataset.pas
View File

@ -86,6 +86,9 @@ Type
FChannel : TROHTTPClientChannel;
FOnLoginFailed: TDAFailedEvent;
FOnLogin: TDALoginSuccessEvent;
FOnLogout: TDASuccessEvent;
FOnLogoutailed: TDAFailedEvent;
FOnLogoutFailed: TDAFailedEvent;
FStreamerType: TDAStreamerType;
FURL: String;
procedure ClearConnection;
@ -112,6 +115,7 @@ Type
// Call this to login. This is an asynchronous call, check the result using OnLoginOK and OnLoginFailed calls.
Procedure Login(aUserName, aPassword : String);
Procedure LoginEx(aLoginString : String);
Procedure Logout;
// You can set this. If you didn't set this, and URL is filled, an instance will be created.
Property DataService : TDADataAbstractService Read GetDataService Write FDataService;
// You can set this. If you didn't set this, and URL is filled, an instance will be created.
@ -129,6 +133,10 @@ Type
Property OnLogin : TDALoginSuccessEvent Read FOnLogin Write FOnLogin;
// Called when login call failed. When call was executed but user is wrong OnLogin is called !
Property OnLoginCallFailed : TDAFailedEvent Read FOnLoginFailed Write FOnLoginFailed;
// Called when logout call is executed.
Property OnLogout : TDASuccessEvent Read FOnLogout Write FOnLogout;
// Called when logout call failed.
Property OnLogOutCallFailed : TDAFailedEvent Read FOnLogoutailed Write FOnLogoutFailed;
// Streamertype : format of the data package in the message.
Property StreamerType : TDAStreamerType Read FStreamerType Write FStreamerType;
end;
@ -203,7 +211,7 @@ begin
end;
end;
function TDAConnection.DetectMessageType(Const aURL : String) : TDAMessageType;
function TDAConnection.DetectMessageType(const aURL: String): TDAMessageType;
Var
S : String;
@ -284,6 +292,11 @@ begin
EnsureLoginService.LoginEx(aLoginString,FOnLogin,FOnLoginFailed);
end;
procedure TDAConnection.Logout;
begin
EnsureLoginService.Logout(FOnLogout,FOnLogoutFailed);
end;
{ TDADataset }
function TDADataset.DataTypeToFieldType(s : String) : TFieldType;
@ -346,6 +359,7 @@ procedure TDADataset.CreateFieldDefs(a: TJSArray);
Var
I : Integer;
F : TDAField;
FO : TJSObject absolute F;
fn,dt : string;
fs : Integer;
FT : TFieldType;
@ -357,9 +371,19 @@ begin
begin
F:=TDAField(A.Elements[i]);
fn:=F.Name;
fs:=F.Size;
dt:=F.type_;
req:=F.Required;
// The JSON streamer does not create all properties :(
if FO.hasOwnProperty('size') then
fs:=F.Size
else
fs:=0;
if FO.hasOwnProperty('type') then
dt:=F.type_
else
dt:='string';
if FO.hasOwnProperty('required') then
req:=F.Required
else
Req:=false;
Ft:=DataTypeToFieldType(dT);
if (ft=ftBlob) and (fs=0) then
fs:=1;
@ -467,6 +491,8 @@ begin
else
Msg:=Fail;
Success:=rrFail;
ErrorMsg:=Msg;
DoAfterRequest;
end;
procedure TDADataRequest.doSuccess(res: JSValue);
@ -488,12 +514,13 @@ begin
if (DADS.DAConnection.EnsureMessageType=mtJSON) then
S:=TROUtil.Frombase64(S);
Case DADS.DAConnection.StreamerType of
stJSON : DStr:=TDABIN2DataStreamer.new;
stJSON : DStr:=TDAJSONDataStreamer.new;
stBIN: DStr:=TDABIN2DataStreamer.new;
end;
DStr.Stream:=S;
DStr.initializeRead;
DT:=TDADataTable.New;
DT.name:=DADS.TableName;
DStr.ReadDataset(DT);
Rows:=TJSArray.New;
for I:=0 to length(DT.rows)-1 do

6
packages/fcl-db/db.pas
View File

@ -670,6 +670,7 @@ type
// Wrapper that calls SetFieldType
// procedure SetBlobType(AValue: TBlobType);
protected
class procedure CheckTypeSize(AValue: Longint); override;
function GetBlobSize: Longint; virtual;
function GetIsNull: Boolean; override;
procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
@ -7027,6 +7028,11 @@ end;
class procedure TBlobField.CheckTypeSize(AValue: Longint);
begin
If AValue<0 then
DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
end;
function TBlobField.GetBlobSize: Longint;

15
packages/fcl-db/extjsdataset.pas
View File

@ -1,3 +1,18 @@
{
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 EXTJS JSON dataset component.
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 ExtJSDataset;
{$mode objfpc}

25
packages/fcl-db/jsondataset.pas
View File

@ -1,3 +1,18 @@
{
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 JSON dataset component.
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.
**********************************************************************}
{$mode objfpc}
unit JSONDataset;
@ -332,7 +347,7 @@ type
// Format JSON date to from DT for Field F
function FormatDateTimeField(DT : TDateTime; F: TField): String; virtual;
// Create fieldmapper. A descendent MUST implement this.
Function CreateFieldMapper : TJSONFieldMapper; virtual; abstract;
Function CreateFieldMapper : TJSONFieldMapper; virtual;
// If True, then the dataset will free MetaData and FRows when it is closed.
Property OwnsData : Boolean Read FownsData Write FOwnsData;
// set to true if unknown field types should be handled as string fields.
@ -1569,6 +1584,14 @@ begin
Result:=FormatDateTime(ptrn,DT);
end;
function TBaseJSONDataSet.CreateFieldMapper: TJSONFieldMapper;
begin
if FRowType=rtJSONArray then
Result:=TJSONArrayFieldMapper.Create
else
Result:=TJSONObjectFieldMapper.Create;
end;
function TBaseJSONDataSet.GetFieldData(Field: TField; Buffer: TDatarecord): JSValue;
var

37
packages/fcl-db/restconnection.pas
View File

@ -1,3 +1,19 @@
{
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 REST connection component for use with Datasets.
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 RestConnection;
{$mode objfpc}
@ -22,9 +38,10 @@ Type
FPageParam: String;
function GetDataProxy: TDataProxy;
Protected
Function GetUpdateBaseURL : String; virtual;
Function GetReadBaseURL : String; virtual;
Function GetPageURL(aRequest : TDataRequest) : String;
Procedure SetupRequest(aXHR : TJSXMLHttpRequest); virtual;
Function GetUpdateBaseURL(aRequest: TRecordUpdateDescriptor) : String; virtual;
Function GetReadBaseURL(aRequest: TDataRequest) : String; virtual;
Function GetPageURL(aRequest : TDataRequest) : String; virtual;
Function GetRecordUpdateURL(aRequest : TRecordUpdateDescriptor) : String;
Public
Function DoGetDataProxy : TDataProxy; virtual;
@ -129,12 +146,17 @@ begin
Result:=FDataProxy;
end;
function TRESTConnection.GetUpdateBaseURL: String;
procedure TRESTConnection.SetupRequest(aXHR: TJSXMLHttpRequest);
begin
// Do nothing
end;
function TRESTConnection.GetUpdateBaseURL(aRequest: TRecordUpdateDescriptor): String;
begin
Result:=BaseURL;
end;
function TRESTConnection.GetReadBaseURL: String;
function TRESTConnection.GetReadBaseURL(aRequest: TDataRequest): String;
begin
Result:=BaseURL;
end;
@ -145,7 +167,7 @@ Var
URL : String;
begin
URL:=GetReadBaseURL;
URL:=GetReadBaseURL(aRequest);
if (PageParam<>'') then
begin
if Pos('?',URL)<>0 then
@ -168,7 +190,7 @@ Var
begin
KeyField:='';
Result:='';
Base:=GetUpdateBaseURL;
Base:=GetUpdateBaseURL(aRequest);
if aRequest.Status in [usModified,usDeleted] then
begin
I:=aRequest.Dataset.Fields.Count-1;
@ -286,6 +308,7 @@ begin
else
begin
R.FXHR.open('GET',URL,true);
Connection.SetupRequest(R.FXHR);
R.FXHR.send;
Result:=True;
end;

416
packages/fcl-db/sqldbrestdataset.pp Normal file
View File

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

7
packages/rtl/webrouter.pp
View File

@ -1251,7 +1251,8 @@ Var
end;
begin
if Result and isDefined(Window) and isDefined(Window.Navigator) then
Result:=False;
if isDefined(Window) and isDefined(Window.Navigator) then
begin
ua:=Window.Navigator.userAgent;
Result:=Not (
@ -1261,9 +1262,9 @@ begin
or IsB('Chrome')
or isB('Windows Phone')
);
If Result then
Result:=isDefined(Window.history) and isDefined(Window.history);
end;
If Result then
Result:=isDefined(Window.history) and isDefined(Window.history);
end;
{ ---------------------------------------------------------------------