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 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;
 387       end;
 388
 389       if Result then begin
 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;
 410                end
 411                else Authenticated:= false;
 412             end
 413             else Authenticated:= false;
 414          end
 415          else Authenticated:= true;
 416
 417          if not Authenticated then AdministerMassFailure(Result);
 418       end
 419       else AdministerMassFailure(Result);
 420
 421    end
 422    else AdministerMassFailure(Result);
 423 end;
 424
 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. }
 432 var
 433    i, c: integer; Prms: string;
 434
 435    procedure ProcessRCPTResponse;
 436    begin
 437       TCP.ReadResponse(Response);
 438       if Response.GetNumericCode = SMTP_R_OK then Inc(c);
 439       Envelope.SetRecipientData(i, Response.GetNumericCode, Response.ReplyText.Text);
 440    end;
 441
 442 begin
 443    Response.Clear;
 444    Prms:= 'FROM:<' + Envelope.ReturnPath + '>';
 445
 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';
 450
 451    TCP.SendCommand(SMTP_C_MAIL, Prms);
 452    TCP.ReadResponse(Response);
 453    if Response.GetNumericCode = SMTP_R_OK then begin
 454       c:= 0;
 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;
 459       end;
 460
 461       { If pipelining is supported, process all responses. }
 462       if SMTPExtensions.Pipelining then
 463          for i:= 0 to Envelope.GetNumberOfRecipients - 1 do
 464             ProcessRCPTResponse;
 465
 466       Result:= c <> 0;
 467       if not Result then begin
 468          TCP.SendCommand(SMTP_C_RSET);
 469          TCP.ReadResponse(Response);
 470       end;
 471    end
 472    else AdministerMassFailure(Result);
 473 end;
 474
 475 function TRelayer.PrepareSendMessage;
 476 { Prepares mail transmission with the DATA command. }
 477 begin
 478    TCP.SendCommand(SMTP_C_DATA);
 479    TCP.ReadResponse(Response);
 480    Result:= Response.GetNumericCode = SMTP_R_START_MAIL_INPUT;
 481 end;
 482
 483 function TRelayer.DeliverMessagePart(Chunk: TStrings): boolean;
 484 { Sends a chunk of the message. }
 485 var i: integer;
 486 begin
 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];
 491
 492    { Send text. }
 493    Result:= TCP.WriteBuffer(PChar(Chunk.Text), Length(Chunk.Text)) <> -1;
 494 end;
 495
 496 procedure TRelayer.FinishDeliverMessage;
 497 { Finishes the message with a line containing a single dot. }
 498 var i: integer;
 499 begin
 500    TCP.WriteLn('.');
 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);
 505    end;
 506 end;
 507
 508 procedure TRelayer.CloseConnection;
 509 begin
 510    TCP.SendCommand(SMTP_C_QUIT);
 511    {TCP.ReadResponse(Response);}
 512    TCP.Free;
 513 end;
 514
 515
 516 function TRelayManager.CreateRelayer(Envelope: TEnvelope; EMailProperties: TEMailProperties): TRelayer;
 517 begin
 518    Result:= TRelayer.Create(RoutingTable, Envelope, EMailProperties);
 519 end;
 520
 521 function TRelayManager.IsOnRelayToList(HostName: string): boolean;
 522 begin
 523    Result:= RelayToList.IndexOf(HostName) <> -1;
 524 end;
 525
 526 function TRelayManager.IsOnNoRelayToList(HostName: string): boolean;
 527 begin
 528    Result:= NoRelayToList.IndexOf(HostName) <> -1;
 529 end;
 530
 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
 538   connection.
 539
 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. }
 545
 546 var i, j, k: integer; f: boolean; Recipient: TRecipient; OrgHost, TrgHost: string;
 547 begin
 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;
 555          j:= 0; f:= false;
 556          while (j < Length(Result)) and (not f) do begin
 557             f:= Result[j].RelayHost = TrgHost;
 558             Inc(j);
 559          end;
 560          { Note, if (not f) then j holds Length(Result). }
 561          if not f then begin
 562             SetLength(Result, j + 1);
 563             Result[j]:= TEnvelope.Create;
 564             Result[j].ReturnPath:= Envelopes[i].ReturnPath;
 565             Result[j].RelayHost:= TrgHost;
 566          end
 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));
 574          end;
 575       end;
 576    end;
 577 end;
 578
 579
 580 end.