{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Original Author: Ian Baker, ADV Systems 2003
Updated by:   Angus Robertson, Magenta Systems Ltd
Creation:     24 September 2013
Description:  How to use TSslSmtpServer
Version:      V9.8
EMail:        francois.piette@overbyte.be  http://www.overbyte.be
Support:      https://en.delphipraxis.net/forum/37-ics-internet-component-suite/
Legal issues: Copyright (C) 1997-2026 by François PIETTE
              Rue de Grady 24, 4053 Embourg, Belgium.

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely, subject to the following
              restrictions:

              1. The origin of this software must not be misrepresented,
                 you must not claim that you wrote the original software.
                 If you use this software in a product, an acknowledgment
                 in the product documentation would be appreciated but is
                 not required.

              2. Altered source versions must be plainly marked as such, and
                 must not be misrepresented as being the original software.

              3. This notice may not be removed or altered from any source
                 distribution.

              4. You must register this software by sending a picture postcard
                 to the author. Use a nice stamp and mention your name, street
                 address, EMail address and any comment you like to say.


Sep 24, 2013 V8.00 Angus created SSL version
Apr 26, 2014 V8.01 Arno - Check for IsIPv6Available rather than IsIPv6ApiAvailable
                   in doStartClick.
Dec 10, 2014 V8.02 Angus added handshake response message, better cipher list
June 2015 V8.03    Angus fixed name space issue that stopped build
May 24, 2016 V8.04 Angus renamed TBufferedFileStream to TIcsBufferedFileStream
Nov 12 2016  V8.37 Set friendly errors
                   Specify minimum and maximum SSL version supported
                   Allow server IP address to be specified
Aug 08, 2023 V9.0  Updated version to major release 9.
Sep 16, 2024 V9.3  Using OverbyteIcsTypes for consolidated types and constants, allowing
                     other import units to be removed.
                    Updated ciphers.
Jan 30, 2026 V9.6  Using IcsHosts instead of multilisten and SslContext.
Aug 26, 2026 V9.8 Commonise sample caption version and date, from Types.

  Pending more testing for certificates




 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit OverbyteIcsSslSmtpServ1;

interface

{$B-}                 { Enable partial boolean evaluation   }
{$T-}                 { Untyped pointers                    }
{$X+}                 { Enable extended syntax              }
{$I+}                 { Turn IO exceptions to on            }
{$H+}                 { Use long strings                    }
{$J+}                 { Allow typed constant to be modified }
{$WARN SYMBOL_PLATFORM   OFF}
{$WARN SYMBOL_LIBRARY    OFF}
{$WARN SYMBOL_DEPRECATED OFF}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, StrUtils, DateUtils, Types,
  OverbyteIcsIniFiles,
  OverbyteIcsCharsetUtils,
  OverbyteIcsWndControl,
  OverbyteIcsWSocket,
  OverbyteIcsWSocketS,
  OverbyteIcsStreams,
  OverbyteIcsSmtpSrv,
  OverbyteIcsSslBase,
  OverbyteIcsUtils,
  OverbyteIcsTypes;  { V9.3 consolidated types and constants }

const
    SmtpSslServerTestVersion    = IcsVerLitNum;                      { V9.8 }
    CopyRight : String = ' OverbyteSslSmtpServer'  + IcsVerLitCopyright; { V9.8 }

  // INI file stuff
    SectionData       = 'Data';
    KeyDnsServer      = 'DnsServer';
    KeyEmailAccs      = 'EmailAccs';
    KeySpoolDir       = 'SpoolDir';
    KeyAddRecvHdrs    = 'AddRecvHdrs';
    KeyAddEnvHdrs     = 'AddEnvHdrs';
    KeyAddReplayHdrs  = 'AddReplayHdrs';
    KeyAllowRelay     = 'AddAllowRelay';
    KeyAuthTls        = 'AuthTls';
    KeyAliasAccs      = 'AddAliasAccs';
    KeyCertFile        = 'CertFile';
    KeyPassPhrase      = 'PassPhrase';
    KeyPrivKeyFile     = 'PrivKeyFile';
    KeyVerifyPeer      = 'VerifyPeer';
    KeyCAFile          = 'CAFile';
    KeyCAPath          = 'CAPath';
    KeyServIpAddr      = 'ServIpAddr';

    SectionWindow     = 'Window';
    KeyTop            = 'Top';
    KeyLeft           = 'Left';
    KeyWidth          = 'Width';
    KeyHeight         = 'Height';


type

  TSmtpSslSrvForm       = class(TForm)
    ButtonPanel: TPanel;
    Log        : TMemo;
    PrefDnsServer: TEdit;
    Label1: TLabel;
    PrefEmailAccs: TMemo;
    Label2: TLabel;
    PrefSpoolDir: TEdit;
    PrefAddRecvHdrs: TCheckBox;
    Label3: TLabel;
    PrefAddEnvHdrs: TCheckBox;
    doStart: TButton;
    doStop: TButton;
    doExit: TButton;
    PrefAllowRelay: TCheckBox;
    PrefAliasAccs: TMemo;
    Label4: TLabel;
    PrefAddReplayHdrs: TCheckBox;
    ToolsPanel: TPanel;
    Label5: TLabel;
    Label7: TLabel;
    Label6: TLabel;
    CertFileEdit: TEdit;
    PrivKeyFileEdit: TEdit;
    PassPhraseEdit: TEdit;
    PrefAuthTls: TCheckBox;
    Label8: TLabel;
    ServIpAddr: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure SmtpServer1Auth(Sender, Client: TObject; const UserName: string; var Password: string;
        var Action: TSmtpMailAction; var Reason: string);
    procedure SmtpServer1AuthPW(Sender, Client: TObject; const UserName: string; var Password: string;
      var Action: TSmtpMailAction; var Reason: string);
    procedure SmtpServer1Connect(Sender, Client: TObject; const IpAddr: string; var Action: TSmtpMailAction;
      var Reason: string);
    procedure SmtpServer1DataEnd(Sender, Client: TObject; var Action: TSmtpMailAction; var Reason: string);
    procedure SmtpServer1DataStart(Sender, Client: TObject; var Action: TSmtpMailAction; var Reason: string);
    procedure SmtpServer1Disconnect(Sender, Client: TObject; Error: Word);
    procedure SmtpServer1Exception(Sender: TObject; E: Exception);
    procedure SmtpServer1MailFrom(Sender, Client: TObject; const MailFrom: string; var Action: TSmtpMailAction;
      var Reason: string);
    procedure SmtpServer1RcptTo(Sender, Client: TObject; const RcptTo: string; var Action: TSmtpMailAction;
      var Reason: string);
    procedure SmtpServer1Command(Sender, Client: TObject; const Command: string);
    procedure SmtpServer1Response(Sender, Client: TObject; const Response: string);
    procedure SmtpServer1ServerStopped(Sender: TObject);
    procedure SmtpServer1ServerStarted(Sender: TObject);
    procedure doStartClick(Sender: TObject);
    procedure doStopClick(Sender: TObject);
    procedure doExitClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure SmtpServer1SslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect: Boolean);
    procedure SmtpServer1SslVerifyPeer(Sender: TObject; var Ok: Integer; Cert: TX509Base);
    procedure SmtpServer1Display(Sender: TObject; const Msg: string);
   end;

