Updated changelog
[mgsmtp.git] / Relay.pas
1 {
2 MegaBrutal's SMTP Server (MgSMTP)
3 Copyright (C) 2010 MegaBrutal
4
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.
9
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.
14
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/>.
17 }
18
19 {
20 Unit: Relay
21 This unit implements the necessary objects to relay messages towards
22 remote servers. It handles the re-routing of messages, when it's
23 configured.
24 }
25
26
27 {$MODE DELPHI}
28 unit Relay;
29
30 interface
31 uses SysUtils, Classes, INIFiles, Base64, CompareWild, Common, Network,
32 DNSMX, NetRFC, RFCSMTP;
33
34 type
35
36 TMailRoute = record
37 Mask: string;
38 Target: integer;
39 end;
40
41 TSMTPExtensions = record
42 Pipelining, Size, EbitMIME: boolean;
43 end;
44
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. }
49
50 TRoutingTarget = class
51 constructor Create(Name, TargetHost: string; Port: integer; Auth: boolean; Username, Password: string);
52 protected
53 FName, FTargetHost, FUsername, FPassword: string;
54 FPort: integer;
55 FAuth: boolean;
56 public
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;
64 end;
65
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. }
68
69 TRoutingTable = class
70 constructor Create;
71 destructor Destroy; override;
72 protected
73 Targets: array of TRoutingTarget;
74 Routes: array of TMailRoute;
75 function FindOrLoadTarget(TargetName, TargetHost: string; Port: integer; Auth: boolean; Username, Password: string): integer;
76 public
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;
80 end;
81
82 { TRelayer does the actual relaying to a host. It connects the target server
83 and passes the message to it by SMTP protocol. }
84
85 TRelayer = class
86 constructor Create(RoutingTable: TRoutingTable; Envelope: TEnvelope; EMailProperties: TEMailProperties);
87 destructor Destroy; override;
88 protected
89 FEnvelope: TEnvelope;
90 FEMailProperties: TEMailProperties;
91 FRoutingTarget: TRoutingTarget;
92 RoutingTable: TRoutingTable;
93 TCP: TTCPRFCConnection;
94 Response: TRFCReply;
95 SMTPExtensions: TSMTPExtensions;
96 procedure AdministerMassFailure(var Result: boolean);
97 function GetRelayServerName: string;
98 function GetRelayServerPort: integer;
99 public
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;
111 end;
112
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. }
116
117 TRelayManager = class
118 constructor Create(Config: TINIFile);
119 destructor Destroy; override;
120 protected
121 RelayToList, NoRelayToList: TStrings;
122 RoutingTable: TRoutingTable;
123 public
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;
128 end;
129
130
131 var
132
133 RelayManager: TRelayManager;
134
135
136
137 implementation
138
139
140 constructor TRoutingTarget.Create(Name, TargetHost: string; Port: Integer; Auth: boolean; Username, Password: string);
141 begin
142 inherited Create;
143 FName:= Name;
144 if TargetHost = '' then FTargetHost:= Name else FTargetHost:= TargetHost;
145 FPort:= Port;
146 FAuth:= Auth;
147 FUsername:= Username;
148 FPassword:= Password;
149 end;
150
151 constructor TRoutingTable.Create;
152 begin
153 inherited Create;
154 SetLength(Targets, 0);
155 SetLength(Routes, 0);
156 end;
157
158 destructor TRoutingTable.Destroy;
159 var i: integer;
160 begin
161 for i:= 0 to Length(Targets) - 1 do
162 Targets[i].Free;
163 SetLength(Routes, 0);
164 SetLength(Targets, 0);
165 inherited Destroy;
166 end;
167
168 constructor TRelayer.Create(RoutingTable: TRoutingTable; Envelope: TEnvelope; EMailProperties: TEMailProperties);
169 begin
170 inherited Create;
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);
177 end;
178
179 destructor TRelayer.Destroy;
180 begin
181 FRoutingTarget.Free;
182 Response.Free;
183 inherited Destroy;
184 end;
185
186 constructor TRelayManager.Create(Config: TINIFile);
187 var i: integer; RouteMasks: TStringList; RouteName: string;
188 begin
189 inherited Create;
190
191 RelayToList:= TStringList.Create;
192 RelayToList.Delimiter:= ',';
193 RelayToList.DelimitedText:= Config.ReadString('Relay', 'RelayTo', '');
194
195 NoRelayToList:= TStringList.Create;
196 NoRelayToList.Delimiter:= ',';
197 NoRelayToList.DelimitedText:= Config.ReadString('Relay', 'NoRelayTo', '');
198
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],
205 RouteName,
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', '')
211 );
212 end;
213 RouteMasks.Free;
214 end;
215
216 destructor TRelayManager.Destroy;
217 begin
218 RelayToList.Free;
219 RoutingTable.Free;
220 inherited Destroy;
221 end;
222
223
224 function TRoutingTarget.Copy: TRoutingTarget;
225 begin
226 Result:= TRoutingTarget.Create(Name, Host, Port, Auth, Username, Password);
227 end;
228
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. }
234 var i: integer;
235 begin
236 i:= Length(Routes);
237 SetLength(Routes, i + 1);
238 Routes[i].Mask:= Mask;
239 Routes[i].Target:= FindOrLoadTarget(TargetName, TargetHost, Port, Auth, Username, Password);
240 end;
241
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;
247 begin
248 i:= 0; Found:= false;
249 while (i < Length(Targets)) and (not Found) do begin
250 if Targets[i].Name = TargetName then begin
251 Found:= true;
252 x:= i;
253 end;
254 Inc(i);
255 end;
256 if not Found then begin
257 x:= Length(Targets);
258 SetLength(Targets, x + 1);
259 Targets[x]:= TRoutingTarget.Create(TargetName, TargetHost, Port, Auth, Username, Password);
260 end;
261 Result:= x;
262 end;
263
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;
270 begin
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;
275 Found:= true;
276 end;
277 Inc(i);
278 end;
279 if not Found then Result:= Host;
280 end;
281
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,
285 or a valid hostname.
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;
291 begin
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;
296 Found:= true;
297 end;
298 Inc(i);
299 end;
300 if not Found then Result:= TRoutingTarget.Create(Host, Host, STANDARD_SMTP_PORT, false, '', '');
301 end;
302
303
304 procedure TRelayer.AdministerMassFailure(var Result: boolean);
305 var i: integer;
306 begin
307 for i:= 0 to Envelope.GetNumberOfRecipients - 1 do
308 Envelope.SetRecipientData(i, Response.GetNumericCode, Response.ReplyText.Text);
309 Result:= false;
310 end;
311
312 function TRelayer.GetRelayServerName: string;
313 begin
314 Result:= FRoutingTarget.Host;
315 end;
316
317 function TRelayer.GetRelayServerPort: integer;
318 begin
319 Result:= FRoutingTarget.Port;
320 end;
321
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;
330 begin
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);
335 i:= 1;
336 while (not TCP.Connected) and (i < MXList.Count) do begin
337 TCP.Connect(MXList.Strings[i], RelayServerPort);
338 Inc(i);
339 end;
340 Result:= TCP.Connected;
341 end
342 else Result:= false;
343 MXList.Free;
344 end;
345
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
351 successful. }
352 var
353 i: integer;
354 Authenticated: boolean;
355 StringStream: TStringStream;
356 Base64EncodingStream: TBase64EncodingStream;
357 Line: string;
358
359 begin
360 Response.Clear;
361 AdministerMassFailure(Result);
362 TCP.ReadResponse(Response);
363 if Response.GetNumericCode = SMTP_R_READY then begin
364
365 TCP.SendCommand(SMTP_C_EHLO, MainServerConfig.Name);
366 TCP.ReadResponse(Response);
367
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;
377 end;
378 Result:= true;
379 end
380 else AdministerMassFailure(Result);
381
382 if Result then begin
383 if FRoutingTarget.Auth then begin
384 TCP.SendCommand(SMTP_C_AUTH, 'LOGIN');
385 TCP.ReadResponse(Response);
386 if Response.GetNumericCode = SMTP_R_AUTH_MESSAGE then begin
387 StringStream:= TStringStream.Create('');
388 Base64EncodingStream:= TBase64EncodingStream.Create(StringStream);
389 Base64EncodingStream.Write(PChar(FRoutingTarget.Username)^, Length(FRoutingTarget.Username));
390 Base64EncodingStream.Destroy;
391 TCP.WriteLn(StringStream.DataString);
392 StringStream.Destroy;
393 TCP.ReadResponse(Response);
394 if Response.GetNumericCode = SMTP_R_AUTH_MESSAGE then begin
395 StringStream:= TStringStream.Create('');
396 Base64EncodingStream:= TBase64EncodingStream.Create(StringStream);
397 Base64EncodingStream.Write(PChar(FRoutingTarget.Password)^, Length(FRoutingTarget.Password));
398 Base64EncodingStream.Destroy;
399 TCP.WriteLn(StringStream.DataString);
400 StringStream.Destroy;
401 TCP.ReadResponse(Response);
402 Authenticated:= Response.GetNumericCode = SMTP_R_AUTH_SUCCESSFUL;
403 end
404 else Authenticated:= false;
405 end
406 else Authenticated:= false;
407 end
408 else Authenticated:= true;
409
410 if not Authenticated then AdministerMassFailure(Result);
411 end;
412
413 end
414 else AdministerMassFailure(Result);
415 end;
416
417 function TRelayer.SendEnvelope: boolean;
418 { Sends the envelope (that is the return-path and the recipient addresses).
419 The function returns true, if the MAIL command were successful, and the
420 relay server has accepted at least one of the recipient addresses.
421 This function is aware of the SMTP extension, named PIPELINING. If it's
422 supported by the server, we send RCPT commands stuffed, without waiting
423 for a response. After all RCPTs are sent, we check all responses. }
424 var
425 i, c: integer; Prms: string;
426
427 procedure ProcessRCPTResponse;
428 begin
429 TCP.ReadResponse(Response);
430 if Response.GetNumericCode = SMTP_R_OK then Inc(c);
431 Envelope.SetRecipientData(i, Response.GetNumericCode, Response.ReplyText.Text);
432 end;
433
434 begin
435 Response.Clear;
436 Prms:= 'FROM:<' + Envelope.ReturnPath + '>';
437
438 if SMTPExtensions.Size then
439 Prms:= Prms + ' SIZE=' + IntToStr(EMailProperties.Size);
440 if SMTPExtensions.EbitMIME and EMailProperties.HasFlag(EF_8BITMIME) then
441 Prms:= Prms + ' BODY=8BITMIME';
442
443 TCP.SendCommand(SMTP_C_MAIL, Prms);
444 TCP.ReadResponse(Response);
445 if Response.GetNumericCode = SMTP_R_OK then begin
446 c:= 0;
447 for i:= 0 to Envelope.GetNumberOfRecipients - 1 do begin
448 TCP.SendCommand(SMTP_C_RCPT, 'TO:<' + Envelope.GetRecipient(i).Address + '>');
449 { If pipelining is not supported, read the responses now. }
450 if not SMTPExtensions.Pipelining then ProcessRCPTResponse;
451 end;
452
453 { If pipelining is supported, process all responses. }
454 if SMTPExtensions.Pipelining then
455 for i:= 0 to Envelope.GetNumberOfRecipients - 1 do
456 ProcessRCPTResponse;
457
458 Result:= c <> 0;
459 if not Result then begin
460 TCP.SendCommand(SMTP_C_RSET);
461 TCP.ReadResponse(Response);
462 end;
463 end
464 else AdministerMassFailure(Result);
465 end;
466
467 function TRelayer.PrepareSendMessage;
468 { Prepares mail transmission with the DATA command. }
469 begin
470 TCP.SendCommand(SMTP_C_DATA);
471 TCP.ReadResponse(Response);
472 Result:= Response.GetNumericCode = SMTP_R_START_MAIL_INPUT;
473 end;
474
475 function TRelayer.DeliverMessagePart(Chunk: TStrings): boolean;
476 { Sends a chunk of the message. }
477 begin
478 Result:= TCP.WriteBuffer(PChar(Chunk.Text), Length(Chunk.Text)) <> -1;
479 end;
480
481 procedure TRelayer.FinishDeliverMessage;
482 { Finishes the message with a line containing a single dot. }
483 var i: integer;
484 begin
485 TCP.WriteLn('.');
486 TCP.ReadResponse(Response);
487 for i:= 0 to Envelope.GetNumberOfRecipients - 1 do begin
488 if Envelope.GetRecipient(i).Data = SMTP_R_OK then
489 Envelope.SetRecipientData(i, Response.GetNumericCode, Response.ReplyText.Text);
490 end;
491 end;
492
493 procedure TRelayer.CloseConnection;
494 begin
495 TCP.SendCommand(SMTP_C_QUIT);
496 {TCP.ReadResponse(Response);}
497 TCP.Free;
498 end;
499
500
501 function TRelayManager.CreateRelayer(Envelope: TEnvelope; EMailProperties: TEMailProperties): TRelayer;
502 begin
503 Result:= TRelayer.Create(RoutingTable, Envelope, EMailProperties);
504 end;
505
506 function TRelayManager.IsOnRelayToList(HostName: string): boolean;
507 begin
508 Result:= RelayToList.IndexOf(HostName) <> -1;
509 end;
510
511 function TRelayManager.IsOnNoRelayToList(HostName: string): boolean;
512 begin
513 Result:= NoRelayToList.IndexOf(HostName) <> -1;
514 end;
515
516 function TRelayManager.OrganizeEnvelopes(Envelopes: TEnvelopeArray): TEnvelopeArray;
517 { Organizes the given envelopes for relaying.
518 This function assumes that input envelopes are containing recipient
519 addresses orientating to the same site.
520 If it turns out that e-mails for multiple sites must be actually relayed
521 through the same relay server, this function merges the envelopes for
522 those sites; so later, such e-mails will be transmitted though a single
523 connection.
524
525 For example, the configuration file indicates:
526 - E-mails for "foo.com" must be relayed through "myrelaysmtp".
527 - E-mails for "bar.com" must be also relayed through "myrelaysmtp".
528 In this case, the envelopes for "foo.com" and "bar.com" will be merged,
529 and the e-mail for these sites will be transmitted in one TCP connection. }
530
531 var i, j, k: integer; f: boolean; Recipient: TRecipient; OrgHost, TrgHost: string;
532 begin
533 SetLength(Result, 0);
534 for i:= 0 to Length(Envelopes) - 1 do begin
535 if Envelopes[i].GetNumberOfRecipients > 0 then begin
536 Recipient:= Envelopes[i].GetRecipient(0);
537 OrgHost:= EMailHost(Recipient.Address);
538 TrgHost:= RoutingTable.ReRoute(OrgHost);
539 if TrgHost = '!' then TrgHost:= OrgHost;
540 j:= 0; f:= false;
541 while (j < Length(Result)) and (not f) do begin
542 f:= Result[j].RelayHost = TrgHost;
543 Inc(j);
544 end;
545 { Note, if (not f) then j holds Length(Result). }
546 if not f then begin
547 SetLength(Result, j + 1);
548 Result[j]:= TEnvelope.Create;
549 Result[j].ReturnPath:= Envelopes[i].ReturnPath;
550 Result[j].RelayHost:= TrgHost;
551 end
552 else Dec(j); { j must be decremented, because we over-incremented it in the loop. }
553 with Result[j] do begin
554 { Add first recipient to the envelope. }
555 AddRecipient(Recipient);
556 { Add the remaining recipients. }
557 for k:= 1 to Envelopes[i].GetNumberOfRecipients - 1 do
558 AddRecipient(Envelopes[i].GetRecipient(k));
559 end;
560 end;
561 end;
562 end;
563
564
565 end.