Sx.DDD.Infra.Email.pas

unit Sx.DDD.Infra.Email;

{$mode delphi}

interface

uses
  SysUtils,
  mormot.core.base,
  mormot.core.data,
  mormot.core.json,
  mormot.core.search,
  mormot.rest.core,
  mormot.rest.server,
  mormot.orm.base,
  mormot.orm.core,
  Sx.DDD.Core,
  Sx.DDD.Email.Interfaces,
  Sx.DDD.User.Types;


{ ****************** 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: TRest); 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: TRestServerURIContext);
  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: TRest); override;
    /// register the callback URI service
    procedure SetURIForServer(aRestServerPublic: TRestServer;
      aParams: TDDDEmailRedirection); overload;
    /// register the callback URI service
    // - same as the overloaded function, but taking parameters one by one
    procedure SetURIForServer(aRestServerPublic: TRestServer;
      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;

  /// base ORM class, which will have creation and modification timestamp fields
  TOrmTimed = class(TOrm)
  protected
    fCreated: TCreateTime;
    fModified: TModTime;
  published
    /// will be filled by the ORM when this item will be created in the database
    property Created: TCreateTime
      read fCreated write fCreated;
    /// will be filled by the ORM each time this item will be written in the database
    property Modified: TModTime
      read fModified write fModified;
  end;

  /// ORM class storing an email in addition to creation/modification timestamps
  // - declared as its own class, since may be reused
  TSQLRecordEmailAbstract = class(TOrmTimed)
  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

uses
  mormot.core.buffers,
  mormot.core.datetime,
  mormot.core.os,
  mormot.core.text,
  mormot.core.unicode,
  mormot.core.variants,
  mormot.crypt.core;

{ TDDDEmailServiceAbstract }

constructor TDDDEmailServiceAbstract.Create(aRest: TRest);
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.Orm,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: TRest);
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: TRestServerURIContext);
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.Orm.Update(EmailValidation) then
        Ctxt.Redirect(FormatUTF8(fSuccessRedirectURI,
          [UrlEncode(logon),UrlEncode(email),UrlEncode(EmailValidation.ValidationIP)]));
    end;
  finally
    EmailValidation.Free;
  end;
end;

procedure TDDDEmailValidationService.SetURIForServer(
  aRestServerPublic: TRestServer; 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: TRestServer; 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.Orm,'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;

procedure _ObjAddProps(Value: TObject; var Obj: variant); overload;
var v: variant;
begin
  ObjectToVariant(Value,v,[woDontStoreDefault]);
  _ObjAddProps(v,Obj);
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.Orm.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.