var
    SmtpSslSrvForm: TSmtpSslSrvForm;
    FIniFileName: string;
    FInitialized  : Boolean;
    FSmtpServer: TSslSmtpServer;     { V9.6 create in code }

implementation

{$R *.dfm}


procedure TSmtpSslSrvForm.FormClose(Sender: TObject; var Action: TCloseAction);
var
    IniFile : TIcsIniFile;
begin
    IniFile := TIcsIniFile.Create(FIniFileName);
    IniFile.WriteString(SectionData, KeyDnsServer,      PrefDnsServer.Text);
    IniFile.WriteString(SectionData, KeyEmailAccs,      PrefEmailAccs.Lines.CommaText);
    IniFile.WriteString(SectionData, KeyAliasAccs,      PrefAliasAccs.Lines.CommaText);
    IniFile.WriteString(SectionData, KeySpoolDir,       PrefSpoolDir.Text);
    IniFile.WriteBool(SectionData,   KeyAddRecvHdrs,    PrefAddRecvHdrs.Checked);
    IniFile.WriteBool(SectionData,   KeyAddEnvHdrs,     PrefAddEnvHdrs.Checked);
    IniFile.WriteBool(SectionData,   KeyAddReplayHdrs,  PrefAddReplayHdrs.Checked);
    IniFile.WriteBool(SectionData,   KeyAllowRelay,     PrefAllowRelay.Checked);
    IniFile.WriteBool(SectionData,   KeyAuthTls,        PrefAuthTls.Checked);
    IniFile.WriteString(SectionData, KeyCertFile,       CertFileEdit.Text);
    IniFile.WriteString(SectionData, KeyPrivKeyFile,    PrivKeyFileEdit.Text);
    IniFile.WriteString(SectionData, KeyPassPhrase,     PassPhraseEdit.Text);
    IniFile.WriteString(SectionData, KeyServIpAddr,     ServIpAddr.Text);  { V8.37 }

    IniFile.WriteInteger(SectionWindow, KeyTop,    Top);
    IniFile.WriteInteger(SectionWindow, KeyLeft,   Left);
    IniFile.WriteInteger(SectionWindow, KeyWidth,  Width);
    IniFile.WriteInteger(SectionWindow, KeyHeight, Height);
    IniFile.UpdateFile;
    IniFile.Free;
