Vichingo455-RePacks/xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

source upload

Browse Source
This commit is contained in:
Razor12911
2022-01-17 22:16:47 +02:00
parent 12936d065b
commit 098e8c48de
1778 changed files with 1206749 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

540
contrib/mORMot/SQLite3/DDD/dom/asynch.pas.mustache Normal file
View File

@@ -0,0 +1,540 @@
{{#soa}}
{{#unitasynch}}
/// asynch version of {{#services}}{{interfaceName}} {{/services}}
{{/unitasynch}}
{{#unitsynch}}
/// implements {{#services}}{{interfaceName}} {{/services}}over *Asynch
{{/unitsynch}}
unit {{filename}};
{
WARNING:
This unit has been generated by {{exeName}}.
Any manual modification of this file may be lost after regeneration.
{{#unitasynch}}
Defines asynchronous (non-blocking) types for the following services:
{{#services}}
- {{interfaceName}} as non-blocking {{interfaceName}}Asynch,
associated with blocking T{{uri}}Synch / {{interfaceName}}Synch,
{{interfaceName}}AsynchAck and T{{uri}}Delays.
{{/services}}
{{/unitasynch}}
{{#unitsynch}}
Defines synchronous (blocking) implementation for the following services:
{{#services}}
- {{interfaceName}} as blocking T{{uri}}Abstract,
calling {{interfaceName}}Synch / {{interfaceName}}Asynch
{{/services}}
{{/unitsynch}}
Corresponding to {{projectname}} version {{exeVersion}}.
Generated by {{User}} at {{time}}.
}
{{<callparam}}const call: {{calltype}}{{/callparam}}
interface
{{<asynchparam}}{{#asynchkey}}const {{.}}: {{asynchkeytype}}{{/asynchkey}}{{/asynchparam}}
uses
SysUtils,
SynCommons,
SynLog,
mORMot,
{{#units}}
{{.}},
{{/units}}
mORMotDDD;
{{<methodasynch}}{{methodName}}({{>asynchparam}}{{#args}}{{#dirInput}};
{{dirName}} {{argName}}: {{typeSource}}{{/dirInput}}{{/args}};
{{>callparam}}){{#args}}{{#dirResult}}: {{typeSource}}{{/dirResult}}{{/args}};{{/methodasynch}}
{{<methodack}}{{methodName}}({{>callparam}}; {{#args}}{{^dirResult}}{{#dirOutput}}
const {{argName}}: {{typeSource}};{{/dirOutput}}{{/dirResult}}{{/args}}{{#args}}{{#dirResult}}
const res: {{typeSource}}{{/dirResult}}{{/args}});{{/methodack}}
{{<methodsynch}}{{methodName}}({{>asynchparam}}{{#args}}{{^dirResult}};
{{dirName}} {{argName}}: {{typeSource}}{{/dirResult}}{{/args}}){{#args}}{{#dirResult}}: {{typeSource}}{{/dirResult}}{{/args}};{{/methodsynch}}
{{#services}}{{#unitasynch}}
{ -------- asynchronous version of {{interfaceName}} }
type
{{<methoddelay}}{{#asynchdelay}}{{.}}{{/asynchdelay}}{{^asynchdelay}}{{defaultdelay}}{{/asynchdelay}}{{/methoddelay}}
/// settings associated to {{interfaceName}}Asynch timeouts
T{{uri}}Delays = class(TSynPersistent)
protected
{{#methods}}
{{^isInherited}}
f{{methodName}}: integer;
{{/isInherited}}
{{/methods}}
public
/// would set all delays to their default values
constructor Create; override;
published
{{#methods}}
{{^isInherited}}
/// default delay for {{interfaceName}}Asynch.{{methodName}} is {{>methoddelay}} ms
property {{methodName}}: integer read f{{methodName}} write f{{methodName}};
{{/isInherited}}
{{/methods}}
end;
/// the {{interfaceName}}Asynch progress callback definition
// - a single callback, after subscription via Subscribe{{uri}}(),
// would receive the acknowledgements of all {{interfaceName}}Asynch methods
// - some commands may take a lot of time, so this asynchronous mechanism
// would increase the system reactivity
// - naming is following the {{interfaceName}} method names
// - call: {{calltype}} is the opaque value supplied at command invoke
{{interfaceName}}AsynchAck = interface(IInvokable)
['{{newguid .}}']
{{#methods}}
{{^isInherited}}
procedure {{>methodack}}
{{/isInherited}}
{{/methods}}
end;
/// identify any {{interfaceName}}Asynch method
// - see also ToText(), ToMethodName() and To{{uri}}Ack() functions
T{{uri}}Ack = (
ack{{uri}}Undefined{{#methods}}{{^isInherited}},
ack{{methodName}}{{/isInherited}}{{/methods}});
/// high-level asynchronous (non blocking) definition of {{interfaceName}}
// - all the methods match the latest inheritance level of synchronous
// (blocking) {{interfaceName}} - it won't define the parents methods,
// since it would allow to work on a dual phase Select/Command with no
// prior Select (multiple inheritance of interfaces may have helped a lot, but
// but they are not allowed yet){{#asynchkey}} using {{.}}: {{asynchkeytype}} to redirect
// the {{interfaceName}}Asynch call to the corresponding {{interfaceName}}
{{/asynchkey}} // - call: {{calltype}} is an opaque value, which would identify the command
// when it is acknowledged by {{interfaceName}}AsynchAck
{{interfaceName}}Asynch = interface(IInvokable)
['{{newguid .}}']
/// this method is expected to be called once at the beginning of the
// process, to receive all asynchronous acknowledgements of the other methods
// - it would return the default delays for the associated timeouts, as
// defined on the server side
function Subscribe{{uri}}(const OnAck: {{interfaceName}}AsynchAck;
out Delays: T{{uri}}Delays): TCQRSResult;
// all methods below map {{interfaceName}} methods, and their input parameters
{{#methods}}
{{^isInherited}}
{{verb}} {{>methodasynch}}
{{/isInherited}}
{{/methods}}
end;
/// waiting semaphore associated to {{interfaceName}}Asynch
// - used internally by T{{uri}}AsynchAck
T{{uri}}AsynchCall = class(TBlockingProcessPoolItem)
protected
procedure ResetInternal; override; // set Params to 0
public
Params: record
// execution context
{{#asynchkey}}
{{.}}: {{asynchkeytype}};
{{/asynchkey}}
methodname: RawUTF8;
ack: T{{uri}}Ack;
// additional parameters, copied from {{interfaceName}}AsynchAck
res: TCQRSResult;{{#methods}}{{^isInherited}}{{#args}}{{#dirOutput}}{{^dirResult}}
{{argName}}{{methodIndex}}: {{typeSource}};{{/dirResult}}{{/dirOutput}}{{/args}}{{/isInherited}}{{/methods}}
end;
published
{{#asynchkey}}
property {{.}}: {{asynchkeytype}} read Params.{{.}};
{{/asynchkey}}
property ack: T{{uri}}Ack read Params.ack;
property res: TCQRSResult read Params.res;
end;
/// propagate acknowledgements for {{interfaceName}}Asynch
// - {{interfaceName}}AsynchAck acknowledgements would be propagated using the
// associated {{calltype}}, to release the wait of the main {{interfaceName}}
// blocking process
// - would allow to run {{interfaceName}} blocking methods over a supplied
// {{interfaceName}}Asynch instance
T{{uri}}AsynchAck = class(TCQRSServiceAsynchAck, {{interfaceName}}AsynchAck)
protected
function Notify({{>callparam}}; ack: T{{uri}}Ack;
res: TCQRSResult; out process: T{{uri}}AsynchCall): boolean; overload;
procedure Notify({{>callparam}}; ack: T{{uri}}Ack;
res: TCQRSResult); overload;
// {{interfaceName}}AsynchAck methods
// would propagate the acknowledgement, and copy any additional parameter
// to T{{uri}}AsynchCall.Params
{{#methods}}
{{^isInherited}}
procedure {{>methodack}}
{{/isInherited}}
{{/methods}}
public
constructor Create(aLog: TSynLogClass);
/// returns a blocking process from the internal semaphore pool
function NewAsynchCall: T{{uri}}AsynchCall;
end;
/// shared synchronous (blocking) interface of {{interfaceName}}Asynch
{{#asynchkey}}
// - every method expects a {{.}}: {{asynchkeytype}} first input
// parameter, in addition to the regular {{interfaceName}} parameters
{{/asynchkey}}
{{interfaceName}}Synch = interface(IInvokable)
['{{newguid .}}']
{{#methods}}
{{^isInherited}}
{{verb}} {{>methodsynch}}
{{/isInherited}}
{{/methods}}
end;
/// implements {{interfaceName}}Synch over a {{interfaceName}}Asynch instance
// - it will use a shared T{{uri}}AsynchAck callback to wait for each
// command to be finished, and emulate synchronous (non-blocking) execution
// - you may use this class e.g. at API level, over a blocking REST server,
// and communicate with the Domain event-driven services via asynchronous calls
T{{uri}}Synch = class(TCQRSServiceSynch, {{interfaceName}}Synch)
protected
fLog: TSynLogClass;
fDelays: T{{uri}}Delays;
fDelaysOwned: boolean;
fAsynch: {{interfaceName}}Asynch;
fSharedCallback: T{{uri}}AsynchAck;
procedure WaitFor(call: T{{uri}}AsynchCall;{{#asynchkey}} const {{.}}: {{asynchkeytype}};{{/asynchkey}}
delay: integer; ack: T{{uri}}Ack; var result: TCQRSResult);
public
/// initialize the blocking instance
// - would allocate an internal T{{uri}}AsynchAck callback, and
// execute {{interfaceName}}Asynch.Subscribe{{uri}}()
// - you may specify custom delays, to overload values supplied by the server
// during Subscribe{{uri}}()
constructor Create(const aAsynch: {{interfaceName}}Asynch;
aDelays: T{{uri}}Delays = nil; aLog: TSynLogClass = nil); reintroduce;
/// finalize the instance
destructor Destroy; override;
/// access to the asynchronous methods
property Asynch: {{interfaceName}}Asynch read fAsynch;
/// associated time out values, in ms
property Delays: T{{uri}}Delays read fDelays;
public
// {{interfaceName}}Synch blocking methods, returning cqrsTimeout if the
// non-blocking calls did not respond in the expected delay, or the
// TCQRSResult returned by the associated {{interfaceName}}Asynch method
{{#methods}}
{{^isInherited}}
{{verb}} {{>methodsynch}}
{{/isInherited}}
{{/methods}}
end;
/// returns the low-level text value of the enumerated, including trailing "ack"
// - may be used e.g. for debugging/logging purpose
function ToText(ack: T{{uri}}Ack): PShortString; overload;
/// returns the original method name without trailing "ack", as defined in
// {{interfaceName}}Asynch
// - reverse function of To{{uri}}Ack()
function ToMethodName(ack: T{{uri}}Ack): RawUTF8; overload;
/// find a T{{uri}}Ack item, matching original method name
// without trailing "ack", as defined in {{interfaceName}}Asynch
// - reverse function of ToMethodName()
function To{{uri}}Ack(const MethodName: RawUTF8): T{{uri}}Ack;
{{/unitasynch}}
{{#asynchkey}}{{#unitsynch}}{ -------- implements {{interfaceName}} over {{interfaceName}}Synch }
{{#query}}{{<method}}{{methodName}}({{#args}}{{^dirResult}}
{{dirName}} {{argName}}: {{typeSource}}{{commaArg}}{{/dirResult}}{{/args}}){{#args}}{{#dirResult}}: {{typeSource}}{{/dirResult}}{{/args}};{{/method}}
type
/// implements CQRS two-phase commit over a {{interfaceName}}Asynch instance
// - first Select phase should have been implemented in {{.}}
// - expects a f{{asynchkey}}: {{asynchkeytype}} field to be available,
// so that the proper {{interfaceName}}Synch method would be called
// - this abstract class should be inherited, and override Set{{uri}}Synch
T{{uri}}Abstract = class({{.}}, {{interfaceName}})
protected
f{{uri}}Synch: {{interfaceName}}Synch;
function BeginSynch(var aResult: TCQRSResult): boolean;
// should be overriden, to set f{{uri}}Synch from f{{asynchkey}}
procedure Set{{uri}}Synch; virtual; abstract;
public
// {{interfaceName}} blocking methods
{{#methods}}
{{^isInherited}}
{{verb}} {{>method}}
{{/isInherited}}
{{/methods}}
end;
{{/query}}{{/unitsynch}}{{/asynchkey}}
{{/services}}
implementation
{{#services}}
{{#unitasynch}}
{ -------- asynchronous version of {{interfaceName}} }
function ToText(ack: T{{uri}}Ack): PShortString;
begin
result := GetEnumName(TypeInfo(T{{uri}}Ack), ord(ack));
end;
function ToMethodName(ack: T{{uri}}Ack): RawUTF8;
begin
result := TrimLeftLowerCaseShort(ToText(ack));
end;
function To{{uri}}Ack(const MethodName: RawUTF8): T{{uri}}Ack;
var
ndx: integer;
begin
ndx := GetEnumNameValueTrimmed(TypeInfo(T{{uri}}Ack),
pointer(MethodName), length(MethodName));
if ndx > 0 then
result := T{{uri}}Ack(ndx)
else
result := ack{{uri}}Undefined;
end;
{ T{{uri}}Delays }
constructor T{{uri}}Delays.Create;
begin
inherited;
{{#methods}}
{{^isInherited}}
f{{methodName}} := {{>methoddelay}};
{{/isInherited}}
{{/methods}}
end;
{ T{{uri}}AsynchCall }
procedure T{{uri}}AsynchCall.ResetInternal;
begin
inherited ResetInternal; // set fEvent := evNone and fCall := 0
Finalize(Params);
FillCharFast(Params, sizeof(Params), 0);
end;
{ T{{uri}}AsynchAck }
constructor T{{uri}}AsynchAck.Create(aLog: TSynLogClass);
begin
inherited Create;
fLog := aLog;
fCalls := TBlockingProcessPool.Create(T{{uri}}AsynchCall);
end;
{{<callfmt}}%(call=%,{{#asynchkey}}%,{{/asynchkey}}%){{/callfmt}}
function T{{uri}}AsynchAck.Notify({{>callparam}};
ack: T{{uri}}Ack; res: TCQRSResult; out process: T{{uri}}AsynchCall): boolean;
var
id: integer;
begin
result := false;
{{#callfunction}}
if not {{.}}(call, id) then begin
fLog.Add.Log(sllTrace, 'Notify: invalid %(call=%) received', [ToText(ack)^, call], self);
exit;
end;
{{/callfunction}}
{{^callfunction}}
id := call;
{{/callfunction}}
process := pointer(fCalls.FromCall(id, true));
if process = nil then begin
fLog.Add.Log(sllTrace, 'Notify: deprecated/unexpected {{>callfmt}} received -> skipped',
[ToText(ack)^, id, {{#asynchkey}}'?', {{/asynchkey}}ToText(res)^], self);
exit;
end;
fLog.Add.Log(sllTrace, 'Notify: {{>callfmt}} received',
[process.Params.methodname, id, {{#asynchkey}}process.{{.}}, {{/asynchkey}}ToText(res)^], self);
process.Params.res := res;
result := true;
end;
procedure T{{uri}}AsynchAck.Notify({{>callparam}};
ack: T{{uri}}Ack; res: TCQRSResult);
var
process: T{{uri}}AsynchCall;
begin
if Notify(call, ack, res, process) then
process.NotifyFinished(true); // notify caller to unlock "WaitFor" method
end;
function T{{uri}}AsynchAck.NewAsynchCall: T{{uri}}AsynchCall;
begin
result := pointer(fCalls.NewProcess(0));
if result = nil then
raise {{Exception}}.CreateUTF8('%.NewAsynchCall: NewProcess=nil', [self]);
end;
// {{interfaceName}}AsynchAck methods
{{#methods}}
{{^isInherited}}
procedure T{{uri}}AsynchAck.{{>methodack}}
{{#hasOutNotResultParams}}
var
process: T{{uri}}AsynchCall;
begin
if Notify(call, ack{{methodName}}, res, process) then begin{{#args}}{{#dirOutput}}{{^dirResult}}
process.Params.{{argName}}{{methodIndex}} := {{argName}};{{/dirResult}}{{/dirOutput}}{{/args}}
process.NotifyFinished(true);
end;
{{/hasOutNotResultParams}}
{{^hasOutNotResultParams}}
begin
Notify(call, ack{{methodName}}, res);
{{/hasOutNotResultParams}}
end;
{{/isInherited}}
{{/methods}}
{ T{{uri}}Synch }
constructor T{{uri}}Synch.Create(const aAsynch: {{interfaceName}}Asynch;
aDelays: T{{uri}}Delays; aLog: TSynLogClass);
var
res: TCQRSResult;
outdelays: T{{uri}}Delays;
begin
if aAsynch = nil then
raise {{exception}}.CreateUTF8('%.Create(aAsynch=nil)', [self]);
fAsynch := aAsynch;
fLog := aLog;
fSharedCallback := T{{uri}}AsynchAck.Create(fLog);
inherited Create(fSharedCallback);
outdelays := T{{uri}}Delays.Create;
try
res := fAsynch.Subscribe{{uri}}(fSharedCallback, outdelays);
if res <> cqrsSuccess then
raise EDomPanel.CreateUTF8('%.Create: {{interfaceName}}Asynch.Subscribe=%',
[self, ToText(res)^]);
if aDelays <> nil then
fDelays := aDelays // force custom delays
else begin
fDelays := outdelays;
fDelaysOwned := true;
outdelays := nil;
end;
finally
outdelays.Free;
end;
end;
destructor T{{uri}}Synch.Destroy;
begin
if fDelaysOwned then
fDelays.Free;
inherited Destroy;
end;
procedure T{{uri}}Synch.WaitFor(call: T{{uri}}AsynchCall;
{{#asynchkey}}const {{.}}: {{asynchkeytype}}; {{/asynchkey}}delay: integer; ack: T{{uri}}Ack;
var result: TCQRSResult);
var
msg: RawUTF8;
begin
call.Lock;
try
{{#asynchkey}}
call.Params.{{.}} := {{.}}; // for Notify()
{{/asynchkey}}
call.Params.ack := ack;
call.Params.methodname := ToMethodName(ack);
FormatUTF8('WaitFor: Asynch.{{>callfmt}}',
[call.Params.methodname, call.Call, {{#asynchkey}}{{.}}, {{/asynchkey}}ToText(result)^], msg);
finally
call.Unlock;
end;
fLog.Add.Log(sllTrace, msg, self);
if result <> cqrsSuccess then
fLog.Add.Log(sllDDDError, '%: input parameters?', [msg])
else if call.WaitFor(delay) = evTimeOut then begin
fLog.Add.Log(sllDDDInfo, '% timeout after %ms', [msg, delay]);
result := cqrsTimeout;
end
else
result := call.Params.res;
end;
// {{interfaceName}}Synch blocking methods
{{<argvalue}}{{#isEnum}}ToText({{argName}})^{{/isEnum}}{{^isEnum}}{{argName}}{{/isEnum}}{{/argvalue}}
{{#methods}}
{{^isInherited}}
{{verb}} T{{uri}}Synch.{{>methodsynch}}
var
log: ISynLog;
call: T{{uri}}AsynchCall;
begin
if fLog <> nil then
log := fLog.Enter('{{methodName}}({{#asynchkey}}{{.}}=%{{/asynchkey}}{{#args}}{{#dirInput}}, {{argName}}=%{{/dirInput}}{{/args}})',
[{{#asynchkey}}{{.}}{{/asynchkey}}{{#args}}{{#dirInput}},{{>argvalue}}{{/dirInput}}{{/args}}], self);
try
call := fSharedCallback.NewAsynchCall;
try
result := Asynch.{{methodName}}({{#asynchkey}}{{.}}, {{/asynchkey}}{{#args}}{{#dirInput}}{{argName}}, {{/dirInput}}{{/args}}call.Call);
WaitFor(call, {{#asynchkey}}{{.}}, {{/asynchkey}}Delays.{{methodName}}, ack{{methodName}}, result);
finally{{#hasOutNotResultParams}}{{#args}}{{#dirOutput}}{{^dirResult}}
{{argName}} := call.Params.{{argName}}{{methodIndex}};{{/dirResult}}{{/dirOutput}}{{/args}}{{/hasOutNotResultParams}}
call.Reset;
end;
except
on Exception do
result := cqrsInternalError;
end;
if log <> nil then
log.Log(sllDebug, '{{methodName}}{{#asynchkey}}(%){{/asynchkey}} returned %{{#args}}{{#dirOutput}}{{^dirResult}} {{argName}}=%{{/dirResult}}{{/dirOutput}}{{/args}}',
[{{#asynchkey}}{{.}}, {{/asynchkey}}ToText(result)^{{#args}}{{#dirOutput}}{{^dirResult}}, {{>argvalue}}{{/dirResult}}{{/dirOutput}}{{/args}}], self);
end;
{{/isInherited}}
{{/methods}}
{{/unitasynch}}
{{#asynchkey}}{{#unitsynch}}{ -------- implements {{interfaceName}} over {{interfaceName}}Synch }
{{#query}}
{ T{{uri}}Abstract }
function T{{uri}}Abstract.BeginSynch(var aResult: TCQRSResult): boolean;
begin
result := false;
if CqrsBeginMethod(qaCommandOnSelect, aResult) then begin
Set{{uri}}Synch;
if f{{uri}}Synch = nil then
CqrsSetResultMsg(cqrsInternalError, '{{uri}}Synch=nil')
else
result := true;
end;
end;
{{#methods}}{{^isInherited}}
{{verb}} T{{uri}}Abstract.{{>method}}
begin
if BeginSynch(result) then
CqrsSetResult(f{{uri}}Synch.{{methodName}}(
f{{asynchkey}}{{#args}}{{^dirResult}}, {{argName}}{{/dirResult}}{{/args}}));
end;
{{/isInherited}}
{{/methods}}
{{/query}}{{/unitsynch}}{{/asynchkey}}
{{/services}}
initialization
{{#services}}
{{#unitasynch}}
TInterfaceFactory.RegisterInterfaces([
TypeInfo({{interfaceName}}AsynchAck), TypeInfo({{interfaceName}}Asynch)]);
{{/unitasynch}}
{{/services}}
{{/soa}}
end.

121
contrib/mORMot/SQLite3/DDD/dom/dddDomAuthInterfaces.pas Normal file
View File

@@ -0,0 +1,121 @@
/// shared DDD Domains: Authentication objects and interfaces
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomAuthInterfaces;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SynCommons,
SysUtils,
Classes,
mORMot,
mORMotDDD;
type
/// the data type which will be returned during a password challenge
// - in practice, will be e.g. Base-64 encoded SHA-256 binary hash
TAuthQueryNonce = RawUTF8;
TAuthInfoName = RawUTF8;
/// DDD entity used to store authentication information
TAuthInfo = class(TSynPersistent)
protected
fLogonName: TAuthInfoName;
published
/// the textual identifier by which the user would recognize himself
property LogonName: TAuthInfoName read fLogonName write fLogonName;
end;
/// repository service to authenticate credentials via a dual pass challenge
IDomAuthQuery = interface(ICQRSService)
['{5FB1E4A6-B432-413F-8958-1FA1857D1195}']
/// initiate the first phase of a dual pass challenge authentication
function ChallengeSelectFirst(const aLogonName: RawUTF8): TAuthQueryNonce;
/// validate the first phase of a dual pass challenge authentication
function ChallengeSelectFinal(const aChallengedPassword: TAuthQueryNonce): TCQRSResult;
/// returns TRUE if the dual pass challenge did succeed
function Logged: boolean;
/// returns the logon name of the authenticated user
function LogonName: RawUTF8;
/// set the credential for Get() or further IAuthCommand.Update/Delete
// - this method execution will be disabled for most clients
function SelectByName(const aLogonName: RawUTF8): TCQRSResult;
/// retrieve some information about the current selected credential
function Get(out aAggregate: TAuthInfo): TCQRSResult;
end;
/// repository service to update or register new authentication credentials
IDomAuthCommand = interface(IDomAuthQuery)
['{8252727B-336B-4105-80FD-C8DFDBD4801E}']
/// register a new credential, from its LogonName/HashedPassword values
// - aHashedPassword should match the algorithm expected by the actual
// implementation class, over UTF-8 encoded LogonName+':'+Password
// - on success, the newly created credential will be the currently selected
function Add(const aLogonName: RawUTF8; aHashedPassword: TAuthQueryNonce): TCQRSResult;
/// update the current selected credential password
// - aHashedPassword should match the algorithm expected by the actual
// implementation class, over UTF-8 encoded LogonName+':'+Password
// - will be allowed only for the current challenged user
function UpdatePassword(const aHashedPassword: TAuthQueryNonce): TCQRSResult;
/// delete the current selected credential
// - this method execution will be disabled for most clients
function Delete: TCQRSResult;
/// write all pending changes prepared by Add/UpdatePassword/Delete methods
function Commit: TCQRSResult;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomAuthQuery),TypeInfo(IDomAuthCommand)]);
end.

483
contrib/mORMot/SQLite3/DDD/dom/dddDomCountry.pas Normal file
View File

@@ -0,0 +1,483 @@
/// shared DDD Domains: TCountry object definition
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomCountry;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SysUtils,
Classes,
SynCommons,
SynTests,
mORMot,
mORMotDDD;
{ *********** Country Modeling }
type
/// Country identifiers, following ISO 3166-1 standard
TCountryIdentifier = (ccUndefined,
ccAF,ccAX,ccAL,ccDZ,ccAS,ccAD,ccAO,ccAI,ccAQ,ccAG,ccAR,ccAM,ccAW,ccAU,ccAT,
ccAZ,ccBS,ccBH,ccBD,ccBB,ccBY,ccBE,ccBZ,ccBJ,ccBM,ccBT,ccBO,ccBQ,ccBA,ccBW,
ccBV,ccBR,ccIO,ccBN,ccBG,ccBF,ccBI,ccKH,ccCM,ccCA,ccCV,ccKY,ccCF,ccTD,ccCL,
ccCN,ccCX,ccCC,ccCO,ccKM,ccCG,ccCD,ccCK,ccCR,ccCI,ccHR,ccCU,ccCW,ccCY,ccCZ,
ccDK,ccDJ,ccDM,ccDO,ccEC,ccEG,ccSV,ccGQ,ccER,ccEE,ccET,ccFK,ccFO,ccFJ,ccFI,
ccFR,ccGF,ccPF,ccTF,ccGA,ccGM,ccGE,ccDE,ccGH,ccGI,ccGR,ccGL,ccGD,ccGP,ccGU,
ccGT,ccGG,ccGN,ccGW,ccGY,ccHT,ccHM,ccVA,ccHN,ccHK,ccHU,ccIS,ccIN,ccID,ccIR,
ccIQ,ccIE,ccIM,ccIL,ccIT,ccJM,ccJP,ccJE,ccJO,ccKZ,ccKE,ccKI,ccKP,ccKR,ccKW,
ccKG,ccLA,ccLV,ccLB,ccLS,ccLR,ccLY,ccLI,ccLT,ccLU,ccMO,ccMK,ccMG,ccMW,ccMY,
ccMV,ccML,ccMT,ccMH,ccMQ,ccMR,ccMU,ccYT,ccMX,ccFM,ccMD,ccMC,ccMN,ccME,ccMS,
ccMA,ccMZ,ccMM,ccNA,ccNR,ccNP,ccNL,ccNC,ccNZ,ccNI,ccNE,ccNG,ccNU,ccNF,ccMP,
ccNO,ccOM,ccPK,ccPW,ccPS,ccPA,ccPG,ccPY,ccPE,ccPH,ccPN,ccPL,ccPT,ccPR,ccQA,
ccRE,ccRO,ccRU,ccRW,ccBL,ccSH,ccKN,ccLC,ccMF,ccPM,ccVC,ccWS,ccSM,ccST,ccSA,
ccSN,ccRS,ccSC,ccSL,ccSG,ccSX,ccSK,ccSI,ccSB,ccSO,ccZA,ccGS,ccSS,ccES,ccLK,
ccSD,ccSR,ccSJ,ccSZ,ccSE,ccCH,ccSY,ccTW,ccTJ,ccTZ,ccTH,ccTL,ccTG,ccTK,ccTO,
ccTT,ccTN,ccTR,ccTM,ccTC,ccTV,ccUG,ccUA,ccAE,ccGB,ccUS,ccUM,ccUY,ccUZ,ccVU,
ccVE,ccVN,ccVG,ccVI,ccWF,ccEH,ccYE,ccZM,ccZW);
/// store ISO 3166-1 alpha-2 code
TCountryIsoAlpha2 = type RawUTF8;
/// store ISO 3166-1 alpha-3 code
TCountryIsoAlpha3 = type RawUTF8;
/// store a ISO 3166-1 numeric value as 16-bit unsigned integer
TCountryIsoNumeric = type word;
/// defines a Country identifier object
// - will store internally the country as 16-bit ISO 3166-1 numeric value
// - includes conversion methods for ISO 3166-1 alpha-2/alpha-3/numeric codes
// as explained in http://en.wikipedia.org/wiki/ISO_3166-1
// - see also some low-level class methods for direct values conversions
// with no persistence
TCountry = class(TSynPersistent)
protected
fIso: TCountryIsoNumeric;
fCache: packed record
Identifier: TCountryIdentifier;
Iso: TCountryIsoNumeric;
end;
function GetIdentifier: TCountryIdentifier;
function GetIsoAlpha2: TCountryIsoAlpha2;
function GetIsoAlpha3: TCountryIsoAlpha3;
procedure SetIdentifier(const Value: TCountryIdentifier);
procedure SetIsoAlpha2(const Value: TCountryIsoAlpha2);
procedure SetIsoAlpha3(const Value: TCountryIsoAlpha3);
function GetEnglish: RawUTF8;
public
/// low-level Country conversion into its plain English text
class function ToEnglish(id: TCountryIdentifier): RawUTF8;
/// low-level Country conversion into its alpha-2 code
class function ToAlpha2(id: TCountryIdentifier): TCountryIsoAlpha2;
/// low-level Country conversion into its alpha-3 code
class function ToAlpha3(id: TCountryIdentifier): TCountryIsoAlpha3;
/// low-level Country conversion to its ISO 3166-1 numeric 3-digit code
class function ToIso(id: TCountryIdentifier): TCountryIsoNumeric;
/// low-level case-insensitive Country conversion from its plain English text
// - returns ccUndefined if the supplied Text has no case-insensitive match
class function FromEnglish(const text: RawUTF8): TCountryIdentifier;
/// low-level Country conversion from its alpha-2 code
// - returns ccUndefined if the supplied text has no case-insensitive match
class function FromAlpha2(const alpha: TCountryIsoAlpha2): TCountryIdentifier;
/// low-level Country conversion from its alpha-3 code
// - returns ccUndefined if the supplied Text has no case-insensitive match
class function FromAlpha3(const alpha: TCountryIsoAlpha3): TCountryIdentifier;
/// low-level Country conversion from its alpha-2 code
// - returns ccUndefined if the supplied 16-bit number as no match
class function FromIso(iso: TCountryIsoNumeric): TCountryIdentifier;
/// built-in simple unit tests
class procedure RegressionTests(test: TSynTestCase);
/// returns TRUE if both Country instances have the same content
// - slightly faster than global function ObjectEquals(self,another)
function Equals(another: TCountry): boolean; reintroduce;
/// internal enumerate corresponding to this country
property Identifier: TCountryIdentifier read GetIdentifier write SetIdentifier;
/// the ISO 3166-1 alpha-2 code of this country
property Alpha2: TCountryIsoAlpha2 read GetIsoAlpha2 write SetIsoAlpha2;
/// the ISO 3166-1 alpha-3 code of this countr
property Alpha3: TCountryIsoAlpha3 read GetIsoAlpha3 write SetIsoAlpha3;
/// plain English text of this country, e.g. 'France' or 'United States'
property English: RawUTF8 read GetEnglish;
published
/// the stored and transmitted value is this ISO 3166-1 numeric 3-digit code
property Iso: TCountryIsoNumeric read fIso write fIso;
end;
implementation
{ TCountry }
const
COUNTRY_NAME_EN: array[TCountryIdentifier] of RawUTF8 = ('',
'Afghanistan','Aland Islands','Albania','Algeria','American Samoa',
'Andorra','Angola','Anguilla','Antarctica','Antigua and Barbuda',
'Argentina','Armenia','Aruba','Australia','Austria','Azerbaijan',
'Bahamas','Bahrain','Bangladesh','Barbados','Belarus','Belgium',
'Belize','Benin','Bermuda','Bhutan','Bolivia, Plurinational State of',
'Bonaire, Sint Eustatius and Saba','Bosnia and Herzegovina','Botswana',
'Bouvet Island','Brazil','British Indian Ocean Territory',
'Brunei Darussalam','Bulgaria','Burkina Faso','Burundi','Cambodia',
'Cameroon','Canada','Cape Verde','Cayman Islands','Central African Republic',
'Chad','Chile','China','Christmas Island','Cocos (Keeling) Islands',
'Colombia','Comoros','Congo','Congo, the Democratic Republic of the',
'Cook Islands','Costa Rica','Ivory Coast','Croatia','Cuba','Curacao',
'Cyprus','Czech Republic','Denmark','Djibouti','Dominica',
'Dominican Republic','Ecuador','Egypt','El Salvador','Equatorial Guinea',
'Eritrea','Estonia','Ethiopia','Falkland Islands (Malvinas)',
'Faroe Islands','Fiji','Finland','France','French Guiana',
'French Polynesia','French Southern Territories','Gabon','Gambia','Georgia',
'Germany','Ghana','Gibraltar','Greece','Greenland','Grenada','Guadeloupe',
'Guam','Guatemala','Guernsey','Guinea','Guinea-Bissau','Guyana','Haiti',
'Heard Island and McDonald Islands','Holy See (Vatican City State)',
'Honduras','Hong Kong','Hungary','Iceland','India','Indonesia',
'Iran, Islamic Republic of','Iraq','Ireland','Isle of Man','Israel',
'Italy','Jamaica','Japan','Jersey','Jordan','Kazakhstan','Kenya',
'Kiribati','Korea, Democratic People''s Republic of','Korea, Republic of',
'Kuwait','Kyrgyzstan','Lao People''s Democratic Republic','Latvia',
'Lebanon','Lesotho','Liberia','Libyan Arab Jamahiriya','Liechtenstein',
'Lithuania','Luxembourg','Macao','Macedonia, the former Yugoslav Republic of',
'Madagascar','Malawi','Malaysia','Maldives','Mali','Malta','Marshall Islands',
'Martinique','Mauritania','Mauritius','Mayotte','Mexico',
'Micronesia, Federated States of','Moldova, Republic of','Monaco',
'Mongolia','Montenegro','Montserrat','Morocco','Mozambique','Myanmar',
'Namibia','Nauru','Nepal','Netherlands','New Caledonia','New Zealand',
'Nicaragua','Niger','Nigeria','Niue','Norfolk Island',
'Northern Mariana Islands','Norway','Oman','Pakistan','Palau',
'Palestinian Territory','Panama','Papua New Guinea','Paraguay','Peru',
'Philippines','Pitcairn','Poland','Portugal','Puerto Rico','Qatar',
'Reunion','Romania','Russian Federation','Rwanda','Saint Barthelemy',
'Saint Helena, Ascension and Tristan da Cunha','Saint Kitts and Nevis',
'Saint Lucia','Saint Martin (French part)','Saint Pierre and Miquelon',
'Saint Vincent and the Grenadines','Samoa','San Marino',
'Sao Tome and Principe','Saudi Arabia','Senegal','Serbia',
'Seychelles','Sierra Leone','Singapore','Sint Maarten (Dutch part)',
'Slovakia','Slovenia','Solomon Islands','Somalia','South Africa',
'South Georgia and the South Sandwich Islands','South Sudan','Spain',
'Sri Lanka','Sudan','Suriname','Svalbard and Jan Mayen','Swaziland',
'Sweden','Switzerland','Syrian Arab Republic','Taiwan, Province of China',
'Tajikistan','Tanzania, United Republic of','Thailand','Timor-Leste',
'Togo','Tokelau','Tonga','Trinidad and Tobago','Tunisia','Turkey',
'Turkmenistan','Turks and Caicos Islands','Tuvalu','Uganda','Ukraine',
'United Arab Emirates','United Kingdom','United States',
'United States Minor Outlying Islands','Uruguay','Uzbekistan','Vanuatu',
'Venezuela, Bolivarian Republic of','Viet Nam','Virgin Islands, British',
'Virgin Islands, U.S.','Wallis and Futuna','Western Sahara','Yemen',
'Zambia','Zimbabwe');
COUNTRY_ISO3: array[TCountryIdentifier] of array[0..3] of AnsiChar = ('',
'AFG','ALA','ALB','DZA','ASM','AND','AGO','AIA','ATA','ATG','ARG','ARM',
'ABW','AUS','AUT','AZE','BHS','BHR','BGD','BRB','BLR','BEL','BLZ','BEN',
'BMU','BTN','BOL','BES','BIH','BWA','BVT','BRA','IOT','BRN','BGR','BFA',
'BDI','KHM','CMR','CAN','CPV','CYM','CAF','TCD','CHL','CHN','CXR','CCK',
'COL','COM','COG','COD','COK','CRI','CIV','HRV','CUB','CUW','CYP','CZE',
'DNK','DJI','DMA','DOM','ECU','EGY','SLV','GNQ','ERI','EST','ETH','FLK',
'FRO','FJI','FIN','FRA','GUF','PYF','ATF','GAB','GMB','GEO','DEU','GHA',
'GIB','GRC','GRL','GRD','GLP','GUM','GTM','GGY','GIN','GNB','GUY','HTI',
'HMD','VAT','HND','HKG','HUN','ISL','IND','IDN','IRN','IRQ','IRL','IMN',
'ISR','ITA','JAM','JPN','JEY','JOR','KAZ','KEN','KIR','PRK','KOR','KWT',
'KGZ','LAO','LVA','LBN','LSO','LBR','LBY','LIE','LTU','LUX','MAC','MKD',
'MDG','MWI','MYS','MDV','MLI','MLT','MHL','MTQ','MRT','MUS','MYT','MEX',
'FSM','MDA','MCO','MNG','MNE','MSR','MAR','MOZ','MMR','NAM','NRU','NPL',
'NLD','NCL','NZL','NIC','NER','NGA','NIU','NFK','MNP','NOR','OMN','PAK',
'PLW','PSE','PAN','PNG','PRY','PER','PHL','PCN','POL','PRT','PRI','QAT',
'REU','ROU','RUS','RWA','BLM','SHN','KNA','LCA','MAF','SPM','VCT','WSM',
'SMR','STP','SAU','SEN','SRB','SYC','SLE','SGP','SXM','SVK','SVN','SLB',
'SOM','ZAF','SGS','SSD','ESP','LKA','SDN','SUR','SJM','SWZ','SWE','CHE',
'SYR','TWN','TJK','TZA','THA','TLS','TGO','TKL','TON','TTO','TUN','TUR',
'TKM','TCA','TUV','UGA','UKR','ARE','GBR','USA','UMI','URY','UZB','VUT',
'VEN','VNM','VGB','VIR','WLF','ESH','YEM','ZMB','ZWE');
COUNTRY_ISONUM: array[TCountryIdentifier] of word = (0,
4,248,8,12,16,20,24,660,10,28,32,51,533,36,40,31,44,48,50,52,112,56,84,
204,60,64,68,535,70,72,74,76,86,96,100,854,108,116,120,124,132,136,140,
148,152,156,162,166,170,174,178,180,184,188,384,191,192,531,196,203,208,
262,212,214,218,818,222,226,232,233,231,238,234,242,246,250,254,258,260,
266,270,268,276,288,292,300,304,308,312,316,320,831,324,624,328,332,334,
336,340,344,348,352,356,360,364,368,372,833,376,380,388,392,832,400,398,
404,296,408,410,414,417,418,428,422,426,430,434,438,440,442,446,807,450,
454,458,462,466,470,584,474,478,480,175,484,583,498,492,496,499,500,504,
508,104,516,520,524,528,540,554,558,562,566,570,574,580,578,512,586,585,
275,591,598,600,604,608,612,616,620,630,634,638,642,643,646,652,654,659,
662,663,666,670,882,674,678,682,686,688,690,694,702,534,703,705,90,706,
710,239,728,724,144,729,740,744,748,752,756,760,158,762,834,764,626,768,
772,776,780,788,792,795,796,798,800,804,784,826,840,581,858,860,548,862,
704,92,850,876,732,887,894,716);
ccFirst = succ(low(TCountryIdentifier));
var
COUNTRY_ISO2: array[TCountryIdentifier] of word;
COUNTRYU_ISO2, COUNTRYU_ISO3: array[TCountryIdentifier] of RawUTF8;
COUNTRY_ISONUM_ORDERED: record // for fast binary search of the ISO numeric
Values, Indexes: array[TCountryIdentifier] of integer;
end;
procedure Initialize;
var c: TCountryIdentifier;
ps: PAnsiChar; // circumvent FPC compilation issue
begin
with COUNTRY_ISONUM_ORDERED do begin
for c := ccFirst to high(c) do begin
Values[c] := COUNTRY_ISONUM[c];
ps := pointer(GetEnumName(TypeInfo(TCountryIdentifier),ord(c)));
COUNTRY_ISO2[c] := PWord(ps+3)^;
FastSetString(COUNTRYU_ISO2[c],ps+3,2);
FastSetString(COUNTRYU_ISO3[c],@COUNTRY_ISO3[c],3);
end;
FillIncreasing(@Indexes,0,length(Indexes));
QuickSortInteger(@Values,@Indexes,0,length(Values)-1);
end;
end;
class function TCountry.ToEnglish(id: TCountryIdentifier): RawUTF8;
begin
result := COUNTRY_NAME_EN[id];
end;
class function TCountry.ToAlpha2(id: TCountryIdentifier): TCountryIsoAlpha2;
begin
result := COUNTRYU_ISO2[id];
end;
class function TCountry.ToAlpha3(id: TCountryIdentifier): TCountryIsoAlpha3;
begin
result := COUNTRYU_ISO3[id];
end;
class function TCountry.ToIso(id: TCountryIdentifier): TCountryIsoNumeric;
begin
result := COUNTRY_ISONUM[id];
end;
class function TCountry.FromEnglish(const text: RawUTF8): TCountryIdentifier;
var L: integer;
P: PRawUTF8;
begin
L := length(text);
P := @COUNTRY_NAME_EN[ccFirst];
for result := ccFirst to high(result) do
if (length(P^)=L) and IdemPropNameUSameLen(pointer(P^),pointer(Text),L) then
exit else
inc(P);
result := ccUndefined;
end;
class function TCountry.FromAlpha2(const alpha: TCountryIsoAlpha2): TCountryIdentifier;
var up: RawUTF8;
ndx: PtrInt;
begin
up := UpperCaseU(Trim(alpha));
if length(up)=2 then begin
ndx := WordScanIndex(@COUNTRY_ISO2[ccFirst],length(COUNTRY_ISO2)-1,PWord(up)^);
if ndx>=0 then begin
result := TCountryIdentifier(ndx+1);
exit;
end;
end;
result := ccUndefined;
end;
class function TCountry.FromAlpha3(const alpha: TCountryIsoAlpha3): TCountryIdentifier;
var up: RawUTF8;
ndx: PtrInt;
begin
up := UpperCaseU(Trim(alpha));
if length(up)=3 then begin
ndx := IntegerScanIndex(@COUNTRY_ISO3[ccFirst],length(COUNTRY_ISO3)-1,PCardinal(up)^);
if ndx>=0 then begin
result := TCountryIdentifier(ndx+1);
exit;
end;
end;
result := ccUndefined;
end;
class function TCountry.FromIso(iso: TCountryIsoNumeric): TCountryIdentifier;
var ndx: PtrInt;
begin
with COUNTRY_ISONUM_ORDERED do begin
ndx := FastFindIntegerSorted(@Values,length(Values)-1,Iso);
if ndx<0 then
result := ccUndefined else
result := TCountryIdentifier(Indexes[TCountryIdentifier(ndx)]);
end;
end;
function TCountry.GetEnglish: RawUTF8;
begin
result := COUNTRY_NAME_EN[GetIdentifier];
end;
function TCountry.GetIdentifier: TCountryIdentifier;
begin
if Iso=0 then
result := ccUndefined
else if Iso=fCache.Iso then
result := fCache.Identifier
else begin
result := FromIso(Iso);
fCache.Iso := Iso;
fCache.Identifier := result;
end;
end;
function TCountry.GetIsoAlpha2: TCountryIsoAlpha2;
begin
result := COUNTRYU_ISO2[GetIdentifier];
end;
function TCountry.GetIsoAlpha3: TCountryIsoAlpha3;
begin
result := COUNTRYU_ISO3[GetIdentifier];
end;
procedure TCountry.SetIdentifier(const Value: TCountryIdentifier);
begin
fIso := COUNTRY_ISONUM[Value];
if Value<>ccUndefined then begin
fCache.Iso := fIso;
fCache.Identifier := Value;
end;
end;
procedure TCountry.SetIsoAlpha2(const Value: TCountryIsoAlpha2);
begin
SetIdentifier(FromAlpha2(Value));
end;
procedure TCountry.SetIsoAlpha3(const Value: TCountryIsoAlpha3);
begin
SetIdentifier(FromAlpha3(Value));
end;
class procedure TCountry.RegressionTests(test: TSynTestCase);
var c,c2: TCountry;
i: TCountryIdentifier;
t: RawUTF8;
begin
c := TCountry.Create;
c2 := TCountry.Create;
with test do
try
c.Alpha2 := ' fR ';
Check(c.Iso=250);
Check(c.Identifier=ccFR);
c.Alpha2 := ' zz ';
Check(c.Iso=0);
Check(c.Identifier=ccUndefined);
c.Alpha2 := ' fzz ';
Check(c.Iso=0);
Check(c.Identifier=ccUndefined);
c.Alpha3 := ' frA ';
Check(c.Iso=250);
Check(c.Identifier=ccFR);
c.Alpha3 := ' frz ';
Check(c.Iso=0);
Check(c.Identifier=ccUndefined);
Check(TCountry.FromEnglish('none')=ccUndefined);
for i := low(i) to high(i) do begin
c.Iso := COUNTRY_ISONUM[i];
Check(c.Iso=c.ToIso(i));
t := c.Alpha2;
Check(c.ToAlpha2(i)=t);
Check(c.Identifier=i);
c.Iso := 0;
c.Alpha2 := t;
Check(c.Identifier=i);
Check(c.Iso=COUNTRY_ISONUM[i]);
end;
for i := low(i) to high(i) do begin
c.Identifier := i;
Check(c.Iso=COUNTRY_ISONUM[i]);
Check(c.Identifier=i);
end;
for i := low(i) to high(i) do begin
c.Alpha3 := COUNTRY_ISO3[i];
Check(c.Iso=COUNTRY_ISONUM[i]);
Check(c.Identifier=i);
t := c.Alpha3;
check(c.ToAlpha3(i)=t);
c.Iso := 0;
c.Alpha3 := t;
Check(c.Identifier=i);
Check(c.Iso=COUNTRY_ISONUM[i]);
CopyObject(c,c2);
Check(c2.Iso=COUNTRY_ISONUM[i]);
Check(c2.Alpha3=c.Alpha3);
Check(ObjectEquals(c,c2,false));
Check(ObjectEquals(c,c2,true));
t := c.English;
Check(c.ToEnglish(i)=t);
Check(c.FromEnglish(t)=i);
end;
finally
c2.Free;
c.Free;
end;
end;
function TCountry.Equals(another: TCountry): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := another.fIso=fIso;
end;
initialization
Initialize;
{$ifndef ISDELPHI2010}
{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug
TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(TypeInfo(TCountryIdentifier));
{$endif}
{$endif}
end.

47
contrib/mORMot/SQLite3/DDD/dom/dddDomEmailInterfaces.pas Normal file
View File

@@ -0,0 +1,47 @@
unit DomUserInterfaces;
interface
uses
SysUtils,
SynCommons,
mORMot,
mORMotDDD,
DomUserTypes;
type
IDomUserEmailCheck = interface(IInvokable)
['{2942BC2D-84F7-4A79-8657-07F0602C3505}']
function CheckRecipient(const aEmail: RawUTF8): TCQRSResult;
function CheckRecipients(const aEmails: TRawUTF8DynArray): TCQRSResult;
end;
IDomUserEmailValidation = interface(IDomUserEmailCheck)
['{20129489-5054-4D4A-84B9-463DB98156B8}']
function ComputeURIForReply(const aLogonName,aEmail: RawUTF8): RawUTF8;
function StartEmailValidation(const aTemplate: TDomUserEmailTemplate;
const aLogonName,aEmail: RawUTF8): TCQRSResult;
function IsEmailValidated(const aLogonName,aEmail: RawUTF8): boolean;
end;
IDomUserEmailer = interface(IInvokable)
['{20B88FCA-B345-4D5E-8E07-4581C814AFD9}']
function SendEmail(const aRecipients: TRawUTF8DynArray;
const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
end;
IDomUserTemplate = interface(IInvokable)
['{378ACC52-46BE-488D-B7ED-3F4E59316DFF}']
function ComputeMessage(const aContext: variant;
const aTemplateName: RawUTF8): RawUTF8;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomUserEmailValidation),TypeInfo(IDomUserEmailer),
TypeInfo(IDomUserTemplate)]);
end.

147
contrib/mORMot/SQLite3/DDD/dom/dddDomUserCQRS.pas Normal file
View File

@@ -0,0 +1,147 @@
/// shared DDD Domains: User CQRS Repository interfaces
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomUserCQRS;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SynCommons,
SysUtils,
Classes,
mORMot,
mORMotDDD,
dddDomUserTypes;
type
/// defines an abstract CQRS Repository for Reading TUser Aggregate Roots
// - this interface allows only read access to the Aggregate: see
// IDomUserCommand to modify the content
// - you could use SelectByLogonName, SelectByLastName or SelectByEmailValidation
// methods to initialize a request, then call Get, GetAll or GetNext to retrieve
// the actual matching Aggregate Roots
IDomUserQuery = interface(ICQRSService)
['{198C01D6-5189-4B74-AAF4-C322237D7D53}']
/// would select a single TUser from its logon name
// - then use Get() method to retrieve its content
function SelectByLogonName(const aLogonName: RawUTF8): TCQRSResult;
/// would select one or several TUser from their email validation state
// - then use GetCount, GetAll() or GetNext() methods to retrieve the items
function SelectByEmailValidation(aValidationState: TDomUserEmailValidation): TCQRSResult;
/// would select one or several TUser from their last name
// - will search for a full matching name, unless aStartWith is TRUE so that
// it would search for the beginning characters
// - then use GetCount, GetAll() or GetNext() methods to retrieve the items
function SelectByLastName(const aName: TLastName; aStartWith: boolean): TCQRSResult;
/// would select all TUser instances
// - you should not use this search criteria, since it may return a huge
// number of values
// - then use GetCount, GetAll() or GetNext() methods to retrieve the items
function SelectAll: TCQRSResult;
/// retrieve a single TUser
function Get(out aAggregate: TUser): TCQRSResult;
/// retrieve all matching TUser instances
// - the caller should release all returned TUser by calling
// ! ObjArrayClear(aAggregates);
function GetAll(out aAggregates: TUserObjArray): TCQRSResult;
/// retrieve the next matching TUser instances
// - returns cqrsNoMoreData if there is no more pending data
function GetNext(out aAggregate: TUser): TCQRSResult;
/// retrieve how many TUser instances do match the selection
function GetCount: integer;
/// retrieve how many TUser have their email validated
function HowManyValidatedEmail: integer;
end;
/// defines an abstract CQRS Repository for Writing TUser Aggregate Roots
// - would implement a dual-phase commit to change TUser content
// - first phase consists in calling Add, Update, Delete or DeleteAll methods
// which would call the registered validators on the supplied content
// - you can call Add, Update, Delete or DeleteAll methods several times,
// so that several write operations will be recorded for the TUser
// - during the first phase, nothing is actually written to the persistence
// storage itself (which may be a RDBMS or a NoSQL engine)
// - then the second phase would take place when the Commit method would
// be executed, which would save all prepared content to the actual storage
// engine (e.g. using a transaction via a BATCH process if implemented by
// mORMot's ORM, via TInfraRepoUser as defined in dddInfraRepoUser)
IDomUserCommand = interface(IDomUserQuery)
['{D345854F-7337-4006-B324-5D635FBED312}']
/// persist a new TUser aggregate
function Add(const aAggregate: TUser): TCQRSResult;
/// update an existing TUser aggregate
// - the existing content should have been retrieved by a previous Select*
// method, e.g. IDomUserQuery.SelectByLogonName
function Update(const aUpdatedAggregate: TUser): TCQRSResult;
/// erase an existing TUser aggregate
// - the existing content should have been retrieved by a previous Select*
// method, e.g. IDomUserQuery.SelectByLogonName
function Delete: TCQRSResult;
/// erase existing TUser aggregate, matching a
// - the existing content should have been retrieved by a previous Select*
// method, e.g. IDomUserQuery.SelectByLogonName: a plain DeleteAll call
// with no prious Select* would return an error
function DeleteAll: TCQRSResult;
/// write all pending changes prepared by Add/Update/Delete methods
// - following the dual-phase pattern, nothing would be written to the
// actual persistence store unless this method is actually called
function Commit: TCQRSResult;
/// flush any pending changes prepared by Add/Update/Delete methods
// - is the same as releasing the actual IDomUserCommand instance and
// creating a new one
function Rollback: TCQRSResult;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomUserQuery),TypeInfo(IDomUserCommand)]);
end.

114
contrib/mORMot/SQLite3/DDD/dom/dddDomUserInterfaces.pas Normal file
View File

@@ -0,0 +1,114 @@
/// shared DDD Domains: User interfaces definition
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomUserInterfaces;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SynCommons,
SysUtils,
Classes,
mORMot,
mORMotDDD,
dddDomUserTypes;
type
/// defines a service able to check the correctness of email addresses
// - will be implemented e.g. by TDDDEmailServiceAbstract and
// TDDDEmailValidationService as defined in the dddInfraEmail unit
IDomUserEmailCheck = interface(IInvokable)
['{2942BC2D-84F7-4A79-8657-07F0602C3505}']
/// check if the supplied email address seems correct
function CheckRecipient(const aEmail: RawUTF8): TCQRSResult;
/// check if the supplied email addresses seem correct
function CheckRecipients(const aEmails: TRawUTF8DynArray): TCQRSResult;
end;
/// defines a service sending a confirmation email to validate an email address
// - will be implemented e.g. by TDDDEmailValidationService as defined in
// the dddInfraEmail unit
IDomUserEmailValidation = interface(IDomUserEmailCheck)
['{20129489-5054-4D4A-84B9-463DB98156B8}']
/// internal method used to compute the validation URI
// - will be included as data context to the email template, to create the
// validation link
function ComputeURIForReply(const aLogonName,aEmail: RawUTF8): RawUTF8;
/// initiate an email validation process, using the given template
function StartEmailValidation(const aTemplate: TDomUserEmailTemplate;
const aLogonName,aEmail: RawUTF8): TCQRSResult;
function IsEmailValidated(const aLogonName,aEmail: RawUTF8): boolean;
end;
/// defines a generic service able to send emails
// - will be implemented e.g. by TDDDEmailerDaemon as defined in the
// dddInfraEmailer unit
IDomUserEmailer = interface(IInvokable)
['{20B88FCA-B345-4D5E-8E07-4581C814AFD9}']
function SendEmail(const aRecipients: TRawUTF8DynArray;
const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
end;
/// defines a service for generic rendering of a template
// - will be implemented e.g. via our SynMustache engine by TDDDTemplateAbstract
// and TDDDTemplateFromFolder as defined in the dddInfraEmailer unit
IDomUserTemplate = interface(IInvokable)
['{378ACC52-46BE-488D-B7ED-3F4E59316DFF}']
function ComputeMessage(const aContext: variant;
const aTemplateName: RawUTF8): RawUTF8;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomUserEmailValidation),TypeInfo(IDomUserEmailer),
TypeInfo(IDomUserTemplate)]);
end.

374
contrib/mORMot/SQLite3/DDD/dom/dddDomUserTypes.pas Normal file
View File

@@ -0,0 +1,374 @@
/// shared DDD Domains: User objects definition
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomUserTypes;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SysUtils,
Classes,
SynCommons,
SynTests,
mORMot,
mORMotDDD,
dddDomCountry;
{ *********** Address Modeling }
type
TStreet = type RawUTF8;
TCityArea = type RawUTF8;
TCity = type RawUTF8;
TRegion = type RawUTF8;
TPostalCode = type RawUTF8;
/// Address object
// - we tried to follow a simple but worldwide layout - see
// http://en.wikipedia.org/wiki/Address_%28geography%29#Address_format
TAddress = class(TSynAutoCreateFields)
protected
fStreet1: TStreet;
fStreet2: TStreet;
fCityArea: TCityArea;
fCity: TCity;
fRegion: TRegion;
fCode: TPostalCode;
fCountry: TCountry;
public
function Equals(another: TAddress): boolean; reintroduce;
published
property Street1: TStreet read fStreet1 write fStreet1;
property Street2: TStreet read fStreet2 write fStreet2;
property CityArea: TCityArea read fCityArea write fCityArea;
property City: TCity read fCity write fCity;
property Region: TRegion read fRegion write fRegion;
property Code: TPostalCode read fCode write fCode;
property Country: TCountry read fCountry;
end;
TAddressObjArray = array of TAddress;
{ *********** Person / User / Customer Modeling }
type
TLastName = type RawUTF8;
TFirstName = type RawUTF8;
TMiddleName = type RawUTF8;
TFullName = type RawUTF8;
/// Person full name
TPersonFullName = class(TSynPersistent)
protected
fFirst: TFirstName;
fMiddle: TMiddleName;
fLast: TLastName;
public
function Equals(another: TPersonFullName): boolean; reintroduce;
function FullName(country: TCountryIdentifier=ccUndefined): TFullName; virtual;
published
property First: TFirstName read fFirst write fFirst;
property Middle: TMiddleName read fMiddle write fMiddle;
property Last: TLastName read fLast write fLast;
end;
/// Person birth date
TPersonBirthDate = class(TSynPersistent)
protected
fDate: TDateTime;
public
function Equals(another: TPersonBirthDate): boolean; reintroduce;
function Age: integer; overload;
function Age(FromDate: TDateTime): integer; overload;
published
property Date: TDateTime read fDate write fDate;
end;
/// Person object
TPerson = class(TSynAutoCreateFields)
protected
fBirthDate: TPersonBirthDate;
fName: TPersonFullName;
public
function Equals(another: TPerson): boolean; reintroduce;
published
property Name: TPersonFullName read fName;
property Birth: TPersonBirthDate read fBirthDate;
end;
TPhoneNumber = type RawUTF8;
TEmailAddress = type RawUTF8;
TEmailAddressDynArray = array of TEmailAddress;
/// a Person object, with some contact information
// - an User is a person, in the context of an application
TPersonContactable = class(TPerson)
protected
fAddress: TAddress;
fPhone1: TPhoneNumber;
fPhone2: TPhoneNumber;
fEmail: TEmailAddress;
public
function Equals(another: TPersonContactable): boolean; reintroduce;
/// built-in simple unit tests
class procedure RegressionTests(test: TSynTestCase);
published
property Address: TAddress read fAddress;
property Phone1: TPhoneNumber read fPhone1 write fPhone1;
property Phone2: TPhoneNumber read fPhone2 write fPhone2;
property Email: TEmailAddress read fEmail write fEmail;
end;
TPersonContactableObjArray = array of TPersonContactable;
{ *********** Email Validation Modeling }
type
/// the status of an email validation process
TDomUserEmailValidation = (evUnknown, evValidated, evFailed);
/// how a confirmation email is to be rendered, for email address validation
// - this information will be available as data context, e.g. to the Mustache
// template used for rendering of the email body
TDomUserEmailTemplate = class(TSynPersistent)
private
fFileName: RawUTF8;
fSenderEmail: RawUTF8;
fSubject: RawUTF8;
fApplication: RawUTF8;
fInfo: variant;
published
/// the local file name of the Mustache template
property FileName: RawUTF8 read fFileName write fFileName;
/// the "sender" field of the validation email
property SenderEmail: RawUTF8 read fSenderEmail write fSenderEmail;
/// the "subject" field of the validation email
property Subject: RawUTF8 read fSubject write fSubject;
/// the name of the application, currently sending the confirmation
property Application: RawUTF8 read fApplication write fApplication;
/// any unstructured additional information, also supplied as data context
property Info: variant read fInfo write fInfo;
end;
{ *********** Application User Modeling, with Logon and Email Validation }
type
TLogonName = type RawUTF8;
/// an application level-user, whose account would be authenticated per Email
TUser = class(TPersonContactable)
private
fLogonName: TLogonName;
fEmailValidated: TDomUserEmailValidation;
published
/// the logon name would be the main entry point to the application
property LogonName: TLogonName
read fLogonName write fLogonName;
/// will reflect the current state of email validation process for this user
// - the validation is not handled by this class: this is just a property
// which reflects the state of TDDDEmailValidationService/IDomUserEmailValidation
property EmailValidated: TDomUserEmailValidation
read fEmailValidated write fEmailValidated;
end;
TUserObjArray = array of TUser;
implementation
{ TAddress }
function TAddress.Equals(another: TAddress): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := (another.Street1=Street1) and (another.Street2=Street2) and
(another.CityArea=CityArea) and (another.City=City) and
(another.Region=Region) and another.Country.Equals(Country);
end;
{ TPersonFullName }
function TPersonFullName.Equals(another: TPersonFullName): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := (First=another.First) and (Last=another.Last) and
(Middle=another.Middle);
end;
function TPersonFullName.FullName(country: TCountryIdentifier): TFullName;
begin // see country-specific http://en.wikipedia.org/wiki/Family_name
case country of
ccJP,ccCN,ccTW,ccKP,ccKR,ccVN,ccHU,ccRO:
// Eastern Order
result := Trim(Trim(Last+' '+Middle)+' '+First);
else
// default Western Order
result := Trim(Trim(First+' '+Middle)+' '+Last);
end;
end;
{ TPersonBirthDate }
function TPersonBirthDate.Age: integer;
begin
result := Age(SysUtils.Date);
end;
function TPersonBirthDate.Age(FromDate: TDateTime): integer;
var YF,YD,MF,MD,DF,DD: word;
begin
if (self=nil) or (fDate=0) then
result := 0 else begin
DecodeDate(FromDate,YF,MF,DF);
DecodeDate(fDate,YD,MD,DD);
result := YF-YD;
if MF<MD then
dec(result) else
if (MF=MD) and (DF<DD) then
dec(result);
end;
end;
function TPersonBirthDate.Equals(another: TPersonBirthDate): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := Date=another.Date;
end;
{ TPerson }
function TPerson.Equals(another: TPerson): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := Name.Equals(another.Name) and Birth.Equals(another.Birth);
end;
{ TPersonContactable }
function TPersonContactable.Equals(another: TPersonContactable): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := inherited Equals(Self) and Address.Equals(another.Address) and
(Phone1=another.Phone1) and (Phone2=another.Phone2) and (Email=another.Email);
end;
class procedure TPersonContactable.RegressionTests(test: TSynTestCase);
var p: TPersonContactable;
json: RawUTF8;
valid: boolean;
procedure TestP;
begin
test.Check(p.Phone2='123456');
test.Check(p.Name.Last='Smith');
test.Check(p.Name.First='John');
test.Check(p.Birth.Age(Iso8601ToDateTime('19821030'))=10);
test.Check(p.Address.Country.Alpha3='FRA');
end;
begin
p := TPersonContactable.Create;
with test do
try
p.Phone2 := '123456';
p.Name.Last := 'Smith';
p.Name.First := 'John';
p.Birth.Date := Iso8601ToDateTime('19721029');
Check(p.Birth.Age>40);
Check(p.Birth.Age(Iso8601ToDateTime('19821020'))=9);
Check(p.Birth.Age(Iso8601ToDateTime('19821030'))=10);
p.Address.Country.Alpha2 := 'FR';
json := ObjectToJSON(p)+'*';
finally
p.Free;
end;
p := TPersonContactable.Create;
with test do
try
// FileFromString(JSONReformat(json),'person.json');
Check(ObjectLoadJSON(p,json));
TestP;
finally
p.Free;
end;
p := TPersonContactable.Create;
with test do
try
Check(JSONToObject(p,pointer(json),valid)^='*');
Check(valid);
TestP;
finally
p.Free;
end;
end;
initialization
{$ifndef ISDELPHI2010}
{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug
TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(TypeInfo(TDomUserEmailValidation));
{$endif}
{$endif}
TJSONSerializer.RegisterObjArrayForJSON([
TypeInfo(TAddressObjArray),TAddress,
TypeInfo(TPersonContactableObjArray),TPersonContactable,
TypeInfo(TUserObjArray),TUser]);
end.

2445
contrib/mORMot/SQLite3/DDD/infra/dddInfraApps.pas Normal file
View File

File diff suppressed because it is too large Load Diff

374
contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas Normal file
View File

@@ -0,0 +1,374 @@
/// shared DDD Infrastructure: Authentication implementation
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddInfraAuthRest;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
TODO:
- manage Authentication expiration?
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SysUtils,
Classes,
SynCommons,
SynCrypto,
SynTests,
mORMot,
mORMotDDD,
dddDomAuthInterfaces;
{ ----- Authentication Implementation using SHA-256 dual step challenge }
type
/// ORM object to persist authentication information, i.e. TAuthInfo
TSQLRecordUserAuth = class(TSQLRecord)
protected
fLogon: RawUTF8;
fHashedPassword: RawUTF8;
class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
published
/// will map TAuthInfo.LogonName
// - is defined as "stored AS_UNIQUE" so that it may be used as primary key
property Logon: RawUTF8 read fLogon write fLogon stored AS_UNIQUE;
/// the password, stored in a hashed form
// - this property does not exist at TAuthInfo level, so will be private
// to the storage layer - which is the safest option possible
property HashedPassword: RawUTF8 read fHashedPassword write fHashedPassword;
end;
/// generic class for implementing authentication
// - do not instantiate this abstract class, but e.g. TDDDAuthenticationSHA256
// or TDDDAuthenticationMD5
TDDDAuthenticationAbstract = class(TDDDRepositoryRestCommand,IDomAuthCommand)
protected
fChallengeLogonName: RawUTF8;
fChallengeNonce: TAuthQueryNonce;
fLogged: boolean;
// inherited classes should override this method with the proper algorithm
class function DoHash(const aValue: TAuthQueryNonce): TAuthQueryNonce; virtual; abstract;
public
/// initiate the first phase of a dual pass challenge authentication
function ChallengeSelectFirst(const aLogonName: RawUTF8): TAuthQueryNonce;
/// validate the first phase of a dual pass challenge authentication
function ChallengeSelectFinal(const aChallengedPassword: TAuthQueryNonce): TCQRSResult;
/// set the credential for Get() or further IDomAuthCommand.Update/Delete
// - this method execution will be disabled for most clients
function SelectByName(const aLogonName: RawUTF8): TCQRSResult;
/// returns TRUE if the dual pass challenge did succeed
function Logged: boolean;
/// returns the logon name of the authenticated user
function LogonName: RawUTF8;
/// retrieve some information about the current selected credential
function Get(out aAggregate: TAuthInfo): TCQRSResult;
/// register a new credential, from its LogonName/HashedPassword values
// - on success, the newly created credential will be the currently selected
function Add(const aLogonName: RawUTF8; aHashedPassword: TAuthQueryNonce): TCQRSResult;
/// update the current selected credential password
function UpdatePassword(const aHashedPassword: TAuthQueryNonce): TCQRSResult;
/// class method to be used to compute a password hash from its plain value
class function ComputeHashPassword(const aLogonName,aPassword: RawUTF8): TAuthQueryNonce;
/// class method to be used on the client side to resolve the challenge
// - is basically
// ! result := DoHash(aLogonName+':'+aChallengeFromServer+':'+
// ! ComputeHashPassword(aLogonName,aPlainPassword));
class function ClientComputeChallengedPassword(
const aLogonName,aPlainPassword: RawUTF8;
const aChallengeFromServer: TAuthQueryNonce): TAuthQueryNonce; virtual;
/// built-in simple unit tests
class procedure RegressionTests(test: TSynTestCase);
end;
/// allows to specify which actual hashing algorithm would be used
// - i.e. either TDDDAuthenticationSHA256 or TDDDAuthenticationMD5
TDDDAuthenticationClass = class of TDDDAuthenticationAbstract;
/// implements authentication using SHA-256 hashing
// - more secure than TDDDAuthenticationMD5
TDDDAuthenticationSHA256 = class(TDDDAuthenticationAbstract)
protected
/// will use SHA-256 algorithm for hashing, and the class name as salt
class function DoHash(const aValue: TAuthQueryNonce): TAuthQueryNonce; override;
end;
/// implements authentication using MD5 hashing
// - less secure than TDDDAuthenticationSHA256
TDDDAuthenticationMD5 = class(TDDDAuthenticationAbstract)
protected
/// will use MD5 algorithm for hashing, and the class name as salt
class function DoHash(const aValue: TAuthQueryNonce): TAuthQueryNonce; override;
end;
/// abstract factory of IDomAuthCommand repository instances using REST
TDDDAuthenticationRestFactoryAbstract = class(TDDDRepositoryRestFactory)
protected
public
/// initialize a factory with the supplied implementation algorithm
constructor Create(aRest: TSQLRest; aImplementationClass: TDDDAuthenticationClass;
aOwner: TDDDRepositoryRestManager); reintroduce;
end;
/// factory of IDomAuthCommand repository instances using a RESTful ORM access
// and SHA-256 hashing algorithm
TDDDAuthenticationRestFactorySHA256 = class(TDDDAuthenticationRestFactoryAbstract)
protected
public
/// initialize a factory with the SHA-256 implementation algorithm
constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
end;
/// factory of IDomAuthCommand repository instances using a RESTful ORM access
// and SHA-256 hashing algorithm
TDDDAuthenticationRestFactoryMD5 = class(TDDDAuthenticationRestFactoryAbstract)
protected
public
/// initialize a factory with the SHA-256 implementation algorithm
constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
end;
implementation
{ TDDDAuthenticationAbstract }
function TDDDAuthenticationAbstract.ChallengeSelectFirst(
const aLogonName: RawUTF8): TAuthQueryNonce;
begin
fLogged := false;
fChallengeLogonName := Trim(aLogonName);
fChallengeNonce := DoHash(aLogonName+NowToString);
result := fChallengeNonce;
end;
function TDDDAuthenticationAbstract.ChallengeSelectFinal(
const aChallengedPassword: TAuthQueryNonce): TCQRSResult;
begin
if (fChallengeLogonName='') or (fChallengeNonce='') then
result := CqrsSetResultError(cqrsBadRequest) else
result := SelectByName(fChallengeLogonName);
if result<>cqrsSuccess then
exit;
CqrsBeginMethod(qaNone, result);
if DoHash(fChallengeLogonName+':'+fChallengeNonce+':'+
(fCurrentORMInstance as TSQLRecordUserAuth).HashedPassword)=aChallengedPassword then begin
fLogged := true;
CqrsSetResult(cqrsSuccess,result);
end else
CqrsSetResultMsg(cqrsBadRequest,'Wrong Password for [%]',[fChallengeLogonName],result);
fChallengeNonce := '';
fChallengeLogonName := '';
end;
function TDDDAuthenticationAbstract.LogonName: RawUTF8;
begin
if (fCurrentORMInstance=nil) or not Logged then
result := '' else
result := TSQLRecordUserAuth(fCurrentORMInstance).Logon;
end;
function TDDDAuthenticationAbstract.Logged: boolean;
begin
result := fLogged;
end;
class function TDDDAuthenticationAbstract.ComputeHashPassword(
const aLogonName, aPassword: RawUTF8): TAuthQueryNonce;
begin
result := DoHash(aLogonName+':'+aPassword);
end;
class function TDDDAuthenticationAbstract.ClientComputeChallengedPassword(
const aLogonName,aPlainPassword: RawUTF8; const aChallengeFromServer: TAuthQueryNonce): TAuthQueryNonce;
begin // see TDDDAuthenticationAbstract.ChallengeSelectFinal
result := DoHash(aLogonName+':'+aChallengeFromServer+':'+
ComputeHashPassword(aLogonName,aPlainPassword));
end;
function TDDDAuthenticationAbstract.SelectByName(
const aLogonName: RawUTF8): TCQRSResult;
begin
result := ORMSelectOne('Logon=?',[aLogonName],(aLogonName=''));
end;
function TDDDAuthenticationAbstract.Get(
out aAggregate: TAuthInfo): TCQRSResult;
begin
result := ORMGetAggregate(aAggregate);
end;
function TDDDAuthenticationAbstract.Add(const aLogonName: RawUTF8;
aHashedPassword: TAuthQueryNonce): TCQRSResult;
begin
if not CqrsBeginMethod(qaCommandDirect,result) then
exit;
with fCurrentORMInstance as TSQLRecordUserAuth do begin
Logon := aLogonName;
HashedPassword := aHashedPassword;
end;
ORMPrepareForCommit(soInsert,nil,result);
end;
function TDDDAuthenticationAbstract.UpdatePassword(
const aHashedPassword: TAuthQueryNonce): TCQRSResult;
begin
if not CqrsBeginMethod(qaCommandOnSelect,result) then
exit;
(fCurrentORMInstance as TSQLRecordUserAuth).HashedPassword := aHashedPassword;
ORMPrepareForCommit(soUpdate,nil,result);
end;
class procedure TDDDAuthenticationAbstract.RegressionTests(
test: TSynTestCase);
var Factory: TDDDAuthenticationRestFactoryAbstract;
procedure TestOne;
const MAX=2000;
var auth: IDomAuthCommand;
nonce,challenge: TAuthQueryNonce;
log,pass: RawUTF8;
info: TAuthInfo;
i: integer;
begin
test.Check(Factory.GetOneInstance(auth));
for i := 1 to MAX do begin
UInt32ToUtf8(i,log);
UInt32ToUtf8(i*7,pass);
test.Check(auth.Add(log,ComputeHashPassword(log,pass))=cqrsSuccess);
end;
test.Check(auth.Commit=cqrsSuccess);
test.Check(Factory.GetOneInstance(auth));
info := TAuthInfo.Create;
try
for i := 1 to MAX do begin
UInt32ToUtf8(i,log);
UInt32ToUtf8(i*7,pass);
nonce := auth.ChallengeSelectFirst(log);
test.Check(nonce<>'');
challenge := ClientComputeChallengedPassword(log,pass,nonce);
test.Check(auth.ChallengeSelectFinal(challenge)=cqrsSuccess);
test.Check(auth.Get(info)=cqrsSuccess);
test.Check(info.LogonName=log);
end;
finally
info.Free;
end;
end;
var Rest: TSQLRestServerFullMemory;
begin
Rest := TSQLRestServerFullMemory.CreateWithOwnModel([TSQLRecordUserAuth]);
try
Factory := TDDDAuthenticationRestFactoryAbstract.Create(Rest,self,nil);
try
TestOne; // sub function to ensure that all I*Command are released
finally
Factory.Free;
end;
finally
Rest.Free;
end;
end;
{ TDDDAuthenticationSHA256 }
class function TDDDAuthenticationSHA256.DoHash(
const aValue: TAuthQueryNonce): TAuthQueryNonce;
begin
result := SHA256(RawUTF8(ClassName)+aValue);
end;
{ TDDDAuthenticationMD5 }
class function TDDDAuthenticationMD5.DoHash(
const aValue: TAuthQueryNonce): TAuthQueryNonce;
begin
result := MD5(RawUTF8(ClassName)+aValue);
end;
{ TDDDAuthenticationRestFactoryAbstract }
constructor TDDDAuthenticationRestFactoryAbstract.Create(aRest: TSQLRest;
aImplementationClass: TDDDAuthenticationClass;
aOwner: TDDDRepositoryRestManager);
begin
inherited Create(
IDomAuthCommand,aImplementationClass,TAuthInfo,aRest,TSQLRecordUserAuth,
['Logon','LogonName'],aOwner);
end;
{ TDDDAuthenticationRestFactorySHA256 }
constructor TDDDAuthenticationRestFactorySHA256.Create(aRest: TSQLRest;
aOwner: TDDDRepositoryRestManager);
begin
inherited Create(aRest,TDDDAuthenticationSHA256,aOwner);
end;
{ TDDDAuthenticationRestFactoryMD5 }
constructor TDDDAuthenticationRestFactoryMD5.Create(aRest: TSQLRest;
aOwner: TDDDRepositoryRestManager);
begin
inherited Create(aRest,TDDDAuthenticationMD5,aOwner);
end;
{ TSQLRecordUserAuth }
class procedure TSQLRecordUserAuth.InternalDefineModel(
Props: TSQLRecordProperties);
begin
AddFilterNotVoidText(['Logon','HashedPassword']);
end;
end.

473
contrib/mORMot/SQLite3/DDD/infra/dddInfraEmail.pas Normal file
View File

@@ -0,0 +1,473 @@
/// shared DDD Infrastructure: implement an email validation service
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddInfraEmail;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SysUtils,
SynCommons,
SynTests,
SynCrypto,
SynTable, // for TSynFilter and TSynValidate
mORMot,
mORMotDDD,
dddDomUserTypes,
dddDomUserInterfaces;
{ ****************** Email Verification Service }
type
/// exception raised during any email process of this DDD's infrastructure
// implementation
EDDDEmail = class(EDDDInfraException);
/// parameters used for the validation link of an email address
// - may be stored as daemon/service level settings, using e.g. dddInfraSettings
TDDDEmailRedirection = class(TSynPersistent)
private
fSuccessRedirectURI: RawUTF8;
fRestServerPublicRootURI: RawUTF8;
fValidationMethodName: RawUTF8;
published
/// the public URI which would be accessible from the Internet
// - may be e.g 'http://publicserver/restroot'
property RestServerPublicRootURI: RawUTF8
read fRestServerPublicRootURI write fRestServerPublicRootURI;
/// the validation method name for the URI
// - if not set, TDDDEmailValidationService will use 'EmailValidate'
// - clickable URI would be RestServerPublicRootURI+'/'+ValidationMethodName
property ValidationMethodName: RawUTF8
read fValidationMethodName write fValidationMethodName;
/// the URI on which the browser will be redirected on validation success
// - you can specify some '%' parameter markers, ordered as logon, email,
// and validation IP
// - may be e.g. 'http://publicwebsite/success&logon=%'
property SuccessRedirectURI: RawUTF8
read fSuccessRedirectURI write fSuccessRedirectURI;
end;
/// parameters used for the validation/verification process of an email address
// - may be stored as daemon/service level settings, using e.g. dddInfraSettings
TDDDEmailValidation = class(TSynAutoCreateFields)
private
fTemplate: TDomUserEmailTemplate;
fTemplateFolder: TFileName;
fRedirection: TDDDEmailRedirection;
public
/// will fill some default values in the properties, if none is set
procedure SetDefaultValuesIfVoid(const aSenderEmail,aApplication,
aRedirectionURIPublicRoot,aRedirectionURISuccess: RawUTF8);
published
/// how the email should be created from a given template
property Template: TDomUserEmailTemplate read fTemplate;
/// where the template files are to be found
property TemplateFolder: TFileName
read fTemplateFolder write fTemplateFolder;
/// parameters defining the validation link of an email address
property Redirection: TDDDEmailRedirection read fRedirection;
end;
TSQLRecordEmailAbstract = class;
TSQLRecordEmailValidation = class;
TSQLRecordEmailValidationClass = class of TSQLRecordEmailValidation;
/// abstract parent of any email-related service
// - will define some common methods to validate an email address
TDDDEmailServiceAbstract = class(TCQRSQueryObjectRest,IDomUserEmailCheck)
protected
fEmailValidate: TSynValidate;
function CheckEmailCorrect(aEmail: TSQLRecordEmailAbstract;
var aResult: TCQRSResult): boolean; virtual;
procedure SetEmailValidate(const Value: TSynValidate); virtual;
public
constructor Create(aRest: TSQLRest); override;
destructor Destroy; override;
function CheckRecipient(const aEmail: RawUTF8): TCQRSResult; virtual;
function CheckRecipients(const aEmails: TRawUTF8DynArray): TCQRSResult;
published
/// direct access to the email validation instance
// - you can customize the default TSynValidateEmail to meet your own
// expectations - once set, it will be owned by this class instance
property EmailValidate: TSynValidate read fEmailValidate write SetEmailValidate;
end;
/// service used to validate an email address via an URL link to be clicked
TDDDEmailValidationService = class(TDDDEmailServiceAbstract,
IDomUserEmailValidation)
protected
fRestClass: TSQLRecordEmailValidationClass;
fEMailer: IDomUserEmailer;
fTemplate: IDomUserTemplate;
fValidationSalt: integer;
fValidationServerRoot: RawUTF8;
fValidationMethodName: RawUTF8;
fSuccessRedirectURI: RawUTF8;
function GetEmailValidation(const aLogonName: RawUTF8): TSQLRecordEmailValidation;
function GetWithSalt(const aLogonName,aEmail: RawUTF8; aSalt: integer): RawUTF8;
procedure EmailValidate(Ctxt: TSQLRestServerURIContext);
public
/// initialize the validation service for a given ORM persistence
// - would recognize the TSQLRecordEmailValidation class from aRest.Model
// - will use aRest.Services for IoC, e.g. EMailer/Template properties
constructor Create(aRest: TSQLRest); override;
/// register the callback URI service
procedure SetURIForServer(aRestServerPublic: TSQLRestServer;
aParams: TDDDEmailRedirection); overload;
/// register the callback URI service
// - same as the overloaded function, but taking parameters one by one
procedure SetURIForServer(aRestServerPublic: TSQLRestServer;
const aRestServerPublicRootURI,aSuccessRedirectURI,aValidationMethodName: RawUTF8); overload;
/// compute the target URI corresponding to SetURIForServer() parameters
function ComputeURIForReply(const aLogonName,aEmail: RawUTF8): RawUTF8;
/// check the supplied parameters, and send an email for validation
function StartEmailValidation(const aTemplate: TDomUserEmailTemplate;
const aLogonName,aEmail: RawUTF8): TCQRSResult; virtual;
/// check if an email has been validated for a given logon
function IsEmailValidated(const aLogonName,aEmail: RawUTF8): boolean; virtual;
published
/// will be injected (and freed) with the emailer service
property EMailer: IDomUserEmailer read fEmailer;
/// will be injected (and freed) with the email template service
property Template: IDomUserTemplate read fTemplate;
published
/// the associated ORM class used to store the email validation process
// - any class inheriting from TSQLRecordEmailValidation in the aRest.Model
// will be recognized by Create(aRest) to store its information
// - this temporary storage should not be the main user persistence domain
property RestClass: TSQLRecordEmailValidationClass read fRestClass;
/// the validation method name for the URI
// - if not set, TDDDEmailValidationService will use 'EmailValidate'
// - clickable URI would be ValidationServerRoot+'/'+ValidationMethodName
property ValidationURI: RawUTF8 read fValidationMethodName;
/// the public URI which would be accessible from the Internet
// - may be e.g 'http://publicserver/restroot'
property ValidationServerRoot: RawUTF8 read fValidationServerRoot;
end;
/// ORM class storing an email in addition to creation/modification timestamps
// - declared as its own class, since may be reused
TSQLRecordEmailAbstract = class(TSQLRecordTimed)
private
fEmail: RawUTF8;
published
/// the stored email address
property Email: RawUTF8 read fEmail write fEmail;
end;
/// ORM class for email validation process
// - we do not create a whole domain here, just an ORM persistence layer
// - any class inheriting from TSQLRecordEmailValidation in the Rest.Model
// will be recognized by TDDDEmailValidationService to store its information
TSQLRecordEmailValidation = class(TSQLRecordEmailAbstract)
protected
fLogon: RawUTF8;
fRequestTime: TTimeLog;
fValidationSalt: Integer;
fValidationTime: TTimeLog;
fValidationIP: RawUTF8;
public
function IsValidated(const aEmail: RawUTF8): Boolean;
published
property Logon: RawUTF8 read fLogon write fLogon stored AS_UNIQUE;
property RequestTime: TTimeLog read fRequestTime write fRequestTime;
property ValidationSalt: Integer read fValidationSalt write fValidationSalt;
property ValidationTime: TTimeLog read fValidationTime write fValidationTime;
property ValidationIP: RawUTF8 read fValidationIP write fValidationIP;
end;
implementation
{ TDDDEmailServiceAbstract }
constructor TDDDEmailServiceAbstract.Create(aRest: TSQLRest);
begin
inherited Create(aRest);
fEmailValidate := TSynValidateEmail.Create;
end;
destructor TDDDEmailServiceAbstract.Destroy;
begin
fEmailValidate.Free;
inherited;
end;
function TDDDEmailServiceAbstract.CheckEmailCorrect(
aEmail: TSQLRecordEmailAbstract; var aResult: TCQRSResult): boolean;
var msg: string;
begin
if (aEmail<>nil) and fEmailValidate.Process(0,aEmail.Email,msg) and
aEmail.FilterAndValidate(Rest,msg) then
result := true else begin
CqrsSetResultString(cqrsDDDValidationFailed,msg,aResult);
result := false;
end;
end;
function TDDDEmailServiceAbstract.CheckRecipient(
const aEmail: RawUTF8): TCQRSResult;
var msg: string;
begin
CqrsBeginMethod(qaNone,result);
if fEmailValidate.Process(0,aEmail,msg) then
CqrsSetResult(cqrsSuccess,result) else
CqrsSetResultString(cqrsDDDValidationFailed,msg,result);
end;
function TDDDEmailServiceAbstract.CheckRecipients(
const aEmails: TRawUTF8DynArray): TCQRSResult;
var msg: string;
i: integer;
begin
CqrsBeginMethod(qaNone,result);
for i := 0 to high(aEMails) do
if not fEmailValidate.Process(0,aEmails[i],msg) then begin
CqrsSetResultString(cqrsDDDValidationFailed,msg,result);
exit;
end;
CqrsSetResult(cqrsSuccess,result);
end;
procedure TDDDEmailServiceAbstract.SetEmailValidate(
const Value: TSynValidate);
begin
fEmailValidate.Free;
fEmailValidate := Value;
end;
{ TDDDEmailValidationService }
constructor TDDDEmailValidationService.Create(aRest: TSQLRest);
var rnd: Int64;
begin
inherited Create(aRest); // will inject aRest.Services for IoC
fRestClass := fRest.Model.AddTableInherited(TSQLRecordEmailValidation);
fRestClass.AddFilterNotVoidText(['Email','Logon']);
rnd := GetTickCount64*PtrInt(self)*Random(MaxInt);
fValidationSalt := crc32c(PtrInt(self),@rnd,sizeof(rnd));
end;
function TDDDEmailValidationService.GetWithSalt(const aLogonName,
aEmail: RawUTF8; aSalt: integer): RawUTF8;
begin
result := SHA256(FormatUTF8('%'#1'%'#2'%'#3,[aLogonName,aEmail,aSalt]));
end;
function TDDDEmailValidationService.ComputeURIForReply(
const aLogonName, aEmail: RawUTF8): RawUTF8;
begin
result := aLogonName+#1+aEmail;
result := fValidationServerRoot+fValidationMethodName+'/'+
GetWithSalt(aLogonName,aEmail,fValidationSalt)+
BinToBase64URI(pointer(result),length(result));
end;
procedure TDDDEmailValidationService.EmailValidate(
Ctxt: TSQLRestServerURIContext);
var code: RawUTF8;
logon,email,signature: RawUTF8;
EmailValidation: TSQLRecordEmailValidation;
begin
signature := Copy(Ctxt.URIBlobFieldName,1,SHA256DIGESTSTRLEN);
if length(signature)<>SHA256DIGESTSTRLEN then
exit;
code := Base64uriToBin(Copy(Ctxt.URIBlobFieldName,SHA256DIGESTSTRLEN+1,200));
Split(code,#1,logon,email);
if (logon='') or (email='') then
exit;
EmailValidation := GetEmailValidation(logon);
if EmailValidation<>nil then
try
if signature=GetWithSalt(logon,email,EmailValidation.ValidationSalt) then begin
EmailValidation.ValidationTime := TimeLogNowUTC;
EmailValidation.ValidationIP := Ctxt.InHeader['remoteip'];
if Rest.Update(EmailValidation) then
Ctxt.Redirect(FormatUTF8(fSuccessRedirectURI,
[UrlEncode(logon),UrlEncode(email),UrlEncode(EmailValidation.ValidationIP)]));
end;
finally
EmailValidation.Free;
end;
end;
procedure TDDDEmailValidationService.SetURIForServer(
aRestServerPublic: TSQLRestServer; aParams: TDDDEmailRedirection);
begin
if aParams=nil then
raise EDDDEmail.CreateUTF8('Invalid %.SetURIForServer(%,nil)',
[self,aRestServerPublic]);
SetURIForServer(aRestServerPublic,aParams.RestServerPublicRootURI,
aParams.SuccessRedirectURI,aParams.ValidationMethodName);
end;
procedure TDDDEmailValidationService.SetURIForServer(
aRestServerPublic: TSQLRestServer; const aRestServerPublicRootURI,
aSuccessRedirectURI, aValidationMethodName: RawUTF8);
begin
fSuccessRedirectURI := Trim(aSuccessRedirectURI);
fValidationServerRoot := IncludeTrailingURIDelimiter(Trim(aRestServerPublicRootURI));
if (aRestServerPublic=nil) or (fSuccessRedirectURI='') or (fValidationServerRoot='') then
raise EDDDEmail.CreateUTF8('Invalid %.SetURIForServer(%,"%","%")',
[self,aRestServerPublic,fValidationServerRoot,fSuccessRedirectURI]);
if not IdemPChar(pointer(fValidationServerRoot),'HTTP') then
fValidationServerRoot := 'http://'+fValidationServerRoot;
fValidationMethodName := Trim(aValidationMethodName);
if fValidationMethodName='' then
fValidationMethodName := 'EmailValidate'; // match method name by default
aRestServerPublic.ServiceMethodRegister(fValidationMethodName,EmailValidate,true);
end;
function TDDDEmailValidationService.GetEmailValidation(const aLogonName: RawUTF8): TSQLRecordEmailValidation;
begin
result := RestClass.Create(Rest,'Logon=?',[aLogonName]);
if result.fID=0 then
FreeAndNil(result);
end;
function TDDDEmailValidationService.IsEmailValidated(const aLogonName,
aEmail: RawUTF8): boolean;
var EmailValidation: TSQLRecordEmailValidation;
begin
EmailValidation := GetEmailValidation(aLogonName);
try
result := EmailValidation.IsValidated(trim(aEmail));
finally
EmailValidation.Free;
end;
end;
function TDDDEmailValidationService.StartEmailValidation(
const aTemplate: TDomUserEmailTemplate; const aLogonName, aEmail: RawUTF8): TCQRSResult;
var EmailValidation: TSQLRecordEmailValidation;
email,msg: RawUTF8;
context: variant;
begin
email := Trim(aEmail);
result := CheckRecipient(email);
if result<>cqrsSuccess then
exit; // supplied email address is invalid
CqrsBeginMethod(qaNone,result);
EmailValidation := GetEmailValidation(aLogonName);
try
if EmailValidation.IsValidated(email) then begin
CqrsSetResultMsg(cqrsSuccess,'Already validated',result);
exit;
end;
if EmailValidation=nil then begin
EmailValidation := RestClass.Create;
EmailValidation.Email := aEmail;
EmailValidation.Logon := aLogonName;
if not CheckEmailCorrect(EmailValidation,result) then
exit;
end else
if EmailValidation.Email<>email then
EmailValidation.Email := email; // allow validation for a new email
EmailValidation.RequestTime := TimeLogNowUTC;
EmailValidation.ValidationSalt := fValidationSalt;
context := EmailValidation.GetSimpleFieldsAsDocVariant(true);
_ObjAddProps(aTemplate,context);
_ObjAddProps(['ValidationUri',
ComputeURIForReply(EmailValidation.Logon,EmailValidation.Email)],context);
msg := Template.ComputeMessage(context,aTemplate.FileName);
if msg='' then
CqrsSetResultMsg(cqrsInvalidContent,
'Impossible to render template [%]',[aTemplate.FileName],result) else
if EMailer.SendEmail(TRawUTF8DynArrayFrom([aEmail]),
aTemplate.SenderEmail,aTemplate.Subject,'',msg)=cqrsSuccess then
if Rest.AddOrUpdate(EmailValidation)=0 then
CqrsSetResultError(cqrsDataLayerError) else
CqrsSetResultMsg(cqrsSuccess,'Validation email sent',result);
finally
EmailValidation.Free;
end;
end;
{ TSQLRecordEmailValidation }
function TSQLRecordEmailValidation.IsValidated(const aEmail: RawUTF8): Boolean;
begin
result := (self<>nil) and (ValidationTime<>0) and (Email=aEmail);
end;
{ TDDDEmailValidation }
procedure TDDDEmailValidation.SetDefaultValuesIfVoid(
const aSenderEmail,aApplication,
aRedirectionURIPublicRoot,aRedirectionURISuccess: RawUTF8);
begin
if Template.SenderEmail='' then
Template.SenderEmail := aSenderEmail;
if Template.Application='' then
Template.Application := aApplication;
if Template.FileName='' then
Template.FileName := 'EmailValidate.txt';
if (TemplateFolder='') and
not FileExists(string(Template.FileName)) then
FileFromString('Welcome to {{Application}}!'#13#10#13#10+
'You have registered as "{{Logon}}", using {{EMail}} as contact address.'#13#10#13#10+
'Please click on the following link to validate your email:'#13#10+
'{{ValidationUri}}'#13#10#13#10'Best regards from the clouds'#13#10#13#10+
'(please do not respond to this email)',
UTF8ToString(Template.FileName));
if Template.Subject='' then
Template.Subject := 'Please Validate Your Email';
if Redirection.RestServerPublicRootURI='' then
Redirection.RestServerPublicRootURI := aRedirectionURIPublicRoot;
if Redirection.SuccessRedirectURI='' then
Redirection.SuccessRedirectURI := aRedirectionURISuccess;
end;
end.

804
contrib/mORMot/SQLite3/DDD/infra/dddInfraEmailer.pas Normal file
View File

@@ -0,0 +1,804 @@
/// shared DDD Infrastructure: generic emailing service
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddInfraEmailer;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
{$ifdef MSWINDOWS}
Windows, // for fSafe.Lock/Unlock inlining
{$endif}
{$ifdef KYLIX3}
Types,
LibC,
{$endif}
SysUtils,
Classes,
SynCommons,
SynLog,
SynTests,
SynCrtSock,
SynMustache,
SynTable,
SyncObjs,
mORMot,
mORMotDDD,
dddDomUserTypes,
dddDomUserInterfaces,
dddInfraEmail; // for TDDDEmailServiceAbstract
{ ****************** Email Sending Service }
type
/// used to inject the exact SMTP process to TDDDEmailerDaemon
ISMTPServerConnection = interface(IInvokable)
['{00479813-4CAB-4563-BD51-AB6606BC7BEE}']
/// this method should send the email, returning an error message on issue
// - if no header is supplied, it will expect one UTF-8 encoded text message
function SendEmail(const aRecipient: TRawUTF8DynArray;
const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8;
end;
/// abstract class used to resolve ISMTPServerConnection
// - see TSMTPServerSocket for actual implementation
TSMTPServer = class(TInterfaceResolverForSingleInterface)
protected
fAddress: RawUTF8;
fPort: cardinal;
fLogin: RawUTF8;
fPassword: RawUTF8;
function CreateInstance: TInterfacedObject; override;
public
/// initialize the class with the supplied parameters
constructor Create(aImplementation: TInterfacedObjectClass;
const aAddress: RawUTF8; aPort: cardinal; const aLogin,aPassword: RawUTF8); overload;
/// initialize the class with the parameters of another TSMTPServer instance
// - in fact, TSMTPServer could be used as parameter storage of its needed
// published properties, e.g. in a TApplicationSettingsAbstract sub-class
constructor Create(aImplementation: TInterfacedObjectClass;
aParameters: TSMTPServer); overload;
/// will fill some default values in the properties, if none is set
// - i.e. 'dummy:dummy@localhost:25'
procedure SetDefaultValuesIfVoid;
published
property Address: RawUTF8 read fAddress write fAddress;
property Port: cardinal read fPort write fPort;
property Login: RawUTF8 read fLogin write fLogin;
property Password: RawUTF8 read fPassword write fPassword;
end;
/// implements an abstract ISMTPServerConnection class
TSMTPServerSocketConnectionAbstract = class(TInterfacedObject,ISMTPServerConnection)
protected
fOwner: TSMTPServer;
public
constructor Create(aOwner: TSMTPServer); virtual;
function SendEmail(const aRecipient: TRawUTF8DynArray;
const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8; virtual; abstract;
end;
TSMTPServerSocketConnectionAbstractClass = class of TSMTPServerSocketConnectionAbstract;
/// implements ISMTPServerConnection using SynCrtSock's low-level SMTP access
TSMTPServerSocketConnection = class(TSMTPServerSocketConnectionAbstract)
protected
fSocket: TCrtSocket;
procedure Expect(const Answer: RawByteString);
procedure Exec(const Command, Answer: RawByteString);
public
constructor Create(aOwner: TSMTPServer); override;
destructor Destroy; override;
function SendEmail(const aRecipient: TRawUTF8DynArray;
const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8; override;
end;
TSQLRecordEmailer = class;
TSQLRecordEmailerClass = class of TSQLRecordEmailer;
TDDDEmailerDaemon = class;
/// statistics about a TDDDEmailerDaemon instance
// - in addition to a standard TSynMonitor, will maintain the connection count
TDDDEmailerDaemonStats = class(TSynMonitorWithSize)
protected
fConnection: cardinal;
procedure LockedSum(another: TSynMonitor); override;
public
/// will increase the connection count
procedure NewConnection;
published
/// the connection count
property Connection: cardinal read fConnection;
end;
/// thread processing a SMTP connection
TDDDEmailerDaemonProcess = class(TDDDMonitoredDaemonProcessRest)
protected
fSMTPConnection: ISMTPServerConnection;
// all the low-level process will take place in those overriden methods
function ExecuteRetrievePendingAndSetProcessing: boolean; override;
function ExecuteProcessAndSetResult: QWord; override;
procedure ExecuteIdle; override;
end;
/// daemon used to send emails via SMTP
// - it will maintain a list of action in a TSQLRecordEmailer ORM storage
TDDDEmailerDaemon = class(TDDDMonitoredDaemon,IDomUserEmailer)
protected
fRestClass: TSQLRecordEmailerClass;
fSMTPServer: TSMTPServer;
public
constructor Create(aRest: TSQLRest); overload; override;
constructor Create(aRest: TSQLRest; aSMTPServer: TSMTPServer;
aConnectionPool: integer=1); reintroduce; overload;
/// this is the main entry point of this service
// - here the supplied message body is already fully encoded, as
// expected by SMTP (i.e. as one text message, or multi-part encoded)
// - if no header is supplied, it will expect one UTF-8 encoded text message
function SendEmail(const aRecipients: TRawUTF8DynArray;
const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
published
/// the associated class TSQLRecordEmailer used for status persistence
// - any class inheriting from TSQLRecordEmailer in the Rest.Model
// will be recognized by TDDDEmailerDaemon to store its information
property RestClass: TSQLRecordEmailerClass read fRestClass;
/// the associated class used as actual SMTP client
property SMTPServer: TSMTPServer read fSMTPServer write fSMTPServer;
end;
/// state machine used during email validation process
TSQLRecordEmailerState = (esPending, esSending, esSent, esFailed);
/// ORM class for email validation process
// - we do not create a whole domain here, just an ORM persistence layer
TSQLRecordEmailer = class(TSQLRecordTimed)
private
fSender: RawUTF8;
fRecipients: TRawUTF8DynArray;
fSubject: RawUTF8;
fHeaders: RawUTF8;
fErrorMsg: RawUTF8;
fSendTime: TTimeLog;
fMessageCompressed: TByteDynArray; // will be transmitted as Base64 JSON
fState: TSQLRecordEmailerState;
public
// will create an index on State+ID
class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;
Options: TSQLInitializeTableOptions); override;
published
property Sender: RawUTF8 read fSender write fSender;
property Recipients: TRawUTF8DynArray read fRecipients write fRecipients;
property Subject: RawUTF8 read fSubject write fSubject;
property Headers: RawUTF8 read fHeaders write fHeaders;
property State: TSQLRecordEmailerState read fState write fState;
property MessageCompressed: TByteDynArray read fMessageCompressed write fMessageCompressed;
property SendTime: TTimeLog read fSendTime write fSendTime;
property ErrorMsg: RawUTF8 read fErrorMsg write fErrorMsg;
end;
{ ****************** Mustache-Based Templating Service }
type
/// abstract Mustache-Based templating
TDDDTemplateAbstract = class(TCQRSService,IDomUserTemplate)
protected
fPartials: TSynMustachePartials;
fHelpers: TSynMustacheHelpers;
fOnTranslate: TOnStringTranslate;
fCache: TSynCache;
function RetrieveTemplate(const aTemplateName: RawUTF8;
out aTemplate, aType: RawUTF8): boolean; virtual; abstract;
public
destructor Destroy; override;
function ComputeMessage(const aContext: variant;
const aTemplateName: RawUTF8): RawUTF8;
property Partials: TSynMustachePartials read fPartials write fPartials;
property Helpers: TSynMustacheHelpers read fHelpers write fHelpers;
property OnTranslate: TOnStringTranslate read fOnTranslate write fOnTranslate;
end;
/// Mustache-Based templating from a local folder
TDDDTemplateFromFolder = class(TDDDTemplateAbstract)
protected
fFolder: TFileName;
fMemoryCacheSize: integer;
function RetrieveTemplate(const aTemplateName: RawUTF8;
out aTemplate, aType: RawUTF8): boolean; override;
procedure SetFolder(const Value: TFileName); virtual;
procedure SetMemoryCacheSize(const Value: integer);
public
constructor Create(const aTemplateFolder: TFileName;
aMemoryCacheSize: integer=1024*2048); reintroduce;
published
property Folder: TFileName read fFolder write SetFolder;
property MemoryCacheSize: integer read fMemoryCacheSize write SetMemoryCacheSize;
end;
/// you can call this function within a TSynTestCase class to validate
// the email validation via a full regression set
// - could be used as such:
// !procedure TTestCrossCuttingFeatures.Emailer;
// !begin // TSQLRestServerDB is injected to avoid any dependency to mORMotSQLite3
// ! TestDddInfraEmailer(TSQLRestServerDB,self);
// !end;
procedure TestDddInfraEmailer(serverClass: TSQLRestServerClass; test: TSynTestCase);
implementation
{ ****************** Email Sending Service }
{ TSMTPServer }
function TSMTPServer.CreateInstance: TInterfacedObject;
begin
result := TSMTPServerSocketConnectionAbstractClass(fImplementation.ItemClass).
Create(self);
end;
constructor TSMTPServer.Create(aImplementation: TInterfacedObjectClass;
const aAddress: RawUTF8; aPort: cardinal; const aLogin, aPassword: RawUTF8);
begin
inherited Create(TypeInfo(ISMTPServerConnection),aImplementation);
fAddress := aAddress;
fPort := aPort;
fLogin := aLogin;
fPassword := aPassword;
end;
constructor TSMTPServer.Create(aImplementation: TInterfacedObjectClass;
aParameters: TSMTPServer);
begin
if (aParameters=nil) or (aImplementation=nil) then
raise EDDDEmail.CreateUTF8('%.Create(nil)',[self]);
Create(aImplementation,
aParameters.Address,aParameters.Port,aParameters.Login,aParameters.Password);
end;
procedure TSMTPServer.SetDefaultValuesIfVoid;
begin
if Address='' then
Address := 'localhost';
if Port=0 then begin
Port := 25;
if Login='' then
Login := 'dummy';
if Password='' then
Password := 'dummy';
end;
end;
{ TSMTPServerSocketConnectionAbstract }
constructor TSMTPServerSocketConnectionAbstract.Create(
aOwner: TSMTPServer);
begin
fOwner := aOwner;
end;
{ TSMTPServerSocketConnection }
{$I+} // low-level communication with readln/writeln should raise exception
constructor TSMTPServerSocketConnection.Create(
aOwner: TSMTPServer);
begin
inherited Create(aOwner);
fSocket := TCrtSocket.Open(fOwner.Address,UInt32ToUtf8(fOwner.Port));
fSocket.CreateSockIn; // we use SockIn and SockOut here
fSocket.CreateSockOut(64*1024);
Expect('220');
if (fOwner.Login<>'') and (fOwner.Password<>'') then begin
Exec('EHLO '+fOwner.Address,'25');
Exec('AUTH LOGIN','334');
Exec(BinToBase64(fOwner.Login),'334');
Exec(BinToBase64(fOwner.Password),'235');
end else
Exec('HELO '+fOwner.Address,'25');
end;
procedure TSMTPServerSocketConnection.Expect(const Answer: RawByteString);
var Res: RawByteString;
begin
repeat
readln(fSocket.SockIn^,Res);
until (Length(Res)<4)or(Res[4]<>'-');
if not IdemPChar(pointer(Res),pointer(Answer)) then
raise ECrtSocket.CreateFmt('returned [%s], expecting [%s]',[Res,Answer]);
end;
procedure TSMTPServerSocketConnection.Exec(const Command,
Answer: RawByteString);
begin
writeln(fSocket.SockOut^,Command);
Expect(Answer)
end;
function TSMTPServerSocketConnection.SendEmail(
const aRecipient: TRawUTF8DynArray;
const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8;
var rcpt,toList,head: RawUTF8;
i: integer;
begin
if (aRecipient=nil) or (aSender='') or (aBody='') then
result := FormatUTF8('Invalid parameters for %.SendEmail(%:%,%)',
[self,fOwner.Address,fOwner.Port,aSender]) else
try
writeln(fSocket.SockOut^,'MAIL FROM:<',aSender,'>');
Expect('250');
toList := 'To: ';
for i := 0 to high(aRecipient) do begin
rcpt := aRecipient[i];
if PosExChar('<',rcpt)=0 then
rcpt := '<'+rcpt+'>';
Exec('RCPT TO:'+rcpt,'25');
toList := toList+rcpt+', ';
end;
Exec('DATA','354');
write(fSocket.SockOut^,'From: ',aSender,#13#10'Subject: ');
if aSubject='' then
writeln(fSocket.SockOut^,'Information') else
if IsAnsiCompatible(PAnsiChar(pointer(aSubject))) then
writeln(fSocket.SockOut^,aSubject) else
writeln(fSocket.SockOut^,'=?utf-8?B?',BinToBase64(aSubject));
writeln(fSocket.SockOut^,toList);
head := Trim(aHeader);
if head='' then // default format is simple UTF-8 text message
head := 'Content-Type: text/plain; charset=utf-8'#13#10+
'Content-Transfer-Encoding: 8bit';
writeln(fSocket.SockOut^,head);
writeln(fSocket.SockOut^,#13#10,aBody,#13#10'.');
Expect('25');
result := ''; // for success
except
on E: Exception do
result := FormatUTF8('%.SendEmail(%:%) server failure % [%]',
[self,fOwner.Address,fOwner.Port,E,E.Message]);
end;
end;
{$I-}
destructor TSMTPServerSocketConnection.Destroy;
begin
try
if fSocket<>nil then begin
writeln(fSocket.SockOut^,'QUIT');
ioresult; // ignore any error within writeln() since we are after $I-
end;
finally
FreeAndNil(fSocket);
inherited Destroy;
end;
end;
{ TSQLRecordEmailer }
class procedure TSQLRecordEmailer.InitializeTable(Server: TSQLRestServer;
const FieldName: RawUTF8; Options: TSQLInitializeTableOptions);
begin
inherited;
if (FieldName='') or IdemPropNameU(FieldName,'State') then
Server.CreateSQLMultiIndex(self,['State','ID'],false);
end;
{ TDDDEmailerDaemonProcess }
const
EMAILERSTAT_CONNECTIONCOUNT = 0;
function TDDDEmailerDaemonProcess.ExecuteRetrievePendingAndSetProcessing: boolean;
begin
fPendingTask := (fDaemon as TDDDEmailerDaemon).RestClass.Create(
fDaemon.Rest,'State=? order by RowID',[ord(esPending)]);
if fPendingTask.ID=0 then begin
result := false; // no more fPendingTask tasks
exit;
end;
with fPendingTask as TSQLRecordEmailer do begin
State := esSending;
SendTime := TimeLogNowUTC;
end;
result := fDaemon.Rest.Update(fPendingTask,'State,SendTime');
end;
function TDDDEmailerDaemonProcess.ExecuteProcessAndSetResult: QWord;
var body: RawByteString;
pendingEmail: TSQLRecordEmailer;
begin
pendingEmail := fPendingTask as TSQLRecordEmailer;
body := SynLZDecompress(pendingEmail.MessageCompressed);
result := length(body);
fMonitoring.AddSize(length(body));
if fSMTPConnection=nil then begin // re-use the same connection
fDaemon.Resolve([ISMTPServerConnection],[@fSMTPConnection]);
(fMonitoring as TDDDEmailerDaemonStats).NewConnection;
end;
pendingEmail.ErrorMsg := fSMTPConnection.SendEmail(
pendingEmail.Recipients,pendingEmail.Sender,pendingEmail.Subject,
pendingEmail.Headers,body);
if pendingEmail.ErrorMsg='' then
pendingEmail.State := esSent else
pendingEmail.State := esFailed;
fDaemon.Rest.Update(pendingEmail,'State,ErrorMsg'); // always write
end;
procedure TDDDEmailerDaemonProcess.ExecuteIdle;
begin
fSMTPConnection := nil; // release ISMTPServerConnection instance
end;
{ TDDDEmailerDaemon }
constructor TDDDEmailerDaemon.Create(aRest: TSQLRest);
begin
fResolver := fSMTPServer; // do it before aRest.Services is set
inherited Create(aRest);
fRestClass := Rest.Model.AddTableInherited(TSQLRecordEmailer);
RestClass.AddFilterNotVoidText(['MessageCompressed']);
fProcessClass := TDDDEmailerDaemonProcess;
fProcessMonitoringClass := TDDDEmailerDaemonStats;
fProcessIdleDelay := 1000; // checking for pending emails every second
end;
constructor TDDDEmailerDaemon.Create(aRest: TSQLRest;
aSMTPServer: TSMTPServer; aConnectionPool: integer);
begin
if not Assigned(aSMTPServer) then
raise ECQRSException.CreateUTF8('%.Create(SMTPServer=nil)',[self]);
fProcessThreadCount := aConnectionPool;
fSMTPServer := aSMTPServer;
Create(aRest);
end;
function TDDDEmailerDaemon.SendEmail(const aRecipients: TRawUTF8DynArray;
const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
var Email: TSQLRecordEmailer;
msg: string;
begin
{ result := CheckRecipients(aRecipient);
if result<>cqrsSuccess then
exit; }
Email := RestClass.Create;
try
Email.Recipients := aRecipients;
Email.Sender := aSender;
Email.Subject := aSubject;
Email.Headers := aHeaders;
{$ifdef WITHLOG}
Rest.LogClass.Enter('SendEmail %',[Email],self);
{$endif}
Email.MessageCompressed := SynLZCompressToBytes(aBody);
CqrsBeginMethod(qaNone,result);
if not Email.FilterAndValidate(Rest,msg) then
CqrsSetResultString(cqrsDDDValidationFailed,msg,result) else
if Rest.Add(Email,true)=0 then
CqrsSetResult(cqrsDataLayerError,result) else
CqrsSetResult(cqrsSuccess,result);
finally
Email.Free;
end;
end;
{ ****************** Mustache-Based Templating Service }
{ TDDDTemplateAbstract }
function TDDDTemplateAbstract.ComputeMessage(const aContext: variant;
const aTemplateName: RawUTF8): RawUTF8;
var template,templateType: RawUTF8;
escapeInvert: boolean;
begin
result := '';
if not RetrieveTemplate(aTemplateName,template,templateType) then
exit;
escapeInvert := false;
if (PosEx('html',templateType)<0) and (PosEx('xml',templateType)<0) then
escapeInvert := true; // may be JSON or plain TEXT
// TODO: compute multi-part message with optional text reduction of the html
result := TSynMustache.Parse(template).Render(aContext,
Partials,Helpers,OnTranslate,escapeInvert);
end;
destructor TDDDTemplateAbstract.Destroy;
begin
fPartials.Free;
fCache.Free;
inherited;
end;
{ TDDDTemplateFromFolder }
constructor TDDDTemplateFromFolder.Create(
const aTemplateFolder: TFileName; aMemoryCacheSize: integer);
begin
inherited Create;
if aTemplateFolder='' then
fFolder := IncludeTrailingPathDelimiter(GetCurrentDir) else begin
fFolder := IncludeTrailingPathDelimiter(ExpandFileName(aTemplateFolder));
if not DirectoryExists(Folder) then
raise ESynMustache.CreateUTF8('%.Create(%) is not a valid folder',[self,Folder]);
end;
fMemoryCacheSize := aMemoryCacheSize;
end;
function TDDDTemplateFromFolder.RetrieveTemplate(
const aTemplateName: RawUTF8; out aTemplate, aType: RawUTF8): boolean;
var age: integer;
ageInCache: PtrInt;
filename: TFileName;
begin
result := false;
if (aTemplateName='') or (PosEx('..',aTemplateName)>0) or
(aTemplateName[2]=':') then
exit; // for security reasons
filename := fFolder+UTF8ToString(Trim(aTemplateName));
{$WARN SYMBOL_DEPRECATED OFF} // we don't need full precision, just some value
age := FileAge(filename);
{$WARN SYMBOL_DEPRECATED ON}
if age<=0 then
exit;
fSafe.Lock;
try
if fCache=nil then
fCache := TSynCache.Create(MemoryCacheSize);
aTemplate := fCache.Find(aTemplateName,@ageInCache);
if (aTemplate='') or (ageInCache<>age) then begin
aTemplate := AnyTextFileToRawUTF8(filename,true);
if (aTemplate<>'') or (ageInCache<>0) then begin
fCache.Add(aTemplate,age);
result := true;
end;
end else
result := true; // from cache
finally
fSafe.UnLock;
end;
aType := GetMimeContentType(pointer(aTemplate),length(aTemplate),filename);
end;
procedure TDDDTemplateFromFolder.SetFolder(const Value: TFileName);
begin
fSafe.Lock;
try
fFolder := Value;
fCache.Reset;
finally
fSafe.UnLock;
end;
end;
procedure TDDDTemplateFromFolder.SetMemoryCacheSize(
const Value: integer);
begin
fSafe.Lock;
try
fMemoryCacheSize := Value;
FreeAndNil(fCache);
finally
fSafe.UnLock;
end;
end;
{ TDDDEmailerDaemonStats }
procedure TDDDEmailerDaemonStats.NewConnection;
begin
fSafe^.Lock;
try
inc(fConnection);
finally
fSafe^.UnLock;
end;
end;
procedure TDDDEmailerDaemonStats.LockedSum(another: TSynMonitor);
begin
inherited LockedSum(another);
if another.InheritsFrom(TDDDEmailerDaemonStats) then
inc(fConnection,TDDDEmailerDaemonStats(another).Connection);
end;
procedure TestDddInfraEmailer(serverClass: TSQLRestServerClass; test: TSynTestCase);
var Rest: TSQLRestServer;
daemon: TDDDEmailerDaemon;
daemonLocal: IUnknown;
smtpMock: TInterfaceMockSpy;
service: TDDDEmailValidationService;
valid: TSQLRecordEmailValidation;
template: TDomUserEmailTemplate;
email: TSQLRecordEmailer;
info: variant;
call: TSQLRestURIParams;
start: Int64;
begin
// generate test ORM file for DDD persistence
TDDDRepositoryRestFactory.ComputeSQLRecord([
TDDDEmailerDaemonStats,TSQLRestServerMonitor]);
// we test here up to the raw SMTP socket layer
Rest := serverClass.CreateWithOwnModel([]);
try
template := TDomUserEmailTemplate.Create;
smtpMock := TInterfaceMockSpy.Create(ISMTPServerConnection,test);
smtpMock.ExpectsCount('SendEmail',qoGreaterThanOrEqualTo,1);
daemon := TDDDEmailerDaemon.CreateInjected(Rest,[],[smtpMock],[]);
daemonLocal := daemon; // ensure daemon won't be released when resolved
service := TDDDEmailValidationService.CreateInjected(Rest,[],
[TInterfaceStub.Create(IDomUserTemplate).
Returns('ComputeMessage',['body'])],
[daemon]);
with test do
try
Rest.CreateMissingTables; // after Rest.Model has been completed
service.SetURIForServer(Rest,'http://validationserver/root',
'http://officialwebsite/success&logon=%','valid');
Check(Rest.TableRowCount(TSQLRecordEmailValidation)=0);
Check(Rest.TableRowCount(TSQLRecordEmailer)=0);
Check(not service.IsEmailValidated('toto','toto@toto.com'));
template.FileName := 'any';
template.Subject := 'Please Validate Your Email';
Check(service.StartEmailValidation(template,'toto','toto@toto .com')=cqrsDDDValidationFailed);
Check(service.StartEmailValidation(template,' ','toto@toto.com')=cqrsDDDValidationFailed);
Check(service.StartEmailValidation(template,'toto','toto@toto.com')=cqrsSuccess);
info := service.LastErrorInfo;
Check(VariantToUTF8(info)='{"Msg":"Validation email sent"}');
Check(not service.IsEmailValidated('toto','toto@toto.com'));
Check(Rest.TableRowCount(TSQLRecordEmailValidation)=1);
Check(Rest.TableRowCount(TSQLRecordEmailer)=1);
valid := TSQLRecordEmailValidation.Create(Rest,1);
Check(valid.Logon='toto');
Check(valid.RequestTime<>0);
Check(valid.ValidationTime=0);
valid.Free;
email := TSQLRecordEmailer.Create(Rest,1);
Check((length(email.Recipients)=1) and (email.Recipients[0]='toto@toto.com'));
Check(email.SendTime=0);
Check(SynLZDecompress(email.MessageCompressed)='body');
email.Free;
Check(daemon.RetrieveState(info)=cqrsSuccess);
Check(info.stats.taskcount=0);
Check(info.stats.connection=0);
daemon.ProcessIdleDelay := 1; // speed up tests
Check(daemon.Start=cqrsSuccess);
Check(daemon.RetrieveState(info)=cqrsSuccess);
start := GetTickCount64;
repeat
Sleep(1);
email := TSQLRecordEmailer.Create(Rest,1);
Check((length(email.Recipients)=1) and (email.Recipients[0]='toto@toto.com'));
if email.SendTime<>0 then
break;
FreeAndNil(email);
until GetTickCount64-start>5000;
if CheckFailed((email<>nil)and(email.SendTime<>0),
'Emailer thread sent message to toto@toto.com') then
exit;
Check(SynLZDecompress(email.MessageCompressed)='body');
email.Free;
Check(daemon.RetrieveState(info)=cqrsSuccess);
Check(info.stats.taskcount=1);
Check(info.stats.connection=1);
Check(not service.IsEmailValidated('toto','toto@toto.com'),'no click yet');
call.Url := service.ComputeURIForReply('titi','toto@toto.com');
Check(IdemPChar(pointer(call.Url),'HTTP://VALIDATIONSERVER/ROOT/VALID/'));
delete(call.Url,1,24);
Check(IdemPChar(pointer(call.Url),'ROOT/VALID/'),'deleted host in URI');
call.Method := 'GET';
Rest.URI(call);
Check(call.OutStatus=HTTP_BADREQUEST,'wrong link');
call.Url := service.ComputeURIForReply('toto','toto@toto.com');
delete(call.Url,1,24);
call.Method := 'GET';
Rest.URI(call);
Check(call.OutStatus=HTTP_TEMPORARYREDIRECT,'emulated click on link');
Check(call.OutHead='Location: http://officialwebsite/success&logon=toto');
Check(service.IsEmailValidated('toto','toto@toto.com'),'after click');
Check(daemon.Stop(info)=cqrsSuccess);
Check(service.StartEmailValidation(template,'toto','toto@toto.com')=cqrsSuccess);
info := service.LastErrorInfo;
Check(VariantToUTF8(info)='{"Msg":"Already validated"}');
Check(service.StartEmailValidation(template,'toto','toto2@toto.com')=cqrsSuccess);
info := service.LastErrorInfo;
Check(VariantToUTF8(info)='{"Msg":"Validation email sent"}');
Check(Rest.TableRowCount(TSQLRecordEmailValidation)=1);
Check(Rest.TableRowCount(TSQLRecordEmailer)=2);
Check(daemon.Start=cqrsSuccess);
start := GetTickCount64;
repeat
Sleep(1);
email := TSQLRecordEmailer.Create(Rest,2);
Check((length(email.Recipients)=1) and (email.Recipients[0]='toto2@toto.com'));
Check(email.Subject='Please Validate Your Email');
if email.SendTime<>0 then
break;
FreeAndNil(email);
until GetTickCount64-start>5000;
if CheckFailed((email<>nil)and(email.SendTime<>0),
'Emailer thread sent message to toto2@toto.com') then
exit;
Check(SynLZDecompress(email.MessageCompressed)='body');
email.Free;
sleep(10);
Check(daemon.Stop(info)=cqrsSuccess);
Check(info.working=0);
smtpMock.Verify('SendEmail',qoEqualTo,2);
finally
service.Free;
template.Free;
end;
info := Rest.Stats.ComputeDetails;
test.Check(info.ServiceMethod=2,'called root/valid twice');
test.Check(info.Errors=1,'root/valid titi');
test.Check(info.Success=1,'root/valid toto');
call.Url := 'root/stat?withall=true';
Rest.URI(call);
test.Check(PosEx('{"valid":{',call.OutBody)>0,'stats for root/valid');
FileFromString(JSONReformat(call.OutBody),'stats.json');
finally
Rest.Free;
end;
end;
initialization
TInterfaceFactory.RegisterInterfaces([TypeInfo(ISMTPServerConnection)]);
end.

383
contrib/mORMot/SQLite3/DDD/infra/dddInfraRepoUser.pas Normal file
View File

@@ -0,0 +1,383 @@
/// shared DDD Infrastructure: User CQRS Repository via ORM
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddInfraRepoUser;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SysUtils,
Classes,
SynCommons,
SynCrypto,
SynTests,
SynTable, // for TSynFilter and TSynValidate
mORMot,
mORMotDDD,
dddDomUserTypes,
dddDomUserCQRS;
{ *********** Implements User Aggregate CQRS Repository via mORMot's RESTful ORM }
type
/// implements a User CQRS Repository via mORMot's RESTful ORM
// - this class will use a supplied TSQLRest instance to persist TUser
// Aggregate Roots, following the IDomUserCommand CQRS methods
// - each TUser aggregate will be mapped into a TSQLRecordUser ORM table
TInfraRepoUser = class(TDDDRepositoryRestCommand,IDomUserCommand,IDomUserQuery)
public
function SelectByLogonName(const aLogonName: RawUTF8): TCQRSResult;
function SelectByEmailValidation(aValidationState: TDomUserEmailValidation): TCQRSResult;
function SelectByLastName(const aName: TLastName; aStartWith: boolean): TCQRSResult;
function SelectAll: TCQRSResult;
function Get(out aAggregate: TUser): TCQRSResult;
function GetAll(out aAggregates: TUserObjArray): TCQRSResult;
function GetNext(out aAggregate: TUser): TCQRSResult;
function Add(const aAggregate: TUser): TCQRSResult;
function Update(const aUpdatedAggregate: TUser): TCQRSResult;
function HowManyValidatedEmail: integer;
end;
/// implements a Factory of User CQRS Repositories via mORMot's RESTful ORM
// - this class will associate the TUser Aggregate Root with a TSQLRecordUser
// ORM table, as managed in a given TSQLRest instance
TInfraRepoUserFactory = class(TDDDRepositoryRestFactory)
public
/// initialize the association with the ORM
constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
/// perform some tests on this Factory/Repository implementation
class procedure RegressionTests(test: TSynTestCase);
end;
{ *********** Person / User / Customer Persistence ORM classes }
type
/// ORM class able to store a TPerson object
// - the TPerson.Name property has been flattened to Name_* columns as
// expected by TDDDRepositoryRestFactory.ComputeMapping
TSQLRecordPerson = class(TSQLRecord)
protected
fFirst: RawUTF8;
fMiddle: RawUTF8;
fLast: RawUTF8;
fBirthDate: TDateTime;
published
property Name_First: RawUTF8 read fFirst write fFirst;
property Name_Middle: RawUTF8 read fMiddle write fMiddle;
property Name_Last: RawUTF8 read fLast write fLast;
property Birth: TDateTime read fBirthDate;
end;
/// ORM class able to store a TPersonContactable object
// - the TPersonContactable.Address property has been flattened to Address_*
// columns as expected by TDDDRepositoryRestFactory.ComputeMapping
TSQLRecordPersonContactable = class(TSQLRecordPerson)
protected
fStreet1: RawUTF8;
fStreet2: RawUTF8;
fCityArea: RawUTF8;
fCity: RawUTF8;
fRegion: RawUTF8;
fCode: RawUTF8;
fCountry: integer;
fEmail: RawUTF8;
fPhone1: RawUTF8;
fPhone2: RawUTF8;
published
property Address_Street1: RawUTF8 read fStreet1 write fStreet1;
property Address_Street2: RawUTF8 read fStreet2 write fStreet2;
property Address_CityArea: RawUTF8 read fCityArea write fCityArea;
property Address_City: RawUTF8 read fCity write fCity;
property Address_Region: RawUTF8 read fRegion write fRegion;
property Address_Code: RawUTF8 read fCode write fCode;
property Address_Country: integer read fCountry;
property Phone1: RawUTF8 read fPhone1 write fPhone1;
property Phone2: RawUTF8 read fPhone2 write fPhone2;
property Email: RawUTF8 read fEmail write fEmail;
end;
/// ORM class used to persist a TUser domain aggregate
TSQLRecordUser = class(TSQLRecordPersonContactable)
protected
fLogonName: RawUTF8;
fEmailValidated: TDomUserEmailValidation;
published
property LogonName: RawUTF8 read fLogonName write fLogonName stored AS_UNIQUE;
property EmailValidated: TDomUserEmailValidation read fEmailValidated write fEmailValidated;
end;
implementation
{ TInfraRepoUser }
{ in practice, implementing a I*Command interface mainly consist in calling
the various TDDDRepositoryRestCommand.ORM*() methods, which would perform
all process on the REST instance using the TSQLRecordUser table mapped to
the TUser aggregate root
- purpose of this I*Command interface is to use the loosely typed
TDDDRepositoryRestCommand.ORM*() methods to match the exact needs of
the DDD Aggregate class
- it would also hide the persistence details so that we would be able
to ignore e.g. what a primary key is, and avoid the "anemic domain model"
anti-pattern, which is basically CRUD in disguise }
function TInfraRepoUser.SelectByLogonName(
const aLogonName: RawUTF8): TCQRSResult;
begin
result := ORMSelectOne('LogonName=?',[aLogonName],(aLogonName=''));
end;
function TInfraRepoUser.SelectByEmailValidation(
aValidationState: TDomUserEmailValidation): TCQRSResult;
begin
result := ORMSelectAll('EmailValidated=?',[ord(aValidationState)]);
end;
function TInfraRepoUser.SelectByLastName(const aName: TLastName;
aStartWith: boolean): TCQRSResult;
begin
if aStartWith then
result := ORMSelectAll('Name_Last LIKE ?',[aName+'%'],(aName='')) else
result := ORMSelectAll('Name_Last=?',[aName],(aName=''));
end;
function TInfraRepoUser.SelectAll: TCQRSResult;
begin
result := ORMSelectAll('',[]);
end;
function TInfraRepoUser.Get(out aAggregate: TUser): TCQRSResult;
begin
result := ORMGetAggregate(aAggregate);
end;
function TInfraRepoUser.GetAll(
out aAggregates: TUserObjArray): TCQRSResult;
begin
result := ORMGetAllAggregates(aAggregates);
end;
function TInfraRepoUser.GetNext(out aAggregate: TUser): TCQRSResult;
begin
result := ORMGetNextAggregate(aAggregate);
end;
function TInfraRepoUser.Add(const aAggregate: TUser): TCQRSResult;
begin
result := ORMAdd(aAggregate);
end;
function TInfraRepoUser.Update(
const aUpdatedAggregate: TUser): TCQRSResult;
begin
result := ORMUpdate(aUpdatedAggregate);
end;
function TInfraRepoUser.HowManyValidatedEmail: integer;
begin
if ORMSelectCount('EmailValidated=%',[ord(evValidated)],[],result)<>cqrsSuccess then
result := 0;
end;
{ TInfraRepoUserFactory }
constructor TInfraRepoUserFactory.Create(aRest: TSQLRest;
aOwner: TDDDRepositoryRestManager);
begin
inherited Create(IDomUserCommand,TInfraRepoUser,TUser,aRest,TSQLRecordUser,aOwner);
AddFilterOrValidate(['*'],TSynFilterTrim.Create);
AddFilterOrValidate(['LogonName'],TSynValidateNonVoidText.Create);
end;
class procedure TInfraRepoUserFactory.RegressionTests(test: TSynTestCase);
procedure TestOne(Rest: TSQLRest);
const MAX=1000;
MOD_EMAILVALID=ord(high(TDomUserEmailValidation))+1;
var cmd: IDomUserCommand;
qry: IDomUserQuery;
user: TUser;
users: TUserObjArray;
i,usersCount: integer;
itext: RawUTF8;
v: TDomUserEmailValidation;
count: array[TDomUserEmailValidation] of integer;
msg: string;
begin
test.Check(Rest.Services.Resolve(IDomUserCommand,cmd));
user := TUser.Create;
try
for i := 1 to MAX do begin
UInt32ToUtf8(i,itext);
user.LogonName := ' '+itext; // left ' ' to test TSynFilterTrim.Create
user.EmailValidated := TDomUserEmailValidation(i mod MOD_EMAILVALID);
user.Name.Last := 'Last'+itext;
user.Name.First := 'First'+itext;
user.Address.Street1 := 'Street '+itext;
user.Address.Country.Alpha2 := 'fr';
user.Phone1 := itext;
test.check(cmd.Add(user)=cqrsSuccess);
end;
test.check(cmd.Commit=cqrsSuccess);
finally
user.Free;
end;
user := TUser.Create;
try
test.Check(Rest.Services.Resolve(IDomUserQuery,qry));
test.Check(qry.GetCount=0);
for i := 1 to MAX do begin
UInt32ToUtf8(i,itext);
test.Check(qry.SelectByLogonName(itext)=cqrsSuccess);
test.Check(qry.GetCount=1);
test.Check(qry.Get(user)=cqrsSuccess);
test.Check(qry.GetCount=1);
test.Check(user.LogonName=itext);
test.Check(user.EmailValidated=TDomUserEmailValidation(i mod MOD_EMAILVALID));
test.Check(user.Name.Last='Last'+itext);
test.Check(user.Name.First='First'+itext);
test.Check(user.Address.Street1='Street '+itext);
test.Check(user.Address.Country.Alpha2='FR');
test.Check(user.Phone1=itext);
end;
test.Check(Rest.Services.Resolve(IDomUserCommand,cmd));
try
usersCount := 0;
for v := low(TDomUserEmailValidation) to high(TDomUserEmailValidation) do begin
test.Check(cmd.SelectByEmailValidation(v)=cqrsSuccess);
ObjArrayClear(users); // should be done, otherwise memory leak
test.Check(cmd.GetAll(users)=cqrsSuccess);
test.Check(length(users)>=MAX div MOD_EMAILVALID);
count[v] := length(users);
inc(usersCount,length(users));
for i := 0 to high(users) do begin
test.Check(users[i].EmailValidated=v);
test.Check(users[i].LogonName=users[i].Phone1);
test.Check(users[i].Name.First='First'+users[i].LogonName);
end;
end;
test.Check(cmd.DeleteAll=cqrsSuccess,'delete all evFailed');
test.check(cmd.Commit=cqrsSuccess);
ObjArrayClear(users);
test.Check(cmd.SelectAll=cqrsSuccess);
test.Check(cmd.GetAll(users)=cqrsSuccess);
test.Check(length(users)=usersCount-count[evFailed]);
for i := 0 to high(users) do begin
test.Check(users[i].LogonName=users[i].Phone1);
test.Check(users[i].Name.First='First'+users[i].LogonName);
test.Check(users[i].Address.Country.Iso=250);
end;
finally
ObjArrayClear(users);
end;
test.Check(Rest.Services.Resolve(IDomUserCommand,cmd));
for v := low(TDomUserEmailValidation) to high(TDomUserEmailValidation) do begin
test.Check(cmd.SelectByEmailValidation(v)=cqrsSuccess);
if v=evFailed then
test.Check(cmd.GetCount=0) else
test.Check(cmd.GetCount=count[v]);
i := 0;
while cmd.GetNext(user)=cqrsSuccess do begin
test.Check(user.EmailValidated=v);
test.Check(user.Name.First='First'+user.LogonName);
test.Check(user.Address.Country.Iso=250);
inc(i);
end;
test.Check(i=cmd.GetCount);
end;
test.Check(cmd.HowManyValidatedEmail=count[evValidated]);
user.LogonName := '';
test.check(cmd.Add(user)=cqrsDDDValidationFailed);
test.check(cmd.GetLastError=cqrsDDDValidationFailed);
msg := cmd.GetLastErrorInfo.msg;
test.check(pos('TUser.LogonName',msg)>0,msg);
finally
user.Free;
end;
end;
var RestServer: TSQLRestServerFullMemory;
RestClient: TSQLRestClientURI;
begin
RestServer := TSQLRestServerFullMemory.CreateWithOwnModel([TSQLRecordUser]);
try // first try directly on server side
RestServer.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(RestServer)],true);
TestOne(RestServer); // sub function will ensure that all I*Command are released
finally
RestServer.Free;
end;
RestServer := TSQLRestServerFullMemory.CreateWithOwnModel([TSQLRecordUser]);
try // then try from a client-server process
RestServer.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(RestServer)],true);
RestServer.ServiceDefine(TInfraRepoUser,[IDomUserCommand,IDomUserQuery],sicClientDriven);
test.Check(RestServer.ExportServer);
RestClient := TSQLRestClientURIDll.Create(TSQLModel.Create(RestServer.Model),@URIRequest);
try
RestClient.Model.Owner := RestClient;
RestClient.ServiceDefine([IDomUserCommand],sicClientDriven);
TestOne(RestServer);
RestServer.DropDatabase;
USEFASTMM4ALLOC := true; // for slightly faster process
TestOne(RestClient);
finally
RestClient.Free;
end;
finally
RestServer.Free;
end;
end;
end.

1205
contrib/mORMot/SQLite3/DDD/infra/dddInfraSettings.pas Normal file
View File

File diff suppressed because it is too large Load Diff

170
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminDB.dfm Normal file
View File

@@ -0,0 +1,170 @@
object DBFrame: TDBFrame
Left = 0
Top = 0
Width = 689
Height = 339
TabOrder = 0
object spl2: TSplitter
Left = 169
Top = 0
Height = 339
end
object pnlRight: TPanel
Left = 172
Top = 0
Width = 517
Height = 339
Align = alClient
TabOrder = 0
object spl1: TSplitter
Left = 1
Top = 113
Width = 515
Height = 3
Cursor = crVSplit
Align = alTop
end
object pnlTop: TPanel
Left = 1
Top = 1
Width = 515
Height = 112
Align = alTop
Constraints.MinHeight = 100
TabOrder = 0
DesignSize = (
515
112)
object mmoSQL: TMemo
Left = 0
Top = 0
Width = 454
Height = 111
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Consolas'
Font.Style = []
ParentFont = False
TabOrder = 0
end
object btnExec: TButton
Left = 461
Top = 8
Width = 43
Height = 25
Hint = 'Execute the SQL statement (F9)'
Anchors = [akTop, akRight]
Caption = 'Exec'
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = btnExecClick
end
object btnHistory: TButton
Left = 461
Top = 40
Width = 43
Height = 25
Hint = 'View SQL log history (Ctrl+H)'
Anchors = [akTop, akRight]
Caption = 'History'
ParentShowHint = False
ShowHint = True
TabOrder = 2
OnClick = btnHistoryClick
end
object btnCmd: TButton
Left = 461
Top = 72
Width = 43
Height = 25
Hint = 'Launch a pseudo-command (F5)'
Anchors = [akTop, akRight]
Caption = '#cmd'
ParentShowHint = False
PopupMenu = pmCmd
ShowHint = True
TabOrder = 3
OnClick = btnCmdClick
end
end
object drwgrdResult: TDrawGrid
Left = 1
Top = 116
Width = 515
Height = 117
Align = alTop
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
TabOrder = 1
Visible = False
OnClick = drwgrdResultClick
end
end
object pnlLeft: TPanel
Left = 0
Top = 0
Width = 169
Height = 339
Align = alLeft
TabOrder = 1
object lstTables: TListBox
Left = 1
Top = 45
Width = 167
Height = 293
Align = alClient
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Tahoma'
Font.Style = []
ItemHeight = 14
ParentFont = False
TabOrder = 0
OnDblClick = lstTablesDblClick
end
object pnlLeftTop: TPanel
Left = 1
Top = 1
Width = 167
Height = 44
Align = alTop
TabOrder = 1
DesignSize = (
167
44)
object edtLabels: TEdit
Left = 5
Top = 4
Width = 156
Height = 21
Hint = 'Incremental Search'
Anchors = [akLeft, akTop, akRight]
ParentShowHint = False
ShowHint = True
TabOrder = 0
OnChange = edtLabelsChange
end
object chkTables: TCheckBox
Left = 8
Top = 26
Width = 156
Height = 17
Caption = 'chkTables'
TabOrder = 1
Visible = False
end
end
end
object pmCmd: TPopupMenu
Left = 648
Top = 80
end
end

695
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminDB.pas Normal file
View File

@@ -0,0 +1,695 @@
unit dddToolsAdminDB;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Grids,
StdCtrls,
ExtCtrls,
Menus,
SynMemoEx,
SynCommons,
mORMot,
mORMotDDD,
mORMotHttpClient,
mORMotUI,
SynMustache;
type
TDBFrame = class;
TOnExecute = function(Sender: TDBFrame; const SQL, Content: RawUTF8): boolean of object;
TDBFrame = class(TFrame)
pnlRight: TPanel;
pnlTop: TPanel;
mmoSQL: TMemo;
btnExec: TButton;
drwgrdResult: TDrawGrid;
spl1: TSplitter;
spl2: TSplitter;
btnHistory: TButton;
btnCmd: TButton;
pmCmd: TPopupMenu;
pnlLeft: TPanel;
lstTables: TListBox;
pnlLeftTop: TPanel;
edtLabels: TEdit;
chkTables: TCheckBox;
procedure lstTablesDblClick(Sender: TObject); virtual;
procedure btnExecClick(Sender: TObject); virtual;
procedure drwgrdResultClick(Sender: TObject); virtual;
procedure btnHistoryClick(Sender: TObject); virtual;
procedure btnCmdClick(Sender: TObject); virtual;
procedure edtLabelsChange(Sender: TObject);
protected
fGridToCellRow: integer;
fGridToCellVariant: variant;
fJson: RawJSON;
fSQL, fPreviousSQL: RawUTF8;
fSQLLogFile: TFileName;
function ExecSQL(const SQL: RawUTF8): RawUTF8;
function OnText(Sender: TSQLTable; FieldIndex, RowIndex: Integer;
var Text: string): boolean;
procedure OnCommandsToGridAdd(const Item: TSynNameValueItem; Index: PtrInt);
function OnGridToCell(Sender: TSQLTable; Row, Field: integer;
HumanFriendly: boolean): RawJSON;
procedure LogClick(Sender: TObject);
procedure LogDblClick(Sender: TObject);
procedure LogSearch(Sender: TObject);
public
DatabaseName: RawUTF8;
mmoResult: TMemoEx; // initialized by code from SynMemoEx.pas
Grid: TSQLTableToGrid;
GridLastTableName: RawUTF8;
Client: TSQLHttpClientWebsockets;
Admin: IAdministratedDaemon;
Tables: TStringList;
AssociatedModel: TSQLModel;
AssociatedServices: TInterfaceFactoryObjArray;
// Add(cmdline/table,nestedobject,-1=text/0..N=nestedarray#)
CommandsToGrid: TSynNameValue;
TableDblClickSelect: TSynNameValue;
TableDblClickOrderByIdDesc: boolean;
TableDblClickOrderByIdDescCSV: string;
SavePrefix: TFileName;
OnBeforeExecute: TOnExecute;
OnAfterExecute: TOnExecute;
constructor Create(AOwner: TComponent); override;
procedure EnableChkTables(const aCaption: string);
procedure Open; virtual;
procedure FillTables(const customcode: string); virtual;
procedure AddSQL(SQL: string; AndExec: boolean);
procedure SetResult(const JSON: RawUTF8); virtual;
function NewCmdPopup(const c: string; NoCmdTrim: boolean): TMenuItem;
destructor Destroy; override;
end;
TDBFrameClass = class of TDBFrame;
TDBFrameDynArray = array of TDBFrame;
implementation
{$R *.dfm}
const
WRAPPER_TEMPLATE = '{{#soa.services}}'#13#10'{{#methods}}'#13#10 +
'#get {{uri}}/{{methodName}}{{#hasInParams}}?{{#args}}{{#dirInput}}{{argName}}={{typeSource}}' +
'{{#commaInSingle}}&{{/commaInSingle}}{{/dirInput}}{{/args}}{{/hasInParams}}'#13#10 +
'{{#hasOutParams}}'#13#10' { {{#args}}{{#dirOutput}}{{jsonQuote argName}}: {{typeSource}}' +
'{{#commaOutResult}},{{/commaOutResult}} {{/dirOutput}}{{/args}} }'#13#10 +
'{{/hasOutParams}}{{/methods}}'#13#10'{{/soa.services}}'#13#10'{{#enumerates}}{{name}}: ' +
'{{#values}}{{EnumTrim .}}={{-index0}}{{^-last}}, {{/-last}}{{/values}}'#13#10'{{/enumerates}}';
{ TDBFrame }
constructor TDBFrame.Create(AOwner: TComponent);
begin
inherited;
fSQLLogFile := ChangeFileExt(ExeVersion.ProgramFileName, '.history');
mmoResult := TMemoEx.Create(self);
mmoResult.Name := 'mmoResult';
mmoResult.Parent := pnlRight;
mmoResult.Align := alClient;
mmoResult.Font.Height := -11;
mmoResult.Font.Name := 'Consolas';
mmoResult.ReadOnly := true;
mmoResult.ScrollBars := ssVertical;
mmoResult.Text := '';
mmoResult.RightMargin := 130;
mmoResult.RightMarginVisible := true;
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
pnlLeftTop.Height := 30;
Tables := TStringList.Create;
TableDblClickSelect.Init(false);
CommandsToGrid.Init(false);
CommandsToGrid.OnAfterAdd := OnCommandsToGridAdd;
end;
procedure TDBFrame.Open;
begin
FillTables('');
edtLabelsChange(nil);
mmoSQL.Text := '#help';
btnExecClick(nil);
mmoSQL.Text := '';
mmoResult.Text := '';
end;
procedure TDBFrame.FillTables(const customcode: string);
var
i: integer;
aTables: TRawUTF8DynArray;
begin
drwgrdResult.Align := alClient;
aTables := Admin.DatabaseTables(DatabaseName);
Tables.Clear;
Tables.BeginUpdate;
try
for i := 0 to high(aTables) do
Tables.Add(UTF8ToString(aTables[i]));
finally
Tables.EndUpdate;
end;
end;
procedure TDBFrame.lstTablesDblClick(Sender: TObject);
var
i: integer;
table, fields, sql, orderby: string;
begin
i := lstTables.ItemIndex;
if i < 0 then
exit;
table := lstTables.Items[i];
fields := string(TableDblClickSelect.Value(RawUTF8(table)));
if fields='' then
fields := '*' else begin
i := Pos(' order by ', fields);
if i > 0 then begin
orderby := copy(fields, i, maxInt);
Setlength(fields, i - 1);
end;
end;
sql := 'select '+fields+' from ' + table;
if orderby <> '' then
sql := sql + orderby
else begin
if TableDblClickOrderByIdDesc or ((TableDblClickOrderByIdDescCSV <> '') and
(Pos(table + ',', TableDblClickOrderByIdDescCSV + ',') > 0)) then
sql := sql + ' order by id desc';
sql := sql + ' limit 1000';
end;
AddSQL(sql, true);
end;
procedure TDBFrame.SetResult(const JSON: RawUTF8);
begin
FreeAndNil(Grid);
drwgrdResult.Hide;
mmoResult.Align := alClient;
mmoResult.WordWrap := false;
mmoResult.ScrollBars := ssBoth;
mmoResult.RightMarginVisible := false;
if (JSON = '') or (JSON[1] in ['A'..'Z', '#']) then
mmoResult.OnGetLineAttr := nil
else
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
mmoResult.Text := UTF8ToString(StringReplaceTabs(JSON, ' '));
mmoResult.SetCaret(0, 0);
mmoResult.TopRow := 0;
fJson := '';
end;
procedure TDBFrame.OnCommandsToGridAdd(const Item: TSynNameValueItem;
Index: PtrInt);
begin
pmCmd.Items.Insert(0, NewCmdPopup(UTF8ToString(Item.Name), true));
end;
function TDBFrame.NewCmdPopup(const c: string; NoCmdTrim: boolean): TMenuItem;
var
cmd, name, lastname: string;
i, ext, num: integer;
res: TDocVariantData;
sub, subpar, subarch: TMenuItem;
begin
result := TMenuItem.Create(self);
if length(c) > 40 then
result.Caption := copy(c, 1, 37) + '...'
else
result.Caption := c;
if NoCmdTrim then
cmd := c
else begin
i := Pos(' ', c);
if i > 0 then
cmd := copy(c, 1, i) + '*'
else begin
i := Pos('(', c);
if i > 0 then
cmd := copy(c, 1, i) + '*)'
else
cmd := c;
end;
end;
result.Hint := cmd;
if (cmd = '#log *') or (cmd = '#db *') then begin // log/db files in sub-menus
res.InitJSON(ExecSQL(StringToUTF8(cmd)), JSON_OPTIONS_FAST);
SetLength(cmd, length(cmd) - 1);
subpar := result;
subarch := nil;
if res.Kind = dvArray then
for i := 0 to res.Count - 1 do begin
name := res.Values[i].Name;
if name = lastname then
continue; // circumvent FindFiles() bug with *.dbs including *.dbsynlz
lastname := name;
case GetFileNameExtIndex(name, 'dbs,dbsynlz') of
0: begin // group sharded database files by 20 in sub-menus
ext := Pos('.dbs', name);
if (ext > 4) and TryStrToInt(Copy(name, ext - 4, 4), num) then
if (subpar = result) or (num mod 20 = 0) then begin
subpar := NewCmdPopup(cmd + name + ' ...', true);
subpar.OnClick := nil;
result.Add(subpar);
end;
end;
1: begin // group database backup files in a dedicated sub-menu
if subarch = nil then begin
subarch := NewCmdPopup(cmd + '*.dbsynlz ...', true);
subarch.OnClick := nil;
result.Add(subarch);
end;
subpar := subarch;
end;
else
subpar := result;
end;
sub := NewCmdPopup(cmd + name, true);
if cmd = '#log ' then
sub.Caption := sub.Caption + ' ' + res.Values[i].TimeStamp
else
sub.Caption := FormatString('% %', [sub.Caption, KB(res.Values[i].Size)]);
subpar.Add(sub);
end;
end
else
result.OnClick := btnExecClick;
end;
procedure TDBFrame.btnExecClick(Sender: TObject);
var
res, ctyp, execTime: RawUTF8;
mmo, cmd, fn, local: string;
SelStart, SelLength, cmdToGrid, i: integer;
table: TSQLTable;
tables: TSQLRecordClassDynArray;
P: PUTF8Char;
exec: TServiceCustomAnswer;
ctxt: variant;
timer: TPrecisionTimer;
begin
if (Sender <> nil) and Sender.InheritsFrom(TMenuItem) then begin
mmo := TMenuItem(Sender).Hint;
mmoSQL.Text := mmo;
i := Pos('*', mmo);
if (i > 0) and (mmo[1] = '#') then begin
mmoSQL.SelStart := i - 1;
mmoSQL.SelLength := 1;
mmoSQL.SetFocus;
exit;
end;
end;
SelStart := mmoSQL.SelStart;
SelLength := mmoSQL.SelLength;
if SelLength > 10 then
mmo := mmoSQL.SelText
else
mmo := mmoSQL.Lines.Text;
fSQL := Trim(StringToUTF8(mmo));
if fSQL = '' then
exit;
if IdemPropNameU(fSQL, '#client') then begin
fJson := ObjectToJSON(Client);
end
else if Assigned(OnBeforeExecute) and not OnBeforeExecute(self, fSQL, '') then
fJson := '"You are not allowed to execute this command for security reasons"'
else begin
Screen.Cursor := crHourGlass;
try
try
timer.Start;
exec := Admin.DatabaseExecute(DatabaseName, fSQL);
execTime := timer.Stop;
ctyp := FindIniNameValue(pointer(exec.Header), HEADER_CONTENT_TYPE_UPPER);
if IdemPChar(pointer(exec.Content), '<HEAD>') then begin // HTML in disguise
i := PosI('<BODY>', exec.content);
if i = 0 then
fJson := exec.Content
else
fJson := copy(exec.Content, i, maxInt);
end
else
if (ctyp = '') or IdemPChar(pointer(ctyp), JSON_CONTENT_TYPE_UPPER) then
fJson := exec.Content
else
if IdemPropNameU(ctyp, BINARY_CONTENT_TYPE) then begin
fn := UTF8ToString(trim(FindIniNameValue(pointer(exec.Header), 'FILENAME:')));
if (fn <> '') and (exec.Content <> '') then
with TSaveDialog.Create(self) do
try
Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing];
InitialDir := GetShellFolderPath(CSIDL_DOCUMENTS);
FileName := SavePrefix + fn;
if Execute then begin
local := FileName;
FileFromString(exec.Content, local);
end;
finally
Free;
end;
fJson := JSONEncode(['file', fn, 'size', length(exec.Content),
'type', ctyp, 'localfile', local]);
end
else
fJson := FormatUTF8('"Unknown content-type: %"', [ctyp]);
except
on E: Exception do
fJson := ObjectToJSON(E);
end;
finally
Screen.Cursor := crDefault;
end;
end;
FreeAndNil(Grid);
GridLastTableName := '';
fGridToCellRow := 0;
cmdToGrid := CommandsToGrid.Find(fSQL);
if (fSQL[1] = '#') and
((cmdToGrid < 0) or (CommandsToGrid.List[cmdToGrid].Tag < 0)) then begin
if fJson <> '' then
if IdemPropNameU(fSQL, '#help') then begin
fJson := Trim(UnQuoteSQLString(fJson)) + '|#client'#13#10;
res := StringReplaceAll(fJson, '|', #13#10' ');
if pmCmd.Items.Count = 0 then begin
P := pointer(res);
while P <> nil do begin
cmd := UTF8ToString(Trim(GetNextLine(P, P)));
if (cmd <> '') and (cmd[1] = '#') then
pmCmd.Items.Add(NewCmdPopup(cmd, false));
end;
end;
end
else if IdemPropNameU(fSQL, '#wrapper') then begin
_Json(fJson,ctxt,JSON_OPTIONS_FAST);
res := TSynMustache.Parse(WRAPPER_TEMPLATE).Render(ctxt, nil,
TSynMustache.HelpersGetStandardList, nil, true);
end
else begin
JSONBufferReformat(pointer(fJson), res, jsonUnquotedPropName);
if (res = '') or (res = 'null') then
res := fJson;
end;
if Assigned(OnAfterExecute) then
OnAfterExecute(self,fSQL,res);
SetResult(res);
end
else begin
mmoResult.Text := '';
mmoResult.SetCaret(0, 0);
mmoResult.TopRow := 0;
mmoResult.Align := alBottom;
mmoResult.WordWrap := true;
mmoResult.ScrollBars := ssVertical;
mmoResult.Height := 100;
if AssociatedModel <> nil then
tables := AssociatedModel.Tables;
if cmdToGrid >= 0 then begin
GridLastTableName := CommandsToGrid.List[cmdToGrid].Name;
if isSelect(pointer(GridLastTableName)) then
GridLastTableName := GetTableNameFromSQLSelect(GridLastTableName,false);
if CommandsToGrid.List[cmdToGrid].Value <> '' then begin
// display a nested object in the grid
P := JsonObjectItem(pointer(fJson), CommandsToGrid.List[cmdToGrid].Value);
if CommandsToGrid.List[cmdToGrid].Tag > 0 then
P := JSONArrayItem(P, CommandsToGrid.List[cmdToGrid].Tag - 1);
if P <> nil then
GetJSONItemAsRawJSON(P, RawJSON(fJSON));
end;
end
else
GridLastTableName := GetTableNameFromSQLSelect(fSQL, false);
table := TSQLTableJSON.CreateFromTables(tables, fSQL, pointer(fJson), length(fJson));
Grid := TSQLTableToGrid.Create(drwgrdResult, table, nil);
Grid.SetAlignedByType(sftCurrency, alRight);
Grid.SetFieldFixedWidth(100);
Grid.FieldTitleTruncatedNotShownAsHint := true;
Grid.OnValueText := OnText;
Grid.Table.OnExportValue := OnGridToCell;
if Assigned(OnAfterExecute) then
OnAfterExecute(self, fSQL, fJSON);
drwgrdResult.Options := drwgrdResult.Options - [goRowSelect];
drwgrdResult.Show;
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
mmoResult.Text := FormatString(#13#10' Returned % row(s), as % in %',
[table.RowCount, KB(fJson), execTime]);
end;
if Sender <> nil then begin
mmoSQL.SelStart := SelStart;
mmoSQL.SelLength := SelLength;
mmoSQL.SetFocus;
end;
if ((fJson <> '') or ((fSQL[1] = '#') and (PosEx(' ', fSQL) > 0))) and
(fSQL <> fPreviousSQL) then begin
AppendToTextFile(fSQL, fSQLLogFile);
fPreviousSQL := fSQL;
end;
end;
destructor TDBFrame.Destroy;
begin
FreeAndNil(Grid);
FreeAndNil(AssociatedModel);
FreeAndNil(Tables);
inherited;
end;
function TDBFrame.OnText(Sender: TSQLTable; FieldIndex, RowIndex: Integer;
var Text: string): boolean;
begin
if Sender.FieldType(FieldIndex) in [sftBoolean] then
result := false
else begin
Text := Sender.GetString(RowIndex, FieldIndex); // display the value as such
result := true;
end;
end;
function TDBFrame.OnGridToCell(Sender: TSQLTable; Row, Field: integer;
HumanFriendly: boolean): RawJSON;
var
methodName: RawUTF8;
serv, m: integer;
begin
if fGridToCellRow <> Row then begin
Sender.ToDocVariant(Row, fGridToCellVariant, JSON_OPTIONS_FAST, true, true, true);
fGridToCellRow := Row;
if AssociatedServices <> nil then
with _Safe(fGridToCellVariant)^ do
if GetAsRawUTF8('Method', methodName) then
for serv := 0 to high(AssociatedServices) do begin
m := AssociatedServices[serv].FindFullMethodIndex(methodName, true);
if m >= 0 then
with AssociatedServices[serv].Methods[m] do begin
ArgsAsDocVariantFix(GetAsDocVariantSafe('Input')^, true);
ArgsAsDocVariantFix(GetAsDocVariantSafe('Output')^, false);
break;
end;
end;
end;
with _Safe(fGridToCellVariant)^ do
if cardinal(Field)>=cardinal(Count) then
result := '' else
if HumanFriendly and (_Safe(Values[Field])^.Kind = dvUndefined) then
VariantToUTF8(Values[field], RawUTF8(result))
else
result := VariantSaveJSON(Values[Field]);
end;
procedure TDBFrame.drwgrdResultClick(Sender: TObject);
var
R: integer;
json: RawUTF8;
begin
R := drwgrdResult.Row;
if (R > 0) and (R <> fGridToCellRow) and (Grid <> nil) then begin
OnGridToCell(Grid.Table,R,0,false);
JSONBufferReformat(pointer(VariantToUTF8(fGridToCellVariant)), json, jsonUnquotedPropNameCompact);
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
mmoResult.Text := UTF8ToString(json);
mmoResult.SetCaret(0, 0);
mmoResult.TopRow := 0;
end;
end;
procedure TDBFrame.btnHistoryClick(Sender: TObject);
var
F: TForm;
List: TListBox;
Search: TEdit;
Details: TMemo;
begin
F := TForm.Create(Application);
try
F.Caption := ' ' + btnHistory.Hint;
F.Font := Font;
F.Width := 800;
F.Height := 600;
F.Position := poMainFormCenter;
Search := TEdit.Create(F);
Search.Parent := F;
Search.Align := alTop;
Search.Height := 24;
Search.OnChange := LogSearch;
Details := TMemo.Create(F);
Details.Parent := F;
Details.Align := alBottom;
Details.Height := 200;
Details.readonly := true;
Details.Font.Name := 'Consolas';
List := TListBox.Create(F);
with List do begin
Parent := F;
Align := alClient;
Tag := PtrInt(Details);
OnClick := LogClick;
OnDblClick := LogDblClick;
end;
Search.Tag := PtrInt(List);
LogSearch(Search);
F.ShowModal;
finally
F.Free;
end;
end;
procedure TDBFrame.LogClick(Sender: TObject);
var
List: TListBox absolute Sender;
ndx: integer;
begin
ndx := cardinal(List.ItemIndex);
if ndx >= 0 then
TMemo(List.Tag).Text := copy(List.Items[ndx], 21, maxInt)
else
TMemo(List.Tag).Clear;
end;
procedure TDBFrame.LogDblClick(Sender: TObject);
var
List: TListBox absolute Sender;
SQL: string;
ndx: integer;
begin
ndx := cardinal(List.ItemIndex);
if ndx >= 0 then begin
SQL := copy(List.Items[ndx], 21, maxInt);
AddSQL(SQL, IsSelect(pointer(StringToAnsi7(SQL))));
TForm(List.Owner).Close;
end;
end;
procedure TDBFrame.LogSearch(Sender: TObject);
const
MAX_LINES_IN_HISTORY = 500;
var
Edit: TEdit absolute Sender;
List: TListBox;
i: integer;
s: RawUTF8;
begin
s := SynCommons.UpperCase(StringToUTF8(Edit.Text));
List := pointer(Edit.Tag);
with TMemoryMapText.Create(fSQLLogFile) do
try
List.Items.BeginUpdate;
List.Items.Clear;
for i := Count - 1 downto 0 do
if (s = '') or LineContains(s, i) then
if List.Items.Add(Strings[i]) > MAX_LINES_IN_HISTORY then
break; // read last 500 lines from UTF-8 file
finally
Free;
List.Items.EndUpdate;
end;
List.ItemIndex := 0;
LogClick(List);
end;
procedure TDBFrame.AddSQL(SQL: string; AndExec: boolean);
var
len: integer;
orig: string;
begin
SQL := SysUtils.Trim(SQL);
len := Length(SQL);
if len = 0 then
exit;
orig := mmoSQL.Lines.Text;
if orig <> '' then
SQL := #13#10#13#10 + SQL;
SQL := orig + SQL;
mmoSQL.Lines.Text := SQL;
mmoSQL.SelStart := length(SQL) - len;
mmoSQL.SelLength := len;
if AndExec then
btnExecClick(btnExec)
else
mmoSQL.SetFocus;
end;
procedure TDBFrame.btnCmdClick(Sender: TObject);
begin
with ClientToScreen(btnCmd.BoundsRect.TopLeft) do
pmCmd.Popup(X, Y + btnCmd.Height);
end;
function TDBFrame.ExecSQL(const SQL: RawUTF8): RawUTF8;
var
exec: TServiceCustomAnswer;
begin
exec := Admin.DatabaseExecute(DatabaseName, sql);
result := exec.Content;
end;
procedure TDBFrame.EnableChkTables(const aCaption: string);
begin
pnlLeftTop.Height := 44;
chkTables.Show;
chkTables.Caption := aCaption;
end;
procedure TDBFrame.edtLabelsChange(Sender: TObject);
var
i, index: integer;
match, previous: string;
begin
i := lstTables.ItemIndex;
if i >= 0 then
previous := lstTables.Items[i];
index := -1;
match := SysUtils.Trim(SysUtils.UpperCase(edtLabels.Text));
if (length(match) > 5) and (match[1] = '%') then begin
FillTables(match);
match := '';
end;
with lstTables.Items do
try
BeginUpdate;
Clear;
for i := 0 to Tables.Count - 1 do
if (match = '') or (Pos(match, SysUtils.UpperCase(Tables[i])) > 0) then begin
AddObject(Tables[i], Tables.Objects[i]);
if previous = Tables[i] then
index := Count - 1;
end;
finally
EndUpdate;
end;
if index >= 0 then
lstTables.ItemIndex := index;
end;
end.

176
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminLog.dfm Normal file
View File

@@ -0,0 +1,176 @@
object LogFrame: TLogFrame
Left = 0
Top = 0
Width = 516
Height = 367
TabOrder = 0
object spl2: TSplitter
Left = 0
Top = 275
Width = 516
Height = 3
Cursor = crVSplit
Align = alBottom
end
object pnlLeft: TPanel
Left = 0
Top = 0
Width = 145
Height = 275
Align = alLeft
TabOrder = 0
DesignSize = (
145
275)
object lblExistingLogKB: TLabel
Left = 12
Top = 34
Width = 56
Height = 13
Caption = 'Existing KB:'
end
object edtSearch: TEdit
Left = 5
Top = 8
Width = 98
Height = 21
Hint = 'Search (Ctrl+F, F3 for next) '
Anchors = [akLeft, akTop, akRight]
ParentShowHint = False
ShowHint = True
TabOrder = 0
Visible = False
OnChange = btnSearchNextClick
end
object chklstEvents: TCheckListBox
Left = 8
Top = 56
Width = 129
Height = 105
OnClickCheck = chklstEventsClickCheck
ItemHeight = 13
PopupMenu = pmFilter
Style = lbOwnerDrawFixed
TabOrder = 3
OnDblClick = chklstEventsDblClick
OnDrawItem = chklstEventsDrawItem
end
object btnStartLog: TButton
Left = 16
Top = 6
Width = 113
Height = 25
Caption = 'Start Logging'
TabOrder = 4
OnClick = btnStartLogClick
end
object edtExistingLogKB: TEdit
Left = 72
Top = 32
Width = 57
Height = 21
Hint = 'How many KB of log text should be transmitted at Start'
ParentShowHint = False
ShowHint = True
TabOrder = 5
Text = '512'
end
object btnStopLog: TButton
Left = 16
Top = 168
Width = 113
Height = 25
Caption = 'Stop Logging'
TabOrder = 6
Visible = False
OnClick = btnStopLogClick
end
object BtnSearchNext: TButton
Left = 103
Top = 6
Width = 20
Height = 23
Hint = 'Search Next (F3)'
Anchors = [akTop, akRight]
Caption = '?'
ParentShowHint = False
ShowHint = True
TabOrder = 1
Visible = False
OnClick = btnSearchNextClick
end
object BtnSearchPrevious: TButton
Left = 123
Top = 6
Width = 20
Height = 23
Hint = 'Search Previous (Shift F3)'
Anchors = [akTop, akRight]
Caption = '^'
ParentShowHint = False
ShowHint = True
TabOrder = 2
Visible = False
OnClick = btnSearchNextClick
end
end
object pnlRight: TPanel
Left = 145
Top = 0
Width = 371
Height = 275
Align = alClient
TabOrder = 1
object spl1: TSplitter
Left = 1
Top = 1
Height = 273
end
object drwgrdEvents: TDrawGrid
Left = 4
Top = 1
Width = 366
Height = 273
Align = alClient
ColCount = 3
DefaultColWidth = 100
DefaultRowHeight = 14
FixedCols = 0
RowCount = 1
FixedRows = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goDrawFocusSelected, goRowSelect, goThumbTracking]
TabOrder = 0
Visible = False
OnClick = drwgrdEventsClick
OnDblClick = drwgrdEventsDblClick
OnDrawCell = drwgrdEventsDrawCell
end
end
object mmoBottom: TMemo
Left = 0
Top = 278
Width = 516
Height = 89
Align = alBottom
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Consolas'
Font.Style = []
ParentFont = False
ReadOnly = True
ScrollBars = ssVertical
TabOrder = 2
end
object pmFilter: TPopupMenu
Left = 96
Top = 112
end
object tmrRefresh: TTimer
Enabled = False
Interval = 200
OnTimer = tmrRefreshTimer
Left = 153
Top = 32
end
end

525
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminLog.pas Normal file
View File

@@ -0,0 +1,525 @@
unit dddToolsAdminLog;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls,
CheckLst,
Menus,
Grids,
SynCommons,
SynLog,
mORMot,
mORMotDDD;
type
TLogFrame = class(TFrame)
pnlLeft: TPanel;
pnlRight: TPanel;
spl1: TSplitter;
edtSearch: TEdit;
chklstEvents: TCheckListBox;
pmFilter: TPopupMenu;
mmoBottom: TMemo;
drwgrdEvents: TDrawGrid;
btnStartLog: TButton;
tmrRefresh: TTimer;
edtExistingLogKB: TEdit;
lblExistingLogKB: TLabel;
btnStopLog: TButton;
spl2: TSplitter;
BtnSearchNext: TButton;
BtnSearchPrevious: TButton;
procedure chklstEventsDrawItem(Control: TWinControl; Index: Integer; Rect:
TRect; State: TOwnerDrawState);
procedure btnStartLogClick(Sender: TObject);
procedure tmrRefreshTimer(Sender: TObject);
procedure drwgrdEventsDrawCell(Sender: TObject; ACol, ARow: Integer; Rect:
TRect; State: TGridDrawState);
procedure drwgrdEventsClick(Sender: TObject); virtual;
procedure btnSearchNextClick(Sender: TObject);
procedure chklstEventsDblClick(Sender: TObject);
procedure btnStopLogClick(Sender: TObject);
procedure chklstEventsClickCheck(Sender: TObject);
procedure drwgrdEventsDblClick(Sender: TObject);
protected
FLog: TSynLogFileView;
FMenuFilterAll, FMenuFilterNone: TMenuItem;
FCallbackPattern: RawUTF8;
FLogSafe: TSynLocker;
procedure EventsCheckToLogEvents;
procedure pmFilterClick(Sender: Tobject);
procedure ReceivedOne(const Text: RawUTF8);
procedure SetListItem(Index: integer; const search: RawUTF8 = '');
public
Admin: IAdministratedDaemon;
Callback: ISynLogCallback;
OnLogReceived: function(Sender: TLogFrame; Level: TSynLogInfo;
const Text: RawUTF8): boolean of object;
constructor Create(Owner: TComponent; const aAdmin: IAdministratedDaemon); reintroduce;
constructor CreateCustom(Owner: TComponent; const aAdmin: IAdministratedDaemon;
const aEvents, aPattern: RawUTF8); virtual;
destructor Destroy; override;
procedure LogFilter(F: TSynLogInfos);
procedure Closing;
end;
TLogFrameClass = class of TLogFrame;
TLogFrameDynArray = array of TLogFrame;
TLogFrameChat = class(TLogFrame)
protected
procedure mmoChatKeyPress(Sender: TObject; var Key: Char);
public
mmoChat: TMemo;
constructor CreateCustom(Owner: TComponent; const aAdmin:
IAdministratedDaemon; const aEvents, aPattern: RawUTF8); override;
end;
implementation
uses
dddToolsAdminMain;
{$R *.dfm}
{ TLogFrameCallback }
type
TLogFrameCallback = class(TInterfacedObject, ISynLogCallback)
public
Owner: TLogFrame;
Pattern: RawUTF8;
procedure Log(Level: TSynLogInfo; const Text: RawUTF8);
end;
procedure TLogFrameCallback.Log(Level: TSynLogInfo; const Text: RawUTF8);
begin
if (Pattern <> '') and (Level <> sllNone) then
if PosI(pointer(Pattern), Text) = 0 then
exit;
Owner.ReceivedOne(Text);
if Assigned(Owner.OnLogReceived) then
Owner.OnLogReceived(Owner, Level, Text);
end;
procedure TLogFrame.chklstEventsDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
E: TSynLogInfo;
begin
if Index < 0 then
exit;
E := TSynLogInfo(chklstEvents.Items.Objects[Index]);
with chklstEvents.Canvas do begin
Brush.Color := LOG_LEVEL_COLORS[false, E];
Font.Color := LOG_LEVEL_COLORS[true, E];
TextRect(Rect, Rect.Left + 4, Rect.Top, ToCaption(E));
end;
end;
var
LogFrameCount: integer;
constructor TLogFrame.Create(Owner: TComponent; const aAdmin: IAdministratedDaemon);
var
F: TSynLogFilter;
M: TMenuItem;
begin
inherited Create(Owner);
FLogSafe.Init;
Admin := aAdmin;
Name := 'LogFrame' + IntToStr(LogFrameCount);
inc(LogFrameCount);
for F := low(F) to high(F) do begin
M := TMenuItem.Create(self);
M.Caption := ToCaption(F);
M.Tag := ord(F);
M.OnClick := pmFilterClick;
if F = lfAll then
FMenuFilterAll := M
else if F = lfNone then
FMenuFilterNone := M;
pmFilter.Items.Add(M);
end;
btnStopLogClick(nil);
end;
constructor TLogFrame.CreateCustom(Owner: TComponent;
const aAdmin: IAdministratedDaemon; const aEvents, aPattern: RawUTF8);
var
P: PUTF8Char;
e: integer;
begin
Create(Owner, aAdmin);
pmFilterClick(FMenuFilterNone);
P := pointer(aEvents);
while P <> nil do begin
e := PTypeInfo(TypeInfo(TSynLogInfo))^.EnumBaseType.GetEnumNameValue(
pointer(GetNextItem(P)));
if e > 0 then // ignore e=0=sllNone
chklstEvents.Checked[e - 1] := True;
end;
FCallbackPattern := UpperCase(aPattern);
btnStartLogClick(self);
btnStopLog.Hide; { TODO: allow event log closing }
end;
destructor TLogFrame.Destroy;
begin
FLogSafe.Done;
inherited;
end;
procedure TLogFrame.btnStopLogClick(Sender: TObject);
var
E: TSynLogInfo;
begin
chklstEvents.Top := 56;
chklstEvents.Items.Clear;
for E := succ(sllNone) to high(E) do begin
if (Sender = Self) and not (E in FLog.Events) then
continue; // from TLogFrame.CreateCustom()
chklstEvents.Items.AddObject(ToCaption(E), pointer(ord(E)));
end;
chklstEvents.Height := 8 + chklstEvents.Count * chklstEvents.ItemHeight;
pmFilterClick(FMenuFilterAll);
if Sender = nil then
exit;
btnStartLog.Show;
btnStopLog.Hide;
edtExistingLogKB.Show;
lblExistingLogKB.Show;
edtSearch.Hide;
btnSearchNext.Hide;
BtnSearchPrevious.Hide;
mmoBottom.Text := '';
drwgrdEvents.Row := 0;
drwgrdEvents.RowCount := 0;
drwgrdEvents.Tag := 0;
tmrRefresh.Enabled := false;
(Owner as TAdminControl).EndLog(self);
end;
procedure TLogFrame.LogFilter(F: TSynLogInfos);
var
i: integer;
begin
for i := 0 to chklstEvents.Count - 1 do
chklstEvents.Checked[i] := TSynLogInfo(chklstEvents.Items.Objects[i]) in F;
chklstEventsClickCheck(nil);
end;
procedure TLogFrame.pmFilterClick(Sender: Tobject);
begin
if Sender.InheritsFrom(TMenuItem) then
LogFilter(LOG_FILTER[TSynLogFilter(TMenuItem(Sender).Tag)]);
end;
procedure TLogFrame.EventsCheckToLogEvents;
var
i: integer;
events: TSynLogInfos;
begin
integer(events) := 0;
for i := 0 to chklstEvents.Count - 1 do
if chklstEvents.Checked[i] then
Include(events, TSynLogInfo(chklstEvents.Items.Objects[i]));
FLog.Events := events;
end;
procedure TLogFrame.btnStartLogClick(Sender: TObject);
var
cb: TLogFrameCallback;
kb, i: integer;
begin
cb := TLogFrameCallback.Create;
cb.Owner := Self;
cb.Pattern := FCallbackPattern;
Callback := cb;
FLogSafe.Lock;
try
try
FLog := TSynLogFileView.Create;
drwgrdEvents.DoubleBuffered := true;
drwgrdEvents.ColCount := 4;
drwgrdEvents.ColWidths[0] := 70;
drwgrdEvents.ColWidths[1] := 60;
drwgrdEvents.ColWidths[2] := 24;
drwgrdEvents.ColWidths[3] := 2000;
if Sender = self then
kb := 64 // from TLogFrame.CreateCustom
else
kb := StrToIntDef(edtExistingLogKB.Text, 0);
EventsCheckToLogEvents; // fill FLog.Events
Admin.SubscribeLog(FLog.Events, Callback, kb);
chklstEvents.Top := lblExistingLogKB.Top;
for i := chklstEvents.Count - 1 downto 0 do
if not chklstEvents.Checked[i] then
chklstEvents.Items.Delete(i);
chklstEvents.Height := 8 + chklstEvents.Count * chklstEvents.ItemHeight;
btnStopLog.Top := chklstEvents.Top + chklstEvents.Height + 8;
btnStartLog.Hide;
btnStopLog.Show;
edtExistingLogKB.Hide;
lblExistingLogKB.Hide;
edtSearch.Show;
btnSearchNext.Show;
BtnSearchPrevious.Show;
drwgrdEvents.Show;
tmrRefresh.Enabled := true;
except
Callback := nil;
FreeAndNil(FLog);
end;
finally
fLogSafe.UnLock;
end;
end;
const
TAG_NONE = 0;
TAG_REFRESH = 1;
procedure TLogFrame.ReceivedOne(const Text: RawUTF8);
var
P: PUTF8Char;
line: RawUTF8;
begin
// warning: this method is called from WebSockets thread, not UI thread
if Callback = nil then
exit;
FLogSafe.Lock;
try
if (FLog = nil) or (Text = '') then
exit;
P := pointer(Text);
repeat // handle multiple log rows in the incoming text
line := GetNextLine(P, P);
if length(line) < 24 then
continue;
FLog.AddInMemoryLine(line);
tmrRefresh.Tag := TAG_REFRESH; // notify tmrRefreshTimer()
until P = nil;
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.tmrRefreshTimer(Sender: TObject);
var
moveToLast: boolean;
begin
FLogSafe.Lock; // to protect tmrRefresh.Tag access from ReceivedOne()
try
if (tmrRefresh.Tag = TAG_NONE) or (fLog = nil) then
exit;
moveToLast := drwgrdEvents.Row = drwgrdEvents.RowCount - 1;
drwgrdEvents.RowCount := FLog.SelectedCount;
if FLog.SelectedCount > 0 then
if (drwgrdEvents.Tag = 0) or moveToLast then begin
drwgrdEvents.Row := FLog.SelectedCount - 1;
drwgrdEvents.Tag := 1;
end;
drwgrdEvents.Invalidate;
tmrRefresh.Tag := TAG_NONE;
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.drwgrdEventsDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
txt: string;
inverted: boolean;
level: TSynLogInfo;
begin
with drwgrdEvents.Canvas do begin
Brush.Style := bsClear;
FLogSafe.Lock;
try
txt := FLog.GetCell(ACol,ARow,level);
finally
FLogSafe.UnLock;
end;
if level=sllNone then
Brush.Color := clLtGray else begin
inverted := (gdFocused in State) or (gdSelected in State);
if inverted then
Brush.Color := clBlack else
Brush.Color := LOG_LEVEL_COLORS[inverted,level];
Font.Color := LOG_LEVEL_COLORS[not inverted,level];
end;
FillRect(Rect);
TextRect(Rect,Rect.Left+4,Rect.Top,txt);
end;
end;
procedure TLogFrame.drwgrdEventsClick(Sender: TObject);
var
row: integer;
s: string;
sel: TGridRect;
begin
row := drwgrdEvents.Row;
sel := drwgrdEvents.Selection;
FLogSafe.Lock;
try
s := FLog.GetLineForMemo(row,sel.Top,sel.Bottom);
finally
FLogSafe.UnLock;
end;
mmoBottom.Text := s;
end;
procedure TLogFrame.btnSearchNextClick(Sender: TObject);
var
s: RawUTF8;
ndx: integer;
begin
s := UpperCase(StringToUTF8(edtSearch.Text));
FLogSafe.Lock;
Screen.Cursor := crHourGlass;
try
if Sender=BtnSearchPrevious then
ndx := FLog.SearchPreviousText(s,drwgrdEvents.Row) else
if Sender=edtSearch then
ndx := FLog.SearchNextText(s,drwgrdEvents.Row,0) else
ndx := FLog.SearchNextText(s,drwgrdEvents.Row,1); // e.g. BtnSearchNext
if ndx>=0 then
SetListItem(ndx,s);
finally
FLogSafe.UnLock;
Screen.Cursor := crDefault;
end;
end;
procedure TLogFrame.SetListItem(Index: integer; const search: RawUTF8);
var
i: integer;
s, ss: string;
begin
if (FLog = nil) or (cardinal(Index) >= cardinal(FLog.SelectedCount)) then
mmoBottom.Text := ''
else begin
drwgrdEvents.Row := Index;
if (search = '') and drwgrdEvents.Visible then
drwgrdEvents.SetFocus;
s := FLog.EventString(FLog.Selected[Index], '', 0, true);
mmoBottom.Text := s;
if search <> '' then begin
ss := UTF8ToString(search);
i := Pos(ss, SysUtils.UpperCase(s));
if i > 0 then begin
mmoBottom.SelStart := i - 1;
mmoBottom.SelLength := length(ss);
mmoBottom.SetFocus;
end;
end;
end;
end;
procedure TLogFrame.Closing;
begin
Callback := nil;
FLogSafe.Lock;
try
FreeAndNil(fLog);
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.chklstEventsDblClick(Sender: TObject);
var
i: integer;
E: TSynLogInfo;
begin
if FLog.EventLevel = nil then // plain text file does not handle this
exit;
i := chklstEvents.ItemIndex;
if i < 0 then
exit;
E := TSynLogInfo(chklstEvents.Items.Objects[i]);
FLogSafe.Lock;
try
i := FLog.SearchNextEvent(E,drwgrdEvents.Row);
if i>=0 then
SetListItem(i);
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.chklstEventsClickCheck(Sender: TObject);
var
selected: integer;
begin
if FLog = nil then
exit;
EventsCheckToLogEvents; // fill FLog.Events
FLogSafe.Lock;
try
selected := FLog.Select(drwgrdEvents.Row);
if cardinal(selected) < cardinal(FLog.SelectedCount) then
drwgrdEvents.Row := 0; // avoid "Grid Out Of Range" when setting RowCount
drwgrdEvents.RowCount := FLog.SelectedCount;
if selected>=0 then
SetListItem(selected);
finally
FLogSafe.UnLock;
end;
if drwgrdEvents.Visible then begin
drwgrdEvents.Repaint;
drwgrdEventsClick(nil);
end;
end;
procedure TLogFrame.drwgrdEventsDblClick(Sender: TObject);
var ndx: integer;
begin
ndx := fLog.SearchEnterLeave(drwgrdEvents.Row);
if ndx>=0 then
SetListItem(ndx);
end;
{ TLogFrameChat }
constructor TLogFrameChat.CreateCustom(Owner: TComponent; const aAdmin:
IAdministratedDaemon; const aEvents, aPattern: RawUTF8);
begin
inherited;
chklstEvents.Enabled := false;
mmoChat := TMemo.Create(self);
mmoChat.Parent := self;
mmoChat.Height := 40;
mmoChat.Align := alTop;
mmoChat.OnKeyPress := mmoChatKeyPress;
end;
procedure TLogFrameChat.mmoChatKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then begin
if Assigned(Admin) then
Admin.DatabaseExecute('', FormatUTF8('#chat % %',
[ExeVersion.User, StringToUTF8(mmoChat.Text)]));
mmoChat.Clear;
Key := #0;
end;
end;
end.

20
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminMain.dfm Normal file
View File

@@ -0,0 +1,20 @@
object AdminForm: TAdminForm
Left = 379
Top = 162
Width = 697
Height = 478
Caption = ' Tools Administrator'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
KeyPreview = True
OldCreateOrder = False
Position = poDefaultSizeOnly
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
end

505
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminMain.pas Normal file
View File

@@ -0,0 +1,505 @@
unit dddToolsAdminMain;
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Clipbrd,
mORMotUI,
mORMotUILogin,
mORMotToolbar,
SynTaskDialog,
SynCommons,
mORMot,
mORMotHttpClient,
mORMotDDD,
dddInfraApps,
dddToolsAdminDB,
dddToolsAdminLog;
type
TAdminSaveOrExport = (expSaveGrid, expCopyGrid, expCopyRow);
TAdminControl = class(TWinControl)
protected
fClient: TSQLHttpClientWebsockets;
fAdmin: IAdministratedDaemon;
fDatabases: TRawUTF8DynArray;
fPage: TSynPager;
fPages: array of TSynPage;
fLogFrame: TLogFrame;
fLogFrames: TLogFrameDynArray;
fChatPage: TSynPage;
fChatFrame: TLogFrame;
fDBFrame: TDBFrameDynArray;
fDefinition: TDDDRestClientSettings;
fDlgSave: TSaveDialog;
public
LogFrameClass: TLogFrameClass;
DBFrameClass: TDBFrameClass;
State: record
raw: TDocVariantData;
daemon: RawUTF8;
version: RawUTF8;
mem: RawUTF8;
clients: integer;
exceptions: TRawUTF8DynArray;
lasttix: Int64;
end;
SavePrefix: TFileName;
OnBeforeExecute: TOnExecute;
OnAfterExecute: TOnExecute;
OnAfterGetState: TNotifyEvent;
destructor Destroy; override;
function Open(Definition: TDDDRestClientSettings; Model: TSQLModel = nil): boolean; virtual;
procedure Show; virtual;
procedure GetState;
function AddPage(const aCaption: RawUTF8): TSynPage; virtual;
function AddDBFrame(const aCaption, aDatabaseName: RawUTF8; aClass:
TDBFrameClass): TDBFrame; virtual;
function AddLogFrame(page: TSynPage; const aCaption, aEvents, aPattern: RawUTF8;
aClass: TLogFrameClass): TLogFrame; virtual;
procedure EndLog(aLogFrame: TLogFrame); virtual;
procedure OnPageChange(Sender: TObject); virtual;
function CurrentDBFrame: TDBFrame;
function FindDBFrame(const aDatabaseName: RawUTF8): TDBFrame;
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;
procedure SaveOrExport(Fmt: TAdminSaveOrExport; const ContextName: string = '';
DB: TDBFrame = nil);
property Client: TSQLHttpClientWebsockets read fClient;
property Page: TSynPager read fPage;
property LogFrame: TLogFrame read fLogFrame;
property DBFrame: TDBFrameDynArray read fDBFrame;
property ChatPage: TSynPage read fChatPage;
property ChatFrame: TLogFrame read fChatFrame;
property Admin: IAdministratedDaemon read fAdmin;
end;
TAdminForm = class(TSynForm)
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
protected
fFrame: TAdminControl;
public
property Frame: TAdminControl read fFrame;
end;
var
AdminForm: TAdminForm;
function AskForUserIfVoid(Definition: TDDDRestClientSettings): boolean;
implementation
{$R *.dfm}
function AskForUserIfVoid(Definition: TDDDRestClientSettings): boolean;
var
U, P: string;
begin
result := false;
if Definition.ORM.User = '' then
if TLoginForm.Login(Application.Mainform.Caption, FormatString(
'Credentials for %', [Definition.ORM.ServerName]), U, P, true, '') then begin
Definition.ORM.User := StringToUTF8(U);
Definition.ORM.PasswordPlain := StringToUTF8(P);
end
else
exit;
result := true;
end;
var
AdminControlConnecting: TForm; // only one Open() attempt at once
function TAdminControl.Open(Definition: TDDDRestClientSettings; Model: TSQLModel): boolean;
begin
result := false;
if Assigned(fAdmin) or (Definition.Orm.User = '') or Assigned(AdminControlConnecting) then
exit;
try
AdminControlConnecting := CreateTempForm('Connecting to ' + string(Definition.ORM.ServerName));
try
Application.ProcessMessages;
if Model = nil then
Model := TSQLModel.Create([], '');
Model.OnClientIdle := TLoginForm.OnIdleProcess; // allow basic UI interactivity
fClient := AdministratedDaemonClient(Definition, Model);
if not fClient.Services.Resolve(IAdministratedDaemon, fAdmin) then
raise EDDDRestClient.CreateUTF8('Resolve(IAdministratedDaemon)=false: check % version',
[Definition.ORM.ServerName]);
GetState;
fDefinition := Definition;
result := true;
finally
FreeAndNil(AdminControlConnecting);
if fClient <> nil then
fClient.OnIdle := nil; // back to default blocking behavior (safer UI)
end;
except
on E: Exception do begin
ShowException(E);
FreeAndNil(fClient);
end;
end;
end;
procedure TAdminControl.GetState;
var
exec: TServiceCustomAnswer;
begin
if self = nil then
exit;
try
if fAdmin <> nil then begin
State.raw.Clear;
exec := fAdmin.DatabaseExecute('', '#info');
if (exec.Content = '') or (exec.Content[1] <> '{') then
exec := fAdmin.DatabaseExecute('', '#state'); // backward compatibility
State.raw.InitJSONInPlace(pointer(exec.Content), JSON_OPTIONS_FAST);
State.raw.GetAsRawUTF8('daemon', State.daemon);
if not State.raw.GetAsRawUTF8('version', State.version) then
State.version := fClient.SessionVersion;
State.mem := State.raw.U['memused'];
if State.mem = '' then
KBU(state.Raw.O['SystemMemory'].O['Allocated'].I['Used'] shl 10, State.mem);
State.clients := State.raw.I['clients'];
State.raw.GetAsDocVariantSafe('exception')^.ToRawUTF8DynArray(State.exceptions);
State.raw.AddValue('remoteip', fClient.Server + ':' + fClient.Port);
State.lasttix := GetTickCount64;
end;
if Assigned(OnAfterGetState) then
OnAfterGetState(self);
except
Finalize(State);
end;
end;
procedure TAdminControl.Show;
var
i, n: integer;
f: TDBFrame;
begin
if (fClient = nil) or (fAdmin = nil) or (fPage <> nil) then
exit; // show again after hide
if LogFrameClass = nil then
LogFrameClass := TLogFrame;
if DBFrameClass = nil then
DBFrameClass := TDBFrame;
fDatabases := fAdmin.DatabaseList;
fPage := TSynPager.Create(self);
fPage.ControlStyle := fPage.ControlStyle + [csClickEvents]; // enable OnDblClick
fPage.Parent := self;
fPage.Align := alClient;
fPage.OnChange := OnPageChange;
n := length(fDatabases);
fLogFrame := AddLogFrame(nil, 'log', '', '', LogFrameClass);
if n > 0 then begin
for i := 0 to n - 1 do begin
f := AddDBFrame(fDatabases[i], fDatabases[i], DBFrameClass);
f.Open;
if i = 0 then begin
fPage.ActivePageIndex := 1;
f.SetResult(State.raw.ToJSON('', '', jsonUnquotedPropName));
end;
end;
Application.ProcessMessages;
fDBFrame[0].mmoSQL.SetFocus;
end;
fChatPage := AddPage('Chat');
fChatPage.TabVisible := false;
end;
procedure TAdminControl.EndLog(aLogFrame: TLogFrame);
begin
if aLogFrame <> nil then
try
Screen.Cursor := crHourGlass;
if aLogFrame.Callback <> nil then begin
fClient.Services.CallBackUnRegister(aLogFrame.Callback);
aLogFrame.Callback := nil;
Sleep(10);
end;
aLogFrame.Closing;
finally
Screen.Cursor := crDefault;
end;
end;
destructor TAdminControl.Destroy;
var
i: integer;
begin
if fClient <> nil then
fClient.OnIdle := TLoginForm.OnIdleProcess; // allow basic UI interactivity
for i := 0 to high(fLogFrames) do begin
EndLog(fLogFrames[i]);
fLogFrames[i].Admin := nil;
fLogFrames[i] := nil;
end;
Finalize(fLogFrames);
for i := 0 to high(fDBFrame) do
fDBFrame[i].Admin := nil;
fDBFrame := nil;
fAdmin := nil;
fDefinition.Free;
if fClient <> nil then begin
for i := 1 to 5 do begin
Sleep(50); // leave some time to flush all pending CallBackUnRegister()
Application.ProcessMessages;
end;
FreeAndNil(fClient);
end;
inherited Destroy;
end;
procedure TAdminControl.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure LogKeys(aLogFrame: TLogFrame);
var ch: char;
begin
if aLogFrame <> nil then
case Key of
VK_F3:
if Shift = [] then
aLogFrame.btnSearchNextClick(aLogFrame.btnSearchNext)
else
aLogFrame.btnSearchNextClick(aLogFrame.btnSearchPrevious);
ord('A')..ord('Z'), ord('0')..ord('9'), 32:
if (Shift = []) and (aLogFrame.ClassType <> TLogFrameChat) and not
aLogFrame.edtSearch.Focused then begin
ch := Char(Key);
if (Key in [ord('A')..ord('Z')]) and (GetKeyState(VK_CAPITAL) and 1=0) then
inc(ch,32); // emulate capslock behavior
aLogFrame.edtSearch.Text := aLogFrame.edtSearch.Text + string(ch);
end
else if (key = ord('F')) and (ssCtrl in Shift) then begin
aLogFrame.edtSearch.SelectAll;
aLogFrame.edtSearch.SetFocus;
end;
end;
end;
var
page: TControl;
ndx: integer;
begin
page := fPage.ActivePage;
if page = nil then
exit;
ndx := page.Tag;
if ndx > 0 then begin
ndx := ndx - 1; // see AddDBFrame()
if cardinal(ndx) < cardinal(length(fDBFrame)) then
with fDBFrame[ndx] do
case Key of
VK_F5:
btnCmdClick(btnCmd);
VK_F9:
btnExecClick(btnExec);
ord('A'):
if ssCtrl in Shift then begin
mmoSQL.SelectAll;
mmoSQL.SetFocus;
end;
ord('H'):
if ssCtrl in Shift then
btnHistoryClick(btnHistory);
end
end
else if ndx < 0 then begin
ndx := -(ndx + 1); // see AddLogFrame()
if cardinal(ndx) < cardinal(length(fLogFrames)) then
LogKeys(fLogFrames[ndx]);
end;
end;
function TAdminControl.AddPage(const aCaption: RawUTF8): TSynPage;
var
n: integer;
begin
n := length(fPages);
SetLength(fPages, n + 1);
result := TSynPage.Create(self);
result.Caption := UTF8ToString(aCaption);
result.PageControl := fPage;
fPages[n] := result;
end;
function TAdminControl.AddDBFrame(const aCaption, aDatabaseName: RawUTF8;
aClass: TDBFrameClass): TDBFrame;
var
page: TSynPage;
n: integer;
begin
page := AddPage(aCaption);
n := length(fDBFrame);
SetLength(fDBFrame, n + 1);
result := aClass.Create(self);
result.Name := FormatString('DBFrame%', [aCaption]);
result.Parent := page;
result.Align := alClient;
result.Client := fClient;
result.Admin := fAdmin;
result.DatabaseName := aDatabaseName;
result.OnBeforeExecute := OnBeforeExecute;
result.OnAfterExecute := OnAfterExecute;
result.SavePrefix := SavePrefix;
fDBFrame[n] := result;
page.Tag := n + 1; // Tag>0 -> index in fDBFrame[Tag-1] -> used in FormKeyDown
end;
function TAdminControl.AddLogFrame(page: TSynPage; const aCaption, aEvents,
aPattern: RawUTF8; aClass: TLogFrameClass): TLogFrame;
var
n: integer;
begin
if page = nil then begin
page := AddPage(aCaption);
fPage.ActivePageIndex := fPage.PageCount - 1;
end;
if aEvents = '' then
result := aClass.Create(self, fAdmin)
else
result := aClass.CreateCustom(self, fAdmin, aEvents, aPattern);
result.Parent := page;
result.Align := alClient;
n := length(fLogFrames);
SetLength(fLogFrames, n + 1);
fLogFrames[n] := result;
page.Tag := -(n + 1); // Tag<0 -> index in fLogFrames[-(Tag+1)] -> used in FormKeyDown
end;
procedure TAdminControl.OnPageChange(Sender: TObject);
var
ndx: cardinal;
begin
if fPage.ActivePage = fChatPage then begin
if fChatFrame = nil then
fChatFrame := AddLogFrame(fChatPage, '', 'Monitoring', '[CHAT] ', TLogFrameChat);
exit;
end;
ndx := fPage.ActivePageIndex - 1;
if ndx >= cardinal(Length(fDBFrame)) then
exit;
end;
function TAdminControl.CurrentDBFrame: TDBFrame;
var
ndx: cardinal;
begin
ndx := fPage.ActivePageIndex - 1;
if ndx >= cardinal(Length(fDBFrame)) then
result := nil
else
result := fDBFrame[ndx];
end;
function TAdminControl.FindDBFrame(const aDatabaseName: RawUTF8): TDBFrame;
var
i: Integer;
begin
for i := 0 to high(fDBFrame) do
if IdemPropNameU(fDBFrame[i].DatabaseName, aDatabaseName) then begin
result := fDBFrame[i];
exit;
end;
result := nil;
end;
procedure TAdminControl.SaveOrExport(Fmt: TAdminSaveOrExport;
const ContextName: string; DB: TDBFrame);
var
grid: TSQLTable;
row: integer;
name, table: RawUTF8;
begin
if DB = nil then
DB := CurrentDBFrame;
if DB = nil then
exit;
grid := DB.Grid.Table;
if (grid = nil) or (grid.RowCount = 0) then
exit;
if Fmt = expSaveGrid then begin
if fDlgSave = nil then begin
fDlgSave := TSaveDialog.Create(Owner);
fDlgSave.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist,
ofEnableSizing];
fDlgSave.Filter :=
'JSON (human readable)|*.json|JSON (small)|*.json|CSV (text)|*.txt|Excel/Office (.ods)|*.ods|HTML|*.html';
fDlgSave.DefaultExt := '.html';
fDlgSave.FilterIndex := 5;
fDlgSave.InitialDir := GetShellFolderPath(CSIDL_DOCUMENTS);
end;
if PropNameValid(pointer(db.GridLastTableName)) then
name := db.GridLastTableName;
fDlgSave.FileName := SysUtils.Trim(FormatString('% % %',
[ContextName, name, NowToString(false)]));
if not fDlgSave.Execute then
exit;
case fDlgSave.FilterIndex of
1:
JSONBufferReformat(pointer(grid.GetJSONValues(true)), table);
2:
table := grid.GetJSONValues(true);
3:
table := grid.GetCSVValues(true);
4:
table := grid.GetODSDocument;
5:
table := grid.GetHtmlTable;
end;
if table <> '' then
FileFromString(table, fDlgSave.FileName);
end
else begin
case Fmt of
expCopyGrid:
table := grid.GetCSVValues(true);
expCopyRow:
begin
row := db.drwgrdResult.Row;
if row < 0 then
exit;
table := grid.GetCSVValues(true, ',', false, row, row);
end;
end;
if table <> '' then
Clipboard.AsText := UTF8ToString(table);
end;
end;
{ TAdminForm }
procedure TAdminForm.FormCreate(Sender: TObject);
begin
DefaultFont.Name := 'Tahoma';
DefaultFont.Size := 9;
Caption := FormatString('% %', [ExeVersion.ProgramName, ExeVersion.Version.Detailed]);
fFrame := TAdminControl.Create(self);
fFrame.Parent := self;
fFrame.Align := alClient;
OnKeyDown := fFrame.FormKeyDown;
end;
procedure TAdminForm.FormShow(Sender: TObject);
begin
fFrame.Show;
Caption := FormatString('% - % % via %', [ExeVersion.ProgramName,
fFrame.State.daemon, fFrame.State.version, fFrame.fDefinition.ORM.ServerName]);
end;
end.