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.