end;

procedure TSmtpSslSrvForm.FormCreate(Sender: TObject);
begin
    Caption := Caption + IcsVerLitSample;   { V9.8 commonise sample caption version and date }
    Log.Clear;
    FIniFileName := GetIcsIniFileName;
    FSmtpServer := TSslSmtpServer.Create(self);  { V9.6 create in code }
    with FSmtpServer do begin
        OnException := SmtpServer1Exception;
        OnServerStarted := SmtpServer1ServerStarted;
        OnServerStopped := SmtpServer1ServerStopped;
        OnConnect := SmtpServer1Connect;
        OnDisconnect := SmtpServer1Disconnect;
        OnCommand := SmtpServer1Command;
        OnResponse := SmtpServer1Response;
        OnMailFrom := SmtpServer1MailFrom;
        OnRcptTo := SmtpServer1RcptTo;
        OnAuth := SmtpServer1Auth;
        OnAuthPW := SmtpServer1AuthPW;
        OnDataStart := SmtpServer1DataStart;
        OnDataEnd := SmtpServer1DataEnd;
        WSDebugOptions := [];
        OnDisplay := SmtpServer1Display;
        OnSslVerifyPeer := SmtpServer1SslVerifyPeer;
        OnSslHandshakeDone := SmtpServer1SslHandshakeDone;
    end;
end;


procedure TSmtpSslSrvForm.FormDestroy(Sender: TObject);
begin
    FSmtpServer.Stop;
    FreeAndNil(FSmtpServer);
end;

procedure TSmtpSslSrvForm.FormShow(Sender: TObject);
var
    IniFile    : TIcsIniFile;
