📄 wsmtpserver.pas
字号:
//******************************************************************//
// 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 //
//******************************************************************//
unit WSMTPserver;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, WSocket, WSocketS, StrUtils,
DateUtils, ExtCtrls, DNSquery;
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';
cSEND = 'SEND';
cSOML = 'SOML';
cSAML = 'SAML';
cEXPN = 'EXPN';
cHELP = 'HELP';
cTURN = 'TURN';
cRSET = 'RSET';
cNOOP = 'NOOP';
cVRFY = 'VFRY';
cETRN = 'ETRN';
// 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
// General exception
EWSMTPserver = Exception;
TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
// This describes the client state required to run a particular SMTP primitive
TWSMTPmsgContext = (mcConnecting,mcConnected,mcCommand,mcMessage,mcData);
// Action to be taken for a given email recipient
TWSMTPmailAction = (wsmtpOK, // Positive response from the calling application
wsmtpConnect, // Client has connected
wsmtpDisconnect, // Client has disconnected
wsmtpMail, // Client is requesting MAIL transmission
wsmtpSend, // Client is requesting Instant Message
wsmtpSendOrMail, // Client is requesting Instant Message, but a Mail will suffice
wsmtpSendAndMail, // Client is requesting Instant Message *and* a mail message
wsmtpBadAccount, // No such account on this server
wsmtpBadDomain, // Specified domain not handled by this server (e.g. could be a relaying request)
wsmtpAccClosed, // Account has closed, and is no longer valid
wsmtpProhibited, // Recipient or complete message rejected through server policy (reason should be given)
wsmtpMsgTooLarge, // Client has exceeded maximum message size. Current message has been lost
wsmtpSysUnavail, // System is not accepting messages (e.g. shutting-down, PM, etc.)
wsmtpNetError, // Network error
wsmtpCongested, // System is congested. Please try again later.
wsmtpTooMany, // Too many recipients specified
wsmtpBadMedia, // Media not supported (e.g. we don't like Base-64 ;o)
wsmtpListNotAuth, // You are not authorised to send messages to this mailing list
wsmtpListNotRec); // Mailing list does not exist
// This handler implements a given SMTP primitive
TWSMTPcmdHandler = 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 : PChar) of object; // Command parameters, if present
// This handler is used to inform the application of client events and requests
TStringDynArray = array of string; // Only available in types.pas from Delphi 6. Included for backwards-compatibility.
TWSMTPactionHandler = function( Sender : TObject; // Sender (the TWSMTPserver)
const ClientID : cardinal; // Unique client ID
const Address : string; // Client IP address
const Domain : string; // Claimed identity. Blank on initial connection
const Hostname : string; // Client rDNS host name. Blank if unlisted
const MailX : string; // Client Mail Exchanger (i.e. best guess at their e-mail server)
const Action : TWSMTPmailAction; // Action request/response (e.g. mail Recipient accepted/rejected)
const MailFrom : string; // Client claimed e-mail address
const MailTo : TStringDynArray; // Intended message recipient (if content undefined), or a list of all recipients
var Reason : string; // Reason text for taking this action (if applicable)
Content : PChar // If full message received *only*, references full message content
) : TWSMTPmailAction of object; // Returned action, e.g. wsmtpRecipientOK for a new recipient request
// This handler allows a full protocol trace to be generated
TWSMTPclientTrace = procedure( Sender : TObject;
Client : cardinal;
const Inbound : boolean; Text : PChar) of object;
// This is the main server component. Use as-is, or derive something with the required behaviour.
TWSMTPserver = class(TComponent)
private
Active : boolean;
Address : string;
ServerPort : string;
ServerHost : string;
ServerDomain : string;
ServerName : string;
MaxUsers : cardinal;
MultiThread : boolean;
MaxMsgSize : integer;
DNSaddr : string;
Commands : array of record
Cmd : string;
Context : TWSMTPmsgContext;
Handler : TWSMTPcmdHandler;
end;
Timeout : integer;
CheckTimer : TTimer;
TraceHandler : TWSMTPclientTrace;
ExtHandler : TExceptionEvent;
ActionHandler : TWSMTPactionHandler;
procedure SetActive(AActive : boolean);
procedure SetAddr(AAddr : string);
procedure SetPort(APort : string);
procedure SetHost(AHost : string);
procedure SetDomain(ADomain : string);
procedure SetServerName(AName : string);
procedure SetTimeout(ATimeout : integer);
procedure SetMaxMsgSize(AMsgSize : integer);
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);
protected
Server : TWsocketServer;
procedure RaiseException(const Message : string);
procedure CheckClientStatus(Sender : TObject);
// Adds or replaces a new SMTP command.
procedure AddCommand(Cmd : string; Handler : TWSMTPcmdHandler; Context : TWSMTPmsgContext = 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 : PChar); virtual;
procedure HandleQUIT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleRSET(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleHELO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleEHLO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleMAIL(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleSEND(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleSOML(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleSAML(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleRCPT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); virtual;
procedure HandleDATA(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); 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;
published
// Sets service active or inactive
property Enabled : boolean read Active write SetActive;
// Sets listener address. 0.0.0.0 for all NICs/IPs
property Addr : string read Address write SetAddr;
// Sets listener port
property Port : string read ServerPort write SetPort;
// Sets local host name
property Host : string read ServerHost write SetHost;
// Sets local domain name
property Domain : string read ServerDomain write SetDomain;
// Sets declared service name (i.e. what the User Agent sees)
property Service : string read ServerName write SetServerName;
// 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 MaxUsers write MaxUsers;
// Set flag if running in a threaded environment
property MultiThreaded : boolean read MultiThread write MultiThread;
// Set maximum message size processed. Can be set dynamically, allowing throttling if storage is running low.
// 0 for "no limit"
property MaxMessageSize : integer read MaxMsgSize write SetMaxMsgSize;
// Address of DNS to be used for all queries
property DNS : string read DNSaddr write DNSaddr;
// Client timeout, in seconds. 0 for no timeout
property ClientTimeout : integer read Timeout write SetTimeout;
// Event called for an unhandled exception
property OnException : TExceptionEvent read ExtHandler write ExtHandler;
// Event called when a client Action takes place (connection/disconnection/attempt to send a message)
property OnClientAction : TWSMTPactionHandler read ActionHandler write ActionHandler;
// Event called for traffic tracing
property OnClientTrace : TWSMTPclientTrace read TraceHandler write TraceHandler;
end;
function SMTPtime : string;
procedure SkipWhitespace(var Ptr : PChar);
function ExtractEmail(var Str : PChar) : string;
function ComputerName : string;
implementation
const
cBlockSize = 2048;
cTempDir = 'TEMP';
cTimerInterval = 2 * 1000;
NUL = #00;
CR = #13;
LF = #10;
CRLF = CR+LF;
EOM = CR+LF+CR+LF+'.'+CR+LF;
cAT = '@';
cOK = 'OK';
cFrom = 'FROM:';
cSize = 'SIZE';
cTo = 'TO:';
wmCheckInputBuffer = WM_USER + 50;
wmClientLookupDone = WM_USER + 51;
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';
xClientStat = 'Error setting client %8.8x status to %s: %s';
xInvalidObj = 'Invalid object passed to %s';
xShutdown = 'service unavailable';
xOutOfSequence = 'Command out-of-sequence';
xNoHello = 'HELO or EHLO is required';
xBadSIZEparam = 'SIZE parameter is not compliant with RFC-1870';
xBadFROMparam = 'Use <MAIL|SEND|SAML|SOML> FROM: <yourname@yourdomain>. Please see RFC-821 for details.';
xBadTOparam = 'Use RCPT TO: <recipient@theirdomain>. Please see RFC-821 for details.';
xBadAccount = 'No such account. Please verify that the address is correct';
xBadDomain = 'Mail for that domain is not accepted here';
xAccClosed = 'That account is no longer valid';
xPolicy = 'Message not accepted due to policy violation. Contact postmaster @ this domain for details';
xNoRecipients = 'No message recipients have been specified';
sQueued = 'Message %s queued';
xNoSpool = 'Spool unavailable';
xMsgTooLarge = 'Message size exceeds maximum. Please contact postmaster @ this domain for details';
sReset = 'Session reset';
sClosingChannel = 'closing transmission channel';
xTimeout = 'timeout period exceeded';
xNoStorage = 'insufficient system storage';
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) %s';
s221 = '221 %s %s';
s250 = '250 %s';
s250c = '250-%s';
s354 = '354 Start mail input; end with <CRLF>.<CRLF>';
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -