{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Original Author: Ian Baker, ADV Systems 2003 Updated by: Angus Robertson, Magenta Systems Ltd Creation: 20 September 2013 Version: V9.6 Description: Implements a TWSocket-based SMTP server component. For further details please see RFC-821, RFC-1869, RFC-1870, RFC-1893, RFC-1985, RFC-2034, RFC-2025, RFC-2920 EMail: http://www.overbyte.be francois.piette@overbyte.be Support: https://en.delphipraxis.net/forum/37-ics-internet-component-suite/ Legal issues: Copyright (C) 1999-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. History: //******************************************************************// // Project ADVmserve // // // // Module WSMTPserver // // // // Description Implements a TWSocket-based SMTP server component. // // For further details please see // // RFC-821, RFC-1869, RFC-1870, RFC-1893, RFC-1985, // // RFC-2034, RFC-2025, RFC-2920 // // // // TWsocket is a component of The Internet Component // // Suite, freely downloadable from // // http://www.overbyte.be // // // // Copyright This software is subject to the license at: // // http://www.codecutters.org/software/license.html // // with the additional conditions below: // // // // (i) This source code is "Open Source" // // (ii) This source code may be freely distributed & // // modified, but it's origin must not be // // misrepresented in any way. This means that // // this this header must remain intact, with // // altered portions clearly marked and commented // // (iii) This source code may be used in any project, // // including commercial software; a mention of // // ADVsystems and a link to the web site would // // be appreciated, but is not mandatory. // // (iv) As stated in the license terms, the author // // accepts no responsibility for damages or costs// // arising from the use or misuse of this // // software; the software is supplied "as-is", // // and no claims are made to its merchantability // // or fitness for a given purpose. // // (v) Please direct and comments/questions to: // // mailto:support@codecutters.org // // // //******************************************************************// // (C) ADV Systems 2003, All rights reserved. // //******************************************************************// // Version Date Author Reason // // 1.00 290303 I.Baker Initial version // // 1.01 300303 I.Baker Expanded tracing, added Client // // Context. Also exposed subcomponents // // 1.02 100403 I.Baker Added Return-Path header // // 1.03 120403 I.Baker Added check for zero recipients // // 1.04 170403 I.Baker Allowed unknown commands to be sent // // to the user handler // // 1.05 270403 I.Baker Made SMTPtime() accessible // // 1.06 300403 I.Baker Copied OnBgException setting // // 2.00 081003 I.Baker Rewritten to simplify reuse // // 2.01 191003 I.Baker Added ClientID to Command handlers // // 2.02 201003 I.Baker Exposed all utility routines // // 2.03 041103 D.Aguirre Added 2 omitted MaxMsgSize checks in // // Grazio ClientDataRx // // 2.04 271103 I.Baker Removed Buffer.Len reset within DATA // // 2.05 291103 I.Baker Added MessageID to Action Handler // // 2.06 021203 I.Baker Added Return-Path and Received // // headers before DATA reception // // 2.07 141203 I.Baker SetActive now virtual, to allow // // additional control over other // // components (e.g. a Spooler) // // Added RaiseExceptionFmt() // // 2.08 231203 I.Baker Counter moved into server, Exception // // in TSmtpSrvCli no longer raised, // // Added max message size check // //******************************************************************// Sep 24, 2013 V8.00 Angus updated for ICS V8 with IPv6 Reformatted closer to ICS style, private variables prefixed with F Using simple LineMode instead of complex dynamic buffer MAIL FROM command is allowed after RCPT TO but resets recipients Added separate events for different commands instead of one ActionHandler Added Options for multiple boolean configuration options Added Multiple Listen addresses, default to 25 and 587, could add IPv6 Added AUTH command for login authentication with PLAIN, LOGIN, CRAM-MD5 and CRAM-SHA1 Support VRFY command (but do nothing useful) Keep DATA content as Stream to avoid 50 meg memory allocations Optionally add Sender, X-Envelope-From and X-Envelope-To headers Optionally add X-Sender and X-Receiver SMTP replay headers Added many more response codes Optionally parse main email content headers Add Apparently-To header if no To: header found Made enhanced response code optional since seem to be rarely used Added LocalAccounts optional list of email addresses for which this server can accept local email, otherwise rejected with 550 Added AliasAccounts optional list of email addresseses whose mail will be saved to an existing LocalAccount, in format alias=account, with special case of *@domain=account that catches all email for the domain Added ToAccounts list similar to MessageTo list of RcpTo, but blank if message is being relayed of different account if an alias address Added SSL support using STARTTLS command only (port 465 implicit is NOT supported since revoked) Optionally add X-Originating-IP header Optionally only allow authentication after TLS negotiated Optionally prevent relaying even with authentication Dec 18, 2013 V8.01 Angus EHLO reports AUTH even without SSL June 2015 V8.02 Angus - fix FMX compile bug Jan 22, 2016 V8.03 Angus - corrected 64-bit casting bug in PostMessage Jun 8, 2016 V8.04 Angus - corrected client timeout, thanks to Alex Markov Nov 12, 2016 V8.37 Added ExclusiveAddr property to stop other applications listening on same socket Added extended exception information, set FSocketErrs = wsErrFriendly for some more friendly messages (without error numbers) Mar 10, 2020 V8.64 Added support for International Domain Names for Applications (IDNA). Currently just DnsQuery returns Unicode. Dec 09, 2020 V8.65 Renamed Ics.Posix.Messages.pas to Ics.Posix.PXMessages.pas. Aug 08, 2023 V9.0 Updated version to major release 9. Nov 17, 2023 V9.1 Added OverbyteIcsSslBase which now includes TX509Base and TX509List. Oct 11, 2024 V9.4 Updated Base64 encoding functions to IcsBase64 functions. Mar 09, 2026 V9.6 Added IcsHosts for multiple listeners and automated certificates. Using new onDisplay event to display messages from TWSocket, controlled by WSDebugOptions. Only available with USE_SSL, none SSL version gone Added X-IpAddr and X-RDNS headers to avoid parsing Received:. Pending - support Sender Policy Framework April 2023 - pending use FDnsQuery.PTRLookupSync to simpify DNS lookup. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} unit OverbyteIcsSmtpSrv; interface {$I Include\OverbyteIcsDefs.inc} {$IFDEF USE_SSL} {$B-} { Enable partial boolean evaluation } {$T-} { Untyped pointers } {$X+} { Enable extended syntax } {$H+} { Use long strings } {$J+} { Allow typed constant to be modified } {$IFDEF COMPILER14_UP} {$IFDEF NO_EXTENDED_RTTI} {$RTTI EXPLICIT METHODS([]) FIELDS([]) PROPERTIES([])} {$ENDIF} {$ENDIF} {$IFNDEF COMPILER7_UP} Bomb = 'No support for ancient compiler'; {$ENDIF} {$IFDEF COMPILER12_UP} { These are usefull for debugging !} {$WARN IMPLICIT_STRING_CAST ON} {$WARN IMPLICIT_STRING_CAST_LOSS ON} {$WARN EXPLICIT_STRING_CAST OFF} {$WARN EXPLICIT_STRING_CAST_LOSS OFF} {$ENDIF} {$WARN SYMBOL_PLATFORM OFF} {$WARN SYMBOL_LIBRARY OFF} {$WARN SYMBOL_DEPRECATED OFF} {$IFDEF BCB} {$ObjExportAll On} {$ENDIF} uses {$IFDEF MSWINDOWS} {$IFDEF RTL_NAMESPACES}Winapi.Windows{$ELSE}Windows{$ENDIF}, {$IFDEF RTL_NAMESPACES}Winapi.Messages{$ELSE}Messages{$ENDIF}, OverbyteIcsWinsock, {$ENDIF} {$IFDEF RTL_NAMESPACES}System.SysUtils{$ELSE}SysUtils{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.Classes{$ELSE}Classes{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.Variants{$ELSE}Variants{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.StrUtils{$ELSE}StrUtils{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.DateUtils{$ELSE}DateUtils{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.Types{$ELSE}Types{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.IniFiles{$ELSE}IniFiles{$ENDIF}, { V9.6 } {$IFDEF RTL_NAMESPACES}System.TypInfo{$ELSE}TypInfo{$ENDIF}, { V9.6 } {$IFNDEF NOFORMS} {$IFDEF FMX} FMX.Forms, {$ELSE} {$IFDEF RTL_NAMESPACES}Vcl.Forms{$ELSE}Forms{$ENDIF}, {$ENDIF} {$ENDIF} {$IFDEF POSIX} //System.IOUtils, Posix.Unistd, Posix.SysSocket, Ics.Posix.WinTypes, Ics.Posix.PXMessages, {$IFDEF MACOS} System.Mac.CFUtils, Macapi.Corefoundation, {$ENDIF} {$ENDIF} {$IFDEF FMX} Ics.Fmx.OverbyteIcsWndControl, Ics.Fmx.OverbyteIcsWSocket, Ics.Fmx.OverbyteIcsWSockBuf, Ics.Fmx.OverbyteIcsWSocketS, Ics.Fmx.OverbyteIcsSmtpProt, Ics.Fmx.OverbyteIcsSslBase, { V9.1 TX509Base } {$ELSE} OverbyteIcsWndControl, OverbyteIcsWSocket, OverbyteIcsWSockBuf, OverbyteIcsWSocketS, OverbyteIcsSmtpProt, // just using some public utility functions OverbyteIcsSslBase, { V9.1 TX509Base } {$ENDIF} OverbyteIcsDnsQuery, OverbyteIcsMimeUtils, OverbyteIcsMimeDec, OverbyteIcsMD5, OverbyteIcsSha1, OverbyteIcsUtils, {$IFDEF AUTO_X509_CERTS} {$IFDEF FMX} Ics.Fmx.OverbyteIcsSslX509Certs, { V9.6 } // Ics.Fmx.OverbyteIcsSslUtils, { V9.1 } {$ELSE} OverbyteIcsSslX509Certs, { V9.6 } // OverbyteIcsSslUtils, { V9.1 } {$ENDIF} {$ENDIF} // AUTO_X509_CERTS OverbyteIcsTypes; const SmtpCliVersion = 906; CopyRight : String = ' SMTP Server (c) 1997-2026 Francois Piette V9.6 '; const // ESMTP commands. Please note that not all are implemented - use AddCommand() to add a handler of your own cHELO = 'HELO'; cEHLO = 'EHLO'; cMAIL = 'MAIL'; cRCPT = 'RCPT'; cDATA = 'DATA'; cQUIT = 'QUIT'; cEXPN = 'EXPN'; // not supported, mailing list cHELP = 'HELP'; // not supported cTURN = 'TURN'; // not supported, obsolete cRSET = 'RSET'; cNOOP = 'NOOP'; cVRFY = 'VFRY'; // always say OK but don't test anything cETRN = 'ETRN'; cAUTH = 'AUTH'; cSTARTTLS = 'STARTTLS'; SmtpSrvAuthLits : array [0..4] of PAnsiChar = ('', 'PLAIN', 'LOGIN', 'CRAM-MD5', 'CRAM-SHA1'); // Number of seconds to wait for a DNS response (both PTR and MX, combined) cDNStimeout = 10; // Number of seconds, by default, to time-out a client connection cClientTimeout = 60; type // forward classes TSmtpServer = class; TSmtpSrvCli = class; TSmtpSrvCliClass = class of TSmtpSrvCli; // General exception ESMTPserver = class(Exception); TExceptionEvent = procedure (Sender: TObject; E: Exception) of object; // authentication types supported TSmtpSrvAuthType = (smtpsAuthNone, smtpsAuthPlain, smtpsAuthLogin, smtpsAuthCramMD5, smtpsAuthCramSha1); // published server options TSmtpsOption = (smtpsAddRecvHeaders, // add Return-Path: and Received: before other SMTP headers smtpsAddEnvHeaders, // add X-Envelope-From: and X-Envelope-To: after other SMTP headers, smtpsAddReplayHdrs, // add X-Sender: and multiple X-Receiver: before other SMTP headers smtpsAddIpAddrHdr, // add X-Originating-IP after other SMTP headers smtpsParseHeaders, // should main email headers be parsed and saved smtpsAllowOpenRelay, // allow accept mail for other servers, which will spooled and relayed smtpsAllowAuthRelay, // only allow relay with authentication smtpsExtendedResp, // allow ENHANCEDSTATUSCODES to be supported smtpsAllowTls, // allow TLS (SSL) smtpsAuthNoTls // allow authentication without TLS ); TSmtpsOptions = set of TSmtpsOption; // note, if smtpsParseHeaders=true and To: is missing, header Apparently-To: is added with Rcpt-To envelope // note, smtpsAddReplayHdrs is used for Microsoft SMTP Server Replay directory forwarding (similar to Pickup) // This describes the client state required to run a particular SMTP primitive TSmtpMsgContext = (mcConnecting, mcConnected, mcCommand, mcWaitTls, mcMessage, mcData, mcAny); // Action to be taken for various commands from application events TSmtpMailAction = ( wsmtpOK, // 2xx Positive response from the calling application wsmtpClosingDown, // 421 0.0 Closing down wsmtpMailboxBusy, // 450 7.0 Mailbox unavailble or busy wsmtpGreyListed, // 451 4.1 Greylisted, try again later wsmtpMsgTooLarge, // 452 3.1 Client has exceeded maximum message size. Current message has been lost wsmtpAuthTempFail, // 454 xxx Authentication temporary failed wsmtpSyntaxError, // 500 5.2 Syntax Error command not recognised wsmtpBadParams, // 501 5.0 Bad parameter wsmtpBadCommand, // 502 5.2 Command not implmented wsmtpBadSequence, // 503 5.0 Command out of sequence wsmtpAuthRequired, // 530 5.1 Authentication required wsmtpAuthPermFail, // 535 7.8 Authentication failed credentials wsmtpBadAccount, // 550 1.1 No such email account on this server wsmtpBadDomain, // 550 1.2 Specified domain not handled by this server (e.g. could be a relaying request) wsmtpAccClosed, // 550 1.6 Email account has closed, and is no longer valid wsmtpAccNotLocal, // 551 7.1 Email account not local, suggest new account wsmtpMailboxFull, // 552 2.2 Mailbox full, 3.4 Message too big wsmtpProhibited, // 553 7.1 Recipient or complete message rejected through server policy (reason should be given) wsmtpSysUnavail, // 554 3.2 System is not accepting messages (e.g. shutting-down, PM, etc.) wsmtpNetError, // 554 4.0 Network error wsmtpCongested, // 554 4.5 System is congested. Please try again later. wsmtpTooMany, // 554 5.3 Too many recipients specified wsmtpBadMedia, // 554 3.1 Media not supported (e.g. we don't like Base-64 ;o) wsmtpListNotAuth, // 554 3.1 You are not authorised to send messages to this mailing list wsmtpListNotRec); // 554 2.4 Mailing list does not exist // This handler implements a given SMTP primitive TSmtpCmdHandler = procedure (Sender : TObject; // Sender (the client object) const ClientID : cardinal; // Unique client ID var ESMTP : boolean; // True if ESMTP has been specified by an EHLO. Parameters : PAnsiChar) of object; // Command parameters, if present // server has new client connection, we might not like it's IP or be busy TSmtpConnectEvent = procedure (Sender : TObject; Client : TObject; const IpAddr : string; var Action : TSmtpmailAction; var Reason : string ) of object; // server has disconnected client TSmtpDisconnectEvent = procedure (Sender : TObject; Client : TObject; Error : Word ) of object; // server has received a command or sent a response TSmtpCommandEvent = procedure (Sender : TObject; Client : TObject; const Command : string ) of object; // server has received a command or sent a response TSmtpResponseEvent = procedure (Sender : TObject; Client : TObject; const Response : string ) of object; // server Mail From command, we may dislike them TSmtpMailFromEvent = procedure (Sender : TObject; Client : TObject; const MailFrom : string; var Action : TSmtpmailAction; var Reason : string ) of object; // server Rcpt To command, do we accept mail for this account, or will we relay it TSmtpRcptToEvent = procedure (Sender : TObject; Client : TObject; const RcptTo : string; var Action : TSmtpmailAction; var Reason : string ) of object; // server AUTH command, do they have an account TSmtpAuthEvent = procedure (Sender : TObject; Client : TObject; const UserName : string; var Password : string; var Action : TSmtpmailAction; var Reason : string ) of object; // server Data command, start and end, did we accept it all TSmtpDataEvent = procedure (Sender : TObject; Client : TObject; var Action : TSmtpmailAction; var Reason : string ) of object; TSmtpSrvCli = class(TSslWSocketClient) protected FID : cardinal; FClientIpAddr : string; FSocketFamily : TSocketFamily; FListenNr : integer; FServIpAddr : string; FServPort : string; FClientDomain : string; FClientRDNS : string; FClientMX : string; FMessageID : string; FMessageFrom : string; FMessageTo : TStrings; FToAccounts : TStrings; FHdrTo : string; FHdrFrom : string; FHdrSubject : string; FHdrDateStr : string; FHdrDateDT : TDateTime; FDoneHdrs : boolean; FDataStream : TStream; // Stream created by application used to save email DATA FUserName : string; // authenticated user name FAuthenticated : boolean; // true if client successfully authenticated FTlsDone : boolean; // true if TLS/SSL negotiated successfully // above are all published FESMTP : boolean; // did we get an ESMTP header FLastContact : TDateTime; // for timeouts FSmtpServer : TSmtpServer; // parent SMTP server FRcvdLine : AnsiString; // last received line FContext : TSmtpmsgContext; // current component state FAuthWait2nd : boolean; // true if next command is expected to be an authentication response FDnsQuery : TDnsQuery; FSmtpSrvAuthType: TSmtpSrvAuthType;// authentication type, if any FAuthChallenge: AnsiString; // authentication challenge sent for Cram-Md5 and Cram-Sha1 FMsg_wmClientLookupDone: UINT; FMsg_wmClientClose: UINT; procedure ClientDataRx(Sender : TObject; Error : Word); procedure ProcessCommand(Str : PAnsiChar); procedure AllocateMsgHandlers; override; procedure FreeMsgHandlers; override; procedure WndProc(var MsgRec: TMessage); override; procedure LookupComplete(Sender : TObject; Error : Word); procedure ClearClient; public DataFileName : string; function SendAnswer(const Str : String) : integer; procedure SendStatus(const FormatStr : string; const EnhancedStat : string; Args : array of const); function SslSendPlain(Data : TWSocketData; Len : Integer) : Integer; constructor Create(AOwner : TComponent); override; destructor Destroy; override; // internal client ID, incremented with each connection, randomised when server starts property ID : cardinal read FID; // remote client IP address property ClientIpAddr : string read FClientIpAddr; // client socket family, IPv4 or IPv6 property SocketFamily : TSocketFamily read FSocketFamily; // server IP address for this client, IPv4 or IPv6 property ServIpAddr : string read FServIpAddr; // server/client port for this client that answered property ServPort : string read FServPort; // client domain from HELO or EHLO command property ClientDomain : string read FClientDomain; // client host from reverse DNS property ClientRDNS : string read FClientRDNS; // client MX from reverse DNS property ClientMX : string read FClientMX; // message ID created from time and FID property MessageID : string read FMessageID; // MAIL FROM envelope command property MessageFrom : string read FMessageFrom; // multiple RCPT TO envelope commands property MessageTo : TStrings read FMessageTo; // authenticated user name property UserName : string read FUserName; // true if client successfully authenticated property Authenticated : boolean read FAuthenticated; // local account to which mail should be delivered, if non blank, one for each MessageTo property ToAccounts : TStrings read FToAccounts; // stream for meessage data content, must be opened in application property DataStream : TStream read FDataStream write FDataStream; // To: parsed email header property HdrTo : string read FHdrTo; // From: parsed email header property HdrFrom : string read FHdrFrom; // Subject: parsed email header property HdrSubject : string read FHdrSubject; // Date: parsed email header as string property HdrDateStr : string read FHdrDateStr; // Date: parsed email header converted to TDateTime property HdrDateDT : TDateTime read FHdrDateDT; // flag true once email header end reached property DoneHdrs : boolean read FDoneHdrs write FDoneHdrs; end; // This is the main server component. Use as-is, or derive something with the required behaviour. TSmtpServer = class(TIcsWndControl) // was (TComponent) protected FServer : TSslWsocketServer; FClientClass : TSmtpSrvCliClass; FAddress : string; FServerPort : string; FServerHost : string; FSocketFamily : TSocketFamily; FServerDesc : string; FMaxUsers : cardinal; FMultiThread : boolean; FMaxMsgSize : integer; FDNSaddr : string; FOptions : TSmtpsOptions; FGreyDelaySecs : integer; FLocalAccounts : TStrings; FAliasAccounts : TStrings; FLocalDomains : TStrings; FSocketErrs : TSocketErrs; { V8.37 } FExclusiveAddr : Boolean; { V8.37 } // above are all published FCommands : array of record Cmd : AnsiString; Context : TSmtpmsgContext; Handler : TSmtpcmdHandler; end; FClientTimeout : integer; { V8.04 avoid conflict with socket server } FCheckTimer : TIcsTimer; FExtHandler : TExceptionEvent; FCounter : cardinal; FOnServerStarted : TNotifyEvent; FOnServerStopped : TNotifyEvent; FOnConnect : TSmtpConnectEvent; FOnDisconnect : TSmtpDisconnectEvent; FOnCommand : TSmtpCommandEvent; FOnResponse : TSmtpResponseEvent; FOnMailFrom : TSmtpMailFromEvent; FOnRcptTo : TSmtpRcptToEvent; FOnAuth : TSmtpAuthEvent; FOnAuthPW : TSmtpAuthEvent; FOnDataStart : TSmtpDataEvent; FOnDataEnd : TSmtpDataEvent; FOnDisplay : TDebugDisplay; { V9.6 } FOnSslHandshakeDone : TSslHandshakeDoneEvent; FOnSslVerifyPeer : TSslVerifyPeerEvent; FOnSslServerName : TSslServerNameEvent; { V9.6 } procedure SetAliasAccounts(newValue : TStrings); procedure SetLocalAccounts(newValue : TStrings); procedure SetTimeout(ATimeout : integer); procedure SetMaxMsgSize(AMsgSize : integer); procedure ServerSessionClosed(Sender : TObject; Error : Word); procedure ClientConnect(Sender: TObject; Client: TWSocketClient; Error: Word); procedure ClientDisconnect(Sender: TObject; Client: TWSocketClient; Error: Word); procedure ServerException(Sender : TObject; E : Exception; var CanClose : Boolean); procedure RaiseException(const Message : string); procedure RaiseExceptionFmt(const Format: string; const Args: array of const); procedure CheckClientStatus(Sender : TObject); function GetActive: boolean; function GetClientCount: Integer; function GetClient(nIndex: Integer): TSmtpSrvCli; // Adds or replaces a new SMTP command. procedure AddCommand(Cmd : AnsiString; Handler : TSmtpcmdHandler; Context : TSmtpmsgContext = mcCommand); // Sends a string to the specified client. Don't forget to add a CRLF in most cases! procedure SendString(Client : TObject; const Str : string); // Command handling routines. May be overridden. procedure HandleNOOP(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleQUIT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleRSET(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleVRFY(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleHELO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleEHLO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleMAIL(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleRCPT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleDATA(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleAUTH(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure HandleAUTH2(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure SendActionFailed(Sender : TObject; Action: TSmtpmailAction; const Reason: string); procedure TriggerDisplay(Sender: TObject; const Msg: String); virtual; { V9.6 } function GetWSDebugOptions: TWSDebugOptions; { V9.6 } procedure SetWSDebugOptions(Value: TWSDebugOptions); { V9.6 } procedure HandleTLS(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); virtual; procedure TlsSslVerifyPeer(Sender : TObject; var Ok : Integer; Cert : TX509Base); virtual; procedure TlsSslHandshakeDone(Sender : TObject; ErrCode : Word; PeerCert : TX509Base; var Disconnect : Boolean); virtual; function GetIcsHosts: TIcsHostCollection; { V9.6 } procedure SetIcsHosts(const Value: TIcsHostCollection); {$IFDEF AUTO_X509_CERTS} function GetSslX509Certs: TSslX509Certs; procedure SetSslX509Certs(const Value : TSslX509Certs); {$ENDIF} // AUTO_X509_CERTS function GetCertExpireDays: Integer; procedure SetCertExpireDays(const Value : Integer); function GetSslCertAutoOrder: Boolean; procedure SetSslCertAutoOrder(const Value : Boolean); procedure TransferSslServerName(Sender: TObject; var Ctx: TSslContext; var ErrCode: TTlsExtError); virtual; public // This routine can be called to update a client when the Action handler has previously returned a wsmtpNotHandled constructor Create(AOwner : TComponent); override; destructor Destroy; override; procedure Start; virtual; procedure Stop; virtual; function ValidateHosts(Stop1stErr: Boolean=True; NoExceptions: Boolean=False): String; virtual; { V9.6 } function RecheckSslCerts(var CertsInfo: String; Stop1stErr: Boolean=True; NoExceptions: Boolean=False): Boolean; function ListenAllOK: Boolean; function ListenAny: Boolean; function ListenStates: String; // Check if a given object is one of our clients function IsClient(SomeThing: TObject) : Boolean; // Runtime readonly property which gives number of connected clients property ClientCount : Integer read GetClientCount; // Client[] give direct access to anyone of our clients property Client[nIndex: Integer] : TSmtpSrvCli read GetClient; // Runtime property which tell the component class which has to be // instanciated to handle client connection property ClientClass : TSmtpSrvCliClass read FClientClass write FClientClass; property WSocketServer : TSslWSocketServer read FServer write FServer; published // is service active property Active : boolean read GetActive; // Sets listener address. 0.0.0.0 for all NICs/IPs property Addr : string read FAddress write FAddress; { V9.6 } // Sets listener port property Port : string read FServerPort write FServerPort; { V9.6 } // sets IP v4 or v6 family property SocketFamily : TSocketFamily read FSocketFamily write FSocketFamily; // Sets host name for mail server - usually published name in MX records property ServerHost : string read FServerHost write FServerHost; { V9.6 } // Sets friendly service description for welcome property ServerDesc : string read FServerDesc write FServerDesc; { V9.6 } // Sets maximum number of connected clients; if reduced, then current connections will be honoured. // Useful for controlled service shutdown as well as licensing limits. 0 for "no limit" property MaxClients : cardinal read FMaxUsers write FMaxUsers; // Set flag if running in a threaded environment property MultiThreaded : boolean read FMultiThread write FMultiThread; // Set maximum message size processed. Can be set dynamically, allowing throttling if storage is running low. // 0 for "no limit" property MaxMessageSize : integer read FMaxMsgSize write SetMaxMsgSize; // Address of DNS to be used for all queries property DnsAddress : string read FDNSaddr write FDNSaddr; // Client timeout, in seconds. 0 for no timeout property ClientTimeout : integer read FClientTimeout write SetTimeout; // Set number of seconds after which GreyListed mail will be accepted on subsequent attempts property GreyDelaySecs : integer read FGreyDelaySecs write FGreyDelaySecs; // set of server options property Options : TSmtpsOptions read FOptions write FOptions; // local accounts handled by this server property LocalAccounts : TStrings read FLocalAccounts write SetLocalAccounts; // accounts that alias a local account, allowing a local account to support multiple addresses property AliasAccounts : TStrings read FAliasAccounts write SetAliasAccounts; // local domains handled by this server, parsed from local and alias accounts property LocalDomains : TStrings read FLocalDomains; // set technical or friendly exception messages property SocketErrs : TSocketErrs read FSocketErrs write FSocketErrs; { V8.37 } // exclusive access for server socket property ExclusiveAddr : Boolean read FExclusiveAddr write FExclusiveAddr; { V8.37 } // Event called for an unhandled exception property OnException : TExceptionEvent read FExtHandler write FExtHandler; // Event when server has started listening property OnServerStarted : TNotifyEvent read FOnServerStarted write FOnServerStarted; // Event when server has stopped listening property OnServerStopped : TNotifyEvent read FOnServerStopped write FOnServerStopped; // Event called for new client connection property OnConnect : TSmtpConnectEvent read FOnConnect write FOnConnect; // Event called for client disconnection property OnDisconnect : TSmtpDisconnectEvent read FOnDisconnect write FOnDisconnect; // Event called for each command received property OnCommand : TSmtpCommandEvent read FOnCommand write FOnCommand ; // Event called for response sent property OnResponse : TSmtpResponseEvent read FOnResponse write FOnResponse; // Event called for Mail From command property OnMailFrom : TSmtpMailFromEvent read FOnMailFrom write FOnMailFrom; // Event called for each RcptTo command property OnRcptTo : TSmtpRcptToEvent read FOnRcptTo write FOnRcptTo; // Event called for Auth command completed property OnAuth : TSmtpAuthEvent read FOnAuth write FOnAuth; // Event called for Auth command needs password for Cram verification property OnAuthPW : TSmtpAuthEvent read FOnAuthPW write FOnAuthPW; // Event called when Data command is received, open stream property OnDataStart : TSmtpDataEvent read FOnDataStart write FOnDataStart; // Event called when Data command content has been received, close stream property OnDataEnd : TSmtpDataEvent read FOnDataEnd write FOnDataEnd; property OnSslVerifyPeer : TSslVerifyPeerEvent read FOnSslVerifyPeer write FOnSslVerifyPeer; property OnSslHandshakeDone : TSslHandshakeDoneEvent read FOnSslHandshakeDone write FOnSslHandshakeDone; property IcsHosts : TIcsHostCollection read GetIcsHosts write SetIcsHosts; { V9.6 } property SslCertAutoOrder : Boolean read GetSslCertAutoOrder write SetSslCertAutoOrder; { V9.6 } property CertExpireDays : Integer read GetCertExpireDays write SetCertExpireDays; { V9.6 } {$IFDEF AUTO_X509_CERTS} property SslX509Certs : TSslX509Certs read GetSslX509Certs write SetSslX509Certs; { V9.6 } {$ENDIF} // AUTO_X509_CERTS property OnSslServerName : TSslServerNameEvent read FOnSslServerName write FOnSslServerName; { V8.65 } property WSDebugOptions: TWSDebugOptions read GetWSDebugOptions { V9.6 Debug Log Options for OnDebugDisplay event } write SetWSDebugOptions; property OnDisplay : TDebugDisplay read FOnDisplay write FOnDisplay; { V9.6 } end; TSslSmtpServer = class(TSmtpServer); { V9.6 only SSL now } // format an IPv6 address with [] function FormatIpAddr (const Addr: string): string ; // format an IPv6 address with [] and port function FormatIpAddrPort (const Addr, Port: string): string ; // strip [] off IPv6 addresses function StripIpAddr (const Addr: string): string ; // RFC1123 date parsing function InetParseDate(DateStr: string): TDateTime; procedure SkipWhitespace (var Ptr: PAnsiChar); function ExtractEmail (var Str: PAnsiChar) : String; function ExtractArg (var Str: PAnsiChar) : String; {$ENDIF} // USE_SSL implementation {$IFDEF USE_SSL} const cBlockSize = 2048; cTempDir = 'TEMP'; cTimerInterval = 2 * 1000; NUL = #00; CR = #13; LF = #10; CRLF = AnsiString(CR+LF); DOT = AnsiString('.'); EOM = AnsiString(DOT+CR+LF); ESCDOT = AnsiString(DOT+DOT); cAT = '@'; cOK = 'OK'; cFrom = 'FROM:'; cSize = 'SIZE'; cTo = 'TO:'; resourcestring xNoAddrWhenActive = 'Cannot change server address while the server is active'; xNoPortWhenActive = 'Cannot change server port while the server is active'; xNoHostWhenActive = 'Cannot change declared host name while the server is active'; xNoDomWhenActive = 'Cannot change server domain while the server is active'; xNoNameWhenActive = 'Cannot change service name while the server is active'; xServerNotRunning = 'Server failed to start'; xClientStat = 'Error setting client %8.8x status to %s: %s'; xInvalidObj = 'Invalid object passed to %s'; xMaxMsgSizeExceeded = 'Message size of %ubytes exceeds the configured maximum'; xShutdown = 'service unavailable'; xOutOfSequence = 'Command out-of-sequence'; xNoHello = 'HELO or EHLO is required'; xBadSIZEparam = 'SIZE parameter is not compliant with RFC-1870'; xNoMailFrom = 'No MAIL FROM has been specified.'; xBadFROMparam = 'Use . See RFC-821.'; xBadTOparam = 'Use RCPT TO: . See RFC-821.'; xBadAccount = 'No such account here.'; xBadDomain = 'Mail for that domain is not accepted here'; xAccClosed = 'That account is no longer valid'; xPolicy = 'Message not accepted due to policy violation.'; xNoRecipients = 'No message recipients have been specified'; sQueued = 'Message %s queued'; xNoSpool = 'Spool unavailable'; xMsgTooLarge = 'Message size exceeds maximum.'; sReset = 'Session reset'; sClosingChannel = 'closing transmission channel.'; xTimeout = 'timeout period exceeded.'; xNoStorage = 'insufficient system storage.'; xTlsAreadyDone = 'TLS already estabished'; xNoSysUnavail = 'System is not currently accepting messages'; xNetError = 'Unspecified network error'; xCongested = 'System is currenty congested. Please try again later'; xTooMany = 'Too many recipients specified'; xBadMedia = 'Media not supported'; xListNotAuth = 'You are not authorised to send messages to this mailing list'; xListNotRec = 'Mailing list does not exist'; s220 = '220 %s ESMTP server %s'; s220s = '220 Ready to start TLS'; // Angus s221 = '221 %s %s'; s235 = '235 Authentication successful'; // Angus s250 = '250 %s'; s250c = '250-%s'; s252 = '252 Just try using the email address'; // Angus s334 = '334 %s'; // Angus s354 = '354 Start mail input; end with .'; s421 = '421 %s %s, %s'; s450 = '450 Mailbox temporarily unavailable'; // Angus s451 = '451 Greylisted, please try again in %s seconds'; // Angus s452 = '452 Requested action not taken: %s'; s454 = '454 Authentication failed'; // Angus s454s = '454 TLS not available'; // Angus s500 = '500 Invalid command: "%s"'; s501 = '501 %s'; s502 = '502 Command not implemented: "%s"'; s503 = '503 %s'; // command not allowed for specific reason s504 = '504 Unrecognised authentication type'; // Angus s530 = '530 Authentication required'; // Angus s535 = '535 Authentication failed credentials'; // Angus s550 = '550 %s'; s551 = '551 Mailbox not local, try %s'; // Angus s552 = '552 Message exceeds fixed maximum message size'; s553 = '553 %s'; s554 = '554 %s'; //******************************************************************// // Routine Utility routines // //******************************************************************// // format an IPv6 address with [] function FormatIpAddr (const Addr: string): string ; begin if (Pos ('.', Addr) = 0) and (Pos ('[', Addr) = 0) and (Pos (':', Addr) > 0) then result := '[' + Addr + ']' else result := Addr ; end; // format an IPv6 address with [] and port function FormatIpAddrPort (const Addr, Port: string): string ; begin result := FormatIpAddr (Addr) + ':' + Port ; end; // strip [] off IPv6 addresses function StripIpAddr (const Addr: string): string ; begin if (Pos ('[', Addr) = 1) and (Addr [Length (Addr)] = ']') then result := Copy (Addr, 2, Length (Addr) - 2) else result := Addr ; end; // RFC1123 date parsing borrowed from HttpApp but adapted to allow // time hh:mm without seconds and for two digit W2K years, and with // fewer exceptions and errors const // These strings are NOT to be resourced Months: array[1..13] of string = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec', ''); DaysOfWeek: array[1..7] of string = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); function InetParseDate (DateStr: string): TDateTime; var Month, Day, Year, Hour, Minute, Sec: Integer; Parser: TParser; StringStream: TStringStream; temptime: TDateTime ; function GetMonth: Boolean; begin Month := 1; while not Parser.TokenSymbolIs(Months[Month]) and (Month < 13) do Inc(Month); Result := Month < 13; end; procedure GetTime; begin with Parser do begin Hour := TokenInt; NextToken; if Token = ':' then NextToken; Minute := TokenInt; NextToken; if Token = ':' then // angus, allow missing seconds begin NextToken; Sec := TokenInt; NextToken; end ; end; end; begin Sec := 0 ; result := 0 ; if DateStr = '' then exit ; // angus, ignore blank // angus, special case of missing day of week if (DateStr [1] >= '0') and (DateStr [1] <= '9') then DateStr := 'Sun, ' + DateStr ; StringStream := TStringStream.Create(DateStr); try Parser := TParser.Create(StringStream); with Parser do try NextToken; if Token = ':' then NextToken; NextToken; // get day of week, might not exixt... if Token = ',' then NextToken; if GetMonth then begin NextToken; Day := TokenInt; NextToken; GetTime; Year := TokenInt; end else begin Day := TokenInt; NextToken; if Token = '-' then NextToken; GetMonth; NextToken; if Token = '-' then NextToken; Year := TokenInt; if Year < 50 then Inc(Year, 2000); // Y2K pivot if Year < 100 then Inc(Year, 1900); NextToken; GetTime; end; // avoid exceptions if TryEncodeDate (Year, Month, Day, Result) then begin if TryEncodeTime (Hour, Minute, Sec, 0, temptime) then result := result + temptime ; end ; finally Free; end; finally StringStream.Free; end; end; procedure SkipWhitespace(var Ptr : PAnsiChar); // Skips whitespace at the start of a PAnsiChar begin while (Ptr^ <> NUL) and (Ptr^ <= ' ') do Inc (Ptr); end; function ExtractArg(var Str : PAnsiChar) : String; // Extracts next argument, remove leading spaces, then until next space var Ptr : PAnsiChar; begin // Advance to first useful character // while (Str^ <= ' ') do // Inc (Str); // Ignore whitespace SkipWhitespace (Str); // Now locate end of string Ptr := Str + 1; if Str^ <> NUL then while (Ptr^ > ' ') do Inc (Ptr); // Set Result.. SetString (Result, Str, Ptr-Str); // Move pointer to end of this parameter if Ptr^ = NUL then Str := Ptr else Str := Ptr+1; end; function ExtractEmail(var Str : PAnsiChar) : String; // Extracts an RFC-821 address, removes angle-brackets var Ptr : PAnsiChar; i,j : integer; begin // Advance to first useful character while (Str^ <= ' ') or (Str^ in ['<',NUL]) do Inc (Str); // Ignore whitespace SkipWhitespace (Str); // Now locate end of string Ptr := Str + 1; if Str^ <> NUL then while (Ptr^ > ' ') and (Ptr^ <> '>') do Inc (Ptr); // Set Result; remove any relay requests while we're at it.. SetString (Result, Str, Ptr-Str); for i := 1 to Length (Result) do if (Result [i] = cAT) or (Result [i] = '!') then Result [i] := cAT; i := Pos (Result, cAT); if i > 0 then begin j := SUCC (i); while (j <= Length (Result)) and (Result [j] <> cAT) do Inc (j); if j <= Length (Result) then SetLength (Result, PRED (j)); end; // Move pointer to end of this parameter if Ptr^ = NUL then Str := Ptr else Str := Ptr+1; end; //******************************************************************// // Component WSMTPserver // //******************************************************************// //******************************************************************// // Routine Constructor // //******************************************************************// constructor TSmtpServer.Create(AOwner : TComponent); var i : integer; begin inherited; FClientClass := TSmtpSrvCli; FAddress := ICS_ANY_HOST_V4; FServerPort := 'smtp'; FSocketFamily := sfIPv4; FMultiThread := false; FMaxUsers := 0; FDNSaddr := ''; SetTimeout (cClientTimeout); FOptions := [smtpsAddRecvHeaders]; FGreyDelaySecs := 0; FCounter := Random ((MAXINT div 2) + $10); // used for mail IDs FExclusiveAddr := True; { 8.37 make our sockets exclusive } // set host name, ideally public mail server name from DNS, otherwise computer name FServerHost := ''; i := 0; while (i < LocalIPlist.Count) and (FServerHost = '') do begin FServerHost := String(WSocketResolveIP (AnsiString (LocalIPlist [i]))); Inc(i); end; if FServerHost = '' then FServerHost := LowerCase (IcsGetCompName); { V9.6 } if FServerHost = '' then FServerHost := 'local'; FServerDesc := CopyRight; FLocalAccounts := TStringList.Create; FAliasAccounts := TStringList.Create; FLocalDomains := TStringList.Create; FServer := TSslWSocketServer.Create(nil); with FServer do begin OnDebugDisplay := TriggerDisplay; { V9.6 debug logging } Banner := ''; BannerTooBusy := ''; end; // Define client check timer FCheckTimer := TIcsTimer.Create (FServer); FCheckTimer.Interval := cTimerInterval; FCheckTimer.OnTimer := CheckClientStatus; FCheckTimer.Enabled := false; // Add commands SetLength (FCommands, 0); AddCommand (cMAIL, HandleMAIL, mcAny); // MAIL FROM (one) AddCommand (cRCPT, HandleRCPT, mcMessage); // RCPT TO (multiple) AddCommand (cDATA, HandleDATA, mcMessage); // content AddCommand (cHELO, HandleHELO, mcConnected); AddCommand (cEHLO, HandleEHLO, mcConnected); AddCommand (cQUIT, HandleQUIT, mcAny); AddCommand (cRSET, HandleRSET, mcAny); AddCommand (cNOOP, HandleNOOP, mcCommand); AddCommand (cVRFY, HandleVRFY, mcCommand); AddCommand (cAUTH, HandleAUTH, mcCommand); AddCommand (cTURN, nil); AddCommand (cEXPN, nil); AddCommand (cETRN, nil); AddCommand (cHELP, nil); end; //******************************************************************// // Routine Destructor // //******************************************************************// destructor TSmtpServer.Destroy; begin if Active then Stop; if Assigned (FCheckTimer) then // must free timer before server, it's descended begin FCheckTimer.Free; FCheckTimer := Nil; end; if Assigned (FServer) then begin FServer.Free; FServer := nil; end; FLocalAccounts.Free; FAliasAccounts.Free; FLocalDomains.Free; inherited; end; //******************************************************************// // Start the server. That is make FServer listening to the ports // //******************************************************************// procedure TSmtpServer.Start; var S: String; begin if NOT Assigned(FServer) then exit; if FServer.State = wsListening then exit; if NOT Assigned(IcsHosts) then begin { V9.6 } TriggerDisplay(Self, 'IcsHosts must be assigned'); Exit; end; try with FServer do begin ClientClass := FClientClass; OnClientConnect := ClientConnect; OnClientDisconnect := ClientDisconnect; OnBgException := ServerException; OnSessionClosed := ServerSessionClosed; SocketFamily := FSocketFamily; MultiThreaded := FMultiThread; ExclusiveAddr := FExclusiveAddr; { V8.37 } SocketErrs := FSocketErrs; { V8.37 } S := ValidateHosts(False, False); { V9.6 } // don't stop on error, might be self signed certs } TriggerDisplay(Self, S); { V9.6 } S := MultiListenEx; { V9.6 } if S = '' then begin FCheckTimer.Enabled := true; if Assigned (FOnServerStarted) then begin FOnServerStarted (Self); end; end else begin TriggerDisplay(Self, 'Server failed to start: ' + S); { V9.6 } RaiseException('Server failed to start: ' + S); end; end; except on E : Exception do RaiseException(E.Message); end; end ; //******************************************************************// // Stop the server // //******************************************************************// procedure TSmtpServer.Stop; var i : integer; begin FCheckTimer.Enabled := false; if not Assigned(FServer) then exit; if FServer.State <> wsListening then exit; FServer.MultiClose; // stop listening // cleanly close active connections for i := PRED (FServer.ClientCount) downto 0 do begin with TSmtpSrvCli (FServer.Client [i]) do begin if State <> wsClosed then begin OnSessionClosed := nil; SendStatus (s421, '0.0', [FServerHost, xShutdown, sClosingChannel]); Close; end; end; end; // Disconnect all clients if any left FServer.DisconnectAll; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.GetWSDebugOptions: TWSDebugOptions; { V9.6 } begin if Assigned(FServer) then Result := FServer.WSDebugOptions; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSmtpServer.SetWSDebugOptions(Value: TWSDebugOptions); { V9.6 } begin if Assigned(FServer) then FServer.WSDebugOptions := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSmtpServer.TriggerDisplay(Sender: TObject; const Msg: String); { V9.6 } begin if Assigned(OnDisplay) then OnDisplay(Sender, Msg); end; //******************************************************************// // Routine RaiseException & RaiseExceptionFmt // // // // Description Raises an exception // //******************************************************************// procedure TSmtpServer.RaiseException(const Message : string); begin if Assigned(FExtHandler) then FExtHandler(Self,ESMTPserver.Create(Message)) else raise ESMTPserver.Create(Message); end; procedure TSmtpServer.RaiseExceptionFmt(const Format: string; const Args: array of const); begin if Assigned(FExtHandler) then FExtHandler(Self,ESMTPserver.CreateFmt(Format,Args)) else raise ESMTPserver.CreateFmt(Format,Args); end; //******************************************************************// // Get function for ClientCount property from FWSocketServer. // //******************************************************************// function TSmtpServer.GetClientCount; begin if not Assigned(FServer) then Result := 0 else Result := FServer.ClientCount; end; //******************************************************************// // Get function for Client[] property from FServer. // //******************************************************************// function TSmtpServer.GetClient(nIndex : Integer) : TSmtpSrvCli; begin if not Assigned(FServer) then Result := nil else Result := TSmtpSrvCli(FServer.Client[nIndex]); end; //******************************************************************// // Check if an object is one of our clients from FServer. // //******************************************************************// function TSmtpServer.IsClient(SomeThing : TObject) : Boolean; begin if not Assigned(FServer) then Result := FALSE else Result := FServer.IsClient(SomeThing); end; //******************************************************************// // Check if FServer is listening // //******************************************************************// function TSmtpServer.GetActive: boolean; begin if not Assigned(FServer) then Result := FALSE else Result := (FServer.State = wsListening); end; //******************************************************************// // Routine SetTimeout // // // // Description Sets the client timeout // //******************************************************************// procedure TSmtpServer.SetTimeout(ATimeout : integer); begin if ATimeout <= 0 then FClientTimeout := ATimeout else FClientTimeout := ATimeout; end; //******************************************************************// // Routine SetLocalAccounts // // // // Description Set local email account and domains as email addresses // //******************************************************************// procedure TSmtpServer.SetLocalAccounts (newValue: TStrings); var I, J, K: Integer; Account, Domain: string; begin FLocalAccounts.Clear; FLocalDomains.Clear; (FLocalAccounts as TStringList).Sorted := true; (FLocalDomains as TStringList).Sorted := true; for I := 0 to newValue.Count - 1 do begin Account := IcsLowerCase (newValue.Strings[I]); J := Pos ('@', Account); if (J > 1) and (Length (Account) >= 3) then begin if NOT (FLocalAccounts as TStringList).Find (Account, K) then begin FLocalAccounts.Add (Account); Domain := Copy (Account, J + 1, 999); if NOT (FLocalDomains as TStringList).Find (Domain, K) then FLocalDomains.Add (Domain); end; end; end; end; //******************************************************************// // Routine SetAliasAccounts // // // // Description Set alias email account and domains as email addresses // //******************************************************************// procedure TSmtpServer.SetAliasAccounts (newValue: TStrings); var I, J, K: Integer; Pair, Alias, Account, Domain: string; begin FAliasAccounts.Clear; (FAliasAccounts as TStringList).Sorted := true; for I := 0 to newValue.Count - 1 do begin Pair := IcsLowerCase (newValue.Strings[I]); J := Pos ('=', Pair); if (J > 1) and (Length (Pair) >= 3) then begin Alias := Copy (Pair, 1, J - 1); Account := Copy (Pair, J + 1, 999); if (FLocalAccounts as TStringList).Find (Account, K) then begin J := Pos ('@', Alias); if (J > 1) and (Length (Alias) >= 3) then begin if FAliasAccounts.IndexOfName (Alias) < 0 then begin FAliasAccounts.Add (Pair); Domain := Copy (Alias, J + 1, 999); if NOT (FLocalDomains as TStringList).Find (Domain, K) then FLocalDomains.Add (Domain); end; end; end; end; end; end; //******************************************************************// // Routine CheckClientStatus // // // // Description Runs through attached clients, looking for timeout // //******************************************************************// procedure TSmtpServer.CheckClientStatus(Sender : TObject); var i : integer; Time : TDateTime; Delta : integer; begin Time := Now; for i := PRED (FServer.ClientCount) downto 0 do with TSmtpSrvCli (FServer.Client [i]) do begin Delta := SecondsBetween (Time, FLastContact); if FContext = mcConnecting then begin // Check for DNS timeout if Delta >= cDNStimeout then PostMessage (Handle, FMsg_wmClientLookupDone, 0, lParam(Self.FServer.Client[i])) { V8.03} end else begin // Check for client timeout if (Self.FClientTimeout > 0) and (Delta > Self.FClientTimeout) then { V8.04 avoid conflict with socket server } begin SendStatus(s221,'0.0',[FServerHost,xTimeout]); CloseDelayed; end end end; end; //******************************************************************// // Routine SetMaxMsgSize // // // // Description Sets the maximum message size // //******************************************************************// procedure TSmtpServer.SetMaxMsgSize(AMsgSize : integer); begin if AMsgSize <= 0 then FMaxMsgSize := 0 else FMaxMsgSize := AMsgSize; end; //******************************************************************// // Routine ServerException // // // // Description Handles a TWSocketServer exception // //******************************************************************// procedure TSmtpServer.ServerException(Sender : TObject; E : Exception; var CanClose : Boolean); begin if Sender is TSmtpSrvCli then CanClose := true else RaiseException(E.Message); end; //******************************************************************// // Routine ServerException // // // // Description Handles a TWSocketServer exception // //******************************************************************// procedure TSmtpServer.ServerSessionClosed(Sender : TObject; Error : Word); begin if Assigned (FOnServerStopped) then begin FOnServerStopped (Self); end; end; //******************************************************************// // Routine AddCommand // // // // Description Add an SMTP command handler // //******************************************************************// procedure TSmtpServer.AddCommand(Cmd : AnsiString; Handler : TSmtpcmdHandler; Context : TSmtpmsgContext); var i : integer; begin // Add NUL terminator and attempt to locate existing entry Cmd := Cmd + #00; i := Low (FCommands); while (i <= High (FCommands)) and (Cmd <> FCommands [i].Cmd) do Inc(i); if i > High (FCommands) then begin // Add new command SetLength (FCommands, SUCC (Length (FCommands))); FCommands [i].Cmd := Cmd; end; // Set command parameters FCommands [i].Context := Context; FCommands [i].Handler := Handler; end; //******************************************************************// // Routine SendString // // // // Description Send a arbitrary string to a client // //******************************************************************// procedure TSmtpServer.SendString(Client : TObject; const Str : String); begin if Client is TSmtpSrvCli then begin with TSmtpSrvCli (Client) do if TWSocketServer (Owner).IsClient (Client) then SendAnswer (Str); end else RaiseException (Format (xInvalidObj, ['SendString()'])); end; //******************************************************************// // Routine ClientConnect // // // // Description Invoked when someone connects to the server // //******************************************************************// procedure TSmtpServer.ClientConnect(Sender : TObject; Client : TWSocketClient; Error : Word); //var // ListenItem: TWSocketMultiListenItem; begin with TSmtpSrvCli(Client) do begin // Assign unique session ID if FCounter = $FFFFFFFE then FCounter := 1 else Inc (FCounter); FID := FCounter; FClientIpAddr := Client.CPeerAddr; { V9.6 } FSocketFamily := Client.SocketFamily; FServIpAddr := Client.CServerAddr; FServPort := Client.CServerPort; FSmtpServer := Self; LineMode := TRUE; // we'll receive single lines LineEdit := FALSE; LineEnd := AnsiChar(LF); // with just LF for end of line if (FMaxUsers > 0) and (cardinal (Self.FServer.ClientCount) >= FMaxUsers) then begin // Reject connection SendStatus(s452, '3.2', ['user limit reached']); Close; end else begin if FDNSaddr = '' then // No DNS available - skip lookup PostMessage(Handle, FMsg_wmClientLookupDone, 0, lParam(Client)) { V8.03} else begin FLastContact := Now; FDnsQuery := TDNSquery.Create(nil); FDnsQuery.Addr := FDNSaddr; FDnsQuery.OnRequestDone := LookupComplete; FDnsQuery.PTRLookup (FClientIpAddr); { V8.64 now string } end; end; end; // note, OnConnect event is called when reverse DNS lookup completes end; //******************************************************************// // Routine ClientDisconnect // // // // Description Invoked when someone disconnects from the server // //******************************************************************// procedure TSmtpServer.ClientDisconnect(Sender : TObject; Client : TWSocketClient; Error : Word); begin if Active and Assigned (FOnDisconnect) then begin FOnDisconnect (Self, Client, Error); end; end; //******************************************************************// // Routine HandleNOOP // // // // Description Handles NOOP command // //******************************************************************// procedure TSmtpServer.HandleNOOP(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); begin with TSmtpSrvCli (Sender) do SendStatus (s250, '0.0', [cOK]); end; //******************************************************************// // Routine HandleQUIT // // // // Description Handles QUIT command // //******************************************************************// procedure TSmtpServer.HandleQUIT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); begin with TSmtpSrvCli (Sender) do begin SendStatus (s221, '0.0', [FServerHost, sClosingChannel]); CloseDelayed; end; end; //******************************************************************// // Routine HandleRSET // // // // Description Handles RSET command // //******************************************************************// procedure TSmtpServer.HandleRSET(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); begin with TSmtpSrvCli (Sender) do begin FContext := mcCommand; ClearClient; SendStatus (s250, '0.0', [sReset]); end; end; //******************************************************************// // Routine HandleVRFY // // // // Description Handles VRFY command // //******************************************************************// procedure TSmtpServer. HandleVRFY(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); begin with TSmtpSrvCli (Sender) do begin SendStatus (s252, '0.0', []); // we don't want to verify email address end; end; //******************************************************************// // Routine HandleHELO // // // // Description Handles HELO command // //******************************************************************// procedure TSmtpServer.HandleHELO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); begin ESMTP := false; with TSmtpSrvCli (Sender) do begin FClientDomain := ExtractEmail (Parameters); FContext := mcCommand; SendStatus (s250, '', [FServerHost]); end end; //******************************************************************// // Routine HandleEHLO // // // // Description Handles EHLO command // //******************************************************************// procedure TSmtpServer.HandleEHLO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); var CommandList : string; i : integer; begin ESMTP := true; with TSmtpSrvCli (Sender) do begin FClientDomain := ExtractEmail (Parameters); FContext := mcCommand; CommandList := Format (s250c, [FServerHost]) + CRLF; // Now list all non-optional commands for i := Low (FCommands) to High (FCommands) do if (StrIComp (@FCommands [i].Cmd [1],cMAIL) = 0) and (StrIComp (@FCommands [i].Cmd [1],cRCPT) = 0) and (StrIComp (@FCommands [i].Cmd [1],cDATA) = 0) and (StrIComp (@FCommands [i].Cmd [1],cRSET) = 0) and (StrIComp (@FCommands [i].Cmd [1],cNOOP) = 0) and (StrIComp (@FCommands [i].Cmd [1],cQUIT) = 0) and Assigned( FCommands [i].Handler) then CommandList := CommandList + Format (s250c, [Trim (String (FCommands[i].Cmd))]) + CRLF; if FMaxMsgSize > 0 then CommandList := CommandList + Format (s250c, ['SIZE '+ IntToStr (FMaxMsgSize)]) + CRLF; // might not want to offer AUTH SSL negotiated if FTlsDone OR (NOT ((smtpsAuthNoTls in FSmtpServer.FOptions) and (smtpsAllowTls in FSmtpServer.FOptions))) then { V8.01 } CommandList := CommandList + Format (s250c, ['AUTH PLAIN LOGIN CRAM-MD5 CRAM-SHA1'])+ CRLF; if (smtpsExtendedResp in FSmtpServer.FOptions) then CommandList := CommandList + Format (s250c, ['ENHANCEDSTATUSCODES'])+ CRLF; {$IFDEF USE_SSL} if (NOT FTlsDone) and (smtpsAllowTls in FSmtpServer.FOptions) then CommandList := CommandList + Format (s250c , ['STARTTLS']) + CRLF ; {$ENDIF} CommandList := CommandList + Format (s250 , ['PIPELINING']) + CRLF ; SendAnswer (CommandList); end end; //******************************************************************// // Routine HandleTLS // // // // Description Handles STARTTLS command // //******************************************************************// procedure TSmtpServer.HandleTLS(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); var Answer: AnsiString; Client: TSmtpSrvCli; begin ESMTP := false; Client := Sender as TSmtpSrvCli; if (Client.FContext <> mcCommand) or (NOT (smtpsAllowTls in FOptions)) then begin Client.SendStatus (s454s, '', ['']); // failed exit; end ; if Client.FTlsDone or (Client.SslState = sslEstablished) then begin Client.SendStatus (s501, '', [xTlsAreadyDone]); // failed exit; end ; // must reset everything for SSL session Client.ClearClient; try Client.SslEnable := True; Client.SslMode := sslModeServer; Client.SslContext := FServer.SslContext; Client.OnSslVerifyPeer := TlsSslVerifyPeer; Client.OnSslHandshakeDone := TlsSslHandshakeDone; Client.FContext := mcWaitTls; Client.AcceptSslHandshake; Answer := AnsiString (s220s + CRLF); Client.SslSendPlain (Pointer(Answer), Length(Answer)); exit; except on E:Exception do begin if Assigned(FExtHandler) then FExtHandler (Self, E); end; end; Client.SslEnable := False; Client.OnSslVerifyPeer := nil; Client.OnSslHandshakeDone := nil; Client.SendStatus (s454s, '', ['']); // failed end; //******************************************************************// // Routine HandleAUTH // // // // Description Handles AUTH command // //******************************************************************// procedure TSmtpServer.HandleAUTH(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); var Reason, EncodedAuth, DecodedAuth, Password: string; Action: TSmtpmailAction; I: integer; begin with TSmtpSrvCli (Sender) do begin {$IFDEF USE_SSL} if (smtpsAllowTls in FSmtpServer.FOptions) and (smtpsAuthNoTls in FOptions) then begin if NOT FTlsDone then begin SendStatus (s503, '5.1', [xOutOfSequence]); exit; end; end; {$ENDIF} FUserName := ''; FSmtpSrvAuthType := smtpsAuthNone; FAuthenticated := false; FAuthChallenge := ''; FAuthWait2nd := false; DecodedAuth := ''; for I := 1 to 4 do begin if StrLIComp (SmtpSrvAuthLits [I], Parameters, Length (SmtpSrvAuthLits [I])) = 0 then begin Parameters := Parameters + Length (SmtpSrvAuthLits [I]); FSmtpSrvAuthType := TSmtpSrvAuthType (I); // Extract any authentication stuff.- PLAIN and LOGIN, optionally EncodedAuth := ExtractArg (Parameters); if Length (EncodedAuth) > 1 then DecodedAuth := String(IcsBase64Decode (EncodedAuth)); { V9.4 } break; end; end; if FSmtpSrvAuthType = smtpsAuthNone then begin SendStatus (s504, '5.0', []); // unknown AUTH type end else if FSmtpSrvAuthType = smtpsAuthPlain then begin if Length (DecodedAuth) > 1 then begin // contains 3 arguments, username(null)mailfrom(null)password I := Pos (#0, DecodedAuth); if I > 0 then begin FUserName := Copy (DecodedAuth, 1, Pred (I)); inc (I); DecodedAuth := Copy (DecodedAuth, I, 999); // remove username I := Pos (#0, DecodedAuth); if I > 0 then // ignore mailfrom, badly documented begin inc (I); if Length (DecodedAuth) >= I then Password := Copy (DecodedAuth, I, 999); end; end; Reason := ''; Action := wsmtpAuthPermFail; if Assigned (FOnAuth) then begin FOnAuth (Self, Sender, FUserName, Password, Action, Reason); end; if Action = wsmtpOK then begin FAuthenticated := true; SendStatus (s235, '', []) end else SendActionFailed (Sender, Action, Reason); end else begin FAuthWait2nd := true; SendStatus (s334, '', ['OK']); end; end else if FSmtpSrvAuthType = smtpsAuthLogin then begin FAuthWait2nd := true; // might have user name already if Length (DecodedAuth) > 1 then begin FUserName := DecodedAuth; EncodedAuth := IcsBase64Encode ('Password'); { V9.4 } end else EncodedAuth := IcsBase64Encode ('Username'); { V9.4 } SendStatus (s334, '', [EncodedAuth]); end else if (FSmtpSrvAuthType = smtpsAuthCramMD5) or (FSmtpSrvAuthType = smtpsAuthCramSha1) then begin FAuthWait2nd := true; FAuthChallenge := AnsiString (FloatToStr (Now) + '@' + FSmtpServer.FServerHost); EncodedAuth := String(IcsBase64EncodeA (FAuthChallenge)); { V9.4 } SendStatus (s334, '', [EncodedAuth]); end; end; end; //******************************************************************// // Routine HandleAUTH2 // // // // Description Handles extra responses after the AUTH command // //******************************************************************// procedure TSmtpServer.HandleAUTH2(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); var Reason, EncodedAuth, DecodedAuth, Password, HDigest: string; Action: TSmtpmailAction; I: integer; MDigest: TMD5Digest; SDigest: SHA1Digest; Pwd: AnsiString; begin Reason := ''; Action := wsmtpAuthPermFail; with TSmtpSrvCli (Sender) do begin FAuthWait2nd := false; // don't come here again // Extract the authentication stuff and check it EncodedAuth := ExtractArg (Parameters); if Length (EncodedAuth) > 1 then begin DecodedAuth := String(IcsBase64Decode (EncodedAuth)); { V9.4 } if FSmtpSrvAuthType = smtpsAuthPlain then begin // contains 3 arguments, username(null)mailfrom(null)password I := Pos (#0, DecodedAuth); if I > 0 then begin FUserName := Copy (DecodedAuth, 1, Pred (I)); inc (I); DecodedAuth := Copy (DecodedAuth, I, 999); // remove username I := Pos (#0, DecodedAuth); if I > 0 then // ignore mailfrom, badly documented begin inc (I); if Length (DecodedAuth) >= I then Password := Copy (DecodedAuth, I, 999); end; end; end else if FSmtpSrvAuthType = smtpsAuthLogin then begin if FUserName = '' then // first response begin FUserName := DecodedAuth; FAuthWait2nd := true; EncodedAuth := IcsBase64Encode ('Password'); { V9.4 } SendStatus (s334, '', [EncodedAuth]); end else Password := DecodedAuth; end else if (FSmtpSrvAuthType = smtpsAuthCramMD5) or (FSmtpSrvAuthType = smtpsAuthCramSha1) then begin I := Pos (' ', DecodedAuth); // contains username(space)hash if I > 0 then begin FUserName := Copy (DecodedAuth, 1, Pred (I)); inc (I); if Length (DecodedAuth) > I then DecodedAuth := Copy (DecodedAuth, I, 999); end; // application needs to provide a password for us to hash and test Password := ''; if Assigned (FOnAuthPW) then begin FOnAuthPW (Self, Sender, FUserName, Password, Action, Reason); end; if Password <> '' then begin Pwd := AnsiString (Password); // MD5DigestInit (MDigest); if FSmtpSrvAuthType = smtpsAuthCramMD5 then begin HMAC_MD5 (PAnsiChar (FAuthChallenge)^, Length (FAuthChallenge), PAnsiChar (Pwd)^, Length (Pwd), MDigest); HDigest := MD5DigestToLowerHex (MDigest); end else if FSmtpSrvAuthType = smtpsAuthCramSha1 then begin HMAC_SHA1(PAnsiChar (FAuthChallenge)^, Length(FAuthChallenge), PAnsiChar (Pwd)^, Length (Pwd), SDigest); HDigest := SHA1DigestToLowerHex (SDigest); end; if DecodedAuth = HDigest then Action := wsmtpOK; // set blank password for event since we don't want to test it Password := ''; end; end ; end; if (NOT FAuthWait2nd) then begin if (Assigned (FOnAuth)) then begin FOnAuth (Self, Sender, FUserName, Password, Action, Reason); end; if Action = wsmtpOK then begin FAuthenticated := true; SendStatus (s235, '', []) end else begin // failed, so reset everything FUserName := ''; FSmtpSrvAuthType := smtpsAuthNone; FAuthenticated := false; FAuthChallenge := ''; SendActionFailed (Sender, Action, Reason); end; end; end; end; //******************************************************************// // Routine HandleMAIL // // // // Description Handles MAIL FROM command // //******************************************************************// procedure TSmtpServer.HandleMAIL(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); var Reason: string; Action: TSmtpmailAction; MsgSize : integer; begin Action := wsmtpOK; Reason := ''; // Line should consist of FROM: <[address]>. Validate. with TSmtpSrvCli (Sender) do begin if StrLIComp (cFrom, Parameters, Length (cFrom)) <> 0 then begin Action := wsmtpBadParams; Reason :=xBadFROMparam; end else if (FServPort = '587') and (NOT FAuthenticated) then begin Action := wsmtpAuthRequired; end; // Extract the From address.. if Action = wsmtpOK then begin Parameters := Parameters + Length (cFrom); FMessageFrom := IcsLowerCase (ExtractEmail (Parameters)); // Clear details of any prior messages FMessageTo.Clear; FToAccounts.Clear; FHdrTo := ''; FHdrFrom := ''; FHdrSubject := ''; FHdrDateStr := ''; FHdrDateDT := 0; FDoneHdrs := false; // Now check for an RFC-1870 SIZE specifier if (FSmtpServer.FMaxMsgSize > 0) then begin SkipWhiteSpace (Parameters); if StrLIComp (cSize, Parameters, Length (cSize)) = 0 then begin // Check SIZE against the limit SkipWhitespace (Parameters); try MsgSize := atoi (Parameters); if MsgSize > FSmtpServer.FMaxMsgSize then begin // Too large.. reject and return to caller SendStatus (s552, '3.4', []); Exit; end; except // Syntax error.. give 'em a hint and return to caller SendStatus (s501, '5.2', [xBadSIZEparam]); Exit; end; end; end; // ask application if we are happy if Assigned (FOnMailFrom) then begin FOnMailFrom (Self, Sender, FMessageFrom, Action, Reason); end; end; // Set message context & tell 'em "full steam ahead".. if Action = wsmtpOK then begin FContext := mcMessage; FMessageID := Format ('%1.1u%9.9x%8.8x', [YearOf (Now) mod 10, MillisecondOfTheYear (Now), FID]); SendStatus(s250, '1.0', ['<' + FMessageFrom + '> ' + cOK]); end else SendActionFailed (Sender, Action, Reason); end; end; //******************************************************************// // Routine HandleRCPT // // // // Description Handles RCPT TO command // //******************************************************************// procedure TSmtpServer.HandleRCPT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); var Recipient, Domain, LocalAccount, Reason: string; Action : TSmtpmailAction; Dupli, AllowRelay: boolean; J, K : integer; begin // Line should consist of TO: <[address]>. Validate. with TSmtpSrvCli (Sender) do begin Dupli := false; Reason := ''; Action := wsmtpOK; if StrLIComp (cTo, Parameters, Length(cTo)) <> 0 then begin Action := wsmtpBadParams; Reason :=xBadTOparam; end else if (FServPort = '587') and (NOT FAuthenticated) then begin Action := wsmtpAuthRequired; end else if Length (FMessageFrom) = 0 then begin // no mail from yet Action := wsmtpBadSequence; Reason := xNoMailFrom; end; // Extract the To address.. if Action = wsmtpOK then begin Parameters := Parameters + Length(cTo); Recipient := IcsLowerCase (ExtractEmail (Parameters)); LocalAccount := ''; // New recipient specified? Dupli := (FMessageTo.IndexOf (Recipient) >= 0) ; // test against local accounts if FLocalAccounts.Count > 0 then begin J := Pos ('@', Recipient); if (J > 1) then Domain := Copy (Recipient, J + 1, 999); if (FLocalAccounts as TStringList).Find (Recipient, K) then LocalAccount := Recipient // main account else begin // alias for a main account, which is where it will be delivered K := FAliasAccounts.IndexOfName (Recipient); if K >= 0 then LocalAccount := FAliasAccounts.ValueFromIndex [K] else begin // catch-all mail for this domain if alias is *@domain K := FAliasAccounts.IndexOfName ('*@' + Domain); if K >= 0 then LocalAccount := FAliasAccounts.ValueFromIndex [K]; end; end; // not local, see if allowed to relay mail if (LocalAccount = '') then begin AllowRelay := false; if (FAuthenticated and (smtpsAllowAuthRelay in FOptions)) then AllowRelay := true; if (smtpsAllowOpenRelay in FOptions) then AllowRelay := true; if NOT AllowRelay then begin if (J > 1) and (NOT (FLocalDomains as TStringList).Find (Domain, K)) then Action := wsmtpBadDomain else Action := wsmtpBadAccount; end; end; end; // New recipient if Assigned (FOnRcptTo) then begin FOnRcptTo (Self, Sender, Recipient, Action, Reason); end; end; // Handle action if Action = wsmtpOK then begin // Accept duplicate recipient (but don't actually add it to the list again) if Dupli then SendStatus (s250, '1.0', ['<' + Recipient + '> ' + cOK]) else begin FMessageTo.Add (Recipient); FToAccounts.Add (LocalAccount); // might be blank if not local SendStatus (s250, '1.5', ['<' + Recipient + '> ' + cOK]); end; end else SendActionFailed (Sender, Action, Reason); end; end; //******************************************************************// // Routine HandleDATA // // // // Description Handles DATA command // //******************************************************************// procedure TSmtpServer.HandleDATA(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PAnsiChar); const SType : array [false..true] of string = ('SMTP','ESMTP'); var CliHost : string; Headers : AnsiString; I : integer; Reason : string; Action : TSmtpmailAction; begin Reason := ''; Action := wsmtpOK; with TSmtpSrvCli (Sender) do begin if FMessageTo.Count = 0 then begin // No recipients specified Action := wsmtpBadSequence; Reason := xNoRecipients; end else begin // free datastream in case left open due to band commands try if Assigned (DataStream) then begin DataStream.Free; DataStream := nil; end; // application must create Datastream in event for mail fails now if Assigned (FOnDataStart) then begin FOnDataStart (Self, Sender, Action, Reason); end; except Action := wsmtpSysUnavail; Reason := xNoSpool; end; end; // check a stream has been assigned in the application to save data if (Action = wsmtpOK) and (NOT Assigned (FDataStream)) then begin Action := wsmtpSysUnavail; Reason := xNoStorage; end; // see if adding headers before other headers, might fail writing stream if Action = wsmtpOK then begin try FDataStream.Seek (0,0); // reset to start Headers := ''; if (smtpsAddReplayHdrs in FOptions) then begin Headers := AnsiString ('X-Sender: <' + FMessageFrom + '>' + CRLF); // optional arguments, BODY=7bit RET=HDRS/FULL, ENVID=xxx, auth=(RFC2554 shceme) for I := 0 to FMessageTo.Count - 1 do Headers := Headers + AnsiString ('X-Receiver: <' + FMessageTo [I] + '>' + CRLF); // optional arguments, NOTIFY=NEVER/DELAY/FAILURE ORcpt=originalrecipient end; if (smtpsAddRecvHeaders in FOptions) then begin // add Return-Path: and Received: headers if FClientRDNS = '' then CliHost := '' else CliHost := FClientRDNS + ' '; Headers := Headers + AnsiString (Format ('Return-Path: <%s>'#13#10 + 'Received: from %s (%s[%s]) by %s'#13#10 + ' with %s id <%s>;'#13#10 + ' %s '#13#10, [FMessageFrom, FClientDomain, CliHost, FClientIpAddr, FServerHost, SType [ESMTP], FMessageID, Rfc822DateTime(Now)])); Headers := Headers + AnsiString ('X-IpAddr: ' + FClientIpAddr + IcsCRLF + { V9.6 } 'X-RDNS: ' + CliHost + IcsCRLF ); end; if Headers <> '' then FDataStream.WriteBuffer (PAnsiChar(Headers)^, Length(Headers)); except Action := wsmtpSysUnavail; Reason := xNoSpool; end; end; // Switch to DATA mode if Action = wsmtpOK then begin FContext := mcData; SendStatus (s354, '0.0', []); end else SendActionFailed (Sender, Action, Reason); end; end; //******************************************************************// // Routine SendActionFailed // // // // Description Send various failed responses // //******************************************************************// procedure TSmtpServer.SendActionFailed(Sender : TObject; Action: TSmtpmailAction; const Reason: string); begin with TSmtpSrvCli (Sender) do begin case Action of wsmtpOK : SendStatus (s250, '1.0', [Reason]); // should not come here for OK wsmtpClosingDown : SendStatus (s421,'', [FSmtpServer.FServerHost, Reason, sClosingChannel]); wsmtpMailboxBusy : SendStatus (s450, '7.0', []); wsmtpGreylisted : SendStatus (s451, '4.1', [IntToStr (FGreyDelaySecs)]); wsmtpMsgTooLarge : SendStatus (s452, '3.1', [xNoStorage]); wsmtpAuthTempFail : SendStatus (s454, '7.0', []); // AUTH failed, unknown wsmtpSyntaxError : SendStatus (s500, '5.2', [Reason]); wsmtpBadParams : SendStatus (s501, '5.2', [Reason]); wsmtpBadCommand : SendStatus (s502, '5.2', [Reason]); wsmtpBadSequence : SendStatus (s503, '5.0', [Reason]); wsmtpAuthRequired : SendStatus (s530, '5.1', []); wsmtpAuthPermFail : SendStatus (s535, '7.8', []); // AUTH failed, bad credentials wsmtpBadAccount : SendStatus (s550, '1.1', [xBadAccount]); wsmtpBadDomain : SendStatus (s550, '1.2', [xBadDomain]); wsmtpAccClosed : SendStatus (s550, '1.6', [xAccClosed]); wsmtpAccNotLocal : SendStatus (s551, '7.1', [Reason]); wsmtpMailboxFull : SendStatus (s552, '2.2', []); wsmtpProhibited : begin if (Reason = '') then SendStatus (s553, '7.1', [xPolicy]) else SendStatus (s553, '7.1', [Reason]); end; wsmtpSysUnavail : SendStatus (s554, '3.5', [xNoSpool]); wsmtpNetError : SendStatus (s554, '4.0', [xNetError]); // Network error wsmtpCongested : SendStatus (s554, '4.5', [xCongested]); // System is congested. Please try again later. wsmtpTooMany : SendStatus (s554, '5.3', [xTooMany]); // Too many recipients specified wsmtpBadMedia : SendStatus (s554, '3.1', [xBadMedia]); // Media not supported (e.g. we don't like Base-64 ;o) wsmtpListNotAuth : SendStatus (s554, '3.1', [xListNotAuth]); // You are not authorised to send messages to this mailing list wsmtpListNotRec : SendStatus (s554, '2.4', [xListNotRec]); // Mailing list does not exist else SendStatus (s501, '5.0', [Reason]); // unknown or undefined end; end; end; //******************************************************************// // Component SmtpSrvCli // //******************************************************************// //******************************************************************// // Routine Constructor/Destructor // //******************************************************************// constructor TSmtpSrvCli.Create(AOwner : TComponent); begin inherited; FContext := mcConnecting; FMessageTo := TStringList.Create; FToAccounts := TStringList.Create; ClearClient; OnBgException := TWSocketServer( AOwner).OnBgException; OnDataAvailable := nil; end; destructor TSmtpSrvCli.Destroy; begin if Assigned(DataStream) then begin DataStream.Free; DataStream := nil; end; FMessageTo.Free; FToAccounts.Free; inherited; end; //******************************************************************// // Routine ClearClient // // // // Description Clear all client variables // //******************************************************************// procedure TSmtpSrvCli.ClearClient; begin FESMTP := false; FDnsQuery := nil; FMessageFrom := ''; FClientDomain := ''; FClientRDNS := ''; FClientMX := ''; FMessageTo.Clear; FToAccounts.Clear; FUserName := ''; FAuthenticated := false; FAuthWait2nd := false; FHdrTo := ''; FHdrFrom := ''; FHdrSubject := ''; FHdrDateStr := ''; FHdrDateDT := 0; FDoneHdrs := false; FTlsDone := false; end; //******************************************************************// // Routine SendAnswer // // // // Description SendAnswer // //******************************************************************// function TSmtpSrvCli.SendAnswer(const Str : String) : integer; begin if Length (Str) > 0 then begin if Assigned (FSmtpServer.FOnResponse) then FSmtpServer.FOnResponse (FSmtpServer, Self, Copy (Str, 1, Length (Str) -2)); Result := SendStr (RawByteString(Str)); end else Result := 0; FLastContact := Now; end; //******************************************************************// // Routine SendStatus // // // // Description Sets and transmits an SMTP status string // //******************************************************************// procedure TSmtpSrvCli.SendStatus(const FormatStr : string; const EnhancedStat : string; Args : array of const); var OutputBuffer : string; begin try OutputBuffer := Format (FormatStr, Args) + CRLF; if (smtpsExtendedResp in FSmtpServer.FOptions) and FESMTP and (EnhancedStat <> '') and (FormatStr <> '') then OutputBuffer := Copy (OutputBuffer, 1, 4) + FormatStr [1] + '.' + EnhancedStat + Copy (OutputBuffer, 4, Length (OutputBuffer)); SendAnswer(OutputBuffer); except on E : Exception do begin RaiseException (Format (xClientStat,[FID, Copy (FormatStr, 1, 3), E.Message])); Abort; end; end; end; //******************************************************************// // Routine SslSendPlain // // // // Description Sends a response before SSL negotiated // //******************************************************************// {$IFDEF USE_SSL} function TSmtpSrvCli.SslSendPlain(Data : TWSocketData; Len : Integer) : Integer; begin Result := RealSend (Data, Len); end; {$ENDIF} //******************************************************************// // Routine ClientDataRx // // // // Description Invoked when data is received from the client // //******************************************************************// procedure TSmtpSrvCli.ClientDataRx(Sender : TObject; Error : Word); var Len, I: integer; Reason, RcvdLower: string; Headers : AnsiString; Action: TSmtpmailAction; procedure TestHdr (const Hdr: string; var Value: string); begin if Pos (Hdr, RcvdLower) <> 1 then exit; if (Len > 0) and (FRcvdLine[Len] = #10) then // remove CRLF begin Dec(Len); if (Len > 0) and (FRcvdLine[Len] = #13) then Dec(Len); end; // decode inline MIME in header, ignore charset Value := DecodeMimeInlineValue (Copy (FRcvdLine, Length (Hdr) + 1, Len - Length (Hdr))) ; end; begin if (Error = ERROR_SUCCESS) then begin { We use line mode. We will receive complete lines } FRcvdLine := ReceiveStrA; Len := Length (FRcvdLine); if (Len > 0) then begin if FContext = mcData then begin // check for end of data if Pos (EOM, FRcvdLine) <> 1 then begin if (NOT Assigned (FDataStream)) then begin Action := wsmtpSysUnavail; FContext := mcCommand; // ready for more commands // tell application we died if Assigned (FSmtpServer.FOnDataEnd) then begin FSmtpServer.FOnDataEnd (FSmtpServer, Sender, Action, Reason); end; SendStatus (s554, '3.5', [xNoSpool]); exit; end else begin // remove escaped period at start of line if Pos (ESCDOT, FRcvdLine) = 1 then begin Dec (Len); FRcvdLine := Copy (FRcvdLine, 2, Len) ; end; // see if adding extra headers to bottom of existing headers if (NOT FDoneHdrs) then begin if Pos (CRLF, FRcvdLine) = 1 then // blank line ends headers begin FDoneHdrs := true; if FHdrDateStr <> '' then try FHdrDateDT := InetParseDate (FHdrDateStr); except FHdrDateDT := 0; // some date strings are very illegal end; // see if adding new headers after other headers Headers := ''; if (smtpsAddEnvHeaders in FSmtpServer.FOptions) then begin Headers := AnsiString ('X-Envelope-From: ' + FMessageFrom + CRLF); for I := 0 to FMessageTo.Count - 1 do Headers := Headers + AnsiString ('X-Envelope-To: ' + FMessageTo [I] + CRLF); end else begin if (HdrTo = '') and (smtpsParseHeaders in FSmtpServer.FOptions) then begin for I := 0 to FMessageTo.Count - 1 do Headers := Headers + AnsiString ('Apparently-To: ' + FMessageTo [I] + CRLF); end; end; if (smtpsAddIpAddrHdr in FSmtpServer.FOptions) then Headers := Headers + AnsiString ('X-Originating-IP: ' + FClientIpAddr + CRLF); if Headers <> '' then FDataStream.WriteBuffer (PAnsiChar(Headers)^, Length(Headers)); // here is where we could add more extra headers, if needed end; end; // write email content line to stream try FDataStream.WriteBuffer (PAnsiChar(FRcvdLine)^, Len); except Action := wsmtpSysUnavail; FContext := mcCommand; // ready for more commands // tell application we died if Assigned (FSmtpServer.FOnDataEnd) then begin FSmtpServer.FOnDataEnd (FSmtpServer, Sender, Action, Reason); end; SendStatus (s554, '3.5', [xNoSpool]); exit; end; // optionally parse a few email headers // WARNING - only first line of multiple line headers is processed currently if (smtpsParseHeaders in FSmtpServer.FOptions) and (NOT FDoneHdrs) then begin RcvdLower := IcsLowerCase (String(FRcvdLine)); TestHdr ('to:', FHdrTo); TestHdr ('from:', FHdrFrom); TestHdr ('subject:', FHdrSubject); TestHdr ('date:', FHdrDateStr); end; end; end else // got a complete message begin FContext := mcCommand; // ready for more commands Reason := ''; Action := wsmtpOK; if (FSmtpServer.FMaxMsgSize > 0) and (FDataStream.Size > FSmtpServer.FMaxMsgSize) then begin Action := wsmtpMsgTooLarge ; end ; // tell application, it can do something with the full DataStream, like close it try if Assigned (FSmtpServer.FOnDataEnd) then begin FSmtpServer.FOnDataEnd (FSmtpServer, Sender, Action, Reason); end else Action := wsmtpSysUnavail; except Action := wsmtpSysUnavail; end; if Action = wsmtpOK then begin SendStatus (s250, '6.0', [Format(sQueued, [FMessageID])]); end else FSmtpServer.SendActionFailed (Sender, Action, Reason); // free datastream if not already done if Assigned(DataStream) then begin DataStream.Free; DataStream := nil; end; end; end else begin { Remove trailing CR/LF } if (Len > 0) and (FRcvdLine[Len] = #10) then begin Dec(Len); if (Len > 0) and (FRcvdLine[Len] = #13) then Dec(Len); SetLength (FRcvdLine, Len); end; if (Len > 0) then begin if Assigned (FSmtpServer.FOnCommand) then FSmtpServer.FOnCommand (FSmtpServer, Self, String(FRcvdLine)); if FAuthWait2nd then begin FAuthWait2nd := false; // may get set again in AUTH2 FSmtpServer.HandleAUTH2 (Self, FID, FESMTP, @FRcvdLine[1]); end else ProcessCommand (@FRcvdLine[1]); end; end; end; end else // Data reception error. Close link Close; end; //******************************************************************// // Routine WndProc // // // // Description Handles custom message processing // //******************************************************************// procedure TSmtpSrvCli.AllocateMsgHandlers; begin inherited AllocateMsgHandlers; FMsg_wmClientLookupDone := FWndHandler.AllocateMsgHandler (Self); FMsg_wmClientClose := FWndHandler.AllocateMsgHandler (Self); end; procedure TSmtpSrvCli.FreeMsgHandlers; begin if Assigned (FWndHandler) then begin FWndHandler.UnregisterMessage (FMsg_wmClientLookupDone); FWndHandler.UnregisterMessage (FMsg_wmClientClose); end; inherited FreeMsgHandlers; end; procedure TSmtpSrvCli.WndProc(var MsgRec: TMessage); var Reason: string; Action: TSmtpmailAction; begin try if MsgRec.Msg = FMsg_wmClientLookupDone then begin with TSmtpSrvCli (MsgRec.LParam) do begin if FContext = mcConnecting then begin // Setup connection FDnsQuery.Free; FDnsQuery := nil; OnDataAvailable := ClientDataRx; // Inform "caller" Action := wsmtpOK; Reason := ''; if Assigned (FSmtpServer.FOnConnect) then begin FSmtpServer.FOnConnect (FSmtpServer, Self, FClientIpAddr, Action, Reason); end; if Action = wsmtpOK then begin FContext := mcConnected; SendStatus (s220, '', [FSmtpServer.FServerHost, FSmtpServer.FServerDesc]); end else begin FSmtpServer.SendActionFailed (Self, Action, Reason); // Reject connection TSmtpSrvCli (MsgRec.LParam).Close; end; end; end ; end else if MsgRec.Msg = FMsg_wmClientClose then begin TSmtpSrvCli (MsgRec.LParam).Close; end else inherited WndProc (MsgRec); except on E:Exception do HandleBackGroundException(E); end; end; //******************************************************************// // Routine LookupComplete // // // // Description RDNS lookup complete for client connection // //******************************************************************// procedure TSmtpSrvCli.LookupComplete(Sender : TObject; Error : Word); var i,j : integer; begin with FDnsQuery do begin if Error = ERROR_SUCCESS then begin if QuestionType = DnsQueryPTR then begin if ResponseANCount = 0 then // No rDNS available. PostMessage(Handle, FMsg_wmClientLookupDone, 0, lParam(Self)) { V8.03} else begin FClientRDNS := String(Hostname[0]); MXLookup (Hostname[0]); end ; end else // MX record located if ResponseANCount = 0 then begin // Failed. Remove front subdomain and try again i := Pos ('.', QuestionName); { V8.64 } if i = 0 then // MX does not exist PostMessage (Handle, FMsg_wmClientLookupDone, 0, lParam(Self)) { V8.03} else // Remove front portion and try again.. MXlookup (Copy (QuestionName, SUCC (i), Length (QuestionName))); end else begin // Locate current primary server i := 0; for j := 1 to PRED(ResponseANCount) do if MXpreference [j] < MXpreference [i] then i := j; FClientMX := String(MXexchange [i]); end; end else begin // DNS lookup has failed. OnRequestDone := nil; PostMessage (Handle, FMsg_wmClientLookupDone, 0, lParam(Self)) { V8.03} end; end; end; //******************************************************************// // Routine ProcessCommand // // // // Description Processes an SMTP command // //******************************************************************// procedure TSmtpSrvCli.ProcessCommand(Str : PAnsiChar); var Cmd, Ptr : PAnsiChar; i : integer; begin if Str^ <> NUL then begin // Trim any trailing whitespace Ptr := StrEnd (Str) - 1; while (Ptr >= Str) and (Ptr^ <= ' ') do Dec (Ptr); PAnsiChar (Ptr +1 )^ := NUL; // Advance pointers to command and any parameters Cmd := Str; while (Cmd^ <> NUL) and (Cmd^ <= ' ') do Inc (Cmd); Ptr := Cmd; while (Ptr^ <> NUL) and (Ptr^ > ' ') do Inc (Ptr); if Ptr <> NUL then begin // Parameter present - skip whitespace Ptr^ := NUL; Inc (Ptr); while (Ptr^ <> NUL) and (Ptr^ <= ' ') do Inc(Ptr); end; // Search command list with FSmtpServer do begin i := Low (FCommands); while (i <= High (FCommands)) and (StrIComp (Cmd, @FCommands [i].Cmd [1]) <> 0) do Inc(i); if i < Length (FCommands) then begin // Command recognized. Is it in-context or allowed anywhere? if (FCommands [i].Context = FContext) or (FCommands [i].Context = mcAny) then begin // Call handler, if assigned if Assigned (FCommands [i].Handler) then FCommands [i].Handler (Self, FID, FESMTP, Ptr) else // No handler.. hence not implemented SendStatus (s502, '5.1', [Cmd]); end else begin // Command is out-of-sequence if FContext = mcConnected then SendStatus (s503, '5.1', [xNoHello]) else SendStatus (s503, '5.1', [xOutOfSequence]); end; end else SendStatus (s500, '5.2', [Cmd]); end; end; end; //******************************************************************// // Routine TlsSslHandshakeDone // // // // Description SSL handshaking has completed OK or failed // //******************************************************************// procedure TSmtpServer.TlsSslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect: Boolean); var Client: TSmtpSrvCli; begin Client := Sender as TSmtpSrvCli; if Assigned(FOnSslHandshakeDone) then FOnSslHandshakeDone(Sender, ErrCode, PeerCert, Disconnect); if (ErrCode <> 0) or Disconnect then begin PostMessage (FHandle, Client.FMsg_wmClientClose, 0, lParam(Sender)); { V8.03} Disconnect := FALSE; end else begin Client.ClearClient; Client.FContext := mcConnected; // expect EHLO next Client.FTlsDone := true; end; end; //******************************************************************// // Routine TlsSslVerifyPeer // // // // Description Verify Peer // //******************************************************************// procedure TSmtpServer.TlsSslVerifyPeer(Sender: TObject; var Ok: Integer; Cert: TX509Base); begin if Assigned(FOnSslVerifyPeer) then FOnSslVerifyPeer(Sender, Ok, Cert); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSmtpServer.TransferSslServerName(Sender: TObject; var Ctx: TSslContext; var ErrCode: TTlsExtError); { V9.6 } begin if Assigned(FOnSslServerName) then FOnSslServerName(Sender, Ctx, ErrCode); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.GetIcsHosts: TIcsHostCollection; { V9.6 } begin if Assigned(FServer) then Result := TSslWSocketServer(FServer).GetIcsHosts else Result := nil; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSmtpServer.SetIcsHosts(const Value: TIcsHostCollection); { V9.6 } begin if Assigned(FServer) then TSslWSocketServer(FServer).SetIcsHosts(Value); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.ValidateHosts(Stop1stErr: Boolean=True; NoExceptions: Boolean=False): String; //var // J: Integer; begin if Assigned(FServer) then begin Result := TSslWSocketServer(FServer).ValidateHosts(Stop1stErr, NoExceptions); if GetIcsHosts <> Nil then begin if TSslWSocketServer(FServer).IcsHosts.Count > 0 then begin // set SSL modes for server if any Hosts have AuthSslCmd specified // implicit handled by SslEnabled on the host { FtpSslTypes := []; for J := 0 to TSslWSocketServer(FServer).IcsHosts.Count - 1 do begin with TSslWSocketServer(FServer).IcsHosts[J] do begin if AuthSslCmd then begin FtpSslTypes := [ftpAuthSsl,ftpAuthTls,ftpAuthTlsP,ftpAuthTlsC]; Break; end; end ; end; } end; end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.RecheckSslCerts(var CertsInfo: String; Stop1stErr: Boolean=True; NoExceptions: Boolean=False): Boolean; { V9.6 } begin Result := False; if Assigned(FServer) then begin Result := TSslWSocketServer(FServer).RecheckSslCerts(CertsInfo, Stop1stErr, NoExceptions); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.GetSslCertAutoOrder: Boolean; { V9.6 } begin if Assigned(FServer) then Result := TSslWSocketServer(FServer).SslCertAutoOrder else Result := False; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSmtpServer.SetSslCertAutoOrder(const Value : Boolean); { V9.6 } begin if Assigned(FServer) then TSslWSocketServer(FServer).SslCertAutoOrder := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.GetCertExpireDays: Integer; { V9.6 } begin if Assigned(FServer) then Result := TSslWSocketServer(FServer).CertExpireDays else Result := 30; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSmtpServer.SetCertExpireDays(const Value : Integer); { V9.6 } begin if Assigned(FServer) then TSslWSocketServer(FServer).CertExpireDays := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.ListenAllOK: Boolean; { V9.6 } begin if Assigned(FServer) then Result := FServer.ListenAllOK else Result := False; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.ListenAny: Boolean; { V9.3 } begin if Assigned(FServer) then Result := FServer.ListenAny else Result := False; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TSmtpServer.ListenStates: String; { V9.6 } begin if Assigned(FServer) then Result := FServer.ListenStates else Result := ''; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} {$IFDEF AUTO_X509_CERTS} function TSmtpServer.GetSslX509Certs: TSslX509Certs; { V9.6 } begin if Assigned(FServer) then Result := TSslWSocketServer(FServer).GetSslX509Certs as TSslX509Certs else Result := nil; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TSmtpServer.SetSslX509Certs(const Value : TSslX509Certs); { V9.6 } begin if Assigned(FServer) then TSslWSocketServer(FServer).SetSslX509Certs(Value); end; {$ENDIF} // AUTO_X509_CERTS {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure IcsLoadSmtpServerFromIni(MyIniFile: TCustomIniFile; SmtpServer: TSmtpServer; const Section: String = 'SmtpServer'); { V9.6 } //var // bandwidth: Integer; begin if NOT Assigned (MyIniFile) then raise ESocketException.Create('Must open and assign INI file first'); if NOT Assigned (SmtpServer) then raise ESocketException.Create('Must assign SmtpServer first'); with SmtpServer do begin // Banner := MyIniFile.ReadString(Section, 'BannerConnect', Banner); // MaxAttempts := MyIniFile.ReadInteger(Section, 'MaxAttempts', MaxAttempts); {$IFDEF AUTO_X509_CERTS} SslCertAutoOrder := IcsCheckTrueFalse(MyIniFile.ReadString (section, 'SslCertAutoOrder', 'False')); CertExpireDays := MyIniFile.ReadInteger(Section, 'CertExpireDays', CertExpireDays); {$ENDIF} { V9.5 new certificate ordering defaults in SocketServer } {$IFDEF AUTO_X509_CERTS} with SmtpServer.WSocketServer as TSslWSocketServer do begin SrvSupplierTitle := Trim(MyIniFile.ReadString(section, 'SrvSupplierTitle', '')); SrvAcmeSupplier := TAcmeSupplier(GetEnumValue (TypeInfo (TAcmeSupplier), IcsTrim(MyIniFile.ReadString(section, 'SrvAcmeSupplier', 'AcmeLetsEncrypt')))); if (SrvAcmeSupplier > High(TAcmeSupplier)) or (SrvAcmeSupplier < Low(TAcmeSupplier)) then SrvAcmeSupplier := AcmeLetsEncrypt; SrvAcmeCertProfile := IcsTrim(MyIniFile.ReadString(section, 'SrvAcmeCertProfile', '')); SrvAcmeCertValidity := MyIniFile.ReadInteger(section, 'SrvAcmeCertValidity', 90); SrvCertChallenge := TChallengeType(GetEnumValue (TypeInfo (TChallengeType), IcsTrim(MyIniFile.ReadString(section, 'SrvCertChallenge', 'ChallNone')))); if SrvCertChallenge > High(TChallengeType) then SrvCertChallenge := ChallNone; SrvCertPKeyType := TSslPrivKeyType(GetEnumValue (TypeInfo (TSslPrivKeyType), IcsTrim(MyIniFile.ReadString(section, 'SrvCertPKeyType', 'PrivKeyRsa2048')))); if SrvCertPKeyType > High(TSslPrivKeyType) then SrvCertPKeyType := PrivKeyRsa2048; SrvCertSignDigest := TEvpDigest(GetEnumValue (TypeInfo (TEvpDigest), IcsTrim(MyIniFile.ReadString(section, 'SrvCertSignDigest', 'Digest_sha256')))); if SrvCertSignDigest > High(TEvpDigest) then SrvCertSignDigest := Digest_sha256; end; {$ENDIF} end; end; {$ENDIF} //******************************************************************// // Routine Initialization/Finalization // //******************************************************************// initialization Randomize; end.