2 MegaBrutal's SMTP Server (MgSMTP)
3 Copyright (C) 2010 MegaBrutal
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU Affero General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU Affero General Public License for more details.
15 You should have received a copy of the GNU Affero General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
21 This unit implements the necessary objects to relay messages towards
22 remote servers. It handles the re-routing of messages, when it's
31 uses SysUtils
, Classes
, INIFiles
, Base64
, CompareWild
, Common
, Network
,
32 DNSMX
, NetRFC
, RFCSMTP
;
41 TSMTPExtensions
= record
42 Pipelining
, Size
, EbitMIME
: boolean;
45 { A TRoutingTarget holds the data for a single relay host.
46 The administrator may give a symbolic name to some relay hosts that
47 identifies a distinct section in the configuration INI file, where
48 all necessary data can be found to contact the particular relay host. }
50 TRoutingTarget
= class
51 constructor Create(Name
, TargetHost
: string; Port
: integer; Auth
: boolean; Username
, Password
: string);
53 FName
, FTargetHost
, FUsername
, FPassword
: string;
57 property Name
: string read FName
;
58 property Host
: string read FTargetHost
;
59 property Port
: integer read FPort
;
60 property Auth
: boolean read FAuth
;
61 property Username
: string read FUsername
;
62 property Password
: string read FPassword
;
63 function Copy
: TRoutingTarget
;
66 { TRoutingTable manages re-routing. It can be asked where to relay e-mails
67 for a specific host. It holds multiple instances of TRoutingTarget. }
71 destructor Destroy
; override;
73 Targets
: array of TRoutingTarget
;
74 Routes
: array of TMailRoute
;
75 function FindOrLoadTarget(TargetName
, TargetHost
: string; Port
: integer; Auth
: boolean; Username
, Password
: string): integer;
77 procedure AddRoute(Mask
: string; TargetName
, TargetHost
: string; Port
: integer; Auth
: boolean; Username
, Password
: string);
78 function ReRoute(Host
: string): string;
79 function GetRouteInfo(Host
: string): TRoutingTarget
;
82 { TRelayer does the actual relaying to a host. It connects the target server
83 and passes the message to it by SMTP protocol. }
86 constructor Create(RoutingTable
: TRoutingTable
; Envelope
: TEnvelope
; EMailProperties
: TEMailProperties
);
87 destructor Destroy
; override;
90 FEMailProperties
: TEMailProperties
;
91 FRoutingTarget
: TRoutingTarget
;
92 RoutingTable
: TRoutingTable
;
93 TCP
: TTCPRFCConnection
;
95 SMTPExtensions
: TSMTPExtensions
;
96 procedure AdministerMassFailure(var Result
: boolean);
97 function GetRelayServerName
: string;
98 function GetRelayServerPort
: integer;
100 property Envelope
: TEnvelope read FEnvelope
;
101 property EMailProperties
: TEMailProperties read FEMailProperties
;
102 property RelayServerName
: string read GetRelayServerName
;
103 property RelayServerPort
: integer read GetRelayServerPort
;
104 function OpenConnection
: boolean;
105 function Greet
: boolean;
106 function SendEnvelope
: boolean;
107 function PrepareSendMessage
: boolean;
108 function DeliverMessagePart(Chunk
: TStrings
): boolean;
109 procedure FinishDeliverMessage
;
110 procedure CloseConnection
;
113 { TRelayManager is the main manager object of the entire relay unit.
114 It loads all the configuration, sets up the corresponding objects,
115 and it creates configured TRelayer-s. }
117 TRelayManager
= class
118 constructor Create(Config
: TINIFile
);
119 destructor Destroy
; override;
121 RelayToList
, NoRelayToList
: TStrings
;
122 RoutingTable
: TRoutingTable
;
124 function CreateRelayer(Envelope
: TEnvelope
; EMailProperties
: TEMailProperties
): TRelayer
;
125 function IsOnRelayToList(HostName
: string): boolean;
126 function IsOnNoRelayToList(HostName
: string): boolean;
127 function OrganizeEnvelopes(Envelopes
: TEnvelopeArray
): TEnvelopeArray
;
133 RelayManager
: TRelayManager
;
140 constructor TRoutingTarget
.Create(Name
, TargetHost
: string; Port
: Integer; Auth
: boolean; Username
, Password
: string);
144 if TargetHost
= '' then FTargetHost
:= Name
else FTargetHost
:= TargetHost
;
147 FUsername
:= Username
;
148 FPassword
:= Password
;
151 constructor TRoutingTable
.Create
;
154 SetLength(Targets
, 0);
155 SetLength(Routes
, 0);
158 destructor TRoutingTable
.Destroy
;
161 for i
:= 0 to Length(Targets
) - 1 do
163 SetLength(Routes
, 0);
164 SetLength(Targets
, 0);
168 constructor TRelayer
.Create(RoutingTable
: TRoutingTable
; Envelope
: TEnvelope
; EMailProperties
: TEMailProperties
);
171 Self
.RoutingTable
:= RoutingTable
;
172 FEnvelope
:= Envelope
;
173 FEMailProperties
:= EMailProperties
;
174 FRoutingTarget
:= RoutingTable
.GetRouteInfo(Envelope
.RelayHost
);
175 Response
:= TRFCReply
.Create
;
176 FillChar(SMTPExtensions
, SizeOf(TSMTPExtensions
), #0);
179 destructor TRelayer
.Destroy
;
186 constructor TRelayManager
.Create(Config
: TINIFile
);
187 var i
: integer; RouteMasks
: TStringList
; RouteName
: string;
191 RelayToList
:= TStringList
.Create
;
192 RelayToList
.Delimiter
:= ',';
193 RelayToList
.DelimitedText
:= Config
.ReadString('Relay', 'RelayTo', '');
195 NoRelayToList
:= TStringList
.Create
;
196 NoRelayToList
.Delimiter
:= ',';
197 NoRelayToList
.DelimitedText
:= Config
.ReadString('Relay', 'NoRelayTo', '');
199 RoutingTable
:= TRoutingTable
.Create
;
200 RouteMasks
:= TStringList
.Create
;
201 Config
.ReadSection('Relay\Routes', RouteMasks
);
202 for i
:= 0 to RouteMasks
.Count
- 1 do begin
203 RouteName
:= Config
.ReadString('Relay\Routes', RouteMasks
.Strings
[i
], '!');
204 RoutingTable
.AddRoute(RouteMasks
.Strings
[i
],
206 Config
.ReadString('Relay\Routes\' + RouteName
, 'Host', ''),
207 Config
.ReadInteger('Relay\Routes\' + RouteName
, 'Port', STANDARD_SMTP_PORT
),
208 Config
.ReadBool('Relay\Routes\' + RouteName
, 'Auth', false),
209 Config
.ReadString('Relay\Routes\' + RouteName
, 'Username', ''),
210 Config
.ReadString('Relay\Routes\' + RouteName
, 'Password', '')
216 destructor TRelayManager
.Destroy
;
224 function TRoutingTarget
.Copy
: TRoutingTarget
;
226 Result
:= TRoutingTarget
.Create(Name
, Host
, Port
, Auth
, Username
, Password
);
229 procedure TRoutingTable
.AddRoute(Mask
: string; TargetName
, TargetHost
: string; Port
: integer; Auth
: boolean; Username
, Password
: string);
230 { It should be only called at start-up. It creates the necessary TRountingTarget
231 objects. It doesn't create redundant targets. If more entries are there to
232 relay to a specific server, then only one TRoutingTarget will be created
233 for that relay host. It is ensured by FindOrLoadTarget. }
237 SetLength(Routes
, i
+ 1);
238 Routes
[i
].Mask
:= Mask
;
239 Routes
[i
].Target
:= FindOrLoadTarget(TargetName
, TargetHost
, Port
, Auth
, Username
, Password
);
242 function TRoutingTable
.FindOrLoadTarget(TargetName
, TargetHost
: string; Port
: integer; Auth
: boolean; Username
, Password
: string): integer;
243 { Creates a new TRoutingTarget, but only if no other TRoutingTarget exists
244 with the same name. If it does find an already-existing TRoutingTarget
245 with the given name, it returns that instance. }
246 var i
, x
: integer; Found
: boolean;
248 i
:= 0; Found
:= false;
249 while (i
< Length(Targets
)) and (not Found
) do begin
250 if Targets
[i
].Name
= TargetName
then begin
256 if not Found
then begin
258 SetLength(Targets
, x
+ 1);
259 Targets
[x
]:= TRoutingTarget
.Create(TargetName
, TargetHost
, Port
, Auth
, Username
, Password
);
264 function TRoutingTable
.ReRoute(Host
: string): string;
265 { It returns the NAME of the relay host that's supposed to relay messages
266 towards the specified host. The mentioned NAME can be a hostname or
267 a symbolic name given in the configuration. If this function returns "!",
268 that means that the message should be relayed to the named host itself. }
269 var i
: integer; Found
: boolean;
271 i
:= 0; Found
:= false;
272 while (i
< Length(Routes
)) and (not Found
) do begin
273 if WildComp(UpperCase(Routes
[i
].Mask
), UpperCase(Host
)) then begin
274 Result
:= Targets
[Routes
[i
].Target
].Name
;
279 if not Found
then Result
:= Host
;
282 function TRoutingTable
.GetRouteInfo(Host
: string): TRoutingTarget
;
283 { It returns the corresponding TRoutingTarget for a given name.
284 That name may be a symbolic name, given in the configuration,
286 Note, this function returns a COPY of the TRoutingTarget.
287 The caller is responsible for freeing it.
288 If there is no TRoutingTarget with the given name, the function
289 creates a new TRoutingTarget and puts the given hostname into it. }
290 var i
: integer; Found
: boolean;
292 i
:= 0; Found
:= false;
293 while (i
< Length(Targets
)) and (not Found
) do begin
294 if Targets
[i
].Name
= Host
then begin
295 Result
:= Targets
[i
].Copy
;
300 if not Found
then Result
:= TRoutingTarget
.Create(Host
, Host
, STANDARD_SMTP_PORT
, false, '', '');
304 procedure TRelayer
.AdministerMassFailure(var Result
: boolean);
307 for i
:= 0 to Envelope
.GetNumberOfRecipients
- 1 do
308 Envelope
.SetRecipientData(i
, Response
.GetNumericCode
, Response
.ReplyText
.Text);
312 function TRelayer
.GetRelayServerName
: string;
314 Result
:= FRoutingTarget
.Host
;
317 function TRelayer
.GetRelayServerPort
: integer;
319 Result
:= FRoutingTarget
.Port
;
322 function TRelayer
.OpenConnection
: boolean;
323 { Initiates connection to the relay site. It queries the MX records for the
324 relay site's domain, and tries to connect the resulting hosts in the
325 order of MX priorities. If there are no MX records for the domain,
326 the domain's A record will be connected.
327 The function returns TRUE, if it successfully established connection
328 to any of the MX hostnames. }
329 var MXList
: TStrings
; i
: integer;
331 MXList
:= GetCorrectMXRecordList(RelayServerName
);
332 if MXList
.Count
>= 1 then begin
333 TCP
:= TTCPRFCConnection
.Create(MXList
.Strings
[0], RelayServerPort
);
334 TCP
.SetSockTimeOut(DEF_SOCK_TIMEOUT
);
336 while (not TCP
.Connected
) and (i
< MXList
.Count
) do begin
337 TCP
.Connect(MXList
.Strings
[i
], RelayServerPort
);
340 Result
:= TCP
.Connected
;
346 function TRelayer
.Greet
: boolean;
347 { This function reads and checks the relay server's greeting.
348 Then, if necessary, authenticates at the connected relay server.
349 Then identifies this server with a HELO.
350 The function returns true, if the authentication and the EHLO command were
354 Authenticated
: boolean;
355 StringStream
: TStringStream
;
356 Base64EncodingStream
: TBase64EncodingStream
;
361 AdministerMassFailure(Result
);
362 TCP
.ReadResponse(Response
);
363 if Response
.GetNumericCode
= SMTP_R_READY
then begin
365 TCP
.SendCommand(SMTP_C_EHLO
, MainServerConfig
.Name
);
366 TCP
.ReadResponse(Response
);
368 if Response
.GetNumericCode
= SMTP_R_OK
then begin
369 for i
:= 1 to Response
.Count
- 1 do begin
370 Line
:= UpperCase(Response
.GetLine(i
));
371 if pos('PIPELINING', Line
) = 1 then
372 SMTPExtensions
.Pipelining
:= true
373 else if pos('SIZE', Line
) = 1 then
374 SMTPExtensions
.Size
:= true
375 else if pos('8BITMIME', Line
) = 1 then
376 SMTPExtensions
.EbitMIME
:= true;
380 else if (Response
.GetNumericCode
>= 500) and (Response
.GetNumericCode
<= 504) then begin
381 { It seems the remote site did not understand our EHLO, that is,
382 let's admit, quite odd in the 21st century...
383 Whatever, let's fall back to RFC 821 then. }
384 TCP
.SendCommand(SMTP_C_HELO
, MainServerConfig
.Name
);
385 TCP
.ReadResponse(Response
);
386 Result
:= Response
.GetNumericCode
= SMTP_R_OK
;
390 if FRoutingTarget
.Auth
then begin
391 TCP
.SendCommand(SMTP_C_AUTH
, 'LOGIN');
392 TCP
.ReadResponse(Response
);
393 if Response
.GetNumericCode
= SMTP_R_AUTH_MESSAGE
then begin
394 StringStream
:= TStringStream
.Create('');
395 Base64EncodingStream
:= TBase64EncodingStream
.Create(StringStream
);
396 Base64EncodingStream
.Write(PChar(FRoutingTarget
.Username
)^, Length(FRoutingTarget
.Username
));
397 Base64EncodingStream
.Destroy
;
398 TCP
.WriteLn(StringStream
.DataString
);
399 StringStream
.Destroy
;
400 TCP
.ReadResponse(Response
);
401 if Response
.GetNumericCode
= SMTP_R_AUTH_MESSAGE
then begin
402 StringStream
:= TStringStream
.Create('');
403 Base64EncodingStream
:= TBase64EncodingStream
.Create(StringStream
);
404 Base64EncodingStream
.Write(PChar(FRoutingTarget
.Password
)^, Length(FRoutingTarget
.Password
));
405 Base64EncodingStream
.Destroy
;
406 TCP
.WriteLn(StringStream
.DataString
);
407 StringStream
.Destroy
;
408 TCP
.ReadResponse(Response
);
409 Authenticated
:= Response
.GetNumericCode
= SMTP_R_AUTH_SUCCESSFUL
;
411 else Authenticated
:= false;
413 else Authenticated
:= false;
415 else Authenticated
:= true;
417 if not Authenticated
then AdministerMassFailure(Result
);
419 else AdministerMassFailure(Result
);
422 else AdministerMassFailure(Result
);
425 function TRelayer
.SendEnvelope
: boolean;
426 { Sends the envelope (that is the return-path and the recipient addresses).
427 The function returns true, if the MAIL command were successful, and the
428 relay server has accepted at least one of the recipient addresses.
429 This function is aware of the SMTP extension, named PIPELINING. If it's
430 supported by the server, we send RCPT commands stuffed, without waiting
431 for a response. After all RCPTs are sent, we check all responses. }
433 i
, c
: integer; Prms
: string;
435 procedure ProcessRCPTResponse
;
437 TCP
.ReadResponse(Response
);
438 if Response
.GetNumericCode
= SMTP_R_OK
then Inc(c
);
439 Envelope
.SetRecipientData(i
, Response
.GetNumericCode
, Response
.ReplyText
.Text);
444 Prms
:= 'FROM:<' + Envelope
.ReturnPath
+ '>';
446 if SMTPExtensions
.Size
then
447 Prms
:= Prms
+ ' SIZE=' + IntToStr(EMailProperties
.Size
);
448 if SMTPExtensions
.EbitMIME
and EMailProperties
.HasFlag(EF_8BITMIME
) then
449 Prms
:= Prms
+ ' BODY=8BITMIME';
451 TCP
.SendCommand(SMTP_C_MAIL
, Prms
);
452 TCP
.ReadResponse(Response
);
453 if Response
.GetNumericCode
= SMTP_R_OK
then begin
455 for i
:= 0 to Envelope
.GetNumberOfRecipients
- 1 do begin
456 TCP
.SendCommand(SMTP_C_RCPT
, 'TO:<' + Envelope
.GetRecipient(i
).Address
+ '>');
457 { If pipelining is not supported, read the responses now. }
458 if not SMTPExtensions
.Pipelining
then ProcessRCPTResponse
;
461 { If pipelining is supported, process all responses. }
462 if SMTPExtensions
.Pipelining
then
463 for i
:= 0 to Envelope
.GetNumberOfRecipients
- 1 do
467 if not Result
then begin
468 TCP
.SendCommand(SMTP_C_RSET
);
469 TCP
.ReadResponse(Response
);
472 else AdministerMassFailure(Result
);
475 function TRelayer
.PrepareSendMessage
;
476 { Prepares mail transmission with the DATA command. }
478 TCP
.SendCommand(SMTP_C_DATA
);
479 TCP
.ReadResponse(Response
);
480 Result
:= Response
.GetNumericCode
= SMTP_R_START_MAIL_INPUT
;
483 function TRelayer
.DeliverMessagePart(Chunk
: TStrings
): boolean;
484 { Sends a chunk of the message. }
487 { Check for lines starting with dots. }
488 for i
:= 0 to Chunk
.Count
- 1 do
489 if (Length(Chunk
.Strings
[i
]) > 0) and (Chunk
.Strings
[i
][1] = '.') then
490 Chunk
.Strings
[i
]:= '.' + Chunk
.Strings
[i
];
493 Result
:= TCP
.WriteBuffer(PChar(Chunk
.Text), Length(Chunk
.Text)) <> -1;
496 procedure TRelayer
.FinishDeliverMessage
;
497 { Finishes the message with a line containing a single dot. }
501 TCP
.ReadResponse(Response
);
502 for i
:= 0 to Envelope
.GetNumberOfRecipients
- 1 do begin
503 if Envelope
.GetRecipient(i
).Data
= SMTP_R_OK
then
504 Envelope
.SetRecipientData(i
, Response
.GetNumericCode
, Response
.ReplyText
.Text);
508 procedure TRelayer
.CloseConnection
;
510 TCP
.SendCommand(SMTP_C_QUIT
);
511 {TCP.ReadResponse(Response);}
516 function TRelayManager
.CreateRelayer(Envelope
: TEnvelope
; EMailProperties
: TEMailProperties
): TRelayer
;
518 Result
:= TRelayer
.Create(RoutingTable
, Envelope
, EMailProperties
);
521 function TRelayManager
.IsOnRelayToList(HostName
: string): boolean;
523 Result
:= RelayToList
.IndexOf(HostName
) <> -1;
526 function TRelayManager
.IsOnNoRelayToList(HostName
: string): boolean;
528 Result
:= NoRelayToList
.IndexOf(HostName
) <> -1;
531 function TRelayManager
.OrganizeEnvelopes(Envelopes
: TEnvelopeArray
): TEnvelopeArray
;
532 { Organizes the given envelopes for relaying.
533 This function assumes that input envelopes are containing recipient
534 addresses orientating to the same site.
535 If it turns out that e-mails for multiple sites must be actually relayed
536 through the same relay server, this function merges the envelopes for
537 those sites; so later, such e-mails will be transmitted though a single
540 For example, the configuration file indicates:
541 - E-mails for "foo.com" must be relayed through "myrelaysmtp".
542 - E-mails for "bar.com" must be also relayed through "myrelaysmtp".
543 In this case, the envelopes for "foo.com" and "bar.com" will be merged,
544 and the e-mail for these sites will be transmitted in one TCP connection. }
546 var i
, j
, k
: integer; f
: boolean; Recipient
: TRecipient
; OrgHost
, TrgHost
: string;
548 SetLength(Result
, 0);
549 for i
:= 0 to Length(Envelopes
) - 1 do begin
550 if Envelopes
[i
].GetNumberOfRecipients
> 0 then begin
551 Recipient
:= Envelopes
[i
].GetRecipient(0);
552 OrgHost
:= EMailHost(Recipient
.Address
);
553 TrgHost
:= RoutingTable
.ReRoute(OrgHost
);
554 if TrgHost
= '!' then TrgHost
:= OrgHost
;
556 while (j
< Length(Result
)) and (not f
) do begin
557 f
:= Result
[j
].RelayHost
= TrgHost
;
560 { Note, if (not f) then j holds Length(Result). }
562 SetLength(Result
, j
+ 1);
563 Result
[j
]:= TEnvelope
.Create
;
564 Result
[j
].ReturnPath
:= Envelopes
[i
].ReturnPath
;
565 Result
[j
].RelayHost
:= TrgHost
;
567 else Dec(j
); { j must be decremented, because we over-incremented it in the loop. }
568 with Result
[j
] do begin
569 { Add first recipient to the envelope. }
570 AddRecipient(Recipient
);
571 { Add the remaining recipients. }
572 for k
:= 1 to Envelopes
[i
].GetNumberOfRecipients
- 1 do
573 AddRecipient(Envelopes
[i
].GetRecipient(k
));