Sx.DDD.Infra.Emailer.pas

unit Sx.DDD.Infra.Emailer;

{$mode delphi}

interface

uses
  //{$ifdef MSWINDOWS}
  //Windows, // for fSafe.Lock/Unlock inlining
  //{$endif}
  //{$ifdef KYLIX3}
  //Types,
  //LibC,
  //{$endif}
  SysUtils,
  Classes,
  mormot.core.base,
  mormot.core.interfaces,
  mormot.core.perf,
  mormot.core.json,
  mormot.core.mustache,
  mormot.core.text,
  mormot.net.sock,
  mormot.rest.core,
  mormot.rest.server,
  mormot.orm.base,
  mormot.orm.core,
  Sx.DDD.Core,
  Sx.DDD.Email.Interfaces,
  Sx.DDD.Infra.Email;

{ ****************** 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: TRest); overload; override;
    constructor Create(aRest: TRest; 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(TOrmTimed)
  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(const Server: IRestOrmServer; const FieldName: RawUtf8; Options: TOrmInitializeTableOptions); 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;


implementation

uses
  mormot.core.buffers,
  mormot.core.unicode,
  mormot.core.os,
  mormot.core.datetime;

{ ****************** Email Sending Service }

{ TSMTPServer }

function TSMTPServer.CreateInstance: TInterfacedObject;
begin
  result := TSMTPServerSocketConnectionAbstractClass(fImplementation.ValueClass).
    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 ENetSock.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(const Server: IRestOrmServer; const FieldName: RawUtf8; Options: TOrmInitializeTableOptions);
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.Orm,'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.Orm.Update(fPendingTask,'State,SendTime');
end;

function TDDDEmailerDaemonProcess.ExecuteProcessAndSetResult: QWord;
var body: RawByteString;
    pendingEmail: TSQLRecordEmailer;
begin
  pendingEmail := fPendingTask as TSQLRecordEmailer;
  body := AlgoSynLZ.Decompress(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.Orm.Update(pendingEmail,'State,ErrorMsg'); // always write
end;

procedure TDDDEmailerDaemonProcess.ExecuteIdle;
begin
  fSMTPConnection := nil; // release ISMTPServerConnection instance
end;


{ TDDDEmailerDaemon }

constructor TDDDEmailerDaemon.Create(aRest: TRest);
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: TRest;
  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 := AlgoSynLZ.CompressToBytes(aBody);
    CqrsBeginMethod(qaNone,result);
    if not Email.FilterAndValidate(Rest.Orm,msg) then
      CqrsSetResultString(cqrsDDDValidationFailed,msg,result) else
      if Rest.Orm.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.AddOrUpdate(aTemplateName, 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;


initialization
  TInterfaceFactory.RegisterInterfaces([TypeInfo(ISMTPServerConnection)]);

end.