begin
    if not FInitialized then
    begin
        FInitialized := TRUE;

        IniFile := TIcsIniFile.Create(FIniFileName);
        PrefDnsServer.Text       := IniFile.ReadString(SectionData, KeyDnsServer, '8.8.8.8');  // Google DNS
        PrefEmailAccs.Lines.CommaText := IniFile.ReadString(SectionData, KeyEmailAccs, 'account@domain.com');
        PrefAliasAccs.Lines.CommaText := IniFile.ReadString(SectionData, KeyAliasAccs, '*@domain.com=account@domain.com');
        PrefSpoolDir.Text        := IniFile.ReadString(SectionData, KeySpoolDir, 'c:\mailspool\');
        PrefAddRecvHdrs.Checked  := IniFile.ReadBool(SectionData, KeyAddRecvHdrs, true);
        PrefAddEnvHdrs.Checked   := IniFile.ReadBool(SectionData, KeyAddEnvHdrs, false);
        PrefAddReplayHdrs.Checked := IniFile.ReadBool(SectionData, KeyAddReplayHdrs, false);
        PrefAllowRelay.Checked   := IniFile.ReadBool(SectionData, KeyAllowRelay, true);
        PrefAuthTls.Checked      := IniFile.ReadBool(SectionData, KeyAuthTls, true);
        CertFileEdit.Text    := IniFile.ReadString(SectionData, KeyCertFile, 'C:\ProgramData\ICS-OpenSSL\ICS-Certs\localhost-bundle.pem');
        PrivKeyFileEdit.Text := IniFile.ReadString(SectionData, KeyPrivKeyFile, '');
        PassPhraseEdit.Text  := IniFile.ReadString(SectionData, KeyPassPhrase, 'password');
        ServIpAddr.Text      := IniFile.ReadString(SectionData, KeyServIpAddr, '127.0.0.1');      { V8.37 }
        Top    := IniFile.ReadInteger(SectionWindow, KeyTop,    (Screen.Height - Height) div 2);
        Left   := IniFile.ReadInteger(SectionWindow, KeyLeft,   (Screen.Width - Width) div 2);
        Width  := IniFile.ReadInteger(SectionWindow, KeyWidth,  Width);
        Height := IniFile.ReadInteger(SectionWindow, KeyHeight, Height);
        IniFile.Free;
    end;
end;

procedure TSmtpSslSrvForm.doStartClick(Sender: TObject);
begin
    if PrefSpoolDir.Text = '' then
    begin
        Log.Lines.Add ('Must specify a spool directory to receive email');
        exit;
    end;
    if NOT ForceDirectories (PrefSpoolDir.Text) then
    begin
        Log.Lines.Add ('Failed to create spool directory: ' + PrefSpoolDir.Text);
        exit;
    end;
    with FSmtpServer do
    begin
        WSDebugOptions := DefWSDebugServer;  { V9.6 }
        ServerHost     := String(WSocketResolveIP (AnsiString (ServIpAddr.Text)));  // should be the mail exchange domain name
        SocketFamily   := sfIpV4;
        CertExpireDays := 7;
        SslCertAutoOrder := False;
        IcsHosts.Clear ;

     // add first IcsHost
        IcsHosts.Add;
        with IcsHosts [0] do begin
            HostEnabled := True;
            BindIpAddr := ServIpAddr.Text;
       //     BindIpAddr2 := // IPv6
            BindNonPort := 25;
            HostTag := 'SmtpServer' ;
            Descr := HostTag;
            CertSupplierProto := SuppProtoNone;
            if FileExists(CertFileEdit.Text) then begin
                HostNames.Text := ServerHost;
                SslCert := IcsTrim(CertFileEdit.Text);
                if FileExists(PrivKeyFileEdit.Text) then
                    SslKey := IcsTrim(PrivKeyFileEdit.Text);
                SslPassword := IcsTrim(PassPhraseEdit.text);

              { following are for automatic ordering and installation of SSL certificates }
             {   if SslCertAutoOrder then begin
                    CertDirWork := IcsTrim(SslCertDirWork.Text);
                    if (CertDirWork <> '') and DirectoryExists(CertDirWork) then begin
                        SslX509Certs.ProxyURL := ProxyURL.Text;
                        IpLogServer.SrvX509Certs := SslX509Certs;
                        CertSupplierProto := TSupplierProto(SslCertSupplierProto.ItemIndex);
                        CertChallenge := TChallengeType(SslCertChallenge.ItemIndex);
                        CertPKeyType := TSslPrivKeyType(SslCertPKeyType.ItemIndex);
                        CertProduct := IcsTrim(SslCertProduct.Text);
                        CertSignDigest := TEvpDigest(SslCertSignDigest.ItemIndex);
                    end
                    else
                        AddLog('Automatic Certificate Ordering Disabled, Work Directory Not Found');
                end; }
            end;
        end;

    // add second IcsHost
        IcsHosts.Add;
        with IcsHosts [1] do begin
            HostEnabled := True;
            BindIpAddr := ServIpAddr.Text;
       //     BindIpAddr2 :=
            BindNonPort := 587;
            HostTag := 'SmtpServer' ;
            Descr := HostTag;
            CertSupplierProto := SuppProtoNone;
            if FileExists(CertFileEdit.Text) then begin
                HostNames.Text := ServerHost;
                SslCert := IcsTrim(CertFileEdit.Text);
                if FileExists(PrivKeyFileEdit.Text) then
                    SslKey := IcsTrim(PrivKeyFileEdit.Text);
                SslPassword := IcsTrim(PassPhraseEdit.text);
           end;
        end;

        DnsAddress     := PrefDnsServer.Text;
        ClientTimeout  := 5 * 60;
        MaxMessageSize := 25 * 1000000;
        if PrefAddRecvHdrs.Checked then
            Options := Options + [smtpsAddRecvHeaders]
        else
            Options := Options - [smtpsAddRecvHeaders];
        Options := Options + [smtpsParseHeaders];
        if PrefAddEnvHdrs.Checked then
            Options := Options + [smtpsAddEnvHeaders]
        else
            Options := Options - [smtpsAddEnvHeaders];
        if PrefAddReplayHdrs.Checked then
            Options := Options + [smtpsAddReplayHdrs]
        else
            Options := Options - [smtpsAddReplayHdrs];
        if PrefAllowRelay.Checked then
        begin
            Options := Options + [smtpsAllowOpenRelay];
            Options := Options + [smtpsAllowAuthRelay];
        end
        else
        begin
            Options := Options - [smtpsAllowOpenRelay];
            Options := Options - [smtpsAllowAuthRelay];
        end;
        if PrefAuthTls.Checked then
            Options := Options + [smtpsAuthNoTls]
        else
            Options := Options - [smtpsAuthNoTls];
        Options := Options + [smtpsAllowTls];
        LocalAccounts  := PrefEmailAccs.Lines;
        AliasAccounts  := PrefAliasAccs.Lines;  // must be assigned after local account, since checked

    //Pre-loads OpenSSL DLL's
        try
            IcsSslRootCAStore.Initialise;       { V9.6 if OpenSSL and internal not loaded, do it }
            Log.Lines.Add ('SSL Version: ' + IcsReportOpenSSLVer(True)) ;   { V9.3 }
        except
            on E: Exception do
                Log.Lines.Add ('Failed to Initialise SSL - ' + E.Message);
        end ;
   // start SMTP server
        try
            Start;
            doStart.Enabled := false;
            doExit.Enabled := false;
            doStop.Enabled := true;
        except
            on E: Exception do
                Log.Lines.Add ('Failed to Start SMTP Server: ' + E.Message);
        end;
    end;
end;

procedure TSmtpSslSrvForm.doStopClick(Sender: TObject);
begin
    FSmtpServer.Stop;
end;

procedure TSmtpSslSrvForm.doExitClick(Sender: TObject);
begin
    FSmtpServer.Stop;
    Close;
end;

procedure TSmtpSslSrvForm.SmtpServer1ServerStarted(Sender: TObject);
begin
    with Sender as TSmtpServer do
    begin
        Log.Lines.Add (Format ('%s  SMTP Server Started', [FormatDateTime ('hh:nn:ss', Time)]));
        Log.Lines.Add ('Socket 1 State: ' + SocketStateNames[WSocketServer.State] + ' ' +
                                 SocketFamilyNames [SocketFamily] + ' on ' +
                                      FormatIpAddrPort (WSocketServer.GetXAddr, WSocketServer.Port));
    end;
end;

procedure TSmtpSslSrvForm.SmtpServer1ServerStopped(Sender: TObject);
begin
    with Sender as TSmtpServer do
    begin
        Log.Lines.Add (Format ('%s  SMTP Server Socket %x Stopped',
                     [FormatDateTime ('hh:nn:ss', Time), WSocketServer.MultiListenIndex + 2]));
    end;
    doStart.Enabled := true;
    doExit.Enabled := true;
    doStop.Enabled := false;
end;

procedure TSmtpSslSrvForm.SmtpServer1SslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base;
  var Disconnect: Boolean);
begin
    with Sender as TSmtpSrvCli do
    begin
        if ErrCode = 0 then
        begin
            Log.Lines.Add (Format('%s  %8.8x  %s',
                    [FormatDateTime('hh:nn:ss', Time), ID, SslHandshakeRespMsg]));  { V8.02 }
        end
        else
            Log.Lines.Add (Format('%s  %8.8x  SslHandshake Failed - %s',
                             [FormatDateTime('hh:nn:aa', Time), ID, SslHandshakeRespMsg]));    { V8.02 }
    end;
end;

procedure TSmtpSslSrvForm.SmtpServer1SslVerifyPeer(Sender: TObject; var Ok: Integer; Cert: TX509Base);
begin
    Log.Lines.Add ('Received certificate'#13#10 +
                'Subject: ' + Cert.SubjectOneLine + #13#10 +
                'Issuer: '  + Cert.IssuerOneLine);
    if OK <> 1 then
    begin
        Log.Lines.Add ('Error msg: ' + Cert.VerifyErrMsg + #13#10 +
                    'In this example we accept any cert');
        OK := 1; //In this example we accept any client.
    end;
end;

procedure TSmtpSslSrvForm.SmtpServer1Connect(Sender, Client: TObject; const IpAddr: string;
                                            var Action: TSmtpMailAction; var Reason: string);
begin
  // we might dislike the remote IP address if it's been spamming us, but generally should respond
  // we could check the IP against ranges authorised to relay by this server and set
  //  Authenticated=true to avoid needing AUTH command
    with TSmtpSrvCli (Client) do
        Log.Lines.Add (Format ('%s  %8.8x  Client connected from %s [%s MX=%s]', [FormatDateTime
                        ('hh:nn:ss', Time), ID, IPAddr, ClientRDNS, ClientMX]));
    // Action := wsmtpSysUnavail, wsmtpNetError or wsmtpCongested
end;

procedure TSmtpSslSrvForm.SmtpServer1Disconnect(Sender, Client: TObject; Error: Word);
begin
    Log.Lines.Add (Format ('%s  %8.8x  Connection terminated', [FormatDateTime
                                 ('hh:nn:ss', Time), TSmtpSrvCli (Client).ID]));
end;

procedure TSmtpSslSrvForm.SmtpServer1Display(Sender: TObject; const Msg: string);     { V9.6 }
begin
    Log.Lines.Add(Msg);
end;

procedure TSmtpSslSrvForm.SmtpServer1Exception(Sender: TObject; E: Exception);
begin
    Log.Lines.Add ('Exception: ' + E.Message);
end;

procedure TSmtpSslSrvForm.SmtpServer1Auth(Sender, Client: TObject; const UserName: string;
    var Password: string; var Action: TSmtpMailAction; var Reason: string);
begin
  // do we need to check authentication now, blank means Cram-md5/sha1 already checked
    with Client as TSmtpSrvCli do
    begin
        if (UserName = '') then
            Action :=  wsmtpAuthRequired
        else if Password <> '' then
        begin
            Action := wsmtpAuthPermFail;
         //  wsmtpAuthTempFail
            if (Password = 'password') then Action := wsmtpOK;
        end;
        if Action = wsmtpOK then
            Log.Lines.Add (Format ('%s  %8.8x  Authentication OK: UserName=%s Password=%S',
                                [FormatDateTime ('hh:nn:ss', Time), ID, UserName, Password]))
        else
            Log.Lines.Add (Format ('%s  %8.8x  Authentication failed: UserName=%s Password=%S',
                                [FormatDateTime ('hh:nn:ss', Time), ID, UserName, Password]));
    end;
end;

procedure TSmtpSslSrvForm.SmtpServer1AuthPW(Sender, Client: TObject; const UserName: string; var Password: string;
  var Action: TSmtpMailAction; var Reason: string);
begin
  // we need to provide a password for Cram-md5/sha1 to test against
    Password := 'password';
end;

procedure TSmtpSslSrvForm.SmtpServer1Command(Sender, Client: TObject; const Command: string);
begin
  // information logging only
    Log.Lines.Add (Format ('%s  %8.8x  < %s', [FormatDateTime
                        ('hh:nn:ss', Time), TSmtpSrvCli (Client).ID, Command]));
end;

procedure TSmtpSslSrvForm.SmtpServer1Response(Sender, Client: TObject; const Response: string);
begin
  // information logging only
    Log.Lines.Add (Format ('%s  %8.8x  > %s', [FormatDateTime
                        ('hh:nn:ss', Time), TSmtpSrvCli (Client).ID, Response]));
end;

procedure TSmtpSslSrvForm.SmtpServer1MailFrom(Sender, Client: TObject;
                  const MailFrom: string; var Action: TSmtpMailAction; var Reason: string);
begin
  // do we accept mail from this address?

   // we can reject MAIL FROM with various responses:
   // Action := wsmtpClosingDown, wsmtpGreyListed, wsmtpMsgTooLarge,
   //           wsmtpSyntaxError, wsmtpBadSequence, wsmtpAuthRequired,
   //           wsmtpSysUnavail, wsmtpCongested
end;

procedure TSmtpSslSrvForm.SmtpServer1RcptTo(Sender, Client: TObject;
                    const RcptTo: string; var Action: TSmtpMailAction; var Reason: string);
begin
  // can we deliver to this email account?
  // might have been validated already if LocalAccounts list specified

   // we can reject RCPT TO with various responses:
   // Action := wsmtpClosingDown, wsmtpMailboxBusy, wsmtpGreyListed, wsmtpMsgTooLarge,
   //           wsmtpSyntaxError, wsmtpBadSequence, wsmtpBadDomain, wsmtpAuthRequired,
   //           wsmtpBadAccount,  wsmtpAccClosed, wsmtpAccNotLocal,
   //           wsmtpTooMany, wsmtpSysUnavail, wsmtpCongested
end;

procedure TSmtpSslSrvForm.SmtpServer1DataStart(Sender, Client: TObject;
                                    var Action: TSmtpMailAction; var Reason: string);
begin
  // got all envelope commands, about to get email data, which we need to save
  // MessageTo [x] is multiple recipients for the message
  // ToAccounts [x] is multiple local accounts to which the mail should be saved, if non-blank
  // if saving email for POP3 and as files, set a directory based on ToAccount [x]
  //   otherwise for relaying save to a spool directory
    with Client as TSmtpSrvCli do
    begin
        try
            DataFileName := PrefSpoolDir.Text + MessageID + '.eml';
            if ToAccounts.Count > 0 then  // only saving a single copy at the moment for first account
            begin
                DataFileName := PrefSpoolDir.Text + ToAccounts [0] + '\' ;
                if NOT ForceDirectories (DataFileName) then
                begin
                    Log.Lines.Add ('Failed to create spool directory: ' + DataFileName);
                    Action := wsmtpSysUnavail;
                    Reason := 'Mail spool unavailable';
                    exit;
                end;
                DataFileName := DataFileName + MessageID + '.eml';
            end;
            DataStream := TIcsBufferedFileStream.Create (DataFileName, fmCreate, MAX_BUFSIZE);
        except
            Log.Lines.Add (Format ('%s  %8.8x  Failed to create mail spool file %s', [FormatDateTime
                        ('hh:nn:ss', Time), ID, DataFileName]));
            Action := wsmtpSysUnavail;
            Reason := 'Mail spool unavailable';
        end;
    end;
   // we can reject DATA with various responses:
   // Action := wsmtpClosingDown, wsmtpGreyListed, wsmtpSyntaxError, wsmtpBadSequence,
   //           wsmtpAuthRequiredwsmtpSysUnavail
end;

procedure TSmtpSslSrvForm.SmtpServer1DataEnd(Sender, Client: TObject;
                                    var Action: TSmtpMailAction; var Reason: string);
begin
  // got a complete email, maybe to several recipients in MessageTo [x] and ToAccount [x]
  //   (see DataStart) so may need to copy the stream to other places, MailFrom is the sender
  // if ParseHeaders=true, HdrTo, HdrFrom, HdrSubjext, HdrDateStr and HdrDateDT contain
  //   the main email header fields, and MessageID the response sent to the sender
    with Client as TSmtpSrvCli do
    begin
        if Assigned(DataStream) then
        begin
            Log.Lines.Add (Format ('%s  %8.8x  Saved mail to spool file %s, size %d',
                             [FormatDateTime ('hh:nn:ss', Time), ID, DataFileName, DataStream.Size]));
            DataStream.Free; // close stream to save file to disk
            DataStream := nil;
        end;
    end;
   // we can reject DATA end with various responses:
   // Action := wsmtpMsgTooLarge, wsmtpMailboxFull, wsmtpSysUnavail
end;


end.