474 lines
18 KiB
ObjectPascal
474 lines
18 KiB
ObjectPascal
/// 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) 2022 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) 2022
|
|
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.
|