├── demo ├── db │ └── rsql.sqlite ├── jwt │ ├── project1.ico │ ├── project1.res │ ├── project1.lpr │ ├── unit1.lfm │ ├── unit1.pas │ ├── project1.lpi │ └── project1.lps └── basic │ ├── client │ ├── rsqlclientproject1.ico │ ├── rsqlclientproject1.res │ ├── rsqlclientproject1.lpr │ ├── unit1.pas │ ├── rsqlclientproject1.lps │ ├── rsqlclientproject1.lpi │ └── unit1.lfm │ └── server_embedded │ ├── rsqlproject1.lps │ ├── rsqlproject1.lpi │ └── rsqlproject1.lpr ├── rsql.inc ├── design ├── trsqlclient.png ├── trsqlserver.png ├── trsqlclient_200.png └── trsqlserver_200.png ├── rsql_package.pas ├── README.md ├── LICENSE.txt ├── .gitignore ├── source ├── rsql_crypto_zstream.pas ├── rsql_crypto_base64.pas ├── rsql_crypto_jwt.pas ├── rsql_server_application.pas ├── rsql_server_component.pas ├── rsql_crypto_hmac.pas ├── rsql_server_database.pas ├── rsql_register.pas ├── rsql_server_transaction.pas ├── rsql_server_router.pas ├── rsql_helper.pas └── rsql_client_connection.pas ├── rsql_package.lpk └── rsql.lrs /demo/db/rsql.sqlite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/demo/db/rsql.sqlite -------------------------------------------------------------------------------- /rsql.inc: -------------------------------------------------------------------------------- 1 | {$mode objfpc}{$H+} 2 | {**$define rsql_debug} 3 | {$define rsql_experimental} 4 | -------------------------------------------------------------------------------- /demo/jwt/project1.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/demo/jwt/project1.ico -------------------------------------------------------------------------------- /demo/jwt/project1.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/demo/jwt/project1.res -------------------------------------------------------------------------------- /design/trsqlclient.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/design/trsqlclient.png -------------------------------------------------------------------------------- /design/trsqlserver.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/design/trsqlserver.png -------------------------------------------------------------------------------- /design/trsqlclient_200.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/design/trsqlclient_200.png -------------------------------------------------------------------------------- /design/trsqlserver_200.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/design/trsqlserver_200.png -------------------------------------------------------------------------------- /demo/basic/client/rsqlclientproject1.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/demo/basic/client/rsqlclientproject1.ico -------------------------------------------------------------------------------- /demo/basic/client/rsqlclientproject1.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupsc10-zz/RSQL/HEAD/demo/basic/client/rsqlclientproject1.res -------------------------------------------------------------------------------- /demo/jwt/project1.lpr: -------------------------------------------------------------------------------- 1 | program project1; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, Unit1 11 | { you can add units after this }; 12 | 13 | {$R *.res} 14 | 15 | begin 16 | RequireDerivedFormResource:=True; 17 | Application.Scaled:=True; 18 | Application.Initialize; 19 | Application.CreateForm(TForm1, Form1); 20 | Application.Run; 21 | end. 22 | 23 | -------------------------------------------------------------------------------- /demo/basic/client/rsqlclientproject1.lpr: -------------------------------------------------------------------------------- 1 | program rsqlclientproject1; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, Unit1 11 | { you can add units after this }; 12 | 13 | {$R *.res} 14 | 15 | begin 16 | RequireDerivedFormResource:=True; 17 | Application.Scaled:=True; 18 | Application.Initialize; 19 | Application.CreateForm(TForm1, Form1); 20 | Application.Run; 21 | end. 22 | 23 | -------------------------------------------------------------------------------- /rsql_package.pas: -------------------------------------------------------------------------------- 1 | { This file was automatically created by Lazarus. Do not edit! 2 | This source is only used to compile and install the package. 3 | } 4 | 5 | unit RSQL_Package; 6 | 7 | {$warn 5023 off : no warning about unused units} 8 | interface 9 | 10 | uses 11 | RSQL_Helper, RSQL_Crypto_HMAC, RSQL_Crypto_BASE64, RSQL_Crypto_ZStream, 12 | RSQL_Crypto_JWT, RSQL_Server_Database, RSQL_Server_Transaction, 13 | RSQL_Server_Router, RSQL_Server_Component, RSQL_Server_Application, 14 | RSQL_Client_Connection, RSQL_Register, LazarusPackageIntf; 15 | 16 | implementation 17 | 18 | procedure Register; 19 | begin 20 | RegisterUnit('RSQL_Register', @RSQL_Register.Register); 21 | end; 22 | 23 | initialization 24 | RegisterPackage('RSQL_Package', @Register); 25 | end. 26 | -------------------------------------------------------------------------------- /demo/basic/client/unit1.pas: -------------------------------------------------------------------------------- 1 | unit Unit1; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, db, sqldb, Forms, Controls, Graphics, Dialogs, DBGrids, 9 | StdCtrls, RSQL_Client_Connection; 10 | 11 | type 12 | 13 | { TForm1 } 14 | 15 | TForm1 = class(TForm) 16 | Button1: TButton; 17 | DataSource1: TDataSource; 18 | DBGrid1: TDBGrid; 19 | RSQLClient1: TRSQLClient; 20 | SQLQuery1: TSQLQuery; 21 | SQLTransaction1: TSQLTransaction; 22 | procedure Button1Click(Sender: TObject); 23 | private 24 | 25 | public 26 | 27 | end; 28 | 29 | var 30 | Form1: TForm1; 31 | 32 | implementation 33 | 34 | {$R *.lfm} 35 | 36 | { TForm1 } 37 | 38 | procedure TForm1.Button1Click(Sender: TObject); 39 | begin 40 | RSQLHTTPConnection1.Open; 41 | SQLQuery1.Open; 42 | end; 43 | 44 | end. 45 | 46 | -------------------------------------------------------------------------------- /demo/basic/server_embedded/rsqlproject1.lps: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # RSQL 2 | 3 | [![License](https://img.shields.io/badge/license-MIT-green.svg)](https://github.com/groupsc10/RSQL/LICENSE.txt) 4 | 5 | ## Introduction 6 | 7 | 8 | **ATTENTION**: We are still in an alpha version, the API can and * will * change frequently. Please use it at your own risk until we release version 1.0. 9 | 10 | **RSQL** is a api/component/lib to access a SQL databases, using native [LAZARUS](https://www.lazarus-ide.org/) connector. 11 | 12 | ## Features 13 | 14 | - Select, Insert, Update and Delete data from a [RDBMS](https://en.wikipedia.org/wiki/Relational_database_management_system) 15 | - Transactions 16 | - Named parameters statement 17 | - Retrieve the data as JSON 18 | - Batch 19 | - JWT security 20 | - Compressed request/response 21 | 22 | 23 | 24 | ## Feature to be implemented 25 | - Tests 26 | - Caching 27 | - Others 28 | 29 | 30 | 31 | ## Contributions 32 | Contributions are welcome! Please, open an issue before submit any kind (ideas, documentation, code, ...) of contribution. 33 | 34 | 35 | 36 | ## License 37 | This project is released under MIT license. See [LICENSE](LICENSE). 38 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /demo/basic/client/rsqlclientproject1.lps: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /demo/jwt/unit1.lfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 163 3 | Height = 424 4 | Top = 139 5 | Width = 597 6 | Anchors = [akTop, akLeft, akRight] 7 | Caption = 'Test JWT' 8 | ClientHeight = 424 9 | ClientWidth = 597 10 | OnCreate = FormCreate 11 | LCLVersion = '2.1.0.0' 12 | object payload_label: TLabel 13 | Left = 16 14 | Height = 18 15 | Top = 16 16 | Width = 64 17 | Anchors = [akLeft] 18 | Caption = 'Payload:' 19 | ParentColor = False 20 | end 21 | object token_label: TLabel 22 | Left = 16 23 | Height = 18 24 | Top = 232 25 | Width = 48 26 | Anchors = [akLeft] 27 | Caption = 'token:' 28 | ParentColor = False 29 | end 30 | object payload_input: TMemo 31 | Left = 16 32 | Height = 146 33 | Top = 48 34 | Width = 567 35 | Anchors = [akLeft, akRight, akBottom] 36 | ScrollBars = ssAutoBoth 37 | TabOrder = 0 38 | end 39 | object token_input: TMemo 40 | Left = 16 41 | Height = 146 42 | Top = 264 43 | Width = 567 44 | Anchors = [akLeft, akRight, akBottom] 45 | ReadOnly = True 46 | ScrollBars = ssBoth 47 | TabOrder = 1 48 | WantTabs = True 49 | end 50 | object gen_token_button: TButton 51 | Left = 328 52 | Height = 25 53 | Top = 9 54 | Width = 255 55 | Anchors = [akLeft, akRight, akBottom] 56 | Caption = 'Generate Token' 57 | OnClick = gen_token_buttonClick 58 | TabOrder = 2 59 | end 60 | object val_token_button1: TButton 61 | Left = 328 62 | Height = 25 63 | Top = 232 64 | Width = 255 65 | Anchors = [akLeft, akRight, akBottom] 66 | Caption = 'Validate Token' 67 | OnClick = val_token_button1Click 68 | TabOrder = 3 69 | end 70 | end 71 | -------------------------------------------------------------------------------- /demo/basic/server_embedded/rsqlproject1.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | <UseAppBundle Value="False"/> 13 | <ResourceType Value="res"/> 14 | </General> 15 | <BuildModes Count="1"> 16 | <Item1 Name="Default" Default="True"/> 17 | </BuildModes> 18 | <PublishOptions> 19 | <Version Value="2"/> 20 | <UseFileFilters Value="True"/> 21 | </PublishOptions> 22 | <RunParams> 23 | <FormatVersion Value="2"/> 24 | <Modes Count="0"/> 25 | </RunParams> 26 | <RequiredPackages Count="1"> 27 | <Item1> 28 | <PackageName Value="RSQL_Package"/> 29 | </Item1> 30 | </RequiredPackages> 31 | <Units Count="1"> 32 | <Unit0> 33 | <Filename Value="rsqlproject1.lpr"/> 34 | <IsPartOfProject Value="True"/> 35 | </Unit0> 36 | </Units> 37 | </ProjectOptions> 38 | <CompilerOptions> 39 | <Version Value="11"/> 40 | <SearchPaths> 41 | <IncludeFiles Value="$(ProjOutDir)"/> 42 | </SearchPaths> 43 | <Other> 44 | <CustomOptions Value="-dUseCThreads"/> 45 | </Other> 46 | </CompilerOptions> 47 | <Debugging> 48 | <Exceptions Count="3"> 49 | <Item1> 50 | <Name Value="EAbort"/> 51 | </Item1> 52 | <Item2> 53 | <Name Value="ECodetoolError"/> 54 | </Item2> 55 | <Item3> 56 | <Name Value="EFOpenError"/> 57 | </Item3> 58 | </Exceptions> 59 | </Debugging> 60 | </CONFIG> 61 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | -------------------------------------------------------------------------------- /demo/jwt/unit1.pas: -------------------------------------------------------------------------------- 1 | unit Unit1; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, strutils, dateutils; 9 | 10 | type 11 | 12 | { TForm1 } 13 | 14 | TForm1 = class(TForm) 15 | gen_token_button: TButton; 16 | val_token_button1: TButton; 17 | payload_input: TMemo; 18 | token_input: TMemo; 19 | payload_label: TLabel; 20 | token_label: TLabel; 21 | procedure FormCreate(Sender: TObject); 22 | procedure gen_token_buttonClick(Sender: TObject); 23 | procedure val_token_button1Click(Sender: TObject); 24 | private 25 | 26 | public 27 | 28 | end; 29 | 30 | var 31 | Form1: TForm1; 32 | 33 | implementation 34 | 35 | {$R *.lfm} 36 | 37 | uses 38 | fpjson, 39 | rsql_crypto_jwt; 40 | 41 | const 42 | CSECRET_KEY = 'mypassword'; 43 | 44 | { TForm1 } 45 | 46 | procedure TForm1.FormCreate(Sender: TObject); 47 | var 48 | J: TJSONObject; 49 | begin 50 | J := TJSONObject.Create(); 51 | try 52 | J.Add('name', 'adm'); 53 | J.Add('age', 21); 54 | J.Add('exp', IncDay(Now, 1)); 55 | 56 | payload_input.Text := J.FormatJSON(); 57 | 58 | finally 59 | J.Free; 60 | end; 61 | end; 62 | 63 | procedure TForm1.gen_token_buttonClick(Sender: TObject); 64 | var 65 | VPayload: string; 66 | VToken: string; 67 | begin 68 | VPayload := payload_input.Text; 69 | VToken := JWTSign(CSECRET_KEY, VPayload); 70 | token_input.Text := VToken; 71 | end; 72 | 73 | procedure TForm1.val_token_button1Click(Sender: TObject); 74 | var 75 | VToken: string; 76 | VMsg: string; 77 | begin 78 | VToken := token_input.Text; 79 | if (JWTParse(VToken, CSECRET_KEY, VMsg)) then 80 | begin 81 | /// OK 82 | ShowMessage(VMsg); 83 | end 84 | else 85 | begin 86 | /// ERROR 87 | ShowMessage(VMsg); 88 | end; 89 | end; 90 | 91 | end. 92 | -------------------------------------------------------------------------------- /demo/basic/server_embedded/rsqlproject1.lpr: -------------------------------------------------------------------------------- 1 | program rsqlproject1; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX} 7 | cthreads, 8 | {$ENDIF} 9 | SysUtils, 10 | Classes, 11 | SQLdb, 12 | //IBConnection, 13 | //mysql40conn, 14 | //mysql41conn, 15 | //mysql50conn, 16 | //mysql51conn, 17 | //mysql55conn, 18 | //mysql56conn, 19 | //mysql57conn, 20 | //odbcconn, 21 | //oracleconnection, 22 | //pqconnection, 23 | sqlite3conn, 24 | HTTPDefs, 25 | RSQL_Server_Application; 26 | 27 | type 28 | TRSQLApp = class(TRSQLApplication) 29 | protected 30 | FDatabase: TSQLConnector; 31 | procedure BeforeRequest({%H-}ASender: TObject; ARequest: TRequest); 32 | procedure AfterRequest({%H-}ASender: TObject; AResponse: TResponse); 33 | public 34 | constructor Create(AOwner: TComponent); overload; override; 35 | end; 36 | 37 | procedure TRSQLApp.BeforeRequest(ASender: TObject; ARequest: TRequest); 38 | begin 39 | WriteLn('<<== REQUEST'); 40 | WriteLn(ARequest.Content); 41 | end; 42 | 43 | procedure TRSQLApp.AfterRequest(ASender: TObject; AResponse: TResponse); 44 | begin 45 | WriteLn('RESPONSE ==>>'); 46 | WriteLn(AResponse.Content); 47 | end; 48 | 49 | constructor TRSQLApp.Create(AOwner: TComponent); 50 | begin 51 | inherited Create(AOwner); 52 | OnAfterRequest := @AfterRequest; 53 | OnBeforeRequest := @BeforeRequest; 54 | FDatabase := TSQLConnector.Create(Self); 55 | FDatabase.ConnectorType := 'SQLite3'; 56 | FDatabase.HostName := 'localhost'; 57 | FDatabase.DatabaseName := '../../db/rsql.sqlite'; 58 | FDatabase.Open; 59 | with DatabaseList.Add do 60 | begin 61 | Database := FDatabase; 62 | Name := 'sqlitedb'; 63 | end; 64 | end; 65 | 66 | begin 67 | with TRSQLApp.Create(nil) do 68 | try 69 | Compressed := True; 70 | CORS := True; 71 | Initialize; 72 | Run; 73 | finally 74 | Free; 75 | end; 76 | end. 77 | -------------------------------------------------------------------------------- /demo/jwt/project1.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="12"/> 5 | <General> 6 | <Flags> 7 | <CompatibilityMode Value="True"/> 8 | </Flags> 9 | <SessionStorage Value="InProjectDir"/> 10 | <Title Value="project1"/> 11 | <Scaled Value="True"/> 12 | <ResourceType Value="res"/> 13 | <UseXPManifest Value="True"/> 14 | <XPManifest> 15 | <DpiAware Value="True"/> 16 | </XPManifest> 17 | <Icon Value="0"/> 18 | </General> 19 | <BuildModes Count="1"> 20 | <Item1 Name="Default" Default="True"/> 21 | </BuildModes> 22 | <PublishOptions> 23 | <Version Value="2"/> 24 | <UseFileFilters Value="True"/> 25 | </PublishOptions> 26 | <RunParams> 27 | <FormatVersion Value="2"/> 28 | <Modes Count="0"/> 29 | </RunParams> 30 | <RequiredPackages Count="2"> 31 | <Item1> 32 | <PackageName Value="RSQL_Package"/> 33 | </Item1> 34 | <Item2> 35 | <PackageName Value="LCL"/> 36 | </Item2> 37 | </RequiredPackages> 38 | <Units Count="2"> 39 | <Unit0> 40 | <Filename Value="project1.lpr"/> 41 | <IsPartOfProject Value="True"/> 42 | </Unit0> 43 | <Unit1> 44 | <Filename Value="unit1.pas"/> 45 | <IsPartOfProject Value="True"/> 46 | <ComponentName Value="Form1"/> 47 | <HasResources Value="True"/> 48 | <ResourceBaseClass Value="Form"/> 49 | <UnitName Value="Unit1"/> 50 | </Unit1> 51 | </Units> 52 | </ProjectOptions> 53 | <CompilerOptions> 54 | <Version Value="11"/> 55 | <Target> 56 | <Filename Value="project1"/> 57 | </Target> 58 | <SearchPaths> 59 | <IncludeFiles Value="$(ProjOutDir)"/> 60 | <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> 61 | </SearchPaths> 62 | <Linking> 63 | <Options> 64 | <Win32> 65 | <GraphicApplication Value="True"/> 66 | </Win32> 67 | </Options> 68 | </Linking> 69 | </CompilerOptions> 70 | <Debugging> 71 | <Exceptions Count="3"> 72 | <Item1> 73 | <Name Value="EAbort"/> 74 | </Item1> 75 | <Item2> 76 | <Name Value="ECodetoolError"/> 77 | </Item2> 78 | <Item3> 79 | <Name Value="EFOpenError"/> 80 | </Item3> 81 | </Exceptions> 82 | </Debugging> 83 | </CONFIG> 84 | -------------------------------------------------------------------------------- /demo/basic/client/rsqlclientproject1.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="11"/> 5 | <General> 6 | <SessionStorage Value="InProjectDir"/> 7 | <MainUnit Value="0"/> 8 | <Title Value="rsqlclientproject1"/> 9 | <Scaled Value="True"/> 10 | <ResourceType Value="res"/> 11 | <UseXPManifest Value="True"/> 12 | <XPManifest> 13 | <DpiAware Value="True"/> 14 | </XPManifest> 15 | <Icon Value="0"/> 16 | </General> 17 | <BuildModes Count="1"> 18 | <Item1 Name="Default" Default="True"/> 19 | </BuildModes> 20 | <PublishOptions> 21 | <Version Value="2"/> 22 | <UseFileFilters Value="True"/> 23 | </PublishOptions> 24 | <RunParams> 25 | <FormatVersion Value="2"/> 26 | <Modes Count="0"/> 27 | </RunParams> 28 | <RequiredPackages Count="3"> 29 | <Item1> 30 | <PackageName Value="RSQL_Package"/> 31 | </Item1> 32 | <Item2> 33 | <PackageName Value="FCL"/> 34 | </Item2> 35 | <Item3> 36 | <PackageName Value="LCL"/> 37 | </Item3> 38 | </RequiredPackages> 39 | <Units Count="2"> 40 | <Unit0> 41 | <Filename Value="rsqlclientproject1.lpr"/> 42 | <IsPartOfProject Value="True"/> 43 | </Unit0> 44 | <Unit1> 45 | <Filename Value="unit1.pas"/> 46 | <IsPartOfProject Value="True"/> 47 | <ComponentName Value="Form1"/> 48 | <HasResources Value="True"/> 49 | <ResourceBaseClass Value="Form"/> 50 | <UnitName Value="Unit1"/> 51 | </Unit1> 52 | </Units> 53 | </ProjectOptions> 54 | <CompilerOptions> 55 | <Version Value="11"/> 56 | <Target> 57 | <Filename Value="rsqlclientproject1"/> 58 | </Target> 59 | <SearchPaths> 60 | <IncludeFiles Value="$(ProjOutDir)"/> 61 | <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> 62 | </SearchPaths> 63 | <Linking> 64 | <Options> 65 | <Win32> 66 | <GraphicApplication Value="True"/> 67 | </Win32> 68 | </Options> 69 | </Linking> 70 | </CompilerOptions> 71 | <Debugging> 72 | <Exceptions Count="3"> 73 | <Item1> 74 | <Name Value="EAbort"/> 75 | </Item1> 76 | <Item2> 77 | <Name Value="ECodetoolError"/> 78 | </Item2> 79 | <Item3> 80 | <Name Value="EFOpenError"/> 81 | </Item3> 82 | </Exceptions> 83 | </Debugging> 84 | </CONFIG> 85 | -------------------------------------------------------------------------------- /source/rsql_crypto_zstream.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Crypto_ZStream; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | ZStream; 33 | 34 | function ZCompressString(AString: string; 35 | const ALevel: TCompressionLevel = clmax): string; 36 | function ZDecompressString(AString: string): string; 37 | 38 | implementation 39 | 40 | uses 41 | base64; 42 | 43 | function ZCompressString(AString: string; const ALevel: TCompressionLevel): string; 44 | var 45 | VCompressionStream: Tcompressionstream; 46 | VStream: TStringStream; 47 | begin 48 | VStream := TStringStream.Create(''); 49 | try 50 | VCompressionStream := Tcompressionstream.Create(ALevel, VStream); 51 | try 52 | VCompressionStream.WriteAnsiString(AString); 53 | finally 54 | FreeAndNil(VCompressionStream); 55 | end; 56 | Result := EncodeStringBase64(VStream.DataString); 57 | finally 58 | FreeAndNil(VStream); 59 | end; 60 | end; 61 | 62 | function ZDecompressString(AString: string): string; 63 | var 64 | VDeCompressionStream: Tdecompressionstream; 65 | VStream: TStringStream; 66 | begin 67 | VStream := TStringStream.Create(DecodeStringBase64(AString)); 68 | try 69 | VDeCompressionStream := Tdecompressionstream.Create(VStream); 70 | try 71 | VDeCompressionStream.Position := 0; 72 | Result := VDeCompressionStream.ReadAnsiString; 73 | finally 74 | FreeAndNil(VDeCompressionStream); 75 | end; 76 | finally 77 | FreeAndNil(VStream); 78 | end; 79 | end; 80 | 81 | end. 82 | -------------------------------------------------------------------------------- /rsql_package.lpk: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <Package Version="5"> 4 | <Name Value="RSQL_Package"/> 5 | <Type Value="RunAndDesignTime"/> 6 | <CompilerOptions> 7 | <Version Value="11"/> 8 | <SearchPaths> 9 | <OtherUnitFiles Value="source"/> 10 | <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> 11 | </SearchPaths> 12 | </CompilerOptions> 13 | <Version Major="1" Minor="1" Release="1" Build="1"/> 14 | <Files Count="12"> 15 | <Item1> 16 | <Filename Value="source/rsql_helper.pas"/> 17 | <UnitName Value="RSQL_Helper"/> 18 | </Item1> 19 | <Item2> 20 | <Filename Value="source/rsql_crypto_hmac.pas"/> 21 | <UnitName Value="RSQL_Crypto_HMAC"/> 22 | </Item2> 23 | <Item3> 24 | <Filename Value="source/rsql_crypto_base64.pas"/> 25 | <UnitName Value="RSQL_Crypto_BASE64"/> 26 | </Item3> 27 | <Item4> 28 | <Filename Value="source/rsql_crypto_zstream.pas"/> 29 | <UnitName Value="RSQL_Crypto_ZStream"/> 30 | </Item4> 31 | <Item5> 32 | <Filename Value="source/rsql_crypto_jwt.pas"/> 33 | <UnitName Value="RSQL_Crypto_JWT"/> 34 | </Item5> 35 | <Item6> 36 | <Filename Value="source/rsql_server_database.pas"/> 37 | <UnitName Value="RSQL_Server_Database"/> 38 | </Item6> 39 | <Item7> 40 | <Filename Value="source/rsql_server_transaction.pas"/> 41 | <UnitName Value="RSQL_Server_Transaction"/> 42 | </Item7> 43 | <Item8> 44 | <Filename Value="source/rsql_server_router.pas"/> 45 | <UnitName Value="RSQL_Server_Router"/> 46 | </Item8> 47 | <Item9> 48 | <Filename Value="source/rsql_server_component.pas"/> 49 | <UnitName Value="RSQL_Server_Component"/> 50 | </Item9> 51 | <Item10> 52 | <Filename Value="source/rsql_server_application.pas"/> 53 | <UnitName Value="RSQL_Server_Application"/> 54 | </Item10> 55 | <Item11> 56 | <Filename Value="source/rsql_client_connection.pas"/> 57 | <UnitName Value="RSQL_Client_Connection"/> 58 | </Item11> 59 | <Item12> 60 | <Filename Value="source/rsql_register.pas"/> 61 | <HasRegisterProc Value="True"/> 62 | <UnitName Value="RSQL_Register"/> 63 | </Item12> 64 | </Files> 65 | <CompatibilityMode Value="True"/> 66 | <RequiredPkgs Count="2"> 67 | <Item1> 68 | <PackageName Value="IDEIntf"/> 69 | </Item1> 70 | <Item2> 71 | <PackageName Value="FCL"/> 72 | </Item2> 73 | </RequiredPkgs> 74 | <UsageOptions> 75 | <UnitPath Value="$(PkgOutDir)"/> 76 | </UsageOptions> 77 | <PublishOptions> 78 | <Version Value="2"/> 79 | <UseFileFilters Value="True"/> 80 | </PublishOptions> 81 | </Package> 82 | </CONFIG> 83 | -------------------------------------------------------------------------------- /source/rsql_crypto_base64.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Crypto_BASE64; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils; 32 | 33 | function BASE64Decode(const AValue: string): string; 34 | function BASE64Encode(const AValue: string): string; 35 | 36 | function BASE64URLDecode(const AValue: string): string; 37 | function BASE64URLEncode(const AValue: string): string; 38 | 39 | implementation 40 | 41 | uses 42 | strutils, 43 | base64; 44 | 45 | function BASE64Decode(const AValue: string): string; 46 | begin 47 | if (AValue = EmptyStr) then 48 | begin 49 | Result := AValue; 50 | end 51 | else 52 | begin 53 | Result := DecodeStringBASE64(AValue); 54 | end; 55 | end; 56 | 57 | function BASE64Encode(const AValue: string): string; 58 | begin 59 | if (AValue = EmptyStr) then 60 | begin 61 | Result := AValue; 62 | end 63 | else 64 | begin 65 | Result := EncodeStringBASE64(AValue); 66 | end; 67 | end; 68 | 69 | function BASE64URLDecode(const AValue: string): string; 70 | var 71 | VLength: integer; 72 | begin 73 | if (AValue = EmptyStr) then 74 | begin 75 | Result := AValue; 76 | end 77 | else 78 | begin 79 | Result := StringsReplace(AValue, ['-', '_'], ['+', '/'], [rfReplaceAll]); 80 | VLength := (Length(Result) mod 4); 81 | if (VLength > 0) then 82 | begin 83 | Result := Result + StringOfChar('=', 4 - VLength); 84 | end; 85 | Result := BASE64Decode(Result); 86 | end; 87 | end; 88 | 89 | function BASE64URLEncode(const AValue: string): string; 90 | begin 91 | if (AValue = EmptyStr) then 92 | begin 93 | Result := AValue; 94 | end 95 | else 96 | begin 97 | Result := BASE64Encode(AValue); 98 | Result := StringsReplace(Result, ['+', '/'], ['-', '_'], [rfReplaceAll]); 99 | Result := TrimRightSet(Result, ['=']); 100 | end; 101 | end; 102 | 103 | end. 104 | -------------------------------------------------------------------------------- /demo/basic/client/unit1.lfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 368 3 | Height = 340 4 | Top = 170 5 | Width = 653 6 | Caption = 'Form1' 7 | ClientHeight = 340 8 | ClientWidth = 653 9 | LCLVersion = '2.0.2.0' 10 | object DBGrid1: TDBGrid 11 | AnchorSideLeft.Control = Owner 12 | AnchorSideTop.Control = Button1 13 | AnchorSideTop.Side = asrBottom 14 | AnchorSideRight.Control = Owner 15 | AnchorSideRight.Side = asrBottom 16 | AnchorSideBottom.Control = Owner 17 | AnchorSideBottom.Side = asrBottom 18 | Left = 5 19 | Height = 300 20 | Top = 35 21 | Width = 643 22 | Anchors = [akTop, akLeft, akRight, akBottom] 23 | BorderSpacing.Left = 5 24 | BorderSpacing.Top = 5 25 | BorderSpacing.Right = 5 26 | BorderSpacing.Bottom = 5 27 | Color = clWindow 28 | Columns = < 29 | item 30 | Title.Caption = 'ID' 31 | Width = 60 32 | FieldName = 'ID' 33 | end 34 | item 35 | Title.Caption = 'JobTitle' 36 | Width = 200 37 | FieldName = 'JobTitle' 38 | end 39 | item 40 | Title.Caption = 'EmailAddress' 41 | Width = 200 42 | FieldName = 'EmailAddress' 43 | end 44 | item 45 | Title.Caption = 'FirstNameLastName' 46 | Width = 250 47 | FieldName = 'FirstNameLastName' 48 | end> 49 | DataSource = DataSource1 50 | TabOrder = 0 51 | end 52 | object Button1: TButton 53 | AnchorSideLeft.Control = Owner 54 | AnchorSideTop.Control = Owner 55 | Left = 5 56 | Height = 25 57 | Top = 5 58 | Width = 75 59 | BorderSpacing.Left = 5 60 | BorderSpacing.Top = 5 61 | Caption = 'Load' 62 | OnClick = Button1Click 63 | TabOrder = 1 64 | end 65 | object RSQLClient1: TRSQLClient 66 | Connected = False 67 | LoginPrompt = False 68 | DatabaseName = 'sqlitedb' 69 | KeepConnection = False 70 | Params.Strings = ( 71 | 'Port=8091' 72 | ) 73 | Transaction = SQLTransaction1 74 | HostName = 'localhost' 75 | left = 300 76 | top = 40 77 | end 78 | object SQLTransaction1: TSQLTransaction 79 | Active = False 80 | Database = RSQLHTTPConnection1 81 | left = 300 82 | top = 90 83 | end 84 | object SQLQuery1: TSQLQuery 85 | IndexName = 'DEFAULT_ORDER' 86 | FieldDefs = < 87 | item 88 | Name = 'ID' 89 | DataType = ftLargeint 90 | end 91 | item 92 | Name = 'JobTitle' 93 | DataType = ftString 94 | Size = 500 95 | end 96 | item 97 | Name = 'EmailAddress' 98 | DataType = ftString 99 | Size = 500 100 | end 101 | item 102 | Name = 'FirstNameLastName' 103 | DataType = ftString 104 | Size = 500 105 | end> 106 | Database = RSQLHTTPConnection1 107 | Transaction = SQLTransaction1 108 | SQL.Strings = ( 109 | 'select * from MOCKDATA' 110 | ) 111 | Params = <> 112 | left = 300 113 | top = 144 114 | end 115 | object DataSource1: TDataSource 116 | DataSet = SQLQuery1 117 | left = 300 118 | top = 200 119 | end 120 | end 121 | -------------------------------------------------------------------------------- /source/rsql_crypto_jwt.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Crypto_JWT; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | fpjson, 33 | jsonparser, 34 | RSQL_Crypto_HMAC, 35 | RSQL_Crypto_BASE64, 36 | RSQL_Helper; 37 | 38 | function JWTParse(const ATOKEN, AKEY: string; out AOutput: string): boolean; overload; 39 | function JWTSign(const AKEY, APAYLOAD: string): string; 40 | 41 | implementation 42 | 43 | uses 44 | strutils; 45 | 46 | function JWTHeader: string; 47 | begin 48 | with TJSONObject.Create() do 49 | begin 50 | try 51 | Add('alg', 'HS256'); 52 | Add('typ', 'JWT'); 53 | Result := Stringify(); 54 | finally 55 | Free; 56 | end; 57 | end; 58 | end; 59 | 60 | function JWTParse(const ATOKEN, AKEY: string; out AOutput: string): boolean; 61 | var 62 | VHeaderSeg: string; 63 | VPAYLOADSeg: string; 64 | VSignatureSeg: string; 65 | VHeader: TJSONObject; 66 | VPAYLOAD: TJSONObject; 67 | VSignature: string; 68 | begin 69 | Result := False; 70 | try 71 | /// Segments 72 | VHeaderSeg := ExtractWord(1, ATOKEN, ['.']); 73 | VPAYLOADSeg := ExtractWord(2, ATOKEN, ['.']); 74 | VSignatureSeg := ExtractWord(3, AToken, ['.']); 75 | /// Check signature 76 | VSignature := BASE64URLEncode(HMACSHA256(AKEY, VHeaderSeg + '.' + VPAYLOADSeg)); 77 | if (VSignature <> VSignatureSeg) then 78 | begin 79 | raise Exception.Create('signature verification failed'); 80 | end; 81 | /// Check algorithm type 82 | if (TJSONData.Parse(BASE64URLDecode(VHeaderSeg), VHeader)) then 83 | begin 84 | try 85 | if (VHeader.Path('alg', EmptyStr) <> 'HS256') then 86 | begin 87 | raise Exception.Create('algorithm not supported'); 88 | end; 89 | finally 90 | FreeAndNil(VHeader); 91 | end; 92 | end; 93 | /// Check if token is expired 94 | if (TJSONData.Parse(BASE64URLDecode(VPAYLOADSeg), VPAYLOAD)) then 95 | begin 96 | try 97 | if (VPAYLOAD.Path('exp', 0) <= Now) then 98 | begin 99 | raise Exception.Create('TOKEN expired'); 100 | end; 101 | finally 102 | FreeAndNil(VPAYLOAD); 103 | end; 104 | end; 105 | // TODO: Add new checks 106 | AOutput := 'JWT signature verified'; 107 | Result := True; 108 | except 109 | on E: Exception do 110 | begin 111 | AOutput := Format('JWT invalid. %s', [E.Message]); 112 | end; 113 | end; 114 | end; 115 | 116 | function JWTSign(const AKEY, APAYLOAD: string): string; 117 | var 118 | VHeader: string; 119 | VPAYLOAD: string; 120 | VSignature: string; 121 | begin 122 | VHeader := BASE64URLEncode(JWTHeader); 123 | VPAYLOAD := BASE64URLEncode(APAYLOAD); 124 | VSignature := BASE64URLEncode(HMACSHA256(AKEY, (VHeader + '.' + VPAYLOAD))); 125 | Result := VHeader + '.' + VPAYLOAD + '.' + VSignature; 126 | end; 127 | 128 | end. 129 | -------------------------------------------------------------------------------- /source/rsql_server_application.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Server_Application; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | httpdefs, 33 | httproute, 34 | fphttp, 35 | custweb, 36 | custhttpapp, 37 | RSQL_Helper, 38 | RSQL_Server_Database, 39 | {%H-}RSQL_Server_Router; 40 | 41 | type 42 | 43 | { TRSQLServerHandler } 44 | 45 | TRSQLServerHandler = class(TFPHTTPServerHandler) 46 | public 47 | procedure HandleRequest(ARequest: TRequest; AResponse: TResponse); override; 48 | end; 49 | 50 | { TRSQLApplication } 51 | 52 | TRSQLApplication = class(TCustomHTTPApplication) 53 | private 54 | FCompressed: boolean; 55 | FCORS: boolean; 56 | FCredential: string; 57 | FDatabaseList: TDatabaseList; 58 | FOnAfterRequest: TResponseEvent; 59 | FOnBeforeRequest: TRequestEvent; 60 | procedure SetDatabaseList(AValue: TDatabaseList); 61 | protected 62 | function InitializeWebHandler: TWebHandler; override; 63 | public 64 | constructor Create(AOwner: TComponent); override; 65 | destructor Destroy; override; 66 | property Compressed: boolean read FCompressed write FCompressed default False; 67 | property CORS: boolean read FCORS write FCORS default True; 68 | property Credential: string read FCredential write FCredential; 69 | property DatabaseList: TDatabaseList read FDatabaseList write SetDatabaseList; 70 | property Port default 8091; 71 | property Threaded default True; 72 | property OnAfterRequest: TResponseEvent read FOnAfterRequest write FOnAfterRequest; 73 | property OnBeforeRequest: TRequestEvent read FOnBeforeRequest write FOnBeforeRequest; 74 | end; 75 | 76 | implementation 77 | 78 | { TRSQLServerHandler } 79 | 80 | procedure TRSQLServerHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse); 81 | var 82 | VServer: TRSQLApplication; 83 | begin 84 | try 85 | if (Assigned(Owner)) and (Owner.InheritsFrom(TRSQLApplication)) then 86 | begin 87 | VServer := TRSQLApplication(Owner); 88 | end 89 | else 90 | begin 91 | raise EFPWebError.Create('unattributed or incompatible SERVER'); 92 | end; 93 | // Before request 94 | if (Assigned(VServer.OnBeforeRequest)) then 95 | begin 96 | VServer.OnBeforeRequest(Self, ARequest); 97 | end; 98 | // Without legacy 99 | HTTPRouter.RouteRequest(VServer, ARequest, AResponse); 100 | // After request 101 | if (Assigned(VServer.OnAfterRequest)) then 102 | begin 103 | VServer.OnAfterRequest(Self, AResponse); 104 | end; 105 | except 106 | on E: Exception do 107 | begin 108 | ShowRequestException(AResponse, E); 109 | end; 110 | end; 111 | end; 112 | 113 | { TRSQLApplication } 114 | 115 | procedure TRSQLApplication.SetDatabaseList(AValue: TDatabaseList); 116 | begin 117 | FDatabaseList.Assign(AValue); 118 | end; 119 | 120 | function TRSQLApplication.InitializeWebHandler: TWebHandler; 121 | begin 122 | Result := TRSQLServerHandler.Create(Self); 123 | end; 124 | 125 | constructor TRSQLApplication.Create(AOwner: TComponent); 126 | begin 127 | inherited Create(AOwner); 128 | Port := 8091; 129 | Threaded := True; 130 | FDatabaseList := TDatabaseList.Create; 131 | FCompressed := False; 132 | FCORS := True; 133 | FCredential := EmptyStr; 134 | // Routes 135 | InitializeRoutes; 136 | end; 137 | 138 | destructor TRSQLApplication.Destroy; 139 | begin 140 | FreeAndNil(FDatabaseList); 141 | inherited Destroy; 142 | end; 143 | 144 | end. 145 | -------------------------------------------------------------------------------- /source/rsql_server_component.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Server_Component; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | httpDefs, 33 | httproute, 34 | fphttpserver, 35 | RSQL_Helper, 36 | RSQL_Server_Database, 37 | {%H-}RSQL_Server_Router; 38 | 39 | type 40 | 41 | { THTTPServerThread } 42 | 43 | THTTPServerThread = class(TThread) 44 | strict private 45 | FOnExecute: TNotifyEvent; 46 | public 47 | constructor Create; reintroduce; 48 | procedure Execute; override; 49 | property Terminated; 50 | property OnExecute: TNotifyEvent read FOnExecute write FOnExecute; 51 | end; 52 | 53 | { THTTPServer } 54 | 55 | THTTPServer = class(TFPCustomHttpServer) 56 | private 57 | FCompressed: boolean; 58 | FCORS: boolean; 59 | FCredential: string; 60 | FDatabaseList: TDatabaseList; 61 | FCanExecute: boolean; 62 | FThread: THTTPServerThread; 63 | FOnAfterRequest: TResponseEvent; 64 | FOnBeforeRequest: TRequestEvent; 65 | procedure DoOnExecute({%H-}ASender: TObject); 66 | procedure DoOnTerminate({%H-}ASender: TObject); 67 | procedure SetDatabaseList(AValue: TDatabaseList); 68 | protected 69 | procedure HandleRequest(var ARequest: TFPHTTPConnectionRequest; 70 | var AResponse: TFPHTTPConnectionResponse); override; 71 | public 72 | constructor Create(AOwner: TComponent); override; 73 | destructor Destroy; override; 74 | procedure Stop; 75 | procedure Start; 76 | published 77 | property Compressed: boolean read FCompressed write FCompressed default False; 78 | property CORS: boolean read FCORS write FCORS default True; 79 | property Credential: string read FCredential write FCredential; 80 | property DatabaseList: TDatabaseList read FDatabaseList write SetDatabaseList; 81 | property Port default 8091; 82 | property Threaded default True; 83 | property OnAfterRequest: TResponseEvent read FOnAfterRequest write FOnAfterRequest; 84 | property OnBeforeRequest: TRequestEvent read FOnBeforeRequest write FOnBeforeRequest; 85 | end; 86 | 87 | { TRSQLServer } 88 | 89 | TRSQLServer = class(THTTPServer); 90 | 91 | implementation 92 | 93 | { THTTPServerThread } 94 | 95 | constructor THTTPServerThread.Create; 96 | begin 97 | FOnExecute := nil; 98 | inherited Create(True); 99 | end; 100 | 101 | procedure THTTPServerThread.Execute; 102 | begin 103 | if (Assigned(FOnExecute)) then 104 | begin 105 | FOnExecute(Self); 106 | end; 107 | end; 108 | 109 | { THTTPServer } 110 | 111 | procedure THTTPServer.DoOnExecute(ASender: TObject); 112 | begin 113 | if (FCanExecute) then 114 | begin 115 | Active := True; 116 | end; 117 | end; 118 | 119 | procedure THTTPServer.DoOnTerminate(ASender: TObject); 120 | begin 121 | FThread := nil; 122 | end; 123 | 124 | procedure THTTPServer.SetDatabaseList(AValue: TDatabaseList); 125 | begin 126 | FDatabaseList.Assign(AValue); 127 | end; 128 | 129 | procedure THTTPServer.HandleRequest(var ARequest: TFPHTTPConnectionRequest; 130 | var AResponse: TFPHTTPConnectionResponse); 131 | begin 132 | // Before request 133 | if (Assigned(FOnBeforeRequest)) then 134 | begin 135 | FOnBeforeRequest(Self, ARequest); 136 | end; 137 | HTTPRouter.RouteRequest(Self, ARequest, AResponse); 138 | // After request 139 | if (Assigned(FOnAfterRequest)) then 140 | begin 141 | FOnAfterRequest(Self, AResponse); 142 | end; 143 | end; 144 | 145 | constructor THTTPServer.Create(AOwner: TComponent); 146 | begin 147 | inherited Create(AOwner); 148 | AcceptIdleTimeout := 1; 149 | Port := 8091; 150 | Threaded := True; 151 | FDatabaseList := TDatabaseList.Create; 152 | FCanExecute := False; 153 | FCompressed := False; 154 | FCORS := True; 155 | FCredential := EmptyStr; 156 | // Routes 157 | InitializeRoutes; 158 | end; 159 | 160 | destructor THTTPServer.Destroy; 161 | begin 162 | FCanExecute := False; 163 | Stop; 164 | if Assigned(FThread) then 165 | begin 166 | FThread.FreeOnTerminate := False; 167 | FThread.Free; 168 | end; 169 | Threaded := False; 170 | FreeAndNil(FDatabaseList); 171 | inherited Destroy; 172 | end; 173 | 174 | procedure THTTPServer.Stop; 175 | begin 176 | if (not (Active)) then 177 | begin 178 | Exit; 179 | end; 180 | try 181 | Active := False; 182 | except 183 | if (Active) then 184 | begin 185 | raise; 186 | end; 187 | end; 188 | end; 189 | 190 | procedure THTTPServer.Start; 191 | begin 192 | if (Active) then 193 | begin 194 | Exit; 195 | end; 196 | FCanExecute := False; 197 | try 198 | if (not (Assigned(FThread))) then 199 | begin 200 | FThread := THTTPServerThread.Create; 201 | FThread.OnExecute := @DoOnExecute; 202 | FThread.FreeOnTerminate := True; 203 | FThread.OnTerminate := @DoOnTerminate; 204 | end; 205 | finally 206 | FCanExecute := True; 207 | end; 208 | // Start 209 | FThread.Start; 210 | end; 211 | 212 | end. 213 | -------------------------------------------------------------------------------- /source/rsql_crypto_hmac.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Crypto_HMAC; 24 | 25 | {$I rsql.inc} 26 | {$R-} 27 | 28 | interface 29 | 30 | uses 31 | Classes, 32 | SysUtils; 33 | 34 | function HMACSHA256(const AKey, AData: string): string; 35 | 36 | implementation 37 | 38 | /// Ref: https://github.com/stijnsanders/TRethinkDB/blob/master/RethinkDBAuth.pas#L35 39 | function SWAPEndian32(Value: cardinal): cardinal; 40 | var 41 | x: array[0..3] of byte absolute Result; 42 | y: array[0..3] of byte absolute Value; 43 | begin 44 | x[0] := y[3]; 45 | x[1] := y[2]; 46 | x[2] := y[1]; 47 | x[3] := y[0]; 48 | end; 49 | 50 | /// Ref: https://github.com/stijnsanders/TRethinkDB/blob/master/RethinkDBAuth.pas#L46 51 | function SHA256HASH(x: string): string; 52 | const 53 | base: array[0..63] of cardinal = ( 54 | $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, 55 | $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5, 56 | $d807aa98, $12835b01, $243185be, $550c7dc3, 57 | $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, 58 | $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc, 59 | $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da, 60 | $983e5152, $a831c66d, $b00327c8, $bf597fc7, 61 | $c6e00bf3, $d5a79147, $06ca6351, $14292967, 62 | $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13, 63 | $650a7354, $766a0abb, $81c2c92e, $92722c85, 64 | $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3, 65 | $d192e819, $d6990624, $f40e3585, $106aa070, 66 | $19a4c116, $1e376c08, $2748774c, $34b0bcb5, 67 | $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3, 68 | $748f82ee, $78a5636f, $84c87814, $8cc70208, 69 | $90befffa, $a4506ceb, $bef9a3f7, $c67178f2); 70 | var 71 | a, b: cardinal; 72 | dl, i, j: integer; 73 | d: array of cardinal; 74 | e: array[0..63] of cardinal; 75 | g, h: array[0..7] of cardinal; 76 | begin 77 | Result := ''; 78 | d := nil; 79 | a := Length(x); 80 | dl := a + 9; 81 | if (dl mod 64) <> 0 then 82 | begin 83 | dl := ((dl div 64) + 1) * 64; 84 | end; 85 | i := dl; 86 | dl := dl div 4; 87 | SetLength(d, dl); 88 | SetLength(x, i); 89 | j := a + 1; 90 | x[j] := #$80; 91 | while j < i do 92 | begin 93 | Inc(j); 94 | x[j] := #0; 95 | end; 96 | Move(x[1], d[0], i); 97 | d[dl - 1] := SWAPEndian32(a shl 3); 98 | h[0] := $6a09e667; 99 | h[1] := $bb67ae85; 100 | h[2] := $3c6ef372; 101 | h[3] := $a54ff53a; 102 | h[4] := $510e527f; 103 | h[5] := $9b05688c; 104 | h[6] := $1f83d9ab; 105 | h[7] := $5be0cd19; 106 | i := 0; 107 | while i < dl do 108 | begin 109 | j := 0; 110 | while j < 16 do 111 | begin 112 | e[j] := SWAPEndian32(d[i]); 113 | Inc(i); 114 | Inc(j); 115 | end; 116 | while j < 64 do 117 | begin 118 | a := e[j - 15]; 119 | b := e[j - 2]; 120 | e[j] := e[j - 16] + (((a shr 7) or (a shl 25)) xor 121 | ((a shr 18) or (a shl 14)) xor (a shr 3)) + e[j - 7] + 122 | (((b shr 17) or (b shl 15)) xor ((b shr 19) or (b shl 13)) xor (b shr 10)); 123 | Inc(j); 124 | end; 125 | g := h; 126 | j := 0; 127 | while j < 64 do 128 | begin 129 | a := g[4]; 130 | b := g[0]; 131 | a := g[7] + (((a shr 6) or (a shl 26)) xor ((a shr 11) or (a shl 21)) xor 132 | ((a shr 25) or (a shl 7))) + ((g[4] and g[5]) or (not (g[4]) and g[6])) + 133 | base[j] + e[j]; 134 | Inc(g[3], a); 135 | a := a + (((b shr 2) or (b shl 30)) xor ((b shr 13) or (b shl 19)) xor 136 | ((b shr 22) or (b shl 10))) + ((g[0] and g[1]) or (g[1] and g[2]) or (g[2] and g[0])); 137 | g[7] := g[6]; 138 | g[6] := g[5]; 139 | g[5] := g[4]; 140 | g[4] := g[3]; 141 | g[3] := g[2]; 142 | g[2] := g[1]; 143 | g[1] := g[0]; 144 | g[0] := a; 145 | Inc(j); 146 | end; 147 | for j := 0 to 7 do 148 | begin 149 | Inc(h[j], g[j]); 150 | end; 151 | end; 152 | SetLength(Result, 32); 153 | for j := 0 to 31 do 154 | begin 155 | Result[j + 1] := AnsiChar(h[j shr 2] shr ((3 - (j and 3)) * 8)); 156 | end; 157 | end; 158 | 159 | function HMACSHA256(const AKey, AData: string): string; 160 | const 161 | BlockSize = 64; 162 | var 163 | k, h1, h2: string; 164 | i: integer; 165 | begin 166 | Result := ''; 167 | if (AKey <> '') then 168 | begin 169 | h1 := ''; 170 | h2 := ''; 171 | if Length(AKey) > BlockSize then 172 | begin 173 | k := SHA256HASH(AKey); 174 | end 175 | else 176 | begin 177 | k := AKey; 178 | i := Length(k); 179 | SetLength(k, BlockSize); 180 | while (i < BlockSize) do 181 | begin 182 | Inc(i); 183 | k[i] := #0; 184 | end; 185 | end; 186 | SetLength(h1, BlockSize); 187 | SetLength(h2, BlockSize); 188 | for i := 1 to BlockSize do 189 | begin 190 | byte(h1[i]) := byte(k[i]) xor $5C; 191 | end; 192 | for i := 1 to BlockSize do 193 | begin 194 | byte(h2[i]) := byte(k[i]) xor $36; 195 | end; 196 | Result := SHA256HASH(h1 + SHA256HASH(h2 + AData)); 197 | end; 198 | end; 199 | 200 | end. 201 | -------------------------------------------------------------------------------- /source/rsql_server_database.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Server_Database; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | DB; 33 | 34 | type 35 | // Forward declaration 36 | TDatabaseList = class; 37 | 38 | { TDatabaseItem } 39 | 40 | TDatabaseItem = class(TCollectionItem) 41 | private 42 | FDatabase: TDatabase; 43 | FDatabaseList: TDatabaseList; 44 | FIsDefault: boolean; 45 | FName: string; 46 | procedure SetDatabase(AValue: TDatabase); 47 | procedure SetIsDefault(AValue: boolean); 48 | procedure SetName(AValue: string); 49 | protected 50 | function GetDisplayName: string; override; 51 | procedure SetCollection(AValue: TCollection); override; 52 | published 53 | property Database: TDatabase read FDatabase write SetDatabase; 54 | property IsDefault: boolean read FIsDefault write SetIsDefault; 55 | property Name: string read FName write SetName; 56 | end; 57 | 58 | { TDatabaseList } 59 | 60 | TDatabaseList = class(TCollection) 61 | private 62 | function GetItems(const AIndex: integer): TDatabaseItem; 63 | protected 64 | procedure Notify(AItem: TCollectionItem; AAction: TCollectionNotification); override; 65 | procedure UpdateDefault(const ADatabaseItem: TDatabaseItem); 66 | public 67 | constructor Create; reintroduce; 68 | function Add: TDatabaseItem; 69 | function Find(const AName: string): TDatabaseItem; 70 | function FindDefault: TDatabaseItem; 71 | property Items[const AIndex: integer]: TDatabaseItem read GetItems; default; 72 | end; 73 | 74 | implementation 75 | 76 | { TDatabaseItem } 77 | 78 | procedure TDatabaseItem.SetIsDefault(AValue: boolean); 79 | begin 80 | if (FIsDefault <> AValue) then 81 | begin 82 | FIsDefault := AValue; 83 | if (Assigned(FDatabaseList)) then 84 | begin 85 | if (FIsDefault) then 86 | begin 87 | FDatabaseList.UpdateDefault(Self); 88 | end 89 | else 90 | begin 91 | // Without default 92 | if (not (Assigned(FDatabaseList.FindDefault))) then 93 | begin 94 | FIsDefault := True; 95 | end; 96 | end; 97 | end; 98 | end; 99 | end; 100 | 101 | procedure TDatabaseItem.SetName(AValue: string); 102 | begin 103 | if (FName <> AValue) then 104 | begin 105 | if (Assigned(FDatabaseList)) and (Assigned(FDatabaseList.Find(AValue))) then 106 | begin 107 | raise Exception.CreateFmt('duplicate name ''%s'' in %s', 108 | [AValue, FDatabaseList.ClassName]); 109 | end; 110 | FName := AValue; 111 | end; 112 | end; 113 | 114 | procedure TDatabaseItem.SetDatabase(AValue: TDatabase); 115 | begin 116 | if (FDatabase <> AValue) then 117 | begin 118 | FDatabase := AValue; 119 | if (Assigned(FDatabase)) and (FName = EmptyStr) then 120 | begin 121 | SetName(FDatabase.Name); 122 | end; 123 | end; 124 | end; 125 | 126 | function TDatabaseItem.GetDisplayName: string; 127 | begin 128 | if (FName = EmptyStr) then 129 | begin 130 | Result := inherited GetDisplayName; 131 | end 132 | else 133 | begin 134 | Result := FName; 135 | end; 136 | end; 137 | 138 | procedure TDatabaseItem.SetCollection(AValue: TCollection); 139 | begin 140 | inherited SetCollection(AValue); 141 | FDatabaseList := nil; 142 | if (Assigned(AValue)) and (AValue.InheritsFrom(TDatabaseList)) then 143 | begin 144 | FDatabaseList := TDatabaseList(AValue); 145 | end; 146 | end; 147 | 148 | { TDatabaseList } 149 | 150 | function TDatabaseList.GetItems(const AIndex: integer): TDatabaseItem; 151 | begin 152 | Result := TDatabaseItem(inherited Items[AIndex]); 153 | end; 154 | 155 | procedure TDatabaseList.UpdateDefault(const ADatabaseItem: TDatabaseItem); 156 | var 157 | VIndex: integer; 158 | VDatabaseItem: TDatabaseItem; 159 | begin 160 | for VIndex := 0 to (Count - 1) do 161 | begin 162 | VDatabaseItem := Items[VIndex]; 163 | if (Assigned(VDatabaseItem)) then 164 | begin 165 | VDatabaseItem.IsDefault := (VDatabaseItem = ADatabaseItem); 166 | end; 167 | end; 168 | end; 169 | 170 | procedure TDatabaseList.Notify(AItem: TCollectionItem; AAction: TCollectionNotification); 171 | begin 172 | inherited Notify(AItem, AAction); 173 | if (Assigned(AItem)) and (AItem.InheritsFrom(TDatabaseItem)) and 174 | (AAction = cnAdded) and (Count = 1) then 175 | begin 176 | UpdateDefault(TDatabaseItem(AItem)); 177 | end; 178 | end; 179 | 180 | constructor TDatabaseList.Create; 181 | begin 182 | inherited Create(TDatabaseItem); 183 | end; 184 | 185 | function TDatabaseList.Add: TDatabaseItem; 186 | begin 187 | Result := TDatabaseItem(inherited Add); 188 | end; 189 | 190 | function TDatabaseList.Find(const AName: string): TDatabaseItem; 191 | var 192 | VIndex: integer; 193 | VDatabaseItem: TDatabaseItem; 194 | begin 195 | Result := nil; 196 | for VIndex := 0 to (Count - 1) do 197 | begin 198 | VDatabaseItem := Items[VIndex]; 199 | if (Assigned(VDatabaseItem)) and (VDatabaseItem.Name = AName) then 200 | begin 201 | Result := VDatabaseItem; 202 | Break; 203 | end; 204 | end; 205 | end; 206 | 207 | function TDatabaseList.FindDefault: TDatabaseItem; 208 | var 209 | VIndex: integer; 210 | VDatabaseItem: TDatabaseItem; 211 | begin 212 | Result := nil; 213 | for VIndex := 0 to (Count - 1) do 214 | begin 215 | VDatabaseItem := Items[VIndex]; 216 | if (Assigned(VDatabaseItem)) and (VDatabaseItem.IsDefault) then 217 | begin 218 | Result := VDatabaseItem; 219 | Break; 220 | end; 221 | end; 222 | end; 223 | 224 | end. 225 | -------------------------------------------------------------------------------- /demo/jwt/project1.lps: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectSession> 4 | <Version Value="12"/> 5 | <BuildModes Active="Default"/> 6 | <Units Count="10"> 7 | <Unit0> 8 | <Filename Value="project1.lpr"/> 9 | <IsPartOfProject Value="True"/> 10 | <EditorIndex Value="-1"/> 11 | <WindowIndex Value="-1"/> 12 | <TopLine Value="-1"/> 13 | <CursorPos X="-1" Y="-1"/> 14 | <UsageCount Value="24"/> 15 | </Unit0> 16 | <Unit1> 17 | <Filename Value="unit1.pas"/> 18 | <IsPartOfProject Value="True"/> 19 | <ComponentName Value="Form1"/> 20 | <HasResources Value="True"/> 21 | <ResourceBaseClass Value="Form"/> 22 | <UnitName Value="Unit1"/> 23 | <TopLine Value="69"/> 24 | <CursorPos X="21" Y="74"/> 25 | <UsageCount Value="24"/> 26 | <Loaded Value="True"/> 27 | <LoadedDesigner Value="True"/> 28 | </Unit1> 29 | <Unit2> 30 | <Filename Value="../../pkg/RSQL-master/source/rsql_crypto_jwt.pas"/> 31 | <UnitName Value="RSQL_Crypto_JWT"/> 32 | <EditorIndex Value="-1"/> 33 | <TopLine Value="89"/> 34 | <CursorPos X="84" Y="90"/> 35 | <UsageCount Value="10"/> 36 | </Unit2> 37 | <Unit3> 38 | <Filename Value="/fpcupdeluxe/installazioni/20191015/lazarus/lcl/include/control.inc"/> 39 | <EditorIndex Value="-1"/> 40 | <TopLine Value="3550"/> 41 | <CursorPos Y="3568"/> 42 | <UsageCount Value="10"/> 43 | </Unit3> 44 | <Unit4> 45 | <Filename Value="../../pkg/RSQL-master/source/rsql_server_router.pas"/> 46 | <UnitName Value="RSQL_Server_Router"/> 47 | <EditorIndex Value="-1"/> 48 | <TopLine Value="172"/> 49 | <CursorPos X="7" Y="191"/> 50 | <UsageCount Value="10"/> 51 | </Unit4> 52 | <Unit5> 53 | <Filename Value="/fpcupdeluxe/installazioni/20191015/fpcsrc/rtl/objpas/sysutils/datih.inc"/> 54 | <EditorIndex Value="-1"/> 55 | <TopLine Value="110"/> 56 | <CursorPos X="10" Y="128"/> 57 | <UsageCount Value="10"/> 58 | </Unit5> 59 | <Unit6> 60 | <Filename Value="../../pkg/RSQL-master/source/rsql_helper.pas"/> 61 | <UnitName Value="RSQL_Helper"/> 62 | <EditorIndex Value="-1"/> 63 | <TopLine Value="38"/> 64 | <CursorPos X="68" Y="56"/> 65 | <UsageCount Value="10"/> 66 | </Unit6> 67 | <Unit7> 68 | <Filename Value="../RSQL-master/source/rsql_crypto_jwt.pas"/> 69 | <UnitName Value="RSQL_Crypto_JWT"/> 70 | <EditorIndex Value="-1"/> 71 | <TopLine Value="87"/> 72 | <CursorPos X="85" Y="74"/> 73 | <UsageCount Value="10"/> 74 | </Unit7> 75 | <Unit8> 76 | <Filename Value="../../../Documentos/dev/fpc/trunk/fpcsrc/packages/rtl-objpas/src/inc/dateutil.inc"/> 77 | <EditorIndex Value="-1"/> 78 | <TopLine Value="382"/> 79 | <CursorPos X="10" Y="128"/> 80 | <UsageCount Value="10"/> 81 | </Unit8> 82 | <Unit9> 83 | <Filename Value="../../source/rsql_crypto_jwt.pas"/> 84 | <UnitName Value="RSQL_Crypto_JWT"/> 85 | <IsVisibleTab Value="True"/> 86 | <EditorIndex Value="1"/> 87 | <TopLine Value="22"/> 88 | <CursorPos X="39" Y="95"/> 89 | <UsageCount Value="10"/> 90 | <Loaded Value="True"/> 91 | </Unit9> 92 | </Units> 93 | <JumpHistory Count="30" HistoryIndex="29"> 94 | <Position1> 95 | <Filename Value="unit1.pas"/> 96 | <Caret Line="35" Column="47" TopLine="29"/> 97 | </Position1> 98 | <Position2> 99 | <Filename Value="unit1.pas"/> 100 | <Caret Line="34" Column="47" TopLine="28"/> 101 | </Position2> 102 | <Position3> 103 | <Filename Value="unit1.pas"/> 104 | <Caret Line="33" Column="47" TopLine="27"/> 105 | </Position3> 106 | <Position4> 107 | <Filename Value="unit1.pas"/> 108 | <Caret Line="32" Column="47" TopLine="26"/> 109 | </Position4> 110 | <Position5> 111 | <Filename Value="unit1.pas"/> 112 | <Caret Line="31" Column="47" TopLine="25"/> 113 | </Position5> 114 | <Position6> 115 | <Filename Value="unit1.pas"/> 116 | <Caret Line="30" Column="47" TopLine="24"/> 117 | </Position6> 118 | <Position7> 119 | <Filename Value="unit1.pas"/> 120 | <Caret Line="31" Column="47" TopLine="25"/> 121 | </Position7> 122 | <Position8> 123 | <Filename Value="unit1.pas"/> 124 | <Caret Line="32" Column="47" TopLine="26"/> 125 | </Position8> 126 | <Position9> 127 | <Filename Value="unit1.pas"/> 128 | <Caret Line="33" Column="47" TopLine="27"/> 129 | </Position9> 130 | <Position10> 131 | <Filename Value="unit1.pas"/> 132 | <Caret Line="34" Column="47" TopLine="28"/> 133 | </Position10> 134 | <Position11> 135 | <Filename Value="unit1.pas"/> 136 | <Caret Line="36" Column="47" TopLine="30"/> 137 | </Position11> 138 | <Position12> 139 | <Filename Value="unit1.pas"/> 140 | <Caret Line="56" Column="3" TopLine="54"/> 141 | </Position12> 142 | <Position13> 143 | <Filename Value="unit1.pas"/> 144 | <Caret Line="61" Column="3" TopLine="54"/> 145 | </Position13> 146 | <Position14> 147 | <Filename Value="unit1.pas"/> 148 | <Caret Line="56" Column="3" TopLine="54"/> 149 | </Position14> 150 | <Position15> 151 | <Filename Value="unit1.pas"/> 152 | <Caret Line="31" Column="73" TopLine="20"/> 153 | </Position15> 154 | <Position16> 155 | <Filename Value="unit1.pas"/> 156 | <Caret Line="51" Column="5" TopLine="32"/> 157 | </Position16> 158 | <Position17> 159 | <Filename Value="unit1.pas"/> 160 | <Caret Line="44" Column="31" TopLine="35"/> 161 | </Position17> 162 | <Position18> 163 | <Filename Value="unit1.pas"/> 164 | <Caret Line="69" Column="26" TopLine="50"/> 165 | </Position18> 166 | <Position19> 167 | <Filename Value="unit1.pas"/> 168 | <Caret Line="37" Column="75" TopLine="35"/> 169 | </Position19> 170 | <Position20> 171 | <Filename Value="unit1.pas"/> 172 | <Caret Line="50" Column="41" TopLine="35"/> 173 | </Position20> 174 | <Position21> 175 | <Filename Value="unit1.pas"/> 176 | <Caret Line="52" Column="40" TopLine="35"/> 177 | </Position21> 178 | <Position22> 179 | <Filename Value="unit1.pas"/> 180 | <Caret Line="62" Column="38" TopLine="62"/> 181 | </Position22> 182 | <Position23> 183 | <Filename Value="unit1.pas"/> 184 | <Caret Line="67" Column="33" TopLine="62"/> 185 | </Position23> 186 | <Position24> 187 | <Filename Value="../../source/rsql_crypto_jwt.pas"/> 188 | <Caret Line="38" Column="10" TopLine="27"/> 189 | </Position24> 190 | <Position25> 191 | <Filename Value="../../source/rsql_crypto_jwt.pas"/> 192 | <Caret Line="73" TopLine="58"/> 193 | </Position25> 194 | <Position26> 195 | <Filename Value="../../source/rsql_crypto_jwt.pas"/> 196 | <Caret Line="91" TopLine="74"/> 197 | </Position26> 198 | <Position27> 199 | <Filename Value="../../source/rsql_crypto_jwt.pas"/> 200 | <Caret Line="92" Column="53" TopLine="83"/> 201 | </Position27> 202 | <Position28> 203 | <Filename Value="unit1.pas"/> 204 | <Caret Line="51" Column="12" TopLine="38"/> 205 | </Position28> 206 | <Position29> 207 | <Filename Value="unit1.pas"/> 208 | <Caret Line="50" Column="42" TopLine="40"/> 209 | </Position29> 210 | <Position30> 211 | <Filename Value="unit1.pas"/> 212 | <Caret Line="56" Column="40" TopLine="45"/> 213 | </Position30> 214 | </JumpHistory> 215 | <RunParams> 216 | <FormatVersion Value="2"/> 217 | <Modes Count="0" ActiveMode=""/> 218 | </RunParams> 219 | </ProjectSession> 220 | </CONFIG> 221 | -------------------------------------------------------------------------------- /source/rsql_register.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Register; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | Controls, 33 | Dialogs, 34 | Forms, 35 | LazIDEIntf, 36 | ProjectIntf; 37 | 38 | type 39 | 40 | { TRSQLApplicationDescriptor } 41 | 42 | TRSQLApplicationDescriptor = class(TProjectDescriptor) 43 | public 44 | constructor Create; override; 45 | function GetLocalizedName: string; override; 46 | function GetLocalizedDescription: string; override; 47 | function InitProject(AProject: TLazProject): TModalResult; override; 48 | end; 49 | 50 | var 51 | ProjectDescriptorRSQLApplication: TRSQLApplicationDescriptor; 52 | 53 | procedure Register; 54 | 55 | implementation 56 | 57 | uses 58 | LResources, 59 | PropEdits, 60 | sqldb, 61 | RSQL_Server_Component, 62 | RSQL_Client_Connection; 63 | 64 | procedure Register; 65 | begin 66 | {$I rsql.lrs} 67 | RegisterComponents('SQLdb', [TRSQLServer, TRSQLClient]); 68 | 69 | /// Hide properties TRSQLServer 70 | RegisterPropertyEditor(TypeInfo(string), TRSQLServer, 'AdminMail', THiddenPropertyEditor); 71 | RegisterPropertyEditor(TypeInfo(string), TRSQLServer, 'AdminName', THiddenPropertyEditor); 72 | RegisterPropertyEditor(TypeInfo(string), TRSQLServer, 'ServerBanner', THiddenPropertyEditor); 73 | RegisterPropertyEditor(TypeInfo(boolean), TRSQLServer, 'LookupHostNames', THiddenPropertyEditor); 74 | RegisterPropertyEditor(TypeInfo(boolean), TRSQLServer, 'Threaded', THiddenPropertyEditor); 75 | 76 | /// Hide properties TRSQLClient 77 | RegisterPropertyEditor(TypeInfo(string), TRSQLClient, 'CharSet', THiddenPropertyEditor); 78 | //RegisterPropertyEditor(TypeInfo(string), TRSQLClient, 'DatabaseName', THiddenPropertyEditor); 79 | RegisterPropertyEditor(TypeInfo(boolean), TRSQLClient, 'KeepConnection', THiddenPropertyEditor); 80 | RegisterPropertyEditor(TypeInfo(boolean), TRSQLClient, 'LoginPrompt', THiddenPropertyEditor); 81 | RegisterPropertyEditor(TypeInfo(string), TRSQLClient, 'Role', THiddenPropertyEditor); 82 | RegisterPropertyEditor(TypeInfo(TStrings), TRSQLClient, 'Params', THiddenPropertyEditor); 83 | RegisterPropertyEditor(TypeInfo(TDBEventTypes), TRSQLClient, 'LogEvents', THiddenPropertyEditor); 84 | RegisterPropertyEditor(TypeInfo(TSQLConnectionOptions), TRSQLClient, 'Options', THiddenPropertyEditor); 85 | 86 | /// RSQL Application 87 | ProjectDescriptorRSQLApplication := TRSQLApplicationDescriptor.Create; 88 | RegisterProjectDescriptor(ProjectDescriptorRSQLApplication); 89 | end; 90 | 91 | { TRSQLApplicationDescriptor } 92 | 93 | constructor TRSQLApplicationDescriptor.Create; 94 | begin 95 | inherited Create; 96 | Name := 'RSQLApplication'; 97 | end; 98 | 99 | function TRSQLApplicationDescriptor.GetLocalizedName: string; 100 | begin 101 | Result := 'RSQL Application'; 102 | end; 103 | 104 | function TRSQLApplicationDescriptor.GetLocalizedDescription: string; 105 | begin 106 | Result := 'RSQL Application'; 107 | end; 108 | 109 | function TRSQLApplicationDescriptor.InitProject(AProject: TLazProject): TModalResult; 110 | 111 | function ProgramSource: string; 112 | begin 113 | Result := ''; 114 | Result := Result + 'program rsqlhttpproject1;' + LineEnding; 115 | Result := Result + LineEnding; 116 | Result := Result + '{$mode objfpc}{$H+}' + LineEnding; 117 | Result := Result + LineEnding; 118 | Result := Result + 'uses' + LineEnding; 119 | Result := Result + ' {$IFDEF UNIX}' + LineEnding; 120 | Result := Result + ' cthreads,' + LineEnding; 121 | Result := Result + ' {$ENDIF}' + LineEnding; 122 | Result := Result + ' SysUtils,' + LineEnding; 123 | Result := Result + ' Classes,' + LineEnding; 124 | Result := Result + ' SQLdb,' + LineEnding; 125 | Result := Result + ' //IBConnection,' + LineEnding; 126 | Result := Result + ' //mysql40conn,' + LineEnding; 127 | Result := Result + ' //mysql41conn,' + LineEnding; 128 | Result := Result + ' //mysql50conn,' + LineEnding; 129 | Result := Result + ' //mysql51conn,' + LineEnding; 130 | Result := Result + ' //mysql55conn,' + LineEnding; 131 | Result := Result + ' //mysql56conn,' + LineEnding; 132 | Result := Result + ' //mysql57conn,' + LineEnding; 133 | Result := Result + ' //odbcconn,' + LineEnding; 134 | Result := Result + ' //oracleconnection,' + LineEnding; 135 | Result := Result + ' //pqconnection,' + LineEnding; 136 | Result := Result + ' //sqlite3conn,' + LineEnding; 137 | Result := Result + ' HTTPDefs,' + LineEnding; 138 | Result := Result + ' RSQL_Server_Application;' + LineEnding; 139 | Result := Result + LineEnding; 140 | Result := Result + 'type' + LineEnding; 141 | Result := Result + ' TRSQLApp = class(TRSQLApplication)' + LineEnding; 142 | Result := Result + ' protected' + LineEnding; 143 | Result := Result + ' FDatabase: TSQLConnector;' + LineEnding; 144 | Result := Result + ' procedure BeforeRequest(ASender: TObject; ARequest : TRequest);' + LineEnding; 145 | Result := Result + ' procedure AfterRequest(ASender: TObject; AResponse : TResponse);' + LineEnding; 146 | Result := Result + ' public' + LineEnding; 147 | Result := Result + ' constructor Create(AOwner: TComponent); overload; override;' + LineEnding; 148 | Result := Result + ' end;' + LineEnding; 149 | Result := Result + LineEnding; 150 | Result := Result + ' procedure TRSQLApp.BeforeRequest(ASender: TObject; ARequest : TRequest);' + LineEnding; 151 | Result := Result + ' begin' + LineEnding; 152 | Result := Result + ' WriteLn(''<<== REQUEST'');' + LineEnding; 153 | Result := Result + ' WriteLn(ARequest.Content);' + LineEnding; 154 | Result := Result + ' end;' + LineEnding; 155 | Result := Result + LineEnding; 156 | Result := Result + ' procedure TRSQLApp.AfterRequest(ASender: TObject; AResponse : TResponse);' + LineEnding; 157 | Result := Result + ' begin' + LineEnding; 158 | Result := Result + ' WriteLn(''RESPONSE ==>>'');' + LineEnding; 159 | Result := Result + ' WriteLn(AResponse.Content);' + LineEnding; 160 | Result := Result + ' end;' + LineEnding; 161 | Result := Result + LineEnding; 162 | Result := Result + ' constructor TRSQLApp.Create(AOwner: TComponent);' + LineEnding; 163 | Result := Result + ' begin' + LineEnding; 164 | Result := Result + ' inherited Create(AOwner);' + LineEnding; 165 | Result := Result + ' OnAfterRequest := @AfterRequest;' + LineEnding; 166 | Result := Result + ' OnBeforeRequest := @BeforeRequest;' + LineEnding; 167 | Result := Result + ' FDatabase := TSQLConnector.Create(Self);' + LineEnding; 168 | Result := Result + ' FDatabase.ConnectorType := ''?'';' + LineEnding; 169 | Result := Result + ' FDatabase.HostName := ''localhost'';' + LineEnding; 170 | Result := Result + ' FDatabase.DatabaseName :=''?'';' + LineEnding; 171 | Result := Result + ' FDatabase.UserName := ''?'';' + LineEnding; 172 | Result := Result + ' FDatabase.Password := ''?'';' + LineEnding; 173 | Result := Result + ' FDatabase.Open;' + LineEnding; 174 | Result := Result + ' with DatabaseList.Add do' + LineEnding; 175 | Result := Result + ' begin' + LineEnding; 176 | Result := Result + ' Database := FDatabase;' + LineEnding; 177 | Result := Result + ' Name := ''database'';' + LineEnding; 178 | Result := Result + ' end;' + LineEnding; 179 | Result := Result + ' end;' + LineEnding; 180 | Result := Result + LineEnding; 181 | Result := Result + 'begin' + LineEnding; 182 | Result := Result + ' with TRSQLApp.Create(nil) do' + LineEnding; 183 | Result := Result + ' try' + LineEnding; 184 | Result := Result + ' Initialize;' + LineEnding; 185 | Result := Result + ' Run;' + LineEnding; 186 | Result := Result + ' finally' + LineEnding; 187 | Result := Result + ' Free;' + LineEnding; 188 | Result := Result + ' end;' + LineEnding; 189 | Result := Result + 'end.' + LineEnding; 190 | end; 191 | 192 | var 193 | VMainFile: TLazProjectFile; 194 | begin 195 | inherited InitProject(AProject); 196 | /// Main 197 | VMainFile := AProject.CreateProjectFile('rsqlproject1.lpr'); 198 | VMainFile.IsPartOfProject := True; 199 | /// Project 200 | AProject.AddFile(VMainFile, False); 201 | AProject.MainFileID := 0; 202 | AProject.MainFile.SetSourceText(ProgramSource); 203 | AProject.AddPackageDependency('RSQL_Package'); 204 | //AProject.LazCompilerOptions.Win32GraphicApp := False; 205 | AProject.LazCompilerOptions.UnitOutputDirectory := 'lib' + PathDelim + '$(TargetCPU)-$(TargetOS)'; 206 | AProject.Flags := AProject.Flags - [pfMainUnitHasCreateFormStatements]; 207 | Result := mrOk; 208 | end; 209 | 210 | end. 211 | -------------------------------------------------------------------------------- /source/rsql_server_transaction.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Server_Transaction; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | fptimer, 33 | DB, 34 | sqldb; 35 | 36 | type 37 | 38 | { TTransactionItem } 39 | 40 | TTransactionItem = class(TObject) 41 | protected 42 | FLOCK: TRTLCriticalSection; 43 | FDatabase: TDatabase; 44 | FTransaction: TSQLTransaction; 45 | FDurability: integer; 46 | FIdentifier: string; 47 | FStarted: TDateTime; 48 | protected 49 | procedure LOCK; 50 | procedure UNLOCK; 51 | procedure CheckDatabase; 52 | public 53 | constructor Create(const ADatabase: TDatabase; const AIdentifier: string = ''; 54 | const ADurability: integer = -1); reintroduce; 55 | destructor Destroy; override; 56 | procedure Start; virtual; 57 | procedure Commit; virtual; 58 | procedure Rollback; virtual; 59 | function InTransaction: boolean; virtual; 60 | function Expired: boolean; virtual; 61 | function Identifier: string; virtual; 62 | function Transaction: TSQLTransaction; virtual; 63 | end; 64 | 65 | { TTransactionList } 66 | 67 | TTransactionList = class 68 | private 69 | FList: TFPList; 70 | FTimer: TFPTimer; 71 | protected 72 | function IndexOf(const AIdentifier: string): integer; 73 | procedure Manager({%H-}ASender: TObject); 74 | public 75 | constructor Create; reintroduce; 76 | destructor Destroy; override; 77 | function Add(const ATransactionItem: TTransactionItem): TTransactionItem; overload; 78 | function Add(const ADatabase: TDatabase; const AIdentifier: string = ''; 79 | const ADurability: integer = -1): TTransactionItem; overload; 80 | procedure Clear; 81 | function Count: integer; 82 | function Exists(const AIdentifier: string): boolean; overload; 83 | function Exists(const AIdentifier: string; out AIndex: integer): boolean; overload; 84 | function Find(const AIndex: integer): TTransactionItem; 85 | public 86 | property Items[const AIndex: integer]: TTransactionItem read Find; default; 87 | end; 88 | 89 | // Singleton 90 | function TransactionList: TTransactionList; 91 | 92 | implementation 93 | 94 | uses 95 | dateutils; 96 | 97 | function CreateUUid: string; 98 | var 99 | G: TGUID; 100 | begin 101 | CreateGUID(G); 102 | Result := ''; 103 | SetLength(Result, 32); 104 | StrLFmt(PChar(Result), 32, '%.8x%.4x%.4x%.2x%.2x%.2x%.2x%.2x%.2x%.2x%.2x', 105 | [longint(G.D1), G.D2, G.D3, G.D4[0], G.D4[1], G.D4[2], G.D4[3], 106 | G.D4[4], G.D4[5], G.D4[6], G.D4[7]]); 107 | end; 108 | 109 | { TTransactionItem } 110 | 111 | procedure TTransactionItem.LOCK; 112 | begin 113 | EnterCriticalSection(FLOCK); 114 | end; 115 | 116 | procedure TTransactionItem.UNLOCK; 117 | begin 118 | LeaveCriticalSection(FLOCK); 119 | end; 120 | 121 | procedure TTransactionItem.CheckDatabase; 122 | begin 123 | if (not (Assigned(FDatabase))) or (not (FDatabase.Connected)) then 124 | begin 125 | raise Exception.Create('database connection is not active'); 126 | end; 127 | end; 128 | 129 | constructor TTransactionItem.Create(const ADatabase: TDatabase; 130 | const AIdentifier: string; const ADurability: integer); 131 | begin 132 | inherited Create; 133 | FStarted := 0; 134 | FDatabase := ADatabase; 135 | FTransaction := TSQLTransaction.Create(nil); // SQLdb 136 | FTransaction.DataBase := FDatabase; 137 | FIdentifier := AIdentifier; 138 | if (FIdentifier = '') then 139 | begin 140 | FIdentifier := CreateUUid; 141 | end; 142 | FDurability := ADurability; 143 | if (FDurability <= 0) then 144 | begin 145 | FDurability := (1000 * 60 * 60); // 1h 146 | end; 147 | InitCriticalSection(FLOCK); 148 | end; 149 | 150 | destructor TTransactionItem.Destroy; 151 | begin 152 | LOCK; 153 | try 154 | FreeAndNil(FTransaction); 155 | inherited Destroy; 156 | finally 157 | UNLOCK; 158 | DoneCriticalSection(FLOCK); 159 | end; 160 | end; 161 | 162 | procedure TTransactionItem.Start; 163 | begin 164 | try 165 | CheckDatabase; 166 | LOCK; 167 | try 168 | if (not (FTransaction.Active)) then 169 | begin 170 | FTransaction.StartTransaction; 171 | FStarted := Now; // Cycle 172 | end; 173 | finally 174 | UNLOCK; 175 | end; 176 | except 177 | on E: Exception do 178 | begin 179 | raise Exception.CreateFmt('it wasn''t possible to start the transaction. [%s]', 180 | [E.Message]); 181 | end; 182 | end; 183 | end; 184 | 185 | procedure TTransactionItem.Commit; 186 | begin 187 | try 188 | CheckDatabase; 189 | LOCK; 190 | try 191 | if (FTransaction.Active) then 192 | begin 193 | FTransaction.Commit; 194 | end 195 | else 196 | begin 197 | raise Exception.Create('there is no transaction to commit'); 198 | end; 199 | finally 200 | UNLOCK; 201 | end; 202 | except 203 | on E: Exception do 204 | begin 205 | raise Exception.CreateFmt('it wasn''t possible to commit the transaction. [%s]', 206 | [E.Message]); 207 | end; 208 | end; 209 | end; 210 | 211 | procedure TTransactionItem.Rollback; 212 | begin 213 | try 214 | CheckDatabase; 215 | Lock; 216 | try 217 | if (FTransaction.Active) then 218 | begin 219 | FTransaction.Rollback; 220 | end 221 | else 222 | begin 223 | raise Exception.Create('there are no transaction to revert'); 224 | end; 225 | finally 226 | UnLock; 227 | end; 228 | except 229 | on E: Exception do 230 | begin 231 | raise Exception.CreateFmt('it wasn''t possible to rollback the transaction. [%s]', 232 | [E.Message]); 233 | end; 234 | end; 235 | end; 236 | 237 | function TTransactionItem.InTransaction: boolean; 238 | begin 239 | try 240 | CheckDatabase; 241 | Result := (FTransaction.Active); 242 | except 243 | on E: Exception do 244 | begin 245 | raise Exception.CreateFmt('it wasn''t possible check transaction. [%s]', 246 | [E.Message]); 247 | end; 248 | end; 249 | end; 250 | 251 | function TTransactionItem.Expired: boolean; 252 | begin 253 | Result := (FStarted > 0) and (IncMilliSecond(FStarted, FDurability) <= Now); 254 | end; 255 | 256 | function TTransactionItem.Identifier: string; 257 | begin 258 | Result := FIdentifier; 259 | end; 260 | 261 | function TTransactionItem.Transaction: TSQLTransaction; 262 | begin 263 | Result := FTransaction; 264 | end; 265 | 266 | { TTransactionList } 267 | 268 | function TTransactionList.IndexOf(const AIdentifier: string): integer; 269 | var 270 | VIndex: integer; 271 | VTransactionItem: TTransactionItem; 272 | begin 273 | Result := -1; 274 | for VIndex := 0 to (Count - 1) do 275 | begin 276 | VTransactionItem := Items[VIndex]; 277 | if (Assigned(VTransactionItem)) and (VTransactionItem.Identifier = AIdentifier) then 278 | begin 279 | Result := VIndex; 280 | Break; 281 | end; 282 | end; 283 | end; 284 | 285 | procedure TTransactionList.Manager(ASender: TObject); 286 | var 287 | VIndex: integer; 288 | VTransactionItem: TTransactionItem; 289 | begin 290 | for VIndex := (Count - 1) downto 0 do 291 | begin 292 | VTransactionItem := Items[VIndex]; 293 | if (Assigned(VTransactionItem)) and (VTransactionItem.Expired) then 294 | begin 295 | FList.Delete(VIndex); 296 | FreeAndNil(VTransactionItem); 297 | end; 298 | end; 299 | end; 300 | 301 | constructor TTransactionList.Create; 302 | begin 303 | inherited Create; 304 | FList := TFPList.Create; 305 | FTimer := TFPTimer.Create(nil); 306 | FTimer.OnTimer := @Manager; 307 | FTimer.Interval := 1000; 308 | FTimer.Enabled := True; 309 | end; 310 | 311 | destructor TTransactionList.Destroy; 312 | begin 313 | Clear; 314 | FreeAndNil(FTimer); 315 | FreeAndNil(FList); 316 | inherited Destroy; 317 | end; 318 | 319 | function TTransactionList.Add( 320 | const ATransactionItem: TTransactionItem): TTransactionItem; 321 | begin 322 | Result := ATransactionItem; 323 | FList.Add(ATransactionItem); 324 | end; 325 | 326 | function TTransactionList.Add(const ADatabase: TDatabase; 327 | const AIdentifier: string; const ADurability: integer): TTransactionItem; 328 | begin 329 | Result := Add(TTransactionItem.Create(ADatabase, AIdentifier, ADurability)); 330 | end; 331 | 332 | procedure TTransactionList.Clear; 333 | var 334 | VIndex: integer; 335 | VTransactionItem: TTransactionItem; 336 | begin 337 | for VIndex := (Count - 1) downto 0 do 338 | begin 339 | VTransactionItem := Items[VIndex]; 340 | FList.Delete(VIndex); 341 | FreeAndNil(VTransactionItem); 342 | end; 343 | end; 344 | 345 | function TTransactionList.Count: integer; 346 | begin 347 | Result := FList.Count; 348 | end; 349 | 350 | function TTransactionList.Exists(const AIdentifier: string): boolean; 351 | begin 352 | Result := (IndexOf(AIdentifier) > -1); 353 | end; 354 | 355 | function TTransactionList.Exists(const AIdentifier: string; 356 | out AIndex: integer): boolean; 357 | begin 358 | AIndex := IndexOf(AIdentifier); 359 | Result := (AIndex > -1); 360 | end; 361 | 362 | function TTransactionList.Find(const AIndex: integer): TTransactionItem; 363 | begin 364 | Result := TTransactionItem(FList[AIndex]); 365 | end; 366 | 367 | // Singleton 368 | var 369 | VTransactionList: TTransactionList = nil; 370 | 371 | function TransactionList: TTransactionList; 372 | begin 373 | if (not (Assigned(VTransactionList))) then 374 | begin 375 | VTransactionList := TTransactionList.Create; 376 | end; 377 | Result := VTransactionList; 378 | end; 379 | 380 | initialization 381 | 382 | finalization 383 | FreeAndNil(VTransactionList); 384 | 385 | end. 386 | -------------------------------------------------------------------------------- /source/rsql_server_router.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Server_Router; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | fpjson, 33 | httpdefs, 34 | httproute, 35 | DB, 36 | sqldb, 37 | RSQL_Helper, 38 | RSQL_Crypto_ZStream, 39 | RSQL_Crypto_JWT, 40 | RSQL_Server_Database; 41 | 42 | type 43 | 44 | { TRoute } 45 | 46 | TRoute = class(TCustomRoute) 47 | protected 48 | FRequest: TRequest; 49 | FResponse: TResponse; 50 | FAuthorization: string; 51 | FCompressed: boolean; 52 | FCORS: boolean; 53 | FCredential: string; 54 | FMethod: string; 55 | FDatabase: TDatabase; 56 | FDatabaseList: TDatabaseList; 57 | FContent: TJSONObject; 58 | protected 59 | function AllowedMethods: string; virtual; 60 | procedure CheckMethod; virtual; 61 | procedure CheckContentEncoding; virtual; 62 | procedure CheckContent; virtual; 63 | procedure CheckAutorization; virtual; 64 | procedure CheckDatabase; virtual; 65 | public 66 | destructor Destroy; override; 67 | procedure HandleRequest(AServer: TObject; ARequest: TRequest; 68 | AResponse: TResponse); override; 69 | public 70 | procedure POST; virtual; abstract; 71 | // TODO: Add other methods 72 | end; 73 | 74 | { TRouteAuthentication } 75 | 76 | TRouteAuthentication = class(TRoute) 77 | protected 78 | procedure CheckAutorization; override; 79 | procedure CheckLogin; virtual; 80 | public 81 | procedure Post; override; 82 | end; 83 | 84 | { TRouteDatabase } 85 | 86 | TRouteDatabase = class(TRoute) 87 | protected 88 | FAction: string; 89 | protected 90 | procedure Index; virtual; 91 | procedure Schema; virtual; 92 | procedure Sequence; virtual; 93 | public 94 | procedure Post; override; 95 | end; 96 | 97 | { TRouteTransaction } 98 | 99 | TRouteTransaction = class(TRoute) 100 | protected 101 | FAction: string; 102 | FIdentifier: string; 103 | protected 104 | procedure Start; virtual; 105 | procedure Commit; virtual; 106 | procedure Rollback; virtual; 107 | public 108 | procedure Post; override; 109 | end; 110 | 111 | { TRouteStatement } 112 | 113 | TRouteStatement = class(TRoute) 114 | protected 115 | FAction: string; 116 | FIdentifier: string; 117 | protected 118 | procedure Batch; 119 | procedure Query; 120 | public 121 | procedure Post; override; 122 | end; 123 | 124 | procedure InitializeRoutes; 125 | // TODO: Finish Routes 126 | 127 | implementation 128 | 129 | uses 130 | strutils, 131 | RSQL_Server_Component, 132 | RSQL_Server_Application, 133 | RSQL_Server_Transaction; 134 | 135 | procedure InitializeRoutes; 136 | begin 137 | with HTTPRouter do 138 | begin 139 | RegisterRoute('authentication', TRouteAuthentication); 140 | RegisterRoute('database', TRouteDatabase); 141 | RegisterRoute('transaction', TRouteTransaction); 142 | RegisterRoute('statement', TRouteStatement); 143 | end; 144 | end; 145 | 146 | { TRoute } 147 | 148 | function TRoute.AllowedMethods: string; 149 | begin 150 | Result := 'POST'; 151 | end; 152 | 153 | procedure TRoute.CheckMethod; 154 | begin 155 | if (Pos(FMethod, AllowedMethods) < 1) then 156 | begin 157 | raise EHTTP.CreateFmt(405, 'the requested method %s is not allowed', [FMethod]); 158 | end; 159 | end; 160 | 161 | procedure TRoute.CheckContentEncoding; 162 | begin 163 | // Decode request 164 | if (FRequest.ContentEncoding <> EmptyStr) and 165 | (LowerCase(FRequest.ContentEncoding) = 'deflate') then 166 | begin 167 | FRequest.Content := ZDecompressString(FRequest.Content); 168 | end; 169 | end; 170 | 171 | procedure TRoute.CheckContent; 172 | begin 173 | if (FRequest.ContentType <> 'application/json') then 174 | begin 175 | raise EHTTP.Create(415, 'media type not supported on request'); 176 | end; 177 | if (not (TJSONData.Parse(FRequest.Content, FContent))) then 178 | begin 179 | raise EHTTP.Create(400, 'request has invalid content type'); 180 | end; 181 | end; 182 | 183 | procedure TRoute.CheckAutorization; 184 | var 185 | VOutput: string; 186 | begin 187 | if (FCredential <> EmptyStr) then 188 | begin 189 | VOutput := EmptyStr; 190 | FAuthorization := FRequest.Authorization; 191 | FAuthorization := StringsReplace(FAuthorization, ['Bearer '], 192 | [EmptyStr], [rfIgnoreCase]); 193 | if (not (JWTParse(FCredential, FAuthorization, VOutput))) then 194 | begin 195 | raise EHTTP.CreateFmt(401, 'request unauthorized. %s', [VOutput]); 196 | end; 197 | end; 198 | end; 199 | 200 | procedure TRoute.CheckDatabase; 201 | var 202 | VDatabaseItem: TDatabaseItem; 203 | VDatabaseName: string; 204 | begin 205 | FDatabase := nil; 206 | if (Assigned(FDatabaseList)) then 207 | begin 208 | VDatabaseName := FRequest.QueryFields.Values['database']; 209 | if (VDatabaseName <> EmptyStr) then 210 | begin 211 | VDatabaseItem := FDatabaseList.Find(VDatabaseName); 212 | end 213 | else 214 | begin 215 | VDatabaseItem := FDatabaseList.FindDefault; 216 | end; 217 | if (Assigned(VDatabaseItem)) then 218 | begin 219 | FDatabase := VDatabaseItem.Database; 220 | end; 221 | end; 222 | if (not (Assigned(FDatabase))) then 223 | begin 224 | raise EHTTP.Create(400, 'database not assigned!'); 225 | end; 226 | if (not (FDatabase.Connected)) then 227 | begin 228 | raise EHTTP.Create(400, 'operation cannot be performed on an disconnected database'); 229 | end; 230 | if (not (FDatabase.InheritsFrom(TSQLConnection))) then 231 | begin 232 | raise EHTTP.Create(400, 'operation is not supported by this type of database'); 233 | end; 234 | end; 235 | 236 | destructor TRoute.Destroy; 237 | begin 238 | FreeAndNil(FContent); 239 | inherited Destroy; 240 | end; 241 | 242 | procedure TRoute.HandleRequest(AServer: TObject; ARequest: TRequest; 243 | AResponse: TResponse); 244 | var 245 | VServerCOMP: TRSQLServer; 246 | VServerAPP: TRSQLApplication; 247 | begin 248 | try 249 | /// Server 250 | if (Assigned(AServer)) and (AServer.InheritsFrom(TRSQLServer)) then 251 | begin 252 | VServerCOMP := TRSQLServer(AServer); 253 | FCompressed := VServerCOMP.Compressed; 254 | FCORS := VServerCOMP.CORS; 255 | FCredential := VServerCOMP.Credential; 256 | FDatabaseList := VServerCOMP.DatabaseList; 257 | end 258 | /// Server Application 259 | else 260 | if (Assigned(AServer)) and (AServer.InheritsFrom(TRSQLApplication)) then 261 | begin 262 | VServerAPP := TRSQLApplication(AServer); 263 | FCompressed := VServerAPP.Compressed; 264 | FCORS := VServerAPP.CORS; 265 | FCredential := VServerAPP.Credential; 266 | FDatabaseList := VServerAPP.DatabaseList; 267 | end 268 | else 269 | begin 270 | FCompressed := False; 271 | FCORS := True; 272 | FCredential := EmptyStr; 273 | FDatabaseList := nil; 274 | end; 275 | /// Request 276 | FRequest := ARequest; 277 | /// Response 278 | FResponse := AResponse; 279 | FResponse.ContentType := 'application/json; charset=utf-8'; 280 | /// Response/CORS 281 | if (FCORS) then 282 | begin 283 | FResponse.SetCustomHeader('Access-Control-Allow-Origin', '*'); 284 | FResponse.SetCustomHeader('Access-Control-Allow-Credentials', 'true'); 285 | FResponse.SetCustomHeader('Access-Control-Allow-Headers', 286 | 'X-Custom-Header, Cache-Control'); 287 | end; 288 | /// Response/Encode 289 | if (FCompressed) then 290 | begin 291 | FResponse.ContentEncoding := 'deflate'; 292 | end; 293 | /// Methods 294 | FMethod := UpperCase(FRequest.Method); 295 | /// Validations 296 | CheckDatabase; 297 | CheckMethod; 298 | CheckContentEncoding; 299 | CheckContent; 300 | CheckAutorization; 301 | /// Redirection 302 | case FMethod of 303 | 'POST': POST; 304 | // TODO: Add other methods 305 | end; 306 | except 307 | on E: EHTTP do 308 | begin 309 | FResponse.Envelop(E.StatusCode, E.Message); 310 | end; 311 | on E: Exception do 312 | begin 313 | FResponse.Envelop(500, 'internal server error, unexpected error :('); 314 | if (Assigned(VServerComp)) then 315 | begin 316 | // TODO: Add log 317 | end; 318 | if (Assigned(VServerApp)) then 319 | begin 320 | VServerApp.Log(etError, E.Message); 321 | end; 322 | end; 323 | end; 324 | end; 325 | 326 | { TRouteAuthentication } 327 | 328 | procedure TRouteAuthentication.CheckAutorization; 329 | begin 330 | /// empty of purpose 331 | end; 332 | 333 | procedure TRouteAuthentication.CheckLogin; 334 | begin 335 | with TSQLConnection(FDatabase) do 336 | begin 337 | if (not (SameText(FContent.Path('username', ''), UserName))) or 338 | (not (SameText(FContent.Path('password', ''), Password))) then 339 | begin 340 | raise EHTTP.Create(401, 'username and/or password are invalid'); 341 | end; 342 | end; 343 | end; 344 | 345 | procedure TRouteAuthentication.Post; 346 | 347 | function PAYLOAD: string; 348 | begin 349 | with TJSONObject.Create([]) do 350 | try 351 | Add('iss', 'rsql'); 352 | Result := Stringify(); 353 | finally 354 | Free; 355 | end; 356 | end; 357 | 358 | function AuthenticationInfo: TJSONObject; 359 | begin 360 | Result := TJSONObject.Create(); 361 | Result.Add('token', JWTSign(FCredential, PAYLOAD)); 362 | Result.Add('compressed', FCompressed); 363 | end; 364 | 365 | begin 366 | CheckLogin; 367 | FResponse.Envelop(200, AuthenticationInfo); 368 | end; 369 | 370 | { TRouteDatabase } 371 | 372 | procedure TRouteDatabase.Index; 373 | 374 | function IndexOptionsToJSON(const AOpts: TIndexOptions): TJSONArray; 375 | begin 376 | Result := TJSONArray.Create(); 377 | if (ixPrimary in AOpts) then 378 | begin 379 | Result.Add('primary'); 380 | end; 381 | if (ixUnique in AOpts) then 382 | begin 383 | Result.Add('unique'); 384 | end; 385 | if (ixDescending in AOpts) then 386 | begin 387 | Result.Add('descending'); 388 | end; 389 | if (ixCaseInsensitive in AOpts) then 390 | begin 391 | Result.Add('caseinsensitive'); 392 | end; 393 | if (ixExpression in AOpts) then 394 | begin 395 | Result.Add('expression'); 396 | end; 397 | if (ixNonMaintained in AOpts) then 398 | begin 399 | Result.Add('nonmaintained'); 400 | end; 401 | end; 402 | 403 | var 404 | VTable: string; 405 | VIndex: integer; 406 | VIndexDef: TIndexDef; 407 | VIndexDefs: TIndexDefs; 408 | VJSONArray: TJSONArray; 409 | VJSONObject: TJSONObject; 410 | VConnection: TSQLConnection; 411 | begin 412 | VTable := FContent.Path('table', ''); 413 | try 414 | VIndexDefs := TIndexDefs.Create(nil); 415 | VConnection := TSQLConnection(FDatabase); 416 | VConnection.FillIndexDefs(VIndexDefs, VTable); 417 | VJSONArray := TJSONArray.Create(); 418 | for VIndex := 0 to (VIndexDefs.Count - 1) do 419 | begin 420 | VIndexDef := VIndexDefs[VIndex]; 421 | if (Assigned(VIndexDef)) then 422 | begin 423 | VJSONObject := TJSONObject.Create(); 424 | with VJSONObject do 425 | begin 426 | Add('name', VIndexDef.Name); 427 | Add('expression', VIndexDef.Expression); 428 | Add('fields', VIndexDef.Fields); 429 | Add('caseinsfields', VIndexDef.CaseInsFields); 430 | Add('descfields', VIndexDef.DescFields); 431 | Add('options', IndexOptionsToJSON(VIndexDef.Options)); 432 | Add('source', VIndexDef.Source); 433 | end; 434 | VJSONArray.Add(VJSONObject); 435 | end; 436 | end; 437 | FResponse.Envelop(200, VJSONArray); 438 | finally 439 | FreeAndNil(VIndexDefs); 440 | end; 441 | end; 442 | 443 | procedure TRouteDatabase.Schema; 444 | var 445 | VObjectName: string; 446 | VPattern: string; 447 | VSchemaType: integer; 448 | VConnection: TSQLConnection; 449 | begin 450 | VObjectName := FContent.Path('object', ''); 451 | VPattern := FContent.Path('pattern', ''); 452 | VSchemaType := FContent.Path('type', 0); 453 | VConnection := TSQLConnection(FDatabase); 454 | FResponse.Envelop(200, VConnection.ExtractSchemaSQL(TSchemaType(VSchemaType), 455 | VObjectName, VPattern)); 456 | end; 457 | 458 | procedure TRouteDatabase.Sequence; 459 | var 460 | VSequence: string; 461 | VIncrement: integer; 462 | VConnection: TSQLConnection; 463 | begin 464 | VSequence := FContent.Path('sequence', ''); 465 | VIncrement := FContent.Path('increment', 0); 466 | VConnection := TSQLConnection(FDatabase); 467 | FResponse.Envelop(200, VConnection.ExtractSequenceSQL(VSequence, VIncrement)); 468 | end; 469 | 470 | procedure TRouteDatabase.Post; 471 | begin 472 | try 473 | FAction := LowerCase(FRequest.QueryFields.Values['action']); 474 | case FAction of 475 | 'index': 476 | begin 477 | Index; 478 | end; 479 | 'schema': 480 | begin 481 | Schema; 482 | end; 483 | 'sequence': 484 | begin 485 | Sequence; 486 | end; 487 | else 488 | begin 489 | raise Exception.CreateFmt('invalid action[%s]', [FAction]); 490 | end; 491 | end; 492 | except 493 | on E: Exception do 494 | begin 495 | raise EHTTP.Create(400, E.Message); 496 | end; 497 | end; 498 | end; 499 | 500 | { TRouteTransaction } 501 | 502 | procedure TRouteTransaction.Start; 503 | var 504 | VIndex: integer; 505 | VTransactionItem: TTransactionItem; 506 | begin 507 | /// Find transaction 508 | if (TransactionList.Exists(FIdentifier, VIndex)) then 509 | begin 510 | VTransactionItem := TransactionList[VIndex]; 511 | VTransactionItem.Start; 512 | /// Response 513 | FResponse.Envelop(200, FIdentifier); 514 | end 515 | else 516 | begin 517 | VTransactionItem := TransactionList.Add(FDatabase); 518 | VTransactionItem.Start; 519 | /// Response 520 | FResponse.Envelop(200, VTransactionItem.Identifier); 521 | end; 522 | end; 523 | 524 | procedure TRouteTransaction.Commit; 525 | var 526 | VIndex: integer; 527 | begin 528 | /// Find transaction 529 | if (TransactionList.Exists(FIdentifier, VIndex)) then 530 | begin 531 | TransactionList[VIndex].Commit; 532 | /// Response 533 | FResponse.Envelop(200, 'transaction(%s) successfully confirmed', [FIdentifier]); 534 | end 535 | else 536 | begin 537 | raise Exception.CreateFmt('transaction[%s] not found', [FIdentifier]); 538 | end; 539 | end; 540 | 541 | procedure TRouteTransaction.Rollback; 542 | var 543 | VIndex: integer; 544 | begin 545 | /// Find transaction 546 | if (TransactionList.Exists(FIdentifier, VIndex)) then 547 | begin 548 | TransactionList[VIndex].Rollback; 549 | /// Response 550 | FResponse.Envelop(200, 'transaction(%s) reverted successfully', [FIdentifier]); 551 | end 552 | else 553 | begin 554 | raise Exception.CreateFmt('transaction[%s] not found', [FIdentifier]); 555 | end; 556 | end; 557 | 558 | procedure TRouteTransaction.Post; 559 | begin 560 | try 561 | FAction := LowerCase(FRequest.QueryFields.Values['action']); 562 | FIdentifier := FRequest.QueryFields.Values['identifier']; 563 | case FAction of 564 | 'start': 565 | begin 566 | Start; 567 | end; 568 | 'commit': 569 | begin 570 | Commit; 571 | end; 572 | 'rollback': 573 | begin 574 | Rollback; 575 | end; 576 | else 577 | begin 578 | raise Exception.CreateFmt('invalid action[%s]', [FAction]); 579 | end; 580 | end; 581 | except 582 | on E: Exception do 583 | begin 584 | raise EHTTP.Create(400, E.Message); 585 | end; 586 | end; 587 | end; 588 | 589 | { TRouteStatement } 590 | 591 | procedure TRouteStatement.Batch; 592 | var 593 | VBatch: TSQLScript; 594 | VTransactionItem: TTransactionItem; 595 | begin 596 | /// Automatic transaction 597 | VTransactionItem := nil; 598 | VBatch := nil; 599 | try 600 | try 601 | /// Transaction 602 | VTransactionItem := TTransactionItem.Create(FDatabase); 603 | VTransactionItem.Start; 604 | /// Batch 605 | VBatch := TSQLScript.Create(nil); 606 | with VBatch do 607 | begin 608 | Transaction := VTransactionItem.Transaction; 609 | UseCommit := True; 610 | UseSetTerm := True; 611 | CommentsInSQL := False; 612 | Script.Text := FContent.Path('sql', ''); 613 | Execute; 614 | end; 615 | /// Response 616 | FResponse.Envelop(200, 'succeeded'); 617 | /// Transaction 618 | VTransactionItem.Commit; 619 | except 620 | /// Transaction 621 | if (Assigned(VTransactionItem)) and (VTransactionItem.InTransaction) then 622 | begin 623 | VTransactionItem.Rollback; 624 | end; 625 | raise 626 | end; 627 | finally 628 | FreeAndNil(VBatch); 629 | FreeAndNil(VTransactionItem); 630 | end; 631 | end; 632 | 633 | procedure TRouteStatement.Query; 634 | var 635 | VQuery: TSQLQuery; 636 | VIndex: integer; 637 | VTransactionItem: TTransactionItem; 638 | begin 639 | if (FIdentifier <> '') then 640 | begin 641 | /// Find 642 | if (TransactionList.Exists(FIdentifier, VIndex)) then 643 | begin 644 | VTransactionItem := nil; 645 | VQuery := nil; 646 | try 647 | try 648 | // Transaction 649 | VTransactionItem := TransactionList[VIndex]; 650 | VTransactionItem.Start; 651 | // Query 652 | VQuery := TSQLQuery.Create(nil); 653 | VQuery.Transaction := VTransactionItem.Transaction; 654 | VQuery.SQL.Text := FContent.Path('sql', ''); 655 | VQuery.Params.AssignJSON(FContent.Path('params')); 656 | VQuery.Prepare; 657 | if (VQuery.StatementType = stSelect) then 658 | begin 659 | VQuery.Open; 660 | end 661 | else 662 | begin 663 | VQuery.ExecSQL; 664 | end; 665 | // Response 666 | {$IfNDef rsql_experimental} 667 | FResponse.Envelop(200, VQuery.SaveToJSON); 668 | {$Else} 669 | FResponse.Envelop(200, VQuery.SaveToJSON( 670 | FContent.Path('options.recno', 0), 671 | FContent.Path('options.packetrecords', -1))); 672 | {$EndIf} 673 | except 674 | raise 675 | end; 676 | finally 677 | FreeAndNil(VQuery); 678 | end; 679 | end 680 | else 681 | begin 682 | raise Exception.CreateFmt('transaction[%s] not found.', [FIdentifier]); 683 | end; 684 | end 685 | else 686 | begin 687 | // Automatic transaction 688 | VTransactionItem := nil; 689 | VQuery := nil; 690 | try 691 | try 692 | // Transaction 693 | VTransactionItem := TTransactionItem.Create(FDatabase); 694 | VTransactionItem.Start; 695 | // Query 696 | VQuery := TSQLQuery.Create(nil); 697 | VQuery.Transaction := VTransactionItem.Transaction; 698 | VQuery.SQL.Text := FContent.Path('sql', ''); 699 | VQuery.Params.AssignJSON(FContent.Path('params')); 700 | VQuery.Prepare; 701 | if (VQuery.StatementType = stSelect) then 702 | begin 703 | VQuery.Open; 704 | end 705 | else 706 | begin 707 | VQuery.ExecSQL; 708 | end; 709 | // Response 710 | {$IfNDef rsql_experimental} 711 | FResponse.Envelop(200, VQuery.SaveToJSON); 712 | {$Else} 713 | FResponse.Envelop(200, VQuery.SaveToJSON( 714 | FContent.Path('options.recno', 1), 715 | FContent.Path('options.packetrecords', 100))); 716 | {$EndIf} 717 | // Transaction 718 | VTransactionItem.Commit; 719 | except 720 | on E: Exception do 721 | begin 722 | // Transaction 723 | if (Assigned(VTransactionItem)) and (VTransactionItem.InTransaction) then 724 | begin 725 | VTransactionItem.Rollback; 726 | end; 727 | raise; 728 | end; 729 | end; 730 | finally 731 | FreeAndNil(VQuery); 732 | FreeAndNil(VTransactionItem); 733 | end; 734 | end; 735 | end; 736 | 737 | procedure TRouteStatement.Post; 738 | begin 739 | try 740 | FAction := LowerCase(FRequest.QueryFields.Values['action']); 741 | FIdentifier := FRequest.QueryFields.Values['identifier']; 742 | case FAction of 743 | 'batch': 744 | begin 745 | Batch; 746 | end; 747 | 'query': 748 | begin 749 | Query; 750 | end; 751 | else 752 | begin 753 | raise Exception.CreateFmt('invalid action[%s]', [FAction]); 754 | end; 755 | end; 756 | except 757 | on E: Exception do 758 | begin 759 | raise EHTTP.Create(400, E.Message); 760 | end; 761 | end; 762 | end; 763 | 764 | end. 765 | -------------------------------------------------------------------------------- /rsql.lrs: -------------------------------------------------------------------------------- 1 | LazarusResources.Add('trsqlclient','PNG',[ 2 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 3 | +#0#0#6'bKGD'#0#255#0#255#0#255#160#189#167#147#0#0#0#9'pHYs'#0#0#14#196#0#0 4 | +#14#196#1#149'+'#14#27#0#0#0#7'tIME'#7#227#6#3#13#24';'#250'9{'#236#0#0#4#26 5 | +'IDATH'#199#173#149'[lTU'#20#134#191#189#207'\Z'#218'R'#234#180#181'\2'#182 6 | +'T21'#16#18'C"'#4#144'"'#154#160#224#11'ABL4B"'#168#240'bh'#194#131#17#211 7 | +#170#9'Oj'#226'-^0'#24#149#144#24'"'#15'F'#11'F'#29#139#2'6'#18'@#'#138'\' 8 | +#164'@h'#135#182'C'#231'>'#195#204'9g'#249'p:'#167#211#153#130'5q='#237#189 9 | +#246'9'#235'_'#235#255#215#218#27'Jl'#235#251''''#248'7'#187#153'7'#213#237 10 | +#206'Ed'#194#185'g'#204#13'("'#17#207#188'Mo'#247'oo'#12#4'Vy'#188#254'Pdx' 11 | +#212#23#25'I0'#28#141#229#135#162#241#179'#'#177'T'#216#239'{q'#183#216#18'A' 12 | +'M'#22#28#148'R'#19'N'#220#205#3';'#127#218'U[['#243#242#221's'#219#168#171 13 | +#173'C'#27#26#165'@)0Ma4'#145#230#215#191#6'8'#242#237')'#228#248'FQ'#170#18 14 | +'B'#196#129'(Et7'#29#157#189#178#178#227'~'#202#18'p-W'#128#221#235'J2S "c9' 15 | +#10'J)'#156#173#154'P'#146'.'#174#183#172'i'#227'X'#223')b'#241'8'#150'e'#187 16 | +'A'#180#6#203#22#134#162'q'#215'7'#30#195#217#8'Np))'#197'qHQ'#3'h'#159'Y' 17 | +#211#187#127'gKG'#207#233'$Wb'#25#18'9'#31#151#7'G'#25#28#138#147'N'''#193 18 | +#202#1#203#156',q'#149#19'UB'#187'*-'#176#156#138#142#206#31#229#153#183#206 19 | +'H'#248#247#132#164's'#166#136#216'Rj'#201'LA>'#248#250#146#132'6'#247#8'K' 20 | +#246#153#0'bO'#252#198'5'#219#150#10#145#223#251#234#146#28'8:'#194#236#153 21 | +'M'#212'74bx|'#12#14#141#18#25#137'3'#28#141'3|#A"'#145'"'#23'K'#211'q'#207 22 | +'|z'#247',|'#1#200#140#199#176#15#129'q'#182#180']'#149'R'#227'='#219'w'#246 23 | +#198#15#205'3'#170';'#194#127#164#25'H'#248'I'#153'>'#174'Fb\'#31'I'#144'N''' 24 | +#241#169'<'#11#130'U<'#191#190#149#13#27#173'+'#167#143#220#17#28#251#181#23 25 | +'X1'#6#180#4'T'#223#164']2'#21#138'>:'#212'/'#161#205'='#210#186#233'`'#146 26 | +#162#138#238#4#136#128't'#149#199'uE~|'#213#28#14#28#29#225#227#240#13#14#158 27 | +#214#183#165'h'#205#162#5#254#254'q'#169#239'*'#174#180#150'C'#182'}'#11#128 28 | +'{'#219#235'{W/j'#25#163'HH'#153#130#161#193#163#21#211#167#25'4'#214#212#176 29 | +' '#24'(R4'#8#4#1#27'p'#177'l['#255'|'#203';d'#197#142'#S'#167#232#169'/'#18 30 | +'EZ'#234#234#172'V'#151'"C'#22#23#218#219''''#175#192#240#232#215#175'Es;' 31 | +#246#222#150#162'$'#185#155'y'#154#237#224'9`'#17'@2i'#244'+%'#221'"'#188#212 32 | +'L'#244'3'#239#197#139#243'*'#0'Vv'#133#9'w-'#239'|'#180#251#212#231'Z'#169 33 | +#205'>'#131#165'^'#15#237#213'~='#173#198'o'#144#173'22i'#191#190#152#210#250 34 | +#24'"{'#135#190'_'#172#129#213#128#223#145'Xu'#129'T'#13'Y'#129','#200'#'#160 35 | +'z&'#148#209#249#225'%'#197#255'd'#229#177'T'#201#129';}'#166'%'#152#150#160 36 | +#20'x='#26#173#28#159'-'#206'5'#227#243'j'#20#144'/'#8#134#1#134#30#143#249 37 | +#218#150'65'#169#6'E'#171#242'i'#182#173'maV'#192#7#192#190#240'0g.g'#216#177 38 | +'n'#150#235#251#228#187'a~9'#151#164#251#137' '#225#223#226#28#255'3y'#203 39 | +#138'*'#0#150#132#234'h'#170#247#178#235#211'+'#140'&M'#130#205'~'#214'/oD' 40 | +#128'm'#239#252#205'}'#161'Z6='#212#204#201#11')'#244#20#136#213#229#142#19 41 | +#231'S$'#178#22#175'<'#25#228#205#231#218#240'{'#20'-'#13'^.'#12'd'#169#246 42 | +'i'#206'_'#203#2#208'T'#239#157#146'&'#21#21'4'#205#240#242#234#254#171#136 43 | +#192#206#199'f'#179'l'#254't'#6#162'y'#230#205#170'&'#155#143#178#176#173#14 44 | +#128#235#177#130'3\'#2#166#237#188'\'#198'$%U'#0'4'#212'zxck'#27#0#209#164 45 | +#201'7''c'#164#178#22#207#174#157#201#187#219#231'b'#219#194#158#195#215'A W' 46 | +#16#214'/'#13#176'ay'#128'3'#151'3'#142#191#204'*'#186#200#22'('#152'6"`'#24 47 | +#10#175#161#220#206#10#205#169#230#233#135#239#228#228#133#20'_'#246#141#146 48 | +#200'Xc'#207'&h'#237'|['#222'E'#255'y'#14',KB'#150'-'#15'Nu'#14#254#1'O'#199 49 | +'i*'#29'('#150#217#0#0#0#0'IEND'#174'B`'#130 50 | ]); 51 | LazarusResources.Add('trsqlclient_200','PNG',[ 52 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0'0'#0#0#0'0'#8#6#0#0#0'W'#2#249#135 53 | +#0#0#0#6'bKGD'#0#255#0#255#0#255#160#189#167#147#0#0#0#9'pHYs'#0#0#14#196#0#0 54 | +#14#196#1#149'+'#14#27#0#0#0#7'tIME'#7#227#6#3#13#23'''i'#160';l'#0#0#7#152 55 | +'IDATh'#222#237#153'kl'#20#215#21#199#127'w'#30#187';'#227#181'w'#253'v0'#152 56 | +#151'x+'#129#240'HJ I1('#224#22#169'M['#155#168'"'#145#162#134'$'#202#167'F' 57 | +#17'$M['#21#181#170'"%'#170#250'!U'#170#16#181#145#18#170' #D>4'#165'n'#18 58 | +#130#133'!'#208#26#171'! ('#134#24#27#27#140#223#143#157#153#157#221#157#189 59 | +#253'`'#179#216#216#192#178#177#157'J'#229'H'#163#221#185's4'#247#156'{'#206 60 | +#249#159#255#189#3'w'#229#155#21'q;'#133'g'#223#174#215#161'd'#173'a'#152#15 61 | +#154#166'q'#191#174#233'e'#17'''Vf9Q'#195#178#221#176'e'#187'XN'#172#207'v' 62 | +#162#142'eG['#172'h'#180#217#182#220#127'G'#220#232#177#190#166#203'G8'#241 63 | +'\\J'#233#7#162#25#216#23#19'B'#248'3r'#160#226'g'#199#22#7#130'Y/'#154#166 64 | +'Qi'#154'F'#200'4LL'#211'@'#211't,'#199#197#178#163#195#191'.'#150#227'b'#143 65 | +'3f9n_<'#238#237#157'^'#172#191'yi'#247#247'Nf'#224'@R'#8#161#222'JA'#27';$' 66 | +#197#186#151#143#236'L*'#226'U'#144#26#128#174#235#4#252'~tMC('#10#217'f'#128 67 | +#160#25'@(C'#254'{'#158#135#151'H'#18'q\'#250#7'm'#218';'#251#184#208'r'#21 68 | +#203'q'#195' '#183']'#233#140'?'#157'Z1'#145#158#229'R'#2#160'H9'#252'/'#221 69 | +#8#172#219'Q'#183']'#192#235#186#207#199#140#233#165#20#23#22#162#251#244#140 70 | +#242#179#187'/'#194#231#13#231'h8'#253#21'^'#205#143'2q'#224#182#162#141#227 71 | +#209#243#0#139#22#204'#'#28#14'g\\'#191#218#12#16#132#173#203#129#229'i'#27 72 | +'8'#198#193#155'y|-D7'#142#155'~5'#251'NV'#224#155#150'1'#14'T>2'#205#3#248 73 | +#207#185'FZ['#219#136#197#227'_'#15#230#196#232#235#166#10'#'#22'v'#220#197 74 | +#187#246#224#6#133'1)'#244#212#134'2'#7#4'{j'#219#233#238#233#193#137'F'#9 75 | +#229'd'#19#12'f'#227#247#251'P'#20#21#137#4#9#202'p'#17'''<'#143'x"'#137#227 76 | +#184#244#14'X\'#237#236#131#205#11#190#153'>'#224'y'#242#151#138#194#175'[:' 77 | +#162#236'='#210#193#233#182#4#154'/'#192#157#194'h'#235#238#245#233#135'(' 78 | +#253#170#150'B'#8#229#150'E'#188#241#231'G'#213#159'l,'#163#234#209'R^z'#188 79 | +#12'/)9}'#201#229#252'U'#143'n;'#137#21#247'H&$q'#13#236#225#21#8#232#10#186 80 | +#162'R'#18'2'#8#155'&sK'#2#147#181#224#201#219'F'#160'|{'#221#25#4#11#231#207 81 | +#8'Q'#249'H)'#171#23#134'0|JF'#179#13#216#9#246#29'n'#229#247#251#206#241'eS' 82 | +'?'#192#25'>'#169'Z,'#165'T'#0'/'#131'W'#198#133#16#190'[F '#219#208'B'#131 83 | +#209#4'M'#237'6'#127#248'k+'#239#213#246#178'zQ'#136'%3'#12#166#231#233#228 84 | +#24#10#134'O'#160#169#2'-U'#3#146#132#151'd0'#234#209#217#23#227'T'#243#0#31 85 | +'7t'#176#231'`3'#150#19'K'#189';7'#232#11#245#222#180#129'f'#22#129'1/'#170 86 | +'x'#176'X'#173#174'mK'#221'''<'#201#137#175'\'#206'\Q1M'#21'MS'#211#166#18 87 | +#177#196#232#249#158#249#206'l'#245#141#15'A'#8#17'K'#135#135'e'#4#163#207'l' 88 | +#154'i'#175#191#191'p'#194#147#247#201#13'3y'#227#217#251#138#199#226#225#216 89 | +#235#208#161'C'#234#215'F'#161#127#157#235'g'#255#177'n.'#245'J'#12#195' '#19 90 | +'2'#231#184'1'#190#181' '#151'W'#158'X@'#197#3'%'#25't'#144#12#168#196'H'#20 91 | +'Z5?'#132#229'&9'#219#230'r'#177#211#163#211'J'#226'x'#30'J2'#137#23#135#168 92 | +#11#170#10'Y~A'#150'O'#163'(''@v'#192'`'#254'='#1#150#205#205'a'#245#162'\r' 93 | +#131':^R'#242#218#7'g'#185#216#30'y'#247#237#23'W>='#214#208#241'Z'#151#148 94 | +#233'81'#198#129#164''''#183#188's'#160#153#218'S})'#20'Z1'#199'`'#197#156 95 | +#145'Z:'#144#149#22#10#189'[s1'#133'B'#155'V'#22#151#223'|'#181'3#/S'#138'B' 96 | +#1#159#26#156#232#218#154'R'#20#170'x'#160'D'#249'p'#178#201#220'd'#162#208 97 | +'s'#155#231#230#166#203#254#171#171#247#170'wQhjPh'#130#165'|{'#221#153#242 98 | +#29'u'#242#249'7'#191#148#159'~'#209'#m'#215#147#153'J'#191#21#151#127#254'{' 99 | +#147#188'w['#141'dC'#181#220#244'J'#237#197#27#155'Vcc'#163'o'#188'fV__'#175 100 | +'e'#20#129'k2'#25'(4'#158#204#155'7o'#152'V'#140#174#131#149'+W'#196#211#161 101 | +#27#218'8'#169#183#7#228#206#201'@'#161#178'b'#243' 0n'#10'UW'#239'U'#171#170 102 | +'*G1'#212#248#220#185'k'#245#11#23#234#238#8#133#146'f'#236#183#18#254'2'#9 103 | +#217#249#254#174'['#228#127'UU'#213#24#166#169'_8'#127#248#142'a'#244#208#206 104 | +'u'#137#207'^_'#187#21'!*$'#162'&C'#222#158#2'5'#160#6#228'&>'#169'z*3'#228 105 | +#185#195's'#161#27#229#199'o5'#231#154#138#182'2'#203'4V'#152#134#185'B'#215 106 | +#181'2'#203#142#133'"'#142#27#182#156'hh8]'#250'm'#199#237#179#236'h'#127#196 107 | +'q['#28';zb'#208#142#157#232#143#201'z>'#218#220'{'#247#4#247#255#234't'#250 108 | +#165'w'#154#254#167#142#180'~'#183'm'#182#184#163'"'#158#144'3'#249'a'#241 109 | +#235#202#164';'#152#246#230'z~'#169#193#186#251'r(-'#240'c'#250#21#172#168'G' 110 | +#215'@'#130'S'#23'm>;'#217'?Jo'#253#178#16#179#138#253#168#138' '#158#144'4^' 111 | +'v'#168'i'#232#163#173#235'zS{'#252#161'<'#22#206'0'#233#30#136#179#235#192 112 | +#213#201'u`'#245#162'l~'#184'&'#31#128'~+ASo'#140'P'#150#198#204'"?'#185'A-' 113 | +#229#192#170#249'A'#170#30'.@'#8'p'#227'I:'#250#226#20#228#232',.3'#153'_j' 114 | +#240#167#127't'#208#216#230#0#16#12#168#228'gk$<9'#249#17#248#246#189#161'az' 115 | +#17#229#143#31#181#147#28#158'svI'#128'5'#139#179'S'#6#253#224#161'|'#132#128 116 | ,#214#174#24#187#14#180'c'#187'I'#242#178'5^'#248'n'#9#225#160#198#150#135#243 117 | +'y'#173#186#13'/9qe'#150'V'#146'^k/'#247#228#249'xlE.'#179'K'#2#232#154#160 118 | +#169'='#202#238#131#157#0',*3'#208#181'!'#197#154#19#189#216#238'Pc'#237#25 119 | +'Lpp8B'#225#160#198#172'b'#255#212#215'@}c'#132#199#150#135#9#248#20'6,'#11 120 | +#177'aY'#136#132'''9'#221'b'#243#183#127#246#210'='#152#160' '#231#250'G'#144 121 | +#203'='#163#9#220#229#238#235#247#5'!'#157#11'W'#162'S'#27#129#143#27#250#216 122 | +'['#215#205#149#17#134'i'#170'`'#233#236',^'#216'\'#130'O'#19'i'#159#209'z' 123 | +#158#156#250#8'('#138#224#248#217'A'#142#159#29'$h'#168#204'*'#242#179'~Y' 124 | +#136#25#133'~BY'#26#165#5'~:'#251#175#127'G'#152#150#231#163#223'rR'#247#165 125 | +#249#215#211'f'#164#222#148'E`Ge)'#203#230'd'#161'*'#130#136#227'q'#170#217 126 | +#166#225#130#149'z'#238#184'IN7'#219#196#18'C'#171'['#177'*'#151'lchK['#144 127 | +#163'S'#190'4''e|K'#135';'#218#0#1#134'_'#25'u'#169#138#152#216#8#228'gkl-/$' 128 | +#158#144't'#13#196'Q'#21'Aax('#231#191'h'#178'h'#239#29'J'#173'}u'#221'ly' 129 | +#180#128'iy>^'#221'2'#157#158'H'#130#130#28#13'U'#17#196#18#146#15'j'#187#184 130 | +'1'#129#10'C:'#191'y'#178'l'#212#216'{'#159'vr'#178#201#154'8'#7#246#31#237 131 | +'a'#201'L'#131#162#176'NQX'''#26'K'#210#210#225'r'#252#236' '#245#231'#)'#189 132 | +#19#231'#'#244'D'#18#148'/'#13'1'#171#200'O'#241#176#147#141'm'#14#251#142 133 | +#246#208'5"}'#186#7#19#180'v'#141#191'[s'#220#244#25#252#164'r'#161#151'+K)' 134 | +#12#233#156'n'#182#217#255'y'#15#193#128'Bo'#196#195#138#166'o'#224#164'p' 135 | +#161't'#229#240#169#1#0#150#204'4'#249#197#19#211#249#233#247#167'Q'#20#214 136 | +'''t'#14#193'$'#139#148'r'#13#176#17'('#0#186#128#183#132#16#237'w7'#2#195 137 | +#242'_/y'#180#250's'#165#138#158#0#0#0#0'IEND'#174'B`'#130 138 | ]); 139 | LazarusResources.Add('trsqlserver','PNG',[ 140 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 141 | +#0#0#6'bKGD'#0#255#0#255#0#255#160#189#167#147#0#0#0#9'pHYs'#0#0#14#196#0#0 142 | +#14#196#1#149'+'#14#27#0#0#0#7'tIME'#7#227#6#3#13#24#26#182'Pk'#178#0#0#4'%I' 143 | +'DATH'#199#173#149'[lTU'#20#134#191#189#207'\:'#237#148#182#12#173#220',-' 144 | +#151'T'#2'!'#26'"'#16'D'#6#208'D'#185#188#24'$F'#163#17#162#160'B4'#134'&$>' 145 | +#160#5'y'#5#19#21'#A'#130#209#24#212'Ty0'#166#168#145#177' h'#3#150#198#180 146 | +#130#148'K'#129#216#150#233#148#185'_'#152#206'9'#203#135#233'L/0'#210'&'#254 147 | +#201#201'Yg'#157#189#254'u'#206#191#214#218#27#134'a'#203#129#179#220#19#11 148 | +#15'0'#30#216#178'7'#1#20#189#189#182'9'#27'?'#236#218'6'#201#227'Ye'#179';' 149 | +#235'z'#251#130#142#222'@'#132#190#254'P'#218#223#31#190#16#8#197'|'#201'Dz?' 150 | +#208'9'#214#4'*g'#172#220#241#235'N'#183#187'd'#247#236#153#181#148#186'K' 151 | +#209#134'F)P'#10'2'#25'!'#24#137#243#247#149'n|'#191'w'#144#201#152';'#229 152 | +#167#13'{'#198#149#192'['#223',+'#188#143#162#148'*'#188'X'#129'i'#10#187#247 153 | +'}i'#209#252#156'Qh'#221'y`'#238#160#173's'#206#205'kj9'#221'r'#142'P8'#140 154 | +'iZyB'#173#193#180#132'@0'#202#169#179#23#217#189#175#145'=['#30'L'#229#226 155 | +#218'G'#145'w'#128'J'#221'Y'#3#152'5'#165#164#249#200#142#201#222#166#182'(' 156 | +#215'C'#9'")'#7#215'z'#130#244#248#195#196#227'Q'#138'm'#3'<<'#219#205#225'o' 157 | +#214#209#218#25':9'#140#195#14#12#228#30#4#196#158#253'pkDfo'#253'Iy'#229#131 158 | +#14#241#181'G$'#158#202#136#136'%'#195#17'M'#12#200#161'c]R'#183#169'IX'#249 159 | +#213#237#225#177#237#163#236#246'a'#210#231#141#143#191#191'*'#141#167#2'L' 160 | +#155'RIY'#197'$'#12#155#131#30#127#144#222'@'#152#190#254'0}'#183'"D"1R'#161 161 | +'8'#222#7#230#209'|h'#193'[@Q.'#222'0'#228#152'i'#170#22'Pr'#215'"'#183'\' 162 | +#184#245'KU'#185#203#235#251'+Nw'#196'I,'#227#224'Fo'#136#155#129#8#241'x'#20 163 | +#135'J3'#191#186#136'7'#215#215#176#225#25#243'z'#219#137#137#213#131#161#205 164 | +#192#242'A'#174'%'#160'Z'#238'Z'#249#241'HT'#179#241'h'#20'D'#178#23#12#217 165 | +#210'P`'#208#224#217'U'#211'i<'#21#224'S'#223'-'#142#182#233#255#148'h'#205 166 | +#194#249#206#174'<'#133#204#200'YZK'#147'5'#178#180'Cm'#250#208#172#178#230 167 | +#131'o'#204#199';'#207'M'#149'[p'#218#4'C'#131'M+&'#20#27#204#189#191#132#151 168 | +'V'#207#160#179'q'#13#221'm'#211'z'#6#195','#160#11#160'fz'#250#29#203#154'}' 169 | +#166#224#16'-'#223'~b'#236#18#189#248'm$''Ki'#169'Y'#147#151'H'#201#162#244 170 | +#235'O'#20#220'*'#246#150#20#187#182'O'#244'x(/'#216'EQR'#183#211'TY'#213#127 171 | +#248#143'/^'#152#155'o'#165#164'A'#132#183#171'\'#161#203#254'd'#197#156';j' 172 | +#176#162#193#135#175'aY'#253#186']'#231#190#214'Jmr'#24','#181#219#152#229'r' 173 | +#234#226#18#167'A'#178#200'H'#196#157#250'rL'#235#211#136#28#246#31'_'#172 174 | +#129''''#0'g'#182#196#170#1#164#200#159',O'#130#172#6#213'4'#226'7'#234#15'^' 175 | +'U'#252'O'#24#205#165#134#189#200#15'H'#198#20'2'#166#160#20#216'm'#26#173 176 | +#178'>K@Dp'#216'5'#10'H'#15#8#134#1#134#30#226#220#187#185'V'#221#181'Ms(rh' 177 | +#182#174#157#204'T'#143#3#128'/|}t\K'#176#253#169#169'y'#223'g?'#247'q'#230 178 | +'b'#148']'#207'W'#227#251'3'#204'o'#231#163#247':p'#134#176#164#174#148#202 179 | +'2;;?'#191'N0'#154#161#186#202#201#250'e'#147#16'`'#235#254'+,'#170's'#179 180 | +#241#241'*Z/'#197#208'c'#16'V'#143'v'#156#237#140#17'I'#154#188#251'B5'#239 181 | +#191'V'#139#211#166#152'\a'#231'Rw'#18#151'C'#211#249'O'#18#128#202'2'#251'x' 182 | +#142#204'!T'#150#219#217's'#228#6'"'#176#227#233'i<2o'#2#221#253'i'#230'Lu' 183 | +#145'L'#247#179#160#182#20#128#155#161#236#14'm'#9'd,A1'#178#22#5#19'T'#184 184 | +'m'#188#183#165#22#128#254'h'#134#31'[C'#196#146'&'#175#174#157#194'G'#219'f' 185 | +'bY'#194'''?'#220#4#129#212#128#176'~'#169#135#13#203'<t\Kd'#253#133#142#204 186 | +'\'#23'Y'#2#3#25#11#17'0'#12#133#221'P'#249#206#170#155#238#226#229''''#239 187 | +#163#245'R'#140#239'Z'#130'D'#18'&2'#184#223'i'#157'];'#186#139#198'='#7#166 188 | +')u'#166'%'#143#141'u'#14#254#5#156'h;'#143#131#236#227#0#0#0#0#0'IEND'#174 189 | +'B`'#130 190 | ]); 191 | LazarusResources.Add('trsqlserver_200','PNG',[ 192 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0'0'#0#0#0'0'#8#6#0#0#0'W'#2#249#135 193 | +#0#0#0#6'bKGD'#0#255#0#255#0#255#160#189#167#147#0#0#0#9'pHYs'#0#0#14#196#0#0 194 | +#14#196#1#149'+'#14#27#0#0#0#7'tIME'#7#227#6#3#13#23#21#161'wj'#236#0#0#8'%I' 195 | +'DATh'#222#237#153'{l'#20#215#21#198#127#243#218#221#25#239'zm'#252#12#139#13 196 | +#14#194'` @b'#146#148#144#132#224#208#0')'#149#154#182'64"'#145#170'<'#21#169 197 | +'R'#211'4'#143#146#164#162#180'U'#170'D'#21#127'P'#165'J'#162'&'#18'M'#21'd' 198 | +#132#18#181'M'#137#203'# '#28#18'Z'#155'6`'#132#139'!'#198#6#19#131#223#246 199 | +#206#204#206#238'<'#250#199#26'cc'#3#246#214'vZ'#149'#'#173'Vs'#231#238#220 200 | +#243#221#243#157#239#156#185#11#215#237#171'5'#225'Z'#19#30#127#163'F'#129 201 | +#252';UU'#187']'#211#212#155#21'Y)'#140#154#241'B'#221#140#169#186'ae'#232 202 | +#134#133'n'#198#187#13'3f'#234'F'#172'Y'#143#197#154#12#221#250'g'#212#138'}' 203 | +#214#221'x'#238#19'j'#159'H|%'#0'V'#255#228#179#185#129'`'#218#211#154#166 204 | +#150'k'#154#26#214'T'#13'MS'#145'e'#5#221#180#208#141'X'#255#183#133'nZ'#24 205 | +'#'#140#233#166#213#157'H8'#219#193#217#204#238'u'#199''''#9#128''','#127#254 206 | +#147#141'>Y'#217#160'i'#170#172'i'#26#225'p:'#161#180' ~'#191#15'A'#148#192 207 | +#243#240#0'AL'#254#220'q'#28#28#219'%jZ'#244#244#25#180#182'us'#170#249'<' 208 | +#205#231#218'I$l'#0#27#132'_'#176#187#252'g'#19#14'`'#249's'#213#207#10#240 209 | +#170#226#243'Q0-B^N'#14#138'OI'#233#225#29#221'Q>=|'#130#218#186'/'#240'<'#15 210 | +#4#225'G'#236'*'#223'<'#158#0#196#17#16'='#9'P2{'#22#211'"SSv'#30' +#'#200 211 | +#154#178'['#248#222'7'#151#246#7#215'{d'#188'#0'#12#128#230#151'B'#201#181 212 | +#198'o'#145'$'#225'p'#211#211#20'u'#194#1#148#223'='#213#1#248#215#137#6#206 213 | +#158'm!'#158'H]D:'#186#250#248#211#158'Z'#182#253#241' '#128#251#227#239#22 214 | +#155#169'<'#231#248'U'#196'f'#216#13#207#243#190#216#186#251'L'#209#182#253 215 | +#173#4#212#0#154#166#17'N'#15#17#12#134#240#251'}'#136#162#148#220'Q'#15#196 216 | +#254'$'#182#29#135#132#237'b'#154#22']'#189':'#231#219#186'9'#217't'#158'3' 217 | +#173#29'$'#18'6'#178'$'#242#211#245'%'#246#203#235#231#30#17#4#161't'#240'zG' 218 | +'A'#16#129'yp'#197#152#215#129#232#0#11#193#189#252#158'|'#249#128#235#242 219 | +#206#195'+'#10'6'#221#179' '#135#237#159'\'#224'X'#139'M'#194#182#177','#11 220 | +'I'#18#145'ea'#212'2'#26'Re'#238'_'#22#225#165#7'K'#152']'#16#194'vyw'#4#10 221 | +#200#30#216#215'b'#161'4'#2'[F'#4#176#242#197#131#210'#+'#11#169'X'#22#225 222 | +#153#7#10'q\'#143'cg,N'#158'w'#232'0\'#244#132#131'k{$d0'#250'C'#24'PD'#20'Q' 223 | +'"?'#172#146#161'i'#204#204#15'p'#219#236'0w'#207#207'B'#150#4#28#215#227'W' 224 | +#219#234'y'#241#237#163'C'#20#161#6#4#15'$'#174#13#224#138'5k'#216'`'#217#179 225 | +#213#199#17#152'S\'#16#166#252#238#8'K'#230#132'Q}bJ9'#208'k'#216#236'8p'#150 226 | +#205';Np'#180#177#199#5#254#193#238#138#197#169'<'#171#14#196#249#163#161'PH' 227 | +#149#195'}1'#155#198'V'#131#223#252#249',['#247'w'#177#164'$'#204#188#2#149 228 | +'iS'#20#210'U'#17#213''' K'#2#242'@'#14'x'#216#142'K_'#204#161#173';N]S/'#187 229 | +#14'_`'#219#222'&t3>'#192#150#204#160'/'#179'+5'#231#5#225#10'92'#12#192#234 230 | +#219#243#164#202#253'-'#3#215#182#227'Q'#251#133#197#241'/%4MB'#150#165'Q' 231 | +#231'@'#220#30#186'a'#143#222'_'#228#127#237#131#177#3#152#127#149#4#31#198 232 | +#141'GWM7'#238#189'9g'#220'{'#150#135'VL'#231#181#199#23'D'#146#21#230#234 233 | +#159'}'#251#246'I)'#183#18#142#227#189','#138'l'#250#251#137#30#222#255#172 234 | +#131'3]'#30#170#170#146'J3gZq'#190'6;'#147#23#214#205'f'#245'm'#249'c'#237'r' 235 | +#132#209#204#186#170#10#221'Z'#28'F'#183'\'#234'[,N'#183'9'#180#233'.'#166 236 | +#227' '#186'.N'#2'b'#22'H'#18#164#249#5#210'|2'#185#233#1'B'#1#149#226#27#2 237 | +','#154#153#206#146#146'L2'#131#10#142#235#241#202'{'#245#156'n'#141#190#243 238 | +#198#211#139#191'?'#220#209#145#234'~'#178'y'#26'3'#0#215#241#214#190#181#179 239 | +#137#253'u'#221#3'*Tz'#163'J'#233#141#131'g)@'#218#168'T'#232#157#170#211#23 240 | +'U'#136'U'#139#243#202#174#188#219#169'5/'#147#169'B'#4'|Rp'#188'skRUh'#245 241 | +'m'#249#226#7#227#12'`RU'#232#137'533'#175#208')'#12#163'Oe'#229'v)'#165#8#8 242 | +#8'ooXW'#188#233#235#131'T('#229#221#17#5#150'-'#200#189#134#10#13'w'#190#183 243 | +#245'|^s~'#133#247'?'#162'B'#195#205#174#175#215#250#149'">'#230']+{'#182#250 244 | +'x'#217's'#213#222#147'['#142'z{>'#239#244#12#203#241'R'#181#30'='#225#189 245 | +#253'Q'#163'w'#211'cU'#30'+*'#189'U/'#236'?}y'#209'jhh'#240#141'T'#204'jjj' 246 | +#228#148'"p'#209'&B'#133'F'#178'Y'#179'f'#197#147#5'u('#149#22'/.M'#140#230 247 | +#216'G'#30'A'#146#183#129#183'q"T'#168'0O'#219#11#140'H'#161#202#202#237'REE' 248 | +#185'3x,'#254#131#149'w'#250#182'TU'#143'I'#133'\-'#254'K'#15#254'0'#1'G8' 249 | +#191#127#243'*'#252#175#168#168#24#214'*'#251#182'|t`'#204'2'#186'o'#227'r' 250 | +#251#227'W'#239'\'#143' '#172#246#16#170#0#231'?p'#218#1#170#192'['#197#238 251 | +#138#135'S'#235#127#174'^'#161#175#201#177#7'_o'#202#212'Dyq'#154#166#150'j' 252 | +#170'V'#170'(r'#161'n'#196#195'Q'#211#202#208#205'X'#184#159'.='#134'iu'#235 253 | +'F'#172'''jZ'#205#166#17#171#237'3'#226#181'=q'#175#134#15#215'tq'#221#254 254 | +#159'N'#167#159'y'#171#209#251'or'#240#215#143#21#9'cJ'#226'q9'#147#239'7' 255 | +#191'"N8@y'#180#19#139'#*'#203#23#164#19#201#246#163#249'E'#244#152'C{'#175 256 | ,'M'#221'i'#131#143#143#244#12#153'w'#239#162'03'#242#252'H'#162'@'#194#246'h' 257 | +'8gRu'#184#155#150#246'KE'#237#129';'#166'0'#167'@'#163#163'7'#193#155';'#207 258 | +'O,'#128'%%!'#190#179'4'#11#128#30#221#166#177'+N8Mfz'#174#159#204#160'<'#0 259 | +#224#214#226' '#21'we#'#8'`%\.t'''#200'NW'#152'['#168'Q'#28'Q'#249#221'_/' 260 | +#208#208#146'<]'#12#6'$'#178'B2'#182#227'M|'#4#238#185')'#220#223'^'#196#248 261 | +#237#135#173#184#253'k'#22#229#7'X:74'#224#208#183#239#200'B'#16#224'l{'#156 262 | +'7w'#182'bX.SB2O}#'#159#140#160#204#218#187#178'x'#165#178#5#199#29#191'4'#27 263 | +#21'I/'#150#151#27#166#248#184#175'4'#147#162#252#0#138','#208#216#26#227#221 264 | +#189'm'#0#148#20#170'(rrbUm'#23#134#149','#172#157'}6{'#251'#'#148#17#148#153 265 | +#145#231#159#252#28#168'i'#136'r'#223'-'#25#4'|"+'#22#133'Y'#177'('#140#237 266 | +'x'#28'k6'#248#203#223#186#232#232#179#201'N'#191'tjx'#174'sh'#3'w'#174#227 267 | +#210'uvX'#225#212#151#177#201#141#192#174#195#221'l'#175#238#224#203'A'#142 268 | +#201#146#192#194#162'4'#158'Z'#147#143'O'#22'Fy'#8#2#142#227'M~'#4'DQ'#224'P' 269 | +'}'#31#135#234#251#8#170#18'3r'#253#220#187'(LA'#142#159'p'#154'L$'#219'O[' 270 | +#207#165#255#17#166'N'#241#209#163'_'#250'+ '#146'u'#137'6'#131#231'MZ'#4#158 271 | +'+'#143#176#232#198'4$Q j:'#212'5'#25#28'>'#165#15#220'7-'#151'cM'#6'q;'#185 272 | +#187#171'o'#205'$'#164'&_i'#179#211#21#202#22#166#15'8'#223'|'#193#26#234#128 273 | +#0#170'_'#28#242#145'Da|#'#144#21#146'Y_'#150'C'#194#246'h'#239'M '#137#2'9' 274 | +#25'I'#206#127#222#168#211#218#149#164#214#142#234#14#214'.'#203'f'#234#20#31 275 | +#27#214'N'#163'3j'#147#157'.#'#137#2'q'#219#227#189#253#237#195#14'9s'#194#10 276 | +'?'#127#168'p'#200#216#214'=m'#28'i'#212#199#15#192#251#7';'#153'7]%7C!7C!' 277 | +#22'wi'#190'`q'#168#190#143#154#147#209#129'y'#181''''#163'tFm'#202#22#134 278 | +#153#145#235''''#175#31'dC'#139#201#142#131#157#180#15#162'OG'#159#205#217 279 | +#246#145#223#214'Lk'#244#29#252#132#246'B'#207#151'G'#200#9'+'#28'k2x'#255 280 | +#211'N'#130#1#145#174#168#131#30#27#189#131#19#210#11#141#214#14#212#245#2'0' 281 | +'o'#186#198'K'#235#166#241#195'oM%7C'#25#215'5'#4'&'#216'<'#207'['#10#172#4 282 | +#178#129'v'#224'uA'#16'Z'#175#191#8#244#219#191#1'_'#236#182#220'K'#225'>'#23 283 | +#0#0#0#0'IEND'#174'B`'#130 284 | ]); 285 | -------------------------------------------------------------------------------- /source/rsql_helper.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Helper; 24 | 25 | {$I rsql.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | jsonscanner, 33 | jsonparser, 34 | fpjson, 35 | DB, 36 | sqldb, 37 | httpdefs, 38 | httproute; 39 | 40 | type 41 | 42 | { TJSONDataHelper } 43 | 44 | TJSONDataHelper = class helper for TJSONData 45 | public 46 | class function Parse(const ASource: TJSONStringType): TJSONData; static; overload; 47 | class function Parse(const ASource: TJSONStringType; 48 | out AJSONData: TJSONData): boolean; static; overload; 49 | class function Parse(const ASource: TJSONStringType; 50 | out AJSONArray: TJSONArray): boolean; static; overload; 51 | class function Parse(const ASource: TJSONStringType; 52 | out AJSONObject: TJSONObject): boolean; static; overload; 53 | public 54 | function Path(const AName: TJSONStringType): TJSONData; overload; 55 | function Path(const AName: TJSONStringType; 56 | const ADefault: TJSONStringType): TJSONStringType; overload; 57 | function Path(const AName: TJSONStringType; const ADefault: boolean): boolean; 58 | overload; 59 | function Path(const AName: TJSONStringType; 60 | const ADefault: TJSONFloat): TJSONFloat; overload; 61 | function Path(const AName: TJSONStringType; const ADefault: integer): integer; 62 | overload; 63 | function Path(const AName: TJSONStringType; const ADefault: int64): int64; 64 | overload; 65 | function Path(const AName: TJSONStringType; 66 | const ADefault: TJSONData): TJSONData; overload; 67 | function Path(const AName: TJSONStringType; 68 | const ADefault: TJSONArray): TJSONArray; overload; 69 | function Path(const AName: TJSONStringType; 70 | const ADefault: TJSONObject): TJSONObject; overload; 71 | public 72 | function Stringify(const AHumanReader: boolean = False): TJSONStringType; 73 | end; 74 | 75 | { TParamsHelper } 76 | 77 | TParamsHelper = class helper for TParams 78 | public 79 | procedure AssignJSON(const AJSONData: TJSONData); 80 | end; 81 | 82 | { TSQLQueryHelper } 83 | 84 | TSQLQueryHelper = class helper for TSQLQuery 85 | public 86 | {$IfNDef rsql_experimental} 87 | function SaveToJSON: TJSONObject; 88 | {$Else} 89 | function SaveToJSON(const ARecno, APacketRecords: Int64): TJSONObject; 90 | {$EndIf} 91 | end; 92 | 93 | { TSQLConnectionHelper } 94 | 95 | TSQLConnectionHelper = class helper for TSQLConnection 96 | public 97 | procedure FillIndexDefs(AIndexDefs: TIndexDefs; const ATableName: string); 98 | function ExtractSchemaSQL(const ASchemaType: TSchemaType; 99 | const ASchemaObjectName, ASchemaPattern: string): string; 100 | function ExtractSequenceSQL(const ASequenceName: string; 101 | const AIncrementBy: integer): string; 102 | end; 103 | 104 | { EHTTP } 105 | 106 | EHTTP = class(Exception) 107 | private 108 | FStatusCode: integer; 109 | public 110 | constructor Create(const ACode: integer; const AMessage: string); 111 | constructor CreateFmt(const ACode: integer; const AMessage: string; 112 | const AArgs: array of const); 113 | property StatusCode: integer read FStatusCode write FStatusCode; 114 | end; 115 | 116 | { TResponseHelper } 117 | 118 | TResponseHelper = class helper for TResponse 119 | public 120 | procedure Envelop(const ACode: integer; const AContent: TJSONData); overload; 121 | procedure Envelop(const ACode: integer; const AContent: string); overload; 122 | procedure Envelop(const ACode: integer; const AContent: string; 123 | const AArgs: array of const); overload; 124 | end; 125 | 126 | { TCustomRoute } 127 | 128 | TCustomRoute = class(TObject) 129 | public 130 | procedure HandleRequest(AServer: TObject; ARequest: TRequest; 131 | AResponse: TResponse); virtual; abstract; 132 | end; 133 | TRouteClass = class of TCustomRoute; 134 | 135 | { THTTPRouterHelper } 136 | 137 | THTTPRouterHelper = class helper for THTTPRouter 138 | public 139 | function RegisterRoute(const APattern: string; const ARouteClass: TRouteClass; 140 | AIsDefault: boolean = False): THttpRoute; overload; 141 | function RegisterRoute(const APattern: string; AMethod: TRouteMethod; 142 | const ARouteClass: TRouteClass; AIsDefault: boolean = False): THttpRoute; overload; 143 | procedure RouteRequest(AServer: TObject; ARequest: TRequest; 144 | AResponse: TResponse); overload; 145 | end; 146 | 147 | implementation 148 | 149 | uses 150 | RSQL_Crypto_BASE64, 151 | RSQL_Crypto_ZStream; 152 | 153 | { TJSONDataHelper } 154 | 155 | class function TJSONDataHelper.Parse(const ASource: TJSONStringType): TJSONData; 156 | begin 157 | Result := nil; 158 | with TJSONParser.Create(ASource, [joUTF8]) do 159 | begin 160 | try 161 | try 162 | Result := Parse; 163 | except 164 | FreeAndNil(Result); 165 | end; 166 | finally 167 | Free; 168 | end; 169 | end; 170 | end; 171 | 172 | class function TJSONDataHelper.Parse(const ASource: TJSONStringType; 173 | out AJSONData: TJSONData): boolean; 174 | begin 175 | AJSONData := Parse(ASource); 176 | Result := Assigned(AJSONData); 177 | end; 178 | 179 | class function TJSONDataHelper.Parse(const ASource: TJSONStringType; 180 | out AJSONArray: TJSONArray): boolean; 181 | var 182 | VJSONData: TJSONData; 183 | begin 184 | Result := False; 185 | AJSONArray := nil; 186 | if (Parse(ASource, VJSONData)) then 187 | begin 188 | if (VJSONData.JSONType = jtArray) then 189 | begin 190 | AJSONArray := TJSONArray(VJSONData); 191 | Result := True; 192 | end 193 | else 194 | begin 195 | FreeAndNil(VJSONData); 196 | end; 197 | end; 198 | end; 199 | 200 | class function TJSONDataHelper.Parse(const ASource: TJSONStringType; 201 | out AJSONObject: TJSONObject): boolean; 202 | var 203 | VJSONData: TJSONData; 204 | begin 205 | Result := False; 206 | AJSONObject := nil; 207 | if (Parse(ASource, VJSONData)) then 208 | begin 209 | if (VJSONData.JSONType = jtObject) then 210 | begin 211 | AJSONObject := TJSONObject(VJSONData); 212 | Result := True; 213 | end 214 | else 215 | begin 216 | FreeAndNil(VJSONData); 217 | end; 218 | end; 219 | end; 220 | 221 | function TJSONDataHelper.Path(const AName: TJSONStringType): TJSONData; 222 | begin 223 | Result := FindPath(AName); 224 | end; 225 | 226 | function TJSONDataHelper.Path(const AName: TJSONStringType; 227 | const ADefault: TJSONStringType): TJSONStringType; 228 | var 229 | VJSONData: TJSONData; 230 | begin 231 | VJSONData := Path(AName); 232 | if (Assigned(VJSONData)) and (VJSONData.JSONType = jtString) then 233 | begin 234 | Result := VJSONData.AsString; 235 | end 236 | else 237 | begin 238 | Result := ADefault; 239 | end; 240 | end; 241 | 242 | function TJSONDataHelper.Path(const AName: TJSONStringType; 243 | const ADefault: boolean): boolean; 244 | var 245 | VJSONData: TJSONData; 246 | begin 247 | VJSONData := Path(AName); 248 | if (Assigned(VJSONData)) and (VJSONData.JSONType = jtBoolean) then 249 | begin 250 | Result := VJSONData.AsBoolean; 251 | end 252 | else 253 | begin 254 | Result := ADefault; 255 | end; 256 | end; 257 | 258 | function TJSONDataHelper.Path(const AName: TJSONStringType; 259 | const ADefault: TJSONFloat): TJSONFloat; 260 | var 261 | VJSONData: TJSONData; 262 | begin 263 | VJSONData := Path(AName); 264 | if (Assigned(VJSONData)) and (VJSONData.JSONType = jtNumber) then 265 | begin 266 | Result := VJSONData.AsInteger; 267 | end 268 | else 269 | begin 270 | Result := ADefault; 271 | end; 272 | end; 273 | 274 | function TJSONDataHelper.Path(const AName: TJSONStringType; 275 | const ADefault: int64): int64; 276 | var 277 | VJSONData: TJSONData; 278 | begin 279 | VJSONData := Path(AName); 280 | if (Assigned(VJSONData)) and (VJSONData.JSONType = jtNumber) then 281 | begin 282 | Result := VJSONData.AsInteger; 283 | end 284 | else 285 | begin 286 | Result := ADefault; 287 | end; 288 | end; 289 | 290 | function TJSONDataHelper.Path(const AName: TJSONStringType; 291 | const ADefault: integer): integer; 292 | var 293 | VJSONData: TJSONData; 294 | begin 295 | VJSONData := Path(AName); 296 | if (Assigned(VJSONData)) and (VJSONData.JSONType = jtNumber) then 297 | begin 298 | Result := VJSONData.AsInt64; 299 | end 300 | else 301 | begin 302 | Result := ADefault; 303 | end; 304 | end; 305 | 306 | function TJSONDataHelper.Path(const AName: TJSONStringType; 307 | const ADefault: TJSONData): TJSONData; 308 | var 309 | VJSONData: TJSONData; 310 | begin 311 | VJSONData := Path(AName); 312 | if (Assigned(VJSONData)) then 313 | begin 314 | Result := VJSONData; 315 | end 316 | else 317 | begin 318 | Result := ADefault; 319 | end; 320 | end; 321 | 322 | function TJSONDataHelper.Path(const AName: TJSONStringType; 323 | const ADefault: TJSONArray): TJSONArray; 324 | var 325 | VJSONData: TJSONData; 326 | begin 327 | VJSONData := Path(AName); 328 | if (Assigned(VJSONData)) and (VJSONData.JSONType = jtArray) then 329 | begin 330 | Result := VJSONData as TJSONArray; 331 | end 332 | else 333 | begin 334 | Result := ADefault; 335 | end; 336 | end; 337 | 338 | function TJSONDataHelper.Path(const AName: TJSONStringType; 339 | const ADefault: TJSONObject): TJSONObject; 340 | var 341 | VJSONData: TJSONData; 342 | begin 343 | VJSONData := Path(AName); 344 | if (Assigned(VJSONData)) and (VJSONData.JSONType = jtObject) then 345 | begin 346 | Result := VJSONData as TJSONObject; 347 | end 348 | else 349 | begin 350 | Result := ADefault; 351 | end; 352 | end; 353 | 354 | function TJSONDataHelper.Stringify(const AHumanReader: boolean): TJSONStringType; 355 | begin 356 | if (AHumanReader) then 357 | begin 358 | Result := FormatJSON(); 359 | end 360 | else 361 | begin 362 | Result := FormatJSON(AsCompressedJSON); 363 | end; 364 | end; 365 | 366 | { TParamsHelper } 367 | 368 | procedure TParamsHelper.AssignJSON(const AJSONData: TJSONData); 369 | var 370 | VParam: TParam; 371 | VIndex: integer; 372 | VName: string; 373 | VJSONData: TJSONData; 374 | VJSONObject: TJSONObject; 375 | begin 376 | if (Assigned(AJSONData)) and (AJSONData.JSONType = jtObject) then 377 | begin 378 | VJSONObject := TJSONObject(AJSONData); 379 | for VIndex := 0 to (VJSONObject.Count - 1) do 380 | begin 381 | VName := VJSONObject.Names[VIndex]; 382 | VJSONData := VJSONObject.Elements[VName]; 383 | VParam := ParamByName(VName); 384 | if (Assigned(VJSONData)) and (Assigned(VParam)) then 385 | begin 386 | case VJSONData.JSONType of 387 | jtBoolean: 388 | begin 389 | VParam.AsBoolean := VJSONData.AsBoolean; 390 | end; 391 | jtNumber: 392 | begin 393 | VParam.AsFloat := VJSONData.AsFloat; 394 | end; 395 | jtString: 396 | begin 397 | VParam.AsString := VJSONData.AsString; 398 | end; 399 | jtObject: 400 | begin 401 | case (LowerCase(VJSONData.Path('type', 'string'))) of 402 | 'boolean': 403 | begin 404 | VParam.AsBoolean := VJSONData.Path('value', False); 405 | end; 406 | 'integer': 407 | begin 408 | VParam.AsLargeInt := VJSONData.Path('value', 0); 409 | end; 410 | 'number': 411 | begin 412 | VParam.AsFloat := VJSONData.Path('value', 0); 413 | VParam.Precision:=VJSONData.Path('precision', 0); 414 | end; 415 | 'currency': 416 | begin 417 | VParam.AsCurrency := VJSONData.Path('value', 0.0); 418 | VParam.Precision:=VJSONData.Path('precision', 0); 419 | end; 420 | 'datetime': 421 | begin 422 | VParam.AsDateTime := VJSONData.Path('value', 0.0); 423 | end; 424 | 'date': 425 | begin 426 | VParam.AsDate := VJSONData.Path('value', 0.0); 427 | end; 428 | 'time': 429 | begin 430 | VParam.AsTime := VJSONData.Path('value', 0.0); 431 | end; 432 | else 433 | begin 434 | if (VJSONData.Path('b64', True)) and 435 | (VJSONData.Path('value', EmptyStr) <> EmptyStr) then 436 | begin 437 | VParam.AsString := BASE64Decode(VJSONData.Path('value', EmptyStr)); 438 | end 439 | else 440 | begin 441 | VParam.AsString := VJSONData.Path('value', EmptyStr); 442 | end; 443 | //VParam.Precision:=VJSONData.Path('precision', 0); 444 | end; 445 | end; 446 | //VParam.Size:=VJSONData.Path('size', 0); 447 | end; 448 | else 449 | begin 450 | VParam.Clear; 451 | end; 452 | end; 453 | end; 454 | end; 455 | end; 456 | end; 457 | 458 | { TSQLQueryHelper } 459 | 460 | {$IfNDef rsql_experimental} 461 | function TSQLQueryHelper.SaveToJSON: TJSONObject; 462 | {$Else} 463 | function TSQLQueryHelper.SaveToJSON(const ARecno, APacketRecords: Int64): TJSONObject; 464 | {$EndIf} 465 | 466 | function ExtractMetadata: TJSONArray; 467 | var 468 | VIndex: integer; 469 | VField: TFieldDef; 470 | VColumn: TJSONObject; 471 | begin 472 | Result := TJSONArray.Create([]); 473 | for VIndex := 0 to (FieldDefs.Count - 1) do 474 | begin 475 | VField := FieldDefs[VIndex]; 476 | if (Assigned(VField)) then 477 | begin 478 | VColumn := TJSONObject.Create([]); 479 | VColumn.Add('name', VField.Name); 480 | VColumn.Add('type', Fieldtypenames[VField.DataType]); 481 | VColumn.Add('length', VField.Size); 482 | VColumn.Add('precision', VField.Precision); 483 | VColumn.Add('required', faRequired in VField.Attributes); 484 | VColumn.Add('readonly', faReadonly in VField.Attributes); 485 | VColumn.Add('hidden', faHiddenCol in VField.Attributes); 486 | VColumn.Add('fixed', faFixed in VField.Attributes); 487 | Result.Add(VColumn); 488 | end; 489 | end; 490 | end; 491 | 492 | function ExtractRow: TJSONArray; 493 | var 494 | VIndex: integer; 495 | VField: TField; 496 | begin 497 | Result := TJSONArray.Create(); 498 | for VIndex := 0 to (FieldCount - 1) do 499 | begin 500 | VField := Fields[VIndex]; 501 | if (Assigned(VField)) then 502 | begin 503 | if (VField.IsNull) then 504 | begin 505 | Result.Add; 506 | end 507 | else 508 | begin 509 | case VField.DataType of 510 | ftString, 511 | ftWideString, 512 | ftFixedChar, 513 | ftFixedWideChar, 514 | ftGuid: 515 | begin 516 | Result.Add(UTF8Decode(VField.AsString)); 517 | end; 518 | ftBoolean: 519 | begin 520 | Result.Add(VField.AsBoolean); 521 | end; 522 | ftInteger, 523 | ftLargeint, 524 | ftSmallint, 525 | ftWord, 526 | ftAutoInc: 527 | begin 528 | Result.Add(VField.AsLargeInt); 529 | end; 530 | ftFloat, 531 | ftCurrency, 532 | ftBCD, 533 | ftFMTBcd: 534 | begin 535 | Result.Add(VField.AsFloat); 536 | end; 537 | ftDateTime, 538 | ftTimeStamp: 539 | begin 540 | Result.Add(VField.AsDateTime); 541 | end; 542 | ftDate: 543 | begin 544 | Result.Add(VField.AsDateTime); 545 | end; 546 | ftTime: 547 | begin 548 | Result.Add(VField.AsDateTime); 549 | end; 550 | ftBlob, 551 | ftBytes, 552 | ftGraphic, 553 | ftVarBytes, 554 | ftMemo, 555 | ftWideMemo, 556 | ftTypedBinary: 557 | begin 558 | Result.Add(BASE64Encode(VField.AsString)); 559 | end; 560 | else 561 | begin 562 | Result.Add(VField.AsString); 563 | end; 564 | end; 565 | end; 566 | end; 567 | end; 568 | end; 569 | 570 | {$IfNDef rsql_experimental} 571 | function ExtractRows: TJSONArray; 572 | {$Else} 573 | function ExtractRows(ARecno, APacketRecords: Int64): TJSONArray; 574 | {$EndIf} 575 | begin 576 | Result := TJSONArray.Create(); 577 | if IsEmpty then 578 | Exit; 579 | try 580 | DisableControls; 581 | {$IfNDef rsql_experimental} 582 | First; 583 | while not EOF do 584 | begin 585 | Result.Add(ExtractRow); 586 | Next; 587 | end; 588 | {$Else} 589 | if APacketRecords > 0 then 590 | begin 591 | ARecno:=ARecno+1; 592 | 593 | if (ARecno < 1) then 594 | begin 595 | ARecno := 1; 596 | end; 597 | 598 | //WriteLn('RECORDCOUNT ',RecordCount); 599 | //if (ARecno-1) > RecordCount then 600 | //Exit; 601 | 602 | //RecNo := ARecno; 603 | while not(EOF) and (RecNo < (ARecno + APacketRecords)) do 604 | begin 605 | if not (RecNo < ARecno) then 606 | Result.Add(ExtractRow); 607 | Next; 608 | end; 609 | end 610 | else 611 | begin 612 | First; 613 | while not EOF do 614 | begin 615 | Result.Add(ExtractRow); 616 | Next; 617 | end; 618 | end; 619 | 620 | {$EndIf} 621 | finally 622 | EnableControls; 623 | end; 624 | end; 625 | 626 | begin 627 | Result := TJSONObject.Create(); 628 | if (StatementType <> stSelect) then 629 | begin 630 | Result.Add('rowsaffected', RowsAffected); 631 | end 632 | else 633 | begin 634 | {$IfNDef rsql_experimental} 635 | Result.Add('rows', ExtractRows); 636 | {$Else} 637 | Result.Add('rows', ExtractRows(ARecno, APacketRecords)); 638 | {$EndIf} 639 | Result.Add('rowsaffected', RowsAffected); 640 | Result.Add('metadata', ExtractMetadata); 641 | end; 642 | end; 643 | 644 | { TSQLConnectionHelper } 645 | 646 | procedure TSQLConnectionHelper.FillIndexDefs(AIndexDefs: TIndexDefs; 647 | const ATableName: string); 648 | var 649 | VTransaction: TSQLTransaction; 650 | begin 651 | if (not (Assigned(Transaction))) then 652 | begin 653 | try 654 | VTransaction := TSQLTransaction.Create(nil); 655 | VTransaction.DataBase := Self; 656 | UpdateIndexDefs(AIndexDefs, ATableName); 657 | finally 658 | FreeAndNil(VTransaction); 659 | end; 660 | end 661 | else 662 | begin 663 | UpdateIndexDefs(AIndexDefs, ATableName); 664 | end; 665 | end; 666 | 667 | function TSQLConnectionHelper.ExtractSchemaSQL(const ASchemaType: TSchemaType; 668 | const ASchemaObjectName, ASchemaPattern: string): string; 669 | begin 670 | Result := GetSchemaInfoSQL(ASchemaType, ASchemaObjectName, ASchemaPattern); 671 | end; 672 | 673 | function TSQLConnectionHelper.ExtractSequenceSQL(const ASequenceName: string; 674 | const AIncrementBy: integer): string; 675 | begin 676 | Result := GetNextValueSQL(ASequenceName, AIncrementBy); 677 | end; 678 | 679 | { EHTTP } 680 | 681 | constructor EHTTP.Create(const ACode: integer; const AMessage: string); 682 | begin 683 | FStatusCode := ACode; 684 | inherited Create(AMessage); 685 | end; 686 | 687 | constructor EHTTP.CreateFmt(const ACode: integer; const AMessage: string; 688 | const AArgs: array of const); 689 | begin 690 | FStatusCode := ACode; 691 | inherited CreateFmt(AMessage, AArgs); 692 | end; 693 | 694 | { TResponseHelper } 695 | 696 | procedure TResponseHelper.Envelop(const ACode: integer; const AContent: TJSONData); 697 | begin 698 | Self.Code := ACode; 699 | with TJSONObject.Create() do 700 | begin 701 | try 702 | Add('success', (ACode >= 200) and (ACode <= 299)); 703 | Add('content', AContent); 704 | if (Self.ContentEncoding = EmptyStr) then 705 | begin 706 | Self.Content := Stringify(); 707 | end 708 | else 709 | begin 710 | // Encode response 711 | if (LowerCase(Self.ContentEncoding) = 'deflate') then 712 | begin 713 | Self.Content := ZCompressString(Stringify()); 714 | end 715 | else 716 | begin 717 | Self.Content := Stringify(); 718 | end; 719 | end; 720 | finally 721 | Free; 722 | end; 723 | end; 724 | end; 725 | 726 | procedure TResponseHelper.Envelop(const ACode: integer; const AContent: string); 727 | begin 728 | Envelop(ACode, TJSONString.Create(AContent)); 729 | end; 730 | 731 | procedure TResponseHelper.Envelop(const ACode: integer; const AContent: string; 732 | const AArgs: array of const); 733 | begin 734 | Envelop(ACode, Format(AContent, AArgs)); 735 | end; 736 | 737 | type 738 | 739 | { TCustomHttpRoute } 740 | 741 | TCustomHTTPRoute = class(THTTPRoute) 742 | private 743 | FRouteClass: TRouteClass; 744 | public 745 | procedure HandleRequest(AServer: TObject; ARequest: TRequest; 746 | AResponse: TResponse); overload; 747 | property RouteClass: TRouteClass read FRouteClass write FRouteClass; 748 | end; 749 | 750 | procedure TCustomHTTPRoute.HandleRequest(AServer: TObject; ARequest: TRequest; 751 | AResponse: TResponse); 752 | var 753 | VCustomRoute: TCustomRoute; 754 | begin 755 | VCustomRoute := FRouteClass.Create; 756 | try 757 | VCustomRoute.HandleRequest(AServer, ARequest, AResponse); 758 | finally 759 | FreeAndNil(VCustomRoute); 760 | end; 761 | end; 762 | 763 | { THTTPRouterHelper } 764 | 765 | function THTTPRouterHelper.RegisterRoute(const APattern: string; 766 | const ARouteClass: TRouteClass; AIsDefault: boolean): THttpRoute; 767 | begin 768 | Result := RegisterRoute(APattern, rmAll, ARouteClass, AIsDefault); 769 | end; 770 | 771 | function THTTPRouterHelper.RegisterRoute(const APattern: string; 772 | AMethod: TRouteMethod; const ARouteClass: TRouteClass; 773 | AIsDefault: boolean): THttpRoute; 774 | begin 775 | Result := CreateHTTPRoute(TCustomHTTPRoute, APattern, AMethod, AIsDefault); 776 | TCustomHTTPRoute(Result).RouteClass := ARouteClass; 777 | end; 778 | 779 | procedure THTTPRouterHelper.RouteRequest(AServer: TObject; ARequest: TRequest; 780 | AResponse: TResponse); 781 | var 782 | VPath: string; 783 | VMethod: TRouteMethod; 784 | VRoute: THTTPRoute; 785 | VParams: TStrings; 786 | VIndex: integer; 787 | VName: string; 788 | VValue: string; 789 | VMethodMisMatch: boolean; 790 | begin 791 | VPath := GetRequestPath(ARequest); 792 | VMethod := StringToRouteMethod(ARequest.Method); 793 | VParams := TStringList.Create; 794 | try 795 | VRoute := FindHTTPRoute(VPath, VMethod, VParams, VMethodMisMatch); 796 | if (Assigned(VRoute)) then 797 | begin 798 | for VIndex := 0 to (VParams.Count - 1) do 799 | begin 800 | VParams.GetNameValue(VIndex, VName, VValue); 801 | if (VName <> '') then 802 | begin 803 | ARequest.RouteParams[VName] := VValue; 804 | end; 805 | end; 806 | if (VRoute.InheritsFrom(TCustomHTTPRoute)) then 807 | begin 808 | TCustomHTTPRoute(VRoute).HandleRequest(AServer, ARequest, AResponse); 809 | end 810 | else 811 | begin 812 | VRoute.HandleRequest(ARequest, AResponse); 813 | end; 814 | end 815 | else 816 | begin 817 | if (VMethodMisMatch) then 818 | begin 819 | AResponse.Envelop(405, 'the requested method %s is not allowed', [VMethod]); 820 | end 821 | else 822 | begin 823 | AResponse.Envelop(404, 'not found'); 824 | end; 825 | end; 826 | finally 827 | FreeAndNil(VParams); 828 | end; 829 | end; 830 | 831 | end. 832 | -------------------------------------------------------------------------------- /source/rsql_client_connection.pas: -------------------------------------------------------------------------------- 1 | { 2 | MIT License 3 | 4 | Copyright (c) 2020 Anderson J. Gado da Silva and Hélio S. Ribeiro 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | unit RSQL_Client_Connection; 24 | 25 | {$I rSQL.inc} 26 | 27 | interface 28 | 29 | uses 30 | Classes, 31 | SysUtils, 32 | DB, 33 | SQLdb, 34 | BufDataset, 35 | fphttpclient, 36 | fpjson, 37 | opensslsockets; 38 | 39 | type 40 | 41 | { TRSQLClient } 42 | 43 | TRSQLClient = class(TSQLConnection) 44 | private 45 | FCompressed: boolean; 46 | FTOKEN: string; 47 | FUseSSL: boolean; 48 | protected 49 | // - Connect/disconnect 50 | procedure DoInternalConnect; override; 51 | // - Handle (de)allocation 52 | function AllocateCursorHandle: TSQLCursor; override; 53 | procedure DeAllocateCursorHandle(var ACursor: TSQLCursor); override; 54 | function AllocateTransactionHandle: TSQLHandle; override; 55 | // - Statement handling 56 | procedure PrepareStatement(ACursor: TSQLCursor; 57 | {%H-}ATransaction: TSQLTransaction; ABuf: string; 58 | {%H-}AParams: TParams); override; 59 | procedure UnPrepareStatement(ACursor: TSQLCursor); override; 60 | // - Transaction handling 61 | function GetTransactionHandle(ATrans: TSQLHandle): pointer; override; 62 | function StartDBTransaction(ATrans: TSQLHandle; 63 | {%H-}AParams: string): boolean; override; 64 | function Commit(ATrans: TSQLHandle): boolean; override; 65 | function Rollback(ATrans: TSQLHandle): boolean; override; 66 | procedure CommitRetaining(ATrans: TSQLHandle); override; 67 | procedure RollbackRetaining(ATrans: TSQLHandle); override; 68 | // - Statement execution 69 | procedure Execute(ACursor: TSQLCursor; ATransaction: TSQLTransaction; 70 | AParams: TParams); override; 71 | function RowsAffected(ACursor: TSQLCursor): TRowsCount; override; 72 | // - Result retrieving 73 | procedure AddFieldDefs(ACursor: TSQLCursor; AFieldDefs: TFieldDefs); override; 74 | function Fetch(ACursor: TSQLCursor): boolean; override; 75 | function LoadField(ACursor: TSQLCursor; AFieldDef: TFieldDef; 76 | ABuffer: pointer; out ACreateBlob: boolean): boolean; override; 77 | procedure LoadBlobIntoBuffer(AFieldDef: TFieldDef; ABlobBuf: PBufBlobField; 78 | ACursor: TSQLCursor; {%H-}ATransaction: TSQLTransaction); override; 79 | // - UpdateIndexDefs 80 | procedure UpdateIndexDefs(AIndexDefs: TIndexDefs; ATableName: string); override; 81 | // - Schema info 82 | function GetSchemaInfoSQL(ASchemaType: TSchemaType; 83 | ASchemaObjectName, ASchemaPattern: string): string; override; 84 | function GetNextValueSQL(const ASequenceName: string; 85 | AIncrementBy: integer): string; override; 86 | public 87 | constructor Create(AOwner: TComponent); override; 88 | function GetConnectionInfo(AInfoType: TConnInfoType): string; override; 89 | function HttpRequest(const ARoute: string; 90 | const ASource: string = '{}'): TJSONData; 91 | property Compressed: boolean read FCompressed; 92 | property Token: string read FTOKEN; 93 | published 94 | property Port default 8091; 95 | property UseSSL: boolean read FUseSSL write FUseSSL; 96 | end; 97 | 98 | { TRSQLClientDef } 99 | 100 | TRSQLClientDef = class(TConnectionDef) 101 | class function TypeName: string; override; 102 | class function ConnectionClass: TSQLConnectionClass; override; 103 | class function Description: string; override; 104 | end; 105 | 106 | { ERSQLError } 107 | 108 | ERSQLError = class(ESQLDatabaseError); 109 | 110 | implementation 111 | 112 | uses 113 | FMTBcd, 114 | RSQL_Helper, 115 | RSQL_Crypto_ZStream, 116 | RSQL_Crypto_BASE64; 117 | 118 | type 119 | 120 | { TRSQLTrans } 121 | 122 | TRSQLTrans = class(TSQLHandle) 123 | strict private 124 | FIdentifier: string; 125 | public 126 | property Identifier: string read FIdentifier write FIdentifier; 127 | end; 128 | 129 | { TRSQLCursor } 130 | 131 | TRSQLCursor = class(TSQLCursor) 132 | private 133 | FConnection: TRSQLClient; 134 | FTransaction: TSQLTransaction; 135 | FStatement: string; 136 | FParams: TParams; 137 | FIndex: int64; 138 | FStatus: int64; 139 | FMax: int64; 140 | FMetadata: TJSONArray; 141 | FRows: TJSONArray; 142 | FRowsCount: int64; 143 | FRowsAffected: int64; 144 | protected 145 | function RequestStatement: string; 146 | procedure RequestNextPack; 147 | public 148 | constructor Create(const AConn: TRSQLClient); 149 | destructor Destroy; override; 150 | procedure Execute(const ATrans: TSQLTransaction; const AParams: TParams); 151 | function Fetch: boolean; 152 | public 153 | property Statement: string read FStatement write FStatement; 154 | property Prepared: boolean read FPrepared write FPrepared; 155 | property Index: int64 read FIndex write FIndex; 156 | property Status: int64 read FStatus write FStatus; 157 | property Metadata: TJSONArray read FMetadata; 158 | property Rows: TJSONArray read FRows; 159 | property RowsAffected: int64 read FRowsAffected; 160 | end; 161 | 162 | function TRSQLCursor.RequestStatement: string; 163 | 164 | function BuildStatement(const AStatement: string): TJSONString; 165 | begin 166 | Result := TJSONString.Create(AStatement); 167 | end; 168 | 169 | function BuildParam(const AParam: TParam): TJSONData; 170 | begin 171 | if (AParam.IsNull) then 172 | begin 173 | Result := TJSONNull.Create; 174 | end 175 | else 176 | begin 177 | case AParam.DataType of 178 | ftAutoInc, 179 | ftLargeint, 180 | ftWord: 181 | begin 182 | Result := TJSONInt64Number.Create(AParam.AsLargeInt); 183 | end; 184 | ftInteger, 185 | ftSmallint: 186 | begin 187 | Result := TJSONIntegerNumber.Create(AParam.AsInteger); 188 | end; 189 | ftBCD, 190 | ftCurrency, 191 | ftFMTBcd: 192 | begin 193 | Result := TJSONObject.Create(); 194 | with TJSONObject(Result) do 195 | begin 196 | Add('value', AParam.AsCurrency); 197 | Add('type', 'currency'); 198 | Add('length', AParam.Size); 199 | Add('precision', AParam.Precision); 200 | end; 201 | end; 202 | ftBoolean: 203 | begin 204 | Result := TJSONBoolean.Create(AParam.AsBoolean); 205 | end; 206 | ftDate: 207 | begin 208 | Result := TJSONObject.Create(); 209 | with TJSONObject(Result) do 210 | begin 211 | Add('value', AParam.AsDate); 212 | Add('type', 'date'); 213 | end; 214 | end; 215 | ftTime: 216 | begin 217 | Result := TJSONObject.Create(); 218 | with TJSONObject(Result) do 219 | begin 220 | Add('value', AParam.AsTime); 221 | Add('type', 'time'); 222 | end; 223 | end; 224 | ftDateTime, 225 | ftTimeStamp: 226 | begin 227 | Result := TJSONObject.Create(); 228 | with TJSONObject(Result) do 229 | begin 230 | Add('value', AParam.AsDateTime); 231 | Add('type', 'datetime'); 232 | end; 233 | end; 234 | ftFixedWideChar: 235 | begin 236 | Result := TJSONString.Create(AParam.AsWideString); 237 | end; 238 | ftBlob, 239 | ftMemo, 240 | ftGraphic, 241 | ftFmtMemo, 242 | ftWideMemo: 243 | begin 244 | Result := TJSONObject.Create(); 245 | with TJSONObject(Result) do 246 | begin 247 | Add('value', BASE64Encode(AParam.AsString)); 248 | Add('type', 'blob'); 249 | Add('b64', True); 250 | end; 251 | end; 252 | else 253 | begin 254 | Result := TJSONString.Create(AParam.AsString); 255 | end; 256 | end; 257 | end; 258 | end; 259 | 260 | function BuildParams(const AParams: TParams): TJSONObject; 261 | var 262 | VIndex: integer; 263 | VParam: TParam; 264 | begin 265 | Result := TJSONObject.Create(); 266 | if (Assigned(AParams)) and (AParams.Count > 0) then 267 | begin 268 | for VIndex := 0 to (AParams.Count - 1) do 269 | begin 270 | VParam := AParams[VIndex]; 271 | if (Assigned(VParam)) then 272 | begin 273 | Result.Add(VParam.Name, BuildParam(VParam)); 274 | end; 275 | end; 276 | end; 277 | end; 278 | 279 | function BuildOptions(const ARecno, APacketRecords: int64): TJSONObject; 280 | begin 281 | Result := TJSONObject.Create(); 282 | Result.Add('recno', ARecno); 283 | Result.Add('packetrecords', APacketRecords); 284 | end; 285 | 286 | begin 287 | with TJSONObject.Create() do 288 | begin 289 | try 290 | Add('sql', BuildStatement(FStatement)); 291 | Add('params', BuildParams(FParams)); 292 | {$IfDef rsql_experimental} 293 | Add('options', BuildOptions(FIndex, FMax)); 294 | {$EndIf} 295 | Result := Stringify(); 296 | finally 297 | Free; 298 | end; 299 | end; 300 | end; 301 | 302 | procedure TRSQLCursor.RequestNextPack; 303 | 304 | procedure Merge(const ATarget, AAdd: TJSONData); 305 | var 306 | VIndex: NativeInt; 307 | begin 308 | if (Assigned(ATarget)) and (Assigned(AAdd)) then 309 | begin 310 | for VIndex := 0 to (AAdd.Count - 1) do 311 | begin 312 | TJSONArray(ATarget).Add(AAdd.Items[VIndex].Clone); 313 | end; 314 | end; 315 | end; 316 | 317 | var 318 | VQuerySource: string; 319 | VRoute: string; 320 | VResponse: TJSONData; 321 | begin 322 | VQuerySource := RequestStatement; 323 | VRoute := Format('statement?action=query&identifier=%s&database=%s', 324 | [TRSQLTrans(FTransaction.Handle).Identifier, FConnection.DatabaseName]); 325 | VResponse := FConnection.HttpRequest(VRoute, VQuerySource); 326 | if (Assigned(VResponse)) then 327 | begin 328 | try 329 | if (VResponse.Path('success', False)) then 330 | begin 331 | if FStatementType = stSelect then 332 | begin 333 | if (not (Assigned(FRows))) then 334 | begin 335 | FMetadata := TJSONArray(VResponse.Path('content.metadata').Clone); 336 | FRows := TJSONArray(VResponse.Path('content.rows').Clone); 337 | end 338 | else 339 | begin 340 | {$IfDef rsql_experimental} 341 | Merge(FRows, VResponse.Path('content.rows')); 342 | {$EndIf} 343 | end; 344 | FRowsCount:=FRows.Count; 345 | end; 346 | FRowsAffected := VResponse.Path('content.rowsaffected', -1); 347 | end 348 | else 349 | begin 350 | raise ERSQLError.Create(VResponse.Path('content', EmptyStr)); 351 | end; 352 | finally 353 | FreeAndNil(VResponse); 354 | end; 355 | end; 356 | end; 357 | 358 | constructor TRSQLCursor.Create(const AConn: TRSQLClient); 359 | begin 360 | inherited Create; 361 | FConnection := AConn; 362 | FMax := 500; 363 | end; 364 | 365 | destructor TRSQLCursor.Destroy; 366 | begin 367 | if Assigned(FMetadata) then 368 | FreeAndNil(FMetadata); 369 | if Assigned(FRows) then 370 | FreeAndNil(FRows); 371 | inherited Destroy; 372 | end; 373 | 374 | procedure TRSQLCursor.Execute(const ATrans: TSQLTransaction; const AParams: TParams); 375 | begin 376 | FreeAndNil(FMetadata); 377 | FreeAndNil(FRows); 378 | FIndex := 0; 379 | FStatus := 0; 380 | FTransaction := ATrans; 381 | FParams := AParams; 382 | RequestNextPack; 383 | end; 384 | 385 | function TRSQLCursor.Fetch: boolean; 386 | begin 387 | {$IfDef rsql_experimental} 388 | if (FStatus >= FMax) then 389 | begin 390 | FStatus := 0; 391 | RequestNextPack; 392 | end; 393 | {$IfEnd} 394 | Result := FRowsCount > FIndex;//(Assigned(FRows)) and (FRows.Count > FIndex); 395 | if (Result) then 396 | begin 397 | Inc(FStatus); 398 | Inc(FIndex); 399 | end; 400 | end; 401 | 402 | { TRSQLClient } 403 | 404 | procedure TRSQLClient.DoInternalConnect; 405 | 406 | function AuthenticationSource: string; 407 | begin 408 | with TJSONObject.Create() do 409 | begin 410 | try 411 | Add('username', UserName); 412 | Add('password', Password); 413 | Result := Stringify(); 414 | finally 415 | Free; 416 | end; 417 | end; 418 | end; 419 | 420 | var 421 | VRoute: string; 422 | VResponse: TJSONData; 423 | begin 424 | inherited DoInternalConnect; 425 | FCompressed := False; 426 | FTOKEN := EmptyStr; 427 | VRoute := Format('authentication?database=%s', [DatabaseName]); 428 | VResponse := HttpRequest(VRoute, AuthenticationSource); 429 | if (Assigned(VResponse)) then 430 | begin 431 | try 432 | if (VResponse.Path('success', False)) then 433 | begin 434 | FCompressed := VResponse.Path('content.compressed', False); 435 | FTOKEN := VResponse.Path('content.token', EmptyStr); 436 | end 437 | else 438 | begin 439 | raise ERSQLError.Create(VResponse.Path('content', EmptyStr)); 440 | end; 441 | finally 442 | FreeAndNil(VResponse); 443 | end; 444 | end; 445 | end; 446 | 447 | function TRSQLClient.AllocateCursorHandle: TSQLCursor; 448 | begin 449 | Result := TRSQLCursor.Create(Self); 450 | end; 451 | 452 | procedure TRSQLClient.DeAllocateCursorHandle(var ACursor: TSQLCursor); 453 | begin 454 | FreeAndNil(ACursor); 455 | end; 456 | 457 | function TRSQLClient.AllocateTransactionHandle: TSQLHandle; 458 | begin 459 | Result := TRSQLTrans.Create; 460 | end; 461 | 462 | procedure TRSQLClient.PrepareStatement(ACursor: TSQLCursor; 463 | ATransaction: TSQLTransaction; ABuf: string; AParams: TParams); 464 | var 465 | VCursor: TRSQLCursor absolute ACursor; 466 | begin 467 | VCursor.Statement := ABuf; 468 | VCursor.Prepared := True; 469 | end; 470 | 471 | procedure TRSQLClient.UnPrepareStatement(ACursor: TSQLCursor); 472 | var 473 | VCursor: TRSQLCursor absolute ACursor; 474 | begin 475 | VCursor.Prepared := False; 476 | end; 477 | 478 | function TRSQLClient.GetTransactionHandle(ATrans: TSQLHandle): pointer; 479 | begin 480 | Result := ATrans; 481 | end; 482 | 483 | function TRSQLClient.StartDBTransaction(ATrans: TSQLHandle; AParams: string): boolean; 484 | var 485 | VRoute: string; 486 | VResponse: TJSONData; 487 | VTrans: TRSQLTrans absolute ATrans; 488 | begin 489 | VRoute := Format('transaction?action=start&database=%s', [DatabaseName]); 490 | VResponse := HttpRequest(VRoute); 491 | if (Assigned(VResponse)) then 492 | begin 493 | try 494 | if (VResponse.Path('success', False)) then 495 | begin 496 | VTrans.Identifier := VResponse.Path('content', EmptyStr); 497 | Result := True; 498 | end 499 | else 500 | begin 501 | raise ERSQLError.Create(VResponse.Path('content', EmptyStr)); 502 | end; 503 | finally 504 | FreeAndNil(VResponse); 505 | end; 506 | end; 507 | end; 508 | 509 | function TRSQLClient.Commit(ATrans: TSQLHandle): boolean; 510 | var 511 | VRoute: string; 512 | VResponse: TJSONData; 513 | VTrans: TRSQLTrans absolute ATrans; 514 | begin 515 | VRoute := Format('transaction?action=commit&identifier=%s&database=%s', 516 | [VTrans.Identifier, DatabaseName]); 517 | VResponse := HttpRequest(VRoute); 518 | if (Assigned(VResponse)) then 519 | begin 520 | try 521 | if (VResponse.Path('success', False)) then 522 | begin 523 | Result := True; 524 | end 525 | else 526 | begin 527 | raise ERSQLError.Create(VResponse.Path('content', EmptyStr)); 528 | end; 529 | finally 530 | FreeAndNil(VResponse); 531 | end; 532 | end; 533 | end; 534 | 535 | function TRSQLClient.Rollback(ATrans: TSQLHandle): boolean; 536 | var 537 | VRoute: string; 538 | VResponse: TJSONData; 539 | VTrans: TRSQLTrans absolute ATrans; 540 | begin 541 | VRoute := Format('transaction?action=rollback&identifier=%s&database=%s', 542 | [VTrans.Identifier, DatabaseName]); 543 | VResponse := HttpRequest(VRoute); 544 | if (Assigned(VResponse)) then 545 | begin 546 | try 547 | if (VResponse.Path('success', False)) then 548 | begin 549 | Result := True; 550 | end 551 | else 552 | begin 553 | raise ERSQLError.Create(VResponse.Path('content', EmptyStr)); 554 | end; 555 | finally 556 | FreeAndNil(VResponse); 557 | end; 558 | end; 559 | end; 560 | 561 | procedure TRSQLClient.CommitRetaining(ATrans: TSQLHandle); 562 | begin 563 | Commit(ATrans); 564 | StartDBTransaction(ATrans, Params.CommaText); 565 | end; 566 | 567 | procedure TRSQLClient.RollbackRetaining(ATrans: TSQLHandle); 568 | begin 569 | Rollback(ATrans); 570 | StartDBTransaction(ATrans, Params.CommaText); 571 | end; 572 | 573 | procedure TRSQLClient.Execute(ACursor: TSQLCursor; ATransaction: TSQLTransaction; 574 | AParams: TParams); 575 | var 576 | VCursor: TRSQLCursor absolute ACursor; 577 | begin 578 | VCursor.Execute(ATransaction, AParams); 579 | end; 580 | 581 | function TRSQLClient.RowsAffected(ACursor: TSQLCursor): TRowsCount; 582 | var 583 | VCursor: TRSQLCursor absolute ACursor; 584 | begin 585 | Result := VCursor.RowsAffected; 586 | end; 587 | 588 | procedure TRSQLClient.AddFieldDefs(ACursor: TSQLCursor; AFieldDefs: TFieldDefs); 589 | var 590 | VCursor: TRSQLCursor absolute ACursor; 591 | VMetadata: TJSONArray; 592 | VData: TJSONData; 593 | VIndex: integer; 594 | VType: TFieldType; 595 | VName: string; 596 | VLength: integer; 597 | VPrecision: integer; 598 | VRequired: boolean; 599 | VReadonly: boolean; 600 | VHidden: boolean; 601 | VFixed: boolean; 602 | begin 603 | VMetadata := VCursor.Metadata; 604 | if (Assigned(VMetadata)) then 605 | begin 606 | for VIndex := 0 to (VMetadata.Count - 1) do 607 | begin 608 | VData := VMetadata[VIndex]; 609 | if (Assigned(VData)) then 610 | begin 611 | VName := VData.Path('name', EmptyStr); 612 | VLength := VData.Path('length', 0); 613 | VPrecision := VData.Path('precision', 0); 614 | VRequired := VData.Path('required', False); 615 | VReadonly := VData.Path('readonly', False); 616 | VHidden := VData.Path('hidden', False); 617 | VFixed := VData.Path('fixed', False); 618 | 619 | case (LowerCase(VData.Path('type', EmptyStr))) of 620 | 'string': VType := ftString; 621 | 'smallint': VType := ftSmallint; 622 | 'integer': VType := ftInteger; 623 | 'word': VType := ftWord; 624 | 'boolean': VType := ftBoolean; 625 | 'float': VType := ftFloat; 626 | 'currency': VType := ftCurrency; 627 | 'bcd': VType := ftBCD; 628 | 'date': VType := ftDate; 629 | 'time': VType := ftTime; 630 | 'datetime': VType := ftDateTime; 631 | 'bytes': VType := ftBytes; 632 | 'varbytes': VType := ftVarBytes; 633 | 'autoinc': VType := ftAutoInc; 634 | 'blob': VType := ftBlob; 635 | 'memo': VType := ftMemo; 636 | 'graphic': VType := ftGraphic; 637 | 'fmtmemo': VType := ftFmtMemo; 638 | 'paradoxole': VType := ftParadoxOle; 639 | 'dbaseole': VType := ftDBaseOle; 640 | 'typedbinary': VType := ftTypedBinary; 641 | 'cursor': VType := ftCursor; 642 | 'fixedchar': VType := ftFixedChar; 643 | 'widestring': VType := ftWideString; 644 | 'largeint': VType := ftLargeint; 645 | 'adt': VType := ftADT; 646 | 'array': VType := ftArray; 647 | 'reference': VType := ftReference; 648 | 'dataset': VType := ftDataSet; 649 | 'orablob': VType := ftOraBlob; 650 | 'oraclob': VType := ftOraClob; 651 | 'variant': VType := ftVariant; 652 | 'interface': VType := ftInterface; 653 | 'idispatch': VType := ftIDispatch; 654 | 'guid': VType := ftGuid; 655 | 'timestamp': VType := ftTimeStamp; 656 | 'fmtbcd': VType := ftFMTBcd; 657 | 'fixedwidechar': VType := ftFixedWideChar; 658 | 'widememo': VType := ftWideMemo; 659 | else VType := ftUnknown; 660 | end; 661 | 662 | /// Add field 663 | with AFieldDefs.AddFieldDef do 664 | begin 665 | Name := VName; 666 | DataType := VType; 667 | Size := VLength; 668 | Required := VRequired; 669 | Precision := VPrecision; 670 | if (VReadonly) then 671 | begin 672 | Attributes := Attributes + [faReadonly]; 673 | end; 674 | if (VHidden) then 675 | begin 676 | Attributes := Attributes + [faHiddenCol]; 677 | end; 678 | if (VFixed) then 679 | begin 680 | Attributes := Attributes + [faFixed]; 681 | end; 682 | end; 683 | end; 684 | end; 685 | end; 686 | end; 687 | 688 | function TRSQLClient.Fetch(ACursor: TSQLCursor): boolean; 689 | var 690 | VCursor: TRSQLCursor absolute ACursor; 691 | begin 692 | Result := VCursor.Fetch; 693 | end; 694 | 695 | function TRSQLClient.LoadField(ACursor: TSQLCursor; AFieldDef: TFieldDef; 696 | ABuffer: pointer; out ACreateBlob: boolean): boolean; 697 | var 698 | VCursor: TRSQLCursor absolute ACursor; 699 | VIndexCol: Integer; 700 | VIndexRow: Int64; 701 | VRows: TJSONArray; 702 | VRow: TJSONArray; 703 | VData: TJSONData; 704 | begin 705 | Result := False; 706 | ACreateBlob := False; 707 | VIndexCol := AFieldDef.FieldNo - 1; 708 | VIndexRow := VCursor.Index - 1; 709 | VRows := VCursor.Rows; 710 | if (VIndexCol > -1) and (VIndexRow > -1) and (Assigned(VRows)) and 711 | ({%H-}VRows.Count > 0) then 712 | begin 713 | VRow := VRows.Arrays[VIndexRow]; 714 | VData := VRow[VIndexCol]; 715 | if (not (VData.IsNull)) then 716 | begin 717 | Result := True; 718 | case AFieldDef.DataType of 719 | ftAutoInc, 720 | ftInteger: 721 | begin 722 | pinteger(ABuffer)^ := VData.AsInteger; 723 | end; 724 | ftSmallInt: 725 | begin 726 | psmallint(ABuffer)^ := VData.AsInt64; 727 | end; 728 | ftWord: 729 | begin 730 | pword(ABuffer)^ := VData.AsInteger; 731 | end; 732 | ftBoolean: 733 | begin 734 | pwordbool(ABuffer)^ := VData.AsBoolean; 735 | end; 736 | ftLargeInt: 737 | begin 738 | PInt64(ABuffer)^ := VData.AsInt64; 739 | end; 740 | ftFmtBCD: 741 | begin 742 | pBCD(ABuffer)^ := CurrToBCD(VData.AsFloat); 743 | end; 744 | ftBCD, 745 | ftCurrency: 746 | begin 747 | PCurrency(ABuffer)^ := FloattoCurr(VData.AsFloat); 748 | end; 749 | ftFloat: 750 | begin 751 | pdouble(ABuffer)^ := VData.AsFloat; 752 | end; 753 | ftDateTime: 754 | begin 755 | PDateTime(ABuffer)^ := FloatToDateTime(VData.AsFloat); 756 | end; 757 | ftDate: 758 | begin 759 | PDateTime(ABuffer)^ := TDate(FloatToDateTime(VData.AsFloat)); 760 | end; 761 | ftTime: 762 | begin 763 | PDateTime(ABuffer)^ := TTime(FloatToDateTime(VData.AsFloat)); 764 | end; 765 | ftFixedChar, 766 | ftString: 767 | begin 768 | if (Length(VData.AsString) > 0) then 769 | begin 770 | Move(PChar(VData.AsString)^, ABuffer^, Length(VData.AsString)); 771 | end; 772 | PAnsiChar(ABuffer + Length(VData.AsString))^ := #0; 773 | end; 774 | ftFixedWideChar, 775 | ftWideString: 776 | begin 777 | PWideString(ABuffer)^ := WideString(VData.AsString); 778 | end; 779 | ftVarBytes, 780 | ftBytes: 781 | begin 782 | PWord(ABuffer)^ := VData.AsInteger; 783 | end; 784 | ftWideMemo, 785 | ftMemo, 786 | ftBlob: 787 | begin 788 | ACreateBlob := True; 789 | end; 790 | else 791 | begin 792 | Result := False; 793 | end; 794 | end; 795 | end; 796 | end; 797 | end; 798 | 799 | procedure TRSQLClient.LoadBlobIntoBuffer(AFieldDef: TFieldDef; 800 | ABlobBuf: PBufBlobField; ACursor: TSQLCursor; ATransaction: TSQLTransaction); 801 | var 802 | VCursor: TRSQLCursor absolute ACursor; 803 | VIndexCol: Integer; 804 | VIndexRow: int64; 805 | VRows: TJSONArray; 806 | VRow: TJSONArray; 807 | VData: TJSONData; 808 | VString: string; 809 | VLength: int64; 810 | begin 811 | VIndexCol := AFieldDef.FieldNo - 1; 812 | VIndexRow := VCursor.Index - 1; 813 | VRows := VCursor.Rows; 814 | VString := ''; 815 | VLength := 0; 816 | if (VIndexCol > -1) and (VIndexRow > -1) and (Assigned(VRows)) and 817 | ({%H-}VRows.Count > 0) then 818 | begin 819 | VRow := VRows.Arrays[VIndexRow]; 820 | VData := VRow[VIndexCol]; 821 | if (not (VData.IsNull)) then 822 | begin 823 | VString := BASE64Decode(VData.AsString); 824 | VLength := Length(VString); 825 | ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, VLength); 826 | if (VLength > 0) then 827 | begin 828 | Move(PByte(VString)^, ABlobBuf^.BlobBuffer^.Buffer^, VLength); 829 | end; 830 | ABlobBuf^.BlobBuffer^.Size := VLength; 831 | end; 832 | end; 833 | end; 834 | 835 | procedure TRSQLClient.UpdateIndexDefs(AIndexDefs: TIndexDefs; ATableName: string); 836 | 837 | function IndexSource: string; 838 | begin 839 | with TJSONObject.Create() do 840 | begin 841 | try 842 | Add('table', ATableName); 843 | Result := Stringify(); 844 | finally 845 | Free; 846 | end; 847 | end; 848 | end; 849 | 850 | function JSONToIndexOptions(const AJSON: TJSONData): TIndexOptions; 851 | var 852 | VIndex: integer; 853 | VData: TJSONData; 854 | begin 855 | Result := []; 856 | if (Assigned(AJSON)) then 857 | begin 858 | for VIndex := 0 to (AJSON.Count - 1) do 859 | begin 860 | VData := AJSON.Items[VIndex]; 861 | if (Assigned(VData)) and (VData.JSONType = jtString) then 862 | begin 863 | case LowerCase(VData.AsString) of 864 | 'primary': Result := Result + [ixPrimary]; 865 | 'unique': Result := Result + [ixUnique]; 866 | 'descending': Result := Result + [ixDescending]; 867 | 'caseinsensitive': Result := Result + [ixCaseInsensitive]; 868 | 'expression': Result := Result + [ixExpression]; 869 | 'nonmaintained': Result := Result + [ixNonMaintained]; 870 | end; 871 | end; 872 | end; 873 | end; 874 | end; 875 | 876 | var 877 | VRoute: string; 878 | VResponse: TJSONData; 879 | VContent: TJSONData; 880 | VContentItem: TJSONData; 881 | VIndex: integer; 882 | begin 883 | VRoute := Format('database?action=index&database=%s', [DatabaseName]); 884 | VResponse := HttpRequest(VRoute, IndexSource); 885 | if (Assigned(VResponse)) then 886 | begin 887 | try 888 | if (VResponse.Path('success', False)) then 889 | begin 890 | VContent := VResponse.Path('content'); 891 | if (Assigned(VContent)) then 892 | begin 893 | for VIndex := 0 to (VContent.Count - 1) do 894 | begin 895 | VContentItem := VContent.Items[VIndex]; 896 | if (Assigned(VContentItem)) then 897 | begin 898 | with AIndexDefs.AddIndexDef do 899 | begin 900 | Name := VContentItem.Path('name', EmptyStr); 901 | Expression := VContentItem.Path('expression', EmptyStr); 902 | Fields := VContentItem.Path('fields', EmptyStr); 903 | CaseInsFields := VContentItem.Path('caseInsFields', EmptyStr); 904 | DescFields := VContentItem.Path('descFields', EmptyStr); 905 | Options := JSONToIndexOptions(VContentItem.Path('options')); 906 | Source := VContentItem.Path('source', EmptyStr); 907 | end; 908 | end; 909 | end; 910 | end; 911 | end 912 | else 913 | begin 914 | raise ERSQLError.CreateFmt( 915 | 'index update is not available for this type of database. %s', 916 | [VResponse.Path('content', EmptyStr)]); 917 | end; 918 | finally 919 | FreeAndNil(VResponse); 920 | end; 921 | end 922 | else 923 | begin 924 | inherited UpdateIndexDefs(AIndexDefs, ATableName); 925 | end; 926 | end; 927 | 928 | function TRSQLClient.GetSchemaInfoSQL(ASchemaType: TSchemaType; 929 | ASchemaObjectName, ASchemaPattern: string): string; 930 | 931 | function SchemaSource: string; 932 | begin 933 | with TJSONObject.Create() do 934 | begin 935 | try 936 | Add('type', Ord(ASchemaType)); 937 | Add('object', ASchemaObjectName); 938 | Add('pattern', ASchemaPattern); 939 | Result := Stringify(); 940 | finally 941 | Free; 942 | end; 943 | end; 944 | end; 945 | 946 | var 947 | VRoute: string; 948 | VResponse: TJSONData; 949 | begin 950 | VRoute := Format('database?action=schema&database=%s', [DatabaseName]); 951 | VResponse := HttpRequest(VRoute, SchemaSource); 952 | if (Assigned(VResponse)) then 953 | begin 954 | try 955 | if (VResponse.Path('success', False)) then 956 | begin 957 | Result := VResponse.Path('content', EmptyStr); 958 | end 959 | else 960 | begin 961 | raise ERSQLError.CreateFmt( 962 | 'schema is not available for this type of database. %s', 963 | [VResponse.Path('content', EmptyStr)]); 964 | end; 965 | finally 966 | FreeAndNil(VResponse); 967 | end; 968 | end 969 | else 970 | begin 971 | Result := inherited GetSchemaInfoSQL(ASchemaType, ASchemaObjectName, 972 | ASchemaPattern); 973 | end; 974 | end; 975 | 976 | function TRSQLClient.GetNextValueSQL(const ASequenceName: string; 977 | AIncrementBy: integer): string; 978 | 979 | function SequenceSource: string; 980 | begin 981 | with TJSONObject.Create() do 982 | begin 983 | try 984 | Add('sequence', ASequenceName); 985 | Add('increment', AIncrementBy); 986 | Result := Stringify(); 987 | finally 988 | Free; 989 | end; 990 | end; 991 | end; 992 | 993 | var 994 | VRoute: string; 995 | VResponse: TJSONData; 996 | begin 997 | VRoute := Format('database?action=sequence&database=%s', [DatabaseName]); 998 | VResponse := HttpRequest(VRoute, SequenceSource); 999 | if (Assigned(VResponse)) then 1000 | begin 1001 | try 1002 | if (VResponse.Path('success', False)) then 1003 | begin 1004 | Result := VResponse.Path('content', EmptyStr); 1005 | end 1006 | else 1007 | begin 1008 | raise ERSQLError.CreateFmt( 1009 | 'sequence is not available for this type of database. %s', 1010 | [VResponse.Path('content', EmptyStr)]); 1011 | end; 1012 | finally 1013 | FreeAndNil(VResponse); 1014 | end; 1015 | end 1016 | else 1017 | begin 1018 | Result := inherited GetNextValueSQL(ASequenceName, AIncrementBy); 1019 | end; 1020 | end; 1021 | 1022 | constructor TRSQLClient.Create(AOwner: TComponent); 1023 | begin 1024 | inherited Create(AOwner); 1025 | Port := 8091; 1026 | FCompressed := False; 1027 | FTOKEN := ''; 1028 | FConnOptions := FConnOptions + [sqSupportParams, sqEscapeRepeat, 1029 | sqSupportReturning]; 1030 | end; 1031 | 1032 | function TRSQLClient.GetConnectionInfo(AInfoType: TConnInfoType): string; 1033 | begin 1034 | case AInfoType of 1035 | citServerType: 1036 | begin 1037 | if (FUseSSL) then 1038 | begin 1039 | Result := 'https'; 1040 | end 1041 | else 1042 | begin 1043 | Result := 'http'; 1044 | end; 1045 | end; 1046 | citServerVersion: Result := '0.9'; 1047 | citServerVersionString: Result := '09'; 1048 | citClientName: Result := 'rSQL'; 1049 | citClientVersion: Result := '0.9'; 1050 | else 1051 | begin 1052 | Result := inherited GetConnectionInfo(AInfoType); 1053 | end; 1054 | end; 1055 | end; 1056 | 1057 | function TRSQLClient.HttpRequest(const ARoute: string; 1058 | const ASource: string): TJSONData; 1059 | 1060 | function UrlBase(const AConn: TRSQLClient): string; 1061 | begin 1062 | if (AConn.Port < 1) then 1063 | begin 1064 | AConn.Port := 8091; 1065 | end; 1066 | if (AConn.HostName = EmptyStr) then 1067 | begin 1068 | AConn.HostName := 'localhost'; 1069 | end; 1070 | if (AConn.UseSSL) then 1071 | begin 1072 | Result := Format('https://%s:%d/', [AConn.HostName, AConn.Port]); 1073 | end 1074 | else 1075 | begin 1076 | Result := Format('http://%s:%d/', [AConn.HostName, AConn.Port]); 1077 | end; 1078 | end; 1079 | 1080 | function HttpPost(const AConn: TRSQLClient; const ARoute: string; 1081 | const ASource: string): string; 1082 | var 1083 | VHttp: TFPHTTPClient; 1084 | VEncoding: string; 1085 | begin 1086 | VHttp := TFPHTTPClient.Create(nil); 1087 | try 1088 | try 1089 | VHttp.AddHeader('Authorization', Format('Bearer %s', [AConn.TOKEN])); 1090 | VHttp.AddHeader('Content-Type', 'application/json'); 1091 | if (AConn.Compressed) then 1092 | begin 1093 | /// Encode request 1094 | VHttp.AddHeader('Content-Encoding', 'deflate'); 1095 | VHttp.RequestBody := TStringStream.Create(ZCompressString(ASource)); 1096 | end 1097 | else 1098 | begin 1099 | VHttp.RequestBody := TStringStream.Create(ASource); 1100 | end; 1101 | /// Send ==> 1102 | Result := VHttp.Post(UrlBase(AConn) + ARoute); 1103 | /// Decode response 1104 | VEncoding := Trim(VHttp.ResponseHeaders.Values['Content-Encoding']); 1105 | if (LowerCase(VEncoding) = 'deflate') then 1106 | begin 1107 | Result := ZDecompressString(Result); 1108 | end; 1109 | except 1110 | on E: Exception do 1111 | begin 1112 | // Close connection 1113 | AConn.Close(True); 1114 | raise; 1115 | end; 1116 | end; 1117 | finally 1118 | VHttp.RequestBody.Free; 1119 | VHttp.RequestBody := nil; 1120 | VHttp.Free; 1121 | end; 1122 | end; 1123 | 1124 | begin 1125 | Result := TJSONData.Parse(HttpPost(Self, ARoute, ASource)); 1126 | end; 1127 | 1128 | { TRSQLClientDef } 1129 | 1130 | class function TRSQLClientDef.TypeName: string; 1131 | begin 1132 | Result := 'RSQL'; 1133 | end; 1134 | 1135 | class function TRSQLClientDef.ConnectionClass: TSQLConnectionClass; 1136 | begin 1137 | Result := TRSQLClient; 1138 | end; 1139 | 1140 | class function TRSQLClientDef.Description: string; 1141 | begin 1142 | Result := 'Connect to any database via an HTTP'; 1143 | end; 1144 | 1145 | initialization 1146 | RegisterConnection(TRSQLClientDef); 1147 | 1148 | finalization 1149 | UnRegisterConnection(TRSQLClientDef); 1150 | 1151 | end. 1152 | --------------------------------------------------------------------------------