source upload
This commit is contained in:
Razor12911
2445
contrib/mORMot/SQLite3/DDD/infra/dddInfraApps.pas
Normal file
2445
contrib/mORMot/SQLite3/DDD/infra/dddInfraApps.pas
Normal file
File diff suppressed because it is too large
Load Diff
374
contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas
Normal file
374
contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas
Normal 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
473
contrib/mORMot/SQLite3/DDD/infra/dddInfraEmail.pas
Normal 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
804
contrib/mORMot/SQLite3/DDD/infra/dddInfraEmailer.pas
Normal 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
383
contrib/mORMot/SQLite3/DDD/infra/dddInfraRepoUser.pas
Normal 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
1205
contrib/mORMot/SQLite3/DDD/infra/dddInfraSettings.pas
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user