source upload

2022-01-17 22:16:47 +02:00
parent 12936d065b
commit 098e8c48de
1778 changed files with 1206749 additions and 0 deletions
--- a/contrib/mORMot/SQLite3/Samples/16
+++ b/contrib/mORMot/SQLite3/Samples/16
@@ -0,0 +1,22 @@
+program Project16Client;
+
+//   first line of uses clause must be   {$I SynDprUses.inc}
+uses
+  {$I SynDprUses.inc}
+  Forms,
+  {$ifdef FPC}
+  Interfaces,
+  {$endif}
+  Project16ClientMain in 'Project16ClientMain.pas' {MainForm},
+  Project16Interface in 'Project16Interface.pas';
+
+{$ifndef FPC}
+{$R *.res}
+{$endif}
+
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TMainForm, MainForm);
+  Application.Run;
+end.
--- a/contrib/mORMot/SQLite3/Samples/16
+++ b/contrib/mORMot/SQLite3/Samples/16
--- a/contrib/mORMot/SQLite3/Samples/16
+++ b/contrib/mORMot/SQLite3/Samples/16
@@ -0,0 +1,166 @@
+object MainForm: TMainForm
+  Left = 599
+  Top = 350
+  Width = 810
+  Height = 602
+  Caption = ' Service-based remote SQL access'
+  Color = clBtnFace
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -13
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  OldCreateOrder = False
+  OnDestroy = FormDestroy
+  OnShow = FormShow
+  PixelsPerInch = 96
+  TextHeight = 16
+  object spl1: TSplitter
+    Left = 0
+    Top = 89
+    Width = 794
+    Height = 3
+    Cursor = crVSplit
+    Align = alTop
+  end
+  object mmoQuery: TMemo
+    Left = 0
+    Top = 0
+    Width = 794
+    Height = 89
+    Align = alTop
+    TabOrder = 0
+    Visible = False
+  end
+  object pnlLogin: TPanel
+    Left = 0
+    Top = 92
+    Width = 794
+    Height = 69
+    Align = alTop
+    TabOrder = 1
+    object lbl1: TLabel
+      Left = 22
+      Top = 10
+      Width = 38
+      Height = 16
+      Caption = 'Engine'
+    end
+    object lbledtServer: TLabeledEdit
+      Left = 264
+      Top = 8
+      Width = 121
+      Height = 24
+      EditLabel.Width = 38
+      EditLabel.Height = 16
+      EditLabel.Caption = 'Server'
+      LabelPosition = lpLeft
+      TabOrder = 2
+    end
+    object lbledtDatabase: TLabeledEdit
+      Left = 264
+      Top = 32
+      Width = 121
+      Height = 24
+      EditLabel.Width = 53
+      EditLabel.Height = 16
+      EditLabel.Caption = 'Database'
+      LabelPosition = lpLeft
+      TabOrder = 3
+    end
+    object lbledtUser: TLabeledEdit
+      Left = 456
+      Top = 8
+      Width = 121
+      Height = 24
+      EditLabel.Width = 26
+      EditLabel.Height = 16
+      EditLabel.Caption = 'User'
+      LabelPosition = lpLeft
+      TabOrder = 4
+    end
+    object lbledtPassword: TLabeledEdit
+      Left = 456
+      Top = 32
+      Width = 121
+      Height = 24
+      EditLabel.Width = 55
+      EditLabel.Height = 16
+      EditLabel.Caption = 'Password'
+      LabelPosition = lpLeft
+      PasswordChar = '*'
+      TabOrder = 5
+    end
+    object cbbEngine: TComboBox
+      Left = 22
+      Top = 28
+      Width = 169
+      Height = 24
+      Style = csDropDownList
+      ItemHeight = 16
+      TabOrder = 1
+    end
+    object btnOpen: TButton
+      Left = 592
+      Top = 16
+      Width = 97
+      Height = 33
+      Caption = 'Open'
+      TabOrder = 0
+      OnClick = btnOpenClick
+    end
+  end
+  object drwgrdData: TDrawGrid
+    Left = 0
+    Top = 202
+    Width = 794
+    Height = 362
+    Align = alClient
+    ColCount = 1
+    FixedCols = 0
+    RowCount = 1
+    FixedRows = 0
+    TabOrder = 2
+    Visible = False
+  end
+  object pnlCommand: TPanel
+    Left = 0
+    Top = 161
+    Width = 794
+    Height = 41
+    Align = alTop
+    TabOrder = 3
+    Visible = False
+    DesignSize = (
+      794
+      41)
+    object lblSelectTable: TLabel
+      Left = 288
+      Top = 11
+      Width = 82
+      Height = 16
+      Alignment = taRightJustify
+      Caption = 'Select * from '
+    end
+    object btnExecute: TButton
+      Left = 668
+      Top = 4
+      Width = 84
+      Height = 33
+      Anchors = [akTop, akRight]
+      Caption = 'Execute'
+      TabOrder = 0
+      OnClick = btnExecuteClick
+    end
+    object cbbTableNames: TComboBox
+      Left = 376
+      Top = 8
+      Width = 201
+      Height = 24
+      Style = csDropDownList
+      ItemHeight = 16
+      TabOrder = 1
+      OnChange = cbbTableNamesChange
+    end
+  end
+end
--- a/contrib/mORMot/SQLite3/Samples/16
+++ b/contrib/mORMot/SQLite3/Samples/16
@@ -0,0 +1,172 @@
+unit Project16ClientMain;
+
+interface
+
+uses
+  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+  Dialogs, StdCtrls,
+  SynCommons, mORMot, mORMotHttpClient, mORMotUI, mORMotUILogin,
+  Project16Interface, ExtCtrls, Grids;
+
+type
+  TProjectSettings = class(TPersistent)
+  private
+    fDatabaseName: RawUTF8;
+    fPassword: RawUTF8;
+    fUserID: RawUTF8;
+    fServerName: RawUTF8;
+    fEngine: TRemoteSQLEngine;
+  published
+    property Engine: TRemoteSQLEngine read fEngine;
+    property ServerName: RawUTF8 read fServerName;
+    property DatabaseName: RawUTF8 read fDatabaseName;
+    property UserID: RawUTF8 read fUserID;
+    property PassWord: RawUTF8 read fPassword;
+  end;
+
+  TMainForm = class(TForm)
+    mmoQuery: TMemo;
+    spl1: TSplitter;
+    pnlLogin: TPanel;
+    drwgrdData: TDrawGrid;
+    lbledtServer: TLabeledEdit;
+    lbledtDatabase: TLabeledEdit;
+    lbledtUser: TLabeledEdit;
+    lbledtPassword: TLabeledEdit;
+    cbbEngine: TComboBox;
+    btnOpen: TButton;
+    pnlCommand: TPanel;
+    btnExecute: TButton;
+    lbl1: TLabel;
+    cbbTableNames: TComboBox;
+    lblSelectTable: TLabel;
+    procedure FormDestroy(Sender: TObject);
+    procedure FormShow(Sender: TObject);
+    procedure btnOpenClick(Sender: TObject);
+    procedure cbbTableNamesChange(Sender: TObject);
+    procedure btnExecuteClick(Sender: TObject);
+  protected
+    fSettings: TProjectSettings;
+    fSettingsFileName: TFileName;
+    fModel: TSQLModel;
+    fClient: TSQLRestClientURI;
+    fTableJSON: RawUTF8;
+    fService: IRemoteSQL;
+  public
+    function Execute(FormatSQLWhere: PUTF8Char; const BoundsSQLWhere: array of const): TSQLTableJSON; overload;
+    procedure ExecuteSQL(FormatSQLWhere: PUTF8Char; const BoundsSQLWhere: array of const);
+  end;
+
+var
+  MainForm: TMainForm;
+
+implementation
+
+{$R *.dfm}
+
+{$R vista.RES} // includes Win10 manifest - use .RES for linux cross-compilation
+
+function TMainForm.Execute(FormatSQLWhere: PUTF8Char;
+  const BoundsSQLWhere: array of const): TSQLTableJSON;
+var SQL: RawUTF8;
+begin
+  SQL := FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere);
+  result := TSQLTableJSON.Create(SQL,fService.Execute(SQL,True,False));
+end;
+
+procedure TMainForm.ExecuteSQL(FormatSQLWhere: PUTF8Char;
+  const BoundsSQLWhere: array of const);
+begin
+  fService.Execute(FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere),False,False);
+end;
+
+procedure TMainForm.FormDestroy(Sender: TObject);
+begin
+  fService := nil;
+  fClient.Free;
+  fModel.Free;
+  fSettings.Free;
+end;
+
+procedure TMainForm.FormShow(Sender: TObject);
+begin
+  PTypeInfo(TypeInfo(TRemoteSQLEngine))^.EnumBaseType^.AddCaptionStrings(cbbEngine.Items);
+  fSettings := TProjectSettings.Create;
+  fSettingsFileName := ChangeFileExt(ExeVersion.ProgramFileName,'.settings');
+  JSONFileToObject(fSettingsFileName,fSettings);
+  cbbEngine.ItemIndex := ord(fSettings.fEngine);
+  lbledtServer.Text := UTF8ToString(fSettings.fServerName);
+  lbledtDatabase.Text := UTF8ToString(fSettings.fDatabaseName);
+  lbledtUser.Text := UTF8ToString(fSettings.fUserID);
+  lbledtPassword.Text := UTF8ToString(fSettings.fPassword);
+  fModel := TSQLModel.Create([],ROOT_NAME);
+  fClient := TSQLHttpClient.Create('localhost',PORT_NAME,fModel);
+  if not fClient.ServerTimeStampSynchronize then begin
+    ShowLastClientError(fClient,'Please run Project16ServerHttp.exe');
+    Close;
+    exit;
+  end;
+  if (not fClient.SetUser('User','synopse'))  or
+     (not fClient.ServiceRegisterClientDriven(TypeInfo(IRemoteSQL),fService)) then begin
+    ShowLastClientError(fClient,'Remote service not available on server');
+    Close;
+    exit;
+  end;
+end;
+
+procedure TMainForm.btnOpenClick(Sender: TObject);
+var TableNames: TRawUTF8DynArray;
+begin
+  if cbbEngine.ItemIndex>=0 then
+  try
+    fSettings.fEngine := TRemoteSQLEngine(cbbEngine.ItemIndex);
+    fSettings.fServerName := StringToUTF8(lbledtServer.Text);
+    fSettings.fDatabaseName := StringToUTF8(lbledtDatabase.Text);
+    fSettings.fUserID := StringToUTF8(lbledtUser.Text);
+    fSettings.fPassword := StringToUTF8(lbledtPassword.Text);
+    ObjectToJSONFile(fSettings,fSettingsFileName);
+    with fSettings do
+      fService.Connect(Engine,ServerName,DatabaseName,UserID,PassWord);
+    pnlLogin.Hide;
+    mmoQuery.Show;
+    pnlCommand.Show;
+    drwgrdData.Show;
+    with CreateTempForm('Please wait') do begin
+      TableNames := fService.GetTableNames;
+      Free;
+    end;
+    cbbTableNames.Items.Text := UTF8ToString(RawUTF8ArrayToCSV(TableNames,#13#10));
+  except
+    on E: Exception do
+      ShowException(E);
+  end;
+end;
+
+procedure TMainForm.cbbTableNamesChange(Sender: TObject);
+begin
+  mmoQuery.Text := 'select * from '+cbbTableNames.Text;
+end;
+
+procedure TMainForm.btnExecuteClick(Sender: TObject);
+var SQL: RawUTF8;
+begin
+  SQL := trim(StringToUTF8(mmoQuery.Text));
+  Screen.Cursor := crHourGlass;
+  try
+    try
+      if isSelect(pointer(SQL)) then begin
+        fTableJSON := fService.Execute(SQL,True,False);
+        TSQLTableToGrid.Create(drwgrdData,
+          TSQLTableJSON.Create(SQL,pointer(fTableJSON),Length(fTableJSON)),fClient);
+      end else
+        fService.Execute(SQL,False,False);
+    except
+      on E: Exception do
+        ShowException(E);
+    end;
+  finally
+    Screen.Cursor := crDefault;
+  end;
+end;
+
+end.
--- a/contrib/mORMot/SQLite3/Samples/16
+++ b/contrib/mORMot/SQLite3/Samples/16
@@ -0,0 +1,27 @@
+/// some common definitions shared by both client and server side 
+unit Project16Interface;
+
+interface
+
+uses
+  SynCommons,
+  mORMot;
+  
+type
+  TRemoteSQLEngine = (rseOleDB, rseODBC, rseOracle, rseSQlite3, rseJet, rseMSSQL);
+  
+  IRemoteSQL = interface(IInvokable)
+    ['{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}']
+    procedure Connect(aEngine: TRemoteSQLEngine; const aServerName, aDatabaseName,
+      aUserID, aPassWord: RawUTF8);
+    function GetTableNames: TRawUTF8DynArray;
+    function Execute(const aSQL: RawUTF8; aExpectResults, aExpanded: Boolean): RawJSON;
+  end;
+
+const
+  ROOT_NAME = 'root';
+  PORT_NAME = '888';
+
+implementation
+
+end.
--- a/contrib/mORMot/SQLite3/Samples/16
+++ b/contrib/mORMot/SQLite3/Samples/16
@@ -0,0 +1,124 @@
+/// this server will use TSQLRestServerFullMemory over HTTP
+program Project16ServerHttp;
+
+{.$APPTYPE CONSOLE} // is done below by calling AllocConsole API 
+
+//   first line of uses clause must be   {$I SynDprUses.inc}
+uses
+  {$I SynDprUses.inc}
+  Windows,
+  SysUtils,
+  Classes,
+  SynCommons,
+  SynTable,
+  SynLog,
+  mORMot,
+  mORMotDB,
+  mORMotHttpServer,
+  SynDB,
+  SynDBOracle,
+  SynDBSQLite3, SynSQLite3Static,
+  SynOleDB,
+  SynDBODBC,
+  Project16Interface;
+
+type
+  TServiceRemoteSQL = class(TInterfacedObject, IRemoteSQL)
+  protected
+    fProps: TSQLDBConnectionProperties;
+  public
+    destructor Destroy; override;
+  public // implements IRemoteSQL methods
+    procedure Connect(aEngine: TRemoteSQLEngine; const aServerName, aDatabaseName,
+      aUserID, aPassWord: RawUTF8);
+    function GetTableNames: TRawUTF8DynArray;
+    function Execute(const aSQL: RawUTF8; aExpectResults, aExpanded: Boolean): RawJSON;
+  end;
+
+
+{ TServiceRemoteSQL }
+
+procedure TServiceRemoteSQL.Connect(aEngine: TRemoteSQLEngine;
+  const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8);
+const // rseOleDB, rseODBC, rseOracle, rseSQlite3, rseJet, rseMSSQL
+  TYPES: array[TRemoteSQLEngine] of TSQLDBConnectionPropertiesClass = (
+     TOleDBConnectionProperties, TODBCConnectionProperties,
+     TSQLDBOracleConnectionProperties, TSQLDBSQLite3ConnectionProperties,
+     {$ifdef WIN64}nil{$else}TOleDBJetConnectionProperties{$endif},
+     TOleDBMSSQL2008ConnectionProperties);
+begin
+  if fProps<>nil then
+    raise Exception.Create('Connect called more than once');
+  if TYPES[aEngine]=nil then
+    raise Exception.CreateFmt('aEngine=%s is not supported',
+      [GetEnumName(TypeInfo(TRemoteSQLEngine),ord(aEngine))^]);
+  fProps := TYPES[aEngine].Create(aServerName,aDatabaseName,aUserID,aPassWord);
+end;
+
+function TServiceRemoteSQL.Execute(const aSQL: RawUTF8; aExpectResults, aExpanded: Boolean): RawJSON;
+var res: ISQLDBRows;
+begin
+  if fProps=nil then
+    raise Exception.Create('Connect call required before Execute');
+  res := fProps.ExecuteInlined(aSQL,aExpectResults);
+  if res=nil then
+    result := '' else
+    result := res.FetchAllAsJSON(aExpanded);
+end;
+
+function TServiceRemoteSQL.GetTableNames: TRawUTF8DynArray;
+begin
+  if fProps=nil then
+    raise Exception.Create('Connect call required before GetTableNames');
+  fProps.GetTableNames(result);
+end;
+
+destructor TServiceRemoteSQL.Destroy;
+begin
+  FreeAndNil(fProps);
+  inherited;
+end;
+
+
+var
+  aModel: TSQLModel;
+  aServer: TSQLRestServer;
+  aHTTPServer: TSQLHttpServer;
+begin
+  // define the log level
+  with TSQLLog.Family do begin
+    Level := LOG_VERBOSE;
+    EchoToConsole := LOG_VERBOSE; // log all events to the console
+    PerThreadLog := ptIdentifiedInOnFile; 
+  end;
+  // manual switch to console mode
+  AllocConsole;
+  TextColor(ccLightGray); // needed to notify previous AllocConsole
+  // create a Data Model
+  aModel := TSQLModel.Create([],ROOT_NAME);
+  try
+    // initialize a TObjectList-based database engine
+    aServer := TSQLRestServerFullMemory.Create(aModel,'users.json',false,true);
+    try
+      // register our IRemoteSQL service on the server side
+      aServer.ServiceRegister(TServiceRemoteSQL,[TypeInfo(IRemoteSQL)],sicClientDriven).
+        // fProps should better be executed/released in the one main thread
+        SetOptions([],[optExecInMainThread,optFreeInMainThread]);
+      // launch the HTTP server
+      aHTTPServer := TSQLHttpServer.Create(PORT_NAME,[aServer],'+',useHttpApiRegisteringURI);
+      try
+        aHTTPServer.AccessControlAllowOrigin := '*'; // for AJAX requests to work
+        Sleep(200); // allow all HTTP threads to be launched and logged
+        writeln(#10'Background server is running.'#10);
+        writeln('Press [Enter] to close the server.'#10);
+        ConsoleWaitForEnterKey;
+      finally
+        aHTTPServer.Free;
+      end;
+    finally
+      aServer.Free;
+    end;
+  finally
+    aModel.Free;
+  end;
+end.