Spool.pas

   1 {
   2    MegaBrutal's SMTP Server (MgSMTP)
   3    Copyright (C) 2010-2014 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: Spool
  21    The Spool unit is the soul of MgSMTP. It implements objects to create
  22    and read "spool objects" (e-mails being queued by the mail server),
  23    and delivery threads (the threads those actually delivers a queued
  24    message to a local mailbox or a remote server.
  25 }
  26
  27
  28 {$MODE DELPHI}
  29 unit Spool;
  30
  31 interface
  32 uses SysUtils, Classes, INIFiles, Common, Log, Relay, Bounce;
  33
  34 type
  35
  36    TSpoolFilters = array of string;
  37
  38    TSpoolConfig = record
  39       AllowExceedQuota: boolean;
  40       MaxReceivedHeaders: integer;
  41       ThreadWait: integer;
  42       TryCount, TryDelay: integer;
  43       TempFailNotifyFirst: boolean;
  44       TempFailNotify: integer;
  45       KeepProcessedEnvelopes: boolean;
  46       KeepProcessedEMails: boolean;
  47    end;
  48
  49
  50    PSpoolObject = ^TSpoolObject;
  51    TSpoolObject = class
  52       constructor Create(const Name: string; const SpoolConfig: TSpoolConfig);
  53       destructor Destroy; override;
  54    protected
  55       FName: string;
  56       FOpened: boolean;
  57       FEnvelope: TEnvelope;
  58       FOriginator: TIPNamePair;
  59       FEMailProperties: TEMailProperties;
  60       SpoolConfig: TSpoolConfig;
  61       SpoolData: TINIFile;
  62       MailFile: TStream;
  63       StringBuffer: TStrings;
  64    public
  65       property Name: string read FName;
  66       property Envelope: TEnvelope read FEnvelope;
  67       property EMailProperties: TEMailProperties read FEMailProperties;
  68       property Originator: TIPNamePair read FOriginator;
  69       property Opened: boolean read FOpened;
  70       function Open: boolean; virtual; abstract;
  71       procedure Close; virtual;
  72       procedure Discard; virtual; abstract;
  73       function IsActual(DelaySeconds: TUnixTimeStamp): boolean; virtual;
  74       function IsExpired(MaxTryCount: integer; BeforeIncrement: boolean): boolean; virtual;
  75       function GetAccessTime: TUnixTimeStamp; virtual;
  76       function GetCurrentTryCount: integer; virtual;
  77       procedure IncrementTryCount; virtual;
  78       procedure SetAccessTime(TimeStamp: TUnixTimeStamp); virtual;
  79       procedure SetThreadInfo(ThreadNum: integer; ThreadOSID: TThreadID); virtual;
  80       procedure Actualize; virtual;
  81       function GetMessageSize: longint; virtual;
  82    end;
  83
  84    TSpoolObjectCreator = class(TSpoolObject)
  85       constructor Create(const SpoolConfig: TSpoolConfig; Databytes: longint; LineBuffer: integer; Originator: TIPNamePair);
  86       destructor Destroy; override;
  87    protected
  88       FDatabytes: longint;
  89       FDatabytesCounter: longint;
  90       FLineBuffer: integer;
  91       FOriginalMessageID: string;
  92       ReceivedCount: integer;
  93       ReceivingHeaders: boolean;
  94       HasDate, HasMessageID: boolean;
  95       WriteFail: boolean;
  96       procedure AddNewHeaders;
  97       procedure TransferEnvelope;
  98    public
  99       procedure SetDatabytes(DatabytesLimit: longint);
 100       function GetOriginalMessageID: string;
 101       function DeliverMessagePart(Line: string): boolean;
 102       function GetErrorCode: integer;
 103       function Open: boolean; override;
 104       procedure Close; override;
 105       procedure Discard; override;
 106       property Databytes: longint read FDatabytes write SetDatabytes;
 107       property OriginalMessageID: string read GetOriginalMessageID;
 108    end;
 109
 110    TSpoolObjectReader = class(TSpoolObject)
 111       constructor Create(const Name: string; const SpoolConfig: TSpoolConfig);
 112    protected
 113       {LockFile: THandle;}
 114    public
 115       function GetHeaders: TStrings;
 116       function IsEOF: boolean;
 117       function MakeEnvelopes(Relay: boolean): TEnvelopeArray;
 118       procedure QuickSetDeliveryStatus(IsLocal: boolean; Recipient: string; Status: integer; RMsg: string);
 119       procedure SetDeliveryStatus(IsLocal: boolean; Envelope: TEnvelope; AddStatus: integer = 0);
 120       procedure ReadChunk(Strings: TStrings; Lines: integer);
 121       function Open: boolean; override;
 122       procedure Close; override;
 123       procedure Discard; override;
 124    end;
 125
 126
 127    TDeliveryThread = class(TThread)
 128       constructor Create(CreateSuspended: boolean; ThreadNum: integer; const SpoolConfig: TSpoolConfig; const SpoolFilters: TSpoolFilters);
 129       destructor Destroy; override;
 130    protected
 131       FFinished: boolean;
 132       FThreadNum: integer;
 133       SpoolConfig: TSpoolConfig;
 134       SpoolFilters: TSpoolFilters;
 135       function DeliverLocalMessage(SpoolObject: TSpoolObjectReader; MailboxPtr: pointer; ReturnPath, Recipient: string): integer;
 136       procedure DeliverRelayMessage(SpoolObject: TSpoolObjectReader; Relayer: TRelayer);
 137       procedure HandleFailure(SpoolObject: TSpoolObjectReader; IsLocal: boolean; FailEnvelope: TEnvelope; FailedRecipient: TRecipient; AddStatus: integer; FailMsg: string);
 138       procedure HandleDeliveryResults(SpoolObject: TSpoolObjectReader; IsLocal: boolean; Envelope, FailEnvelope: TEnvelope; AddStatus: integer; FailMsg: string);
 139       procedure CreateBounceMessage(SourceSpoolObject: TSpoolObjectReader; FailEnvelope: TEnvelope);
 140       function NeedSendReport(SpoolObject: TSpoolObject): boolean;
 141       procedure Execute; override;
 142    public
 143       procedure CallExecute;
 144       property Finished: boolean read FFinished;
 145       property ThreadNum: integer read FThreadNum;
 146    end;
 147
 148
 149    TSpoolManager = class
 150       constructor Create(Config: TINIFile);
 151    protected
 152       FDatabytes: longint;
 153       FLineBuffer: integer;
 154       SpoolConfig: TSpoolConfig;
 155       DeliveryThreads: array of TDeliveryThread;
 156    public
 157       function GetNumberOfDeliveryThreads: integer;
 158       function CreateSpoolObject(Originator: TIPNamePair): TSpoolObjectCreator;
 159       procedure DebugDeliveryThread;
 160       procedure StartDeliveryThreads;
 161       procedure StopDeliveryThreads;
 162       property Databytes: longint read FDatabytes;
 163       property AllowExceedQuota: boolean read SpoolConfig.AllowExceedQuota;
 164       property ThreadWait: integer read SpoolConfig.ThreadWait;
 165       property DeliveryThreadNumber: integer read GetNumberOfDeliveryThreads;
 166    end;
 167
 168
 169 const
 170
 171    { SpoolObjectCreator errors: }
 172    SCE_NO_ERROR         =  0;
 173    SCE_SIZE_EXCEEDED    =  1;
 174    SCE_LOOP_DETECTED    =  2;
 175    SCE_WRITE_FAIL       =  3;
 176
 177
 178 var
 179
 180    SpoolManager: TSpoolManager;
 181
 182
 183 implementation
 184 uses Mailbox;
 185
 186 const
 187
 188    { Search attributes: }
 189    SEARCH_ATTR = faAnyFile - faDirectory - faVolumeID - faHidden;
 190
 191
 192 constructor TSpoolObject.Create(const Name: string; const SpoolConfig: TSpoolConfig);
 193 begin
 194    inherited Create;
 195    FName:= Name;
 196    FOpened:= false;
 197    FEnvelope:= TEnvelope.Create;
 198    FEMailProperties:= TEMailProperties.Create;
 199    Self.SpoolConfig:= SpoolConfig;
 200 end;
 201
 202 destructor TSpoolObject.Destroy;
 203 begin
 204    FEMailProperties.Free;
 205    FEnvelope.Free;
 206    inherited Destroy;
 207 end;
 208
 209 constructor TSpoolObjectCreator.Create(const SpoolConfig: TSpoolConfig; Databytes: longint; LineBuffer: integer; Originator: TIPNamePair);
 210 begin
 211    inherited Create(GenerateRandomString(16), SpoolConfig);
 212    FDatabytes:= Databytes;
 213    FLineBuffer:= LineBuffer;
 214    FOriginator:= Originator;
 215    WriteFail:= false;
 216 end;
 217
 218 destructor TSpoolObjectCreator.Destroy;
 219 begin
 220    FOriginator.Free;
 221    inherited Destroy;
 222 end;
 223
 224 constructor TSpoolObjectReader.Create(const Name: string; const SpoolConfig: TSpoolConfig);
 225 begin
 226    inherited Create(Name, SpoolConfig);
 227 end;
 228
 229 constructor TDeliveryThread.Create(CreateSuspended: boolean; ThreadNum: integer; const SpoolConfig: TSpoolConfig; const SpoolFilters: TSpoolFilters);
 230 begin
 231    FreeOnTerminate:= false;
 232    FFinished:= false;
 233    FThreadNum:= ThreadNum;
 234    Self.SpoolConfig:= SpoolConfig;
 235    Self.SpoolFilters:= SpoolFilters;
 236    inherited Create(CreateSuspended);
 237 end;
 238
 239 destructor TDeliveryThread.Destroy;
 240 begin
 241    SetLength(SpoolFilters, 0);
 242    inherited Destroy;
 243 end;
 244
 245 constructor TSpoolManager.Create(Config: TINIFile);
 246 begin
 247    inherited Create;
 248    FDatabytes:=         Config.ReadInteger('Spool', 'Databytes', MainServerConfig.Databytes);
 249    FLineBuffer:=        Config.ReadInteger('Spool', 'LineBuffer', 64);
 250    SetLength(DeliveryThreads, Config.ReadInteger('Spool', 'DeliveryThreads', 8));
 251    SpoolConfig.AllowExceedQuota:=         Config.ReadBool('Spool', 'AllowExceedQuota', false);
 252    SpoolConfig.MaxReceivedHeaders:=       Config.ReadInteger('Spool', 'MaxReceivedHeaders', 32);
 253    SpoolConfig.ThreadWait:=               Config.ReadInteger('Spool', 'ThreadWait', 250);
 254    SpoolConfig.TryCount:=                 Config.ReadInteger('Spool', 'TryCount', 0);
 255    SpoolConfig.TryDelay:=                 Config.ReadInteger('Spool', 'TryDelay', 2);
 256    SpoolConfig.TempFailNotifyFirst:=      Config.ReadBool('Spool', 'TempFailNotifyFirst', false);
 257    SpoolConfig.TempFailNotify:=           Config.ReadInteger('Spool', 'TempFailNotify', 720);
 258    SpoolConfig.KeepProcessedEnvelopes:=   Config.ReadBool('Spool', 'KeepProcessedEnvelopes', false);
 259    SpoolConfig.KeepProcessedEMails:=      Config.ReadBool('Spool', 'KeepProcessedEMails', false);
 260 end;
 261
 262
 263 procedure TSpoolObject.Close;
 264 begin
 265    MailFile.Free;
 266    SpoolData.Free;
 267    FOpened:= false;
 268 end;
 269
 270 function TSpoolObject.IsActual(DelaySeconds: TUnixTimeStamp): boolean;
 271 begin
 272    Result:= UnixTimeStamp(Now) >= (GetAccessTime + DelaySeconds);
 273 end;
 274
 275 function TSpoolObject.IsExpired(MaxTryCount: integer; BeforeIncrement: boolean): boolean;
 276 begin
 277    if MaxTryCount > 0 then begin
 278       if BeforeIncrement then Dec(MaxTryCount);
 279       Result:= GetCurrentTryCount >= MaxTryCount;
 280    end
 281    else
 282       Result:= false;
 283 end;
 284
 285 function TSpoolObject.GetAccessTime: TUnixTimeStamp;
 286 begin
 287    Result:= SpoolData.ReadInteger('SpoolObject', 'AccessTime', 0);
 288 end;
 289
 290 function TSpoolObject.GetCurrentTryCount: integer;
 291 begin
 292    Result:= SpoolData.ReadInteger('SpoolObject', 'TryCount', 0);
 293 end;
 294
 295 procedure TSpoolObject.IncrementTryCount;
 296 begin
 297    SpoolData.WriteInteger('SpoolObject', 'TryCount', GetCurrentTryCount + 1);
 298 end;
 299
 300 procedure TSpoolObject.SetAccessTime(TimeStamp: TUnixTimeStamp);
 301 begin
 302    SpoolData.WriteInteger('SpoolObject', 'AccessTime', TimeStamp);
 303 end;
 304
 305 procedure TSpoolObject.SetThreadInfo(ThreadNum: integer; ThreadOSID: TThreadID);
 306 begin
 307    SpoolData.WriteString('SpoolObject', 'ThreadInfo', IntToStr(ThreadNum) + ',' + IntToStr(ThreadOSID));
 308 end;
 309
 310 procedure TSpoolObject.Actualize;
 311 begin
 312    IncrementTryCount;
 313    SetAccessTime(UnixTimeStamp(Now));
 314 end;
 315
 316 function TSpoolObject.GetMessageSize: longint;
 317 var SearchRec: TSearchRec;
 318 begin
 319    if FindFirst('spool\' + FName + '.eml', SEARCH_ATTR, SearchRec) = 0 then
 320       Result:= SearchRec.Size
 321    else
 322       Result:= 0;
 323    FindClose(SearchRec);
 324 end;
 325
 326
 327 procedure TSpoolObjectCreator.AddNewHeaders;
 328 begin
 329    { Add a date, if not present. }
 330    if not HasDate then StringBuffer.Insert(0, 'Date: ' + EMailTimeStampCorrected(Now));
 331
 332    { Add Message-Id, if not present. }
 333    if not HasMessageID then StringBuffer.Insert(0,
 334       'Message-Id: <' + OriginalMessageID + '>');
 335
 336    { Add Received by... }
 337    StringBuffer.Insert(0, 'Received: from ' + Originator.Name
 338       + ' ([' + Originator.IP + ']) ');
 339    StringBuffer.Insert(1, #9'by ' + MainServerConfig.Name + ' with SMTP (MgSMTP '
 340       + MainServerConfig.VersionStr + ')');
 341    StringBuffer.Insert(2, #9'id ' + Name + '; ' + EMailTimeStampCorrected(Now));
 342
 343    { Flush it to the file. }
 344    try
 345       StringBuffer.SaveToStream(MailFile);
 346       StringBuffer.Clear;
 347    except
 348    end;
 349    ReceivingHeaders:= false;
 350 end;
 351
 352 procedure TSpoolObjectCreator.TransferEnvelope;
 353 { Write the actual envelope structure to the data file of the spool object.
 354   (That's actually an INI file.) }
 355 var i: integer; Recipient: TRecipient; Pref: string;
 356 begin
 357    with SpoolData do begin
 358       WriteString('SpoolObject', 'ID', Name);
 359       WriteString('SpoolObject', 'Return-Path', Envelope.ReturnPath);
 360       WriteString('Originator', 'Name', Originator.Name);
 361       WriteString('Originator', 'IP', Originator.IP);
 362       for i:= 0 to Envelope.GetNumberOfRecipients - 1 do begin
 363          Recipient:= Envelope.GetRecipient(i);
 364          if MailboxManager.IsLocalAddress(Recipient.Address) then Pref:= 'Local\' else Pref:= 'Relay\';
 365          WriteInteger(Pref + EMailHost(Recipient.Address), EMailUserName(Recipient.Address),
 366             Recipient.Data);
 367       end;
 368    end;
 369 end;
 370
 371 procedure TSpoolObjectCreator.SetDatabytes(DatabytesLimit: longint);
 372 begin
 373    FDatabytes:= DatabytesLimit;
 374 end;
 375
 376 function TSpoolObjectCreator.GetOriginalMessageID: string;
 377 begin
 378    if HasMessageID then
 379       Result:= FOriginalMessageID
 380    else
 381       Result:= Name + '@' + MainServerConfig.Name;
 382 end;
 383
 384 function TSpoolObjectCreator.GetErrorCode: integer;
 385 begin
 386    if WriteFail then
 387       Result:= SCE_WRITE_FAIL
 388    else if (FDatabytesCounter > FDatabytes) and (FDatabytes <> 0) then
 389       Result:= SCE_SIZE_EXCEEDED
 390    else if ReceivedCount >= SpoolConfig.MaxReceivedHeaders then
 391       Result:= SCE_LOOP_DETECTED
 392    else
 393       Result:= SCE_NO_ERROR;
 394 end;
 395
 396 function TSpoolObjectCreator.DeliverMessagePart(Line: string): boolean;
 397 var Header, Value: string;
 398 begin
 399    if Opened and (not WriteFail) then begin
 400
 401       { If we haven't received all the headers of the e-mail, keep checking
 402         the incoming headers - we need to check for the existence of some
 403         headers, and add missing headers after all headers have arrived. }
 404       if ReceivingHeaders then begin
 405          if Length(Line) = 0 then begin
 406             { End of headers. }
 407             AddNewHeaders;
 408          end
 409          else if pos('MESSAGE-ID:', UpperCase(Line)) = 1 then begin
 410             HasMessageID:= true;
 411             SplitParameters(Line, Header, Value, ':');
 412             FOriginalMessageID:= CleanEMailAddress(Value);
 413          end
 414          else if pos('DATE:', UpperCase(Line)) = 1 then HasDate:= true
 415          else if pos('RECEIVED:', UpperCase(Line)) = 1 then Inc(ReceivedCount);
 416       end;
 417
 418       { In any way, write the received line to the buffer, unless the databytes
 419         limit has been reached. }
 420       if (FDatabytesCounter <= FDatabytes) or (FDatabytes = 0) then begin
 421          StringBuffer.Add(Line);
 422          FDatabytesCounter:= FDatabytesCounter + Length(Line) + 2;
 423          { Don't flush the buffer, until all the headers received. }
 424          if not ReceivingHeaders and (StringBuffer.Count >= FLineBuffer) then begin
 425             try
 426                StringBuffer.SaveToStream(MailFile);
 427                StringBuffer.Clear;
 428                Result:= true;
 429             except
 430                Result:= false;
 431                WriteFail:= true;
 432             end;
 433          end
 434          else Result:= true;
 435       end
 436       else Result:= false;
 437    end
 438    else Result:= false;
 439 end;
 440
 441 function TSpoolObjectCreator.Open: boolean;
 442 begin
 443    try
 444       MailFile:= TFileStream.Create('spool\' + Name + '.eml', fmCreate);
 445       SpoolData:= TINIFile.Create('spool\' + Name + '.tmp');
 446       FOpened:= true;
 447       StringBuffer:= TStringList.Create;
 448       ReceivedCount:= 0;
 449       ReceivingHeaders:= true;
 450       HasDate:= false; HasMessageID:= false;
 451       FDatabytesCounter:= 0;
 452       TransferEnvelope;
 453       Result:= true;
 454    except
 455       MailFile.Free;
 456       SpoolData.Free;
 457       Result:= false;
 458    end;
 459 end;
 460
 461 procedure TSpoolObjectCreator.Close;
 462 begin
 463    SpoolData.WriteInteger('SpoolObject', 'Flags', EMailProperties.Flags);
 464    SpoolData.WriteInteger('SpoolObject', 'TryCount', 0);
 465    if ReceivingHeaders then AddNewHeaders;
 466    StringBuffer.SaveToStream(MailFile);
 467    inherited Close;
 468    StringBuffer.Free;
 469    RenameFile('spool\' + Name + '.tmp', 'spool\' + Name + '.dat');
 470 end;
 471
 472 procedure TSpoolObjectCreator.Discard;
 473 begin
 474    MailFile.Free;
 475    SpoolData.Free;
 476    DeleteFile('spool\' + FName + '.tmp');
 477    DeleteFile('spool\' + FName + '.eml');
 478    StringBuffer.Free;
 479    FOpened:= false;
 480 end;
 481
 482
 483 function TSpoolObjectReader.Open: boolean;
 484 begin
 485    {LockFile:= FileCreate('spool\' + FName + '.lck', fmShareExclusive);
 486    if LockFile <> feInvalidHandle then begin}
 487    try
 488       MailFile:= TFileStream.Create('spool\' + Name + '.eml', fmOpenRead);
 489       { !!! TODO: Someday it would be nice to add a working buffer... !!! }
 490       { 16 KB read buffer - maybe it should be configurable. }
 491       {MailFile:= TReadBufStream.Create(TFileStream.Create('spool\' + Name + '.eml', fmOpenRead), 16 * 1024);}
 492       {(MailFile as TReadBufStream).SourceOwner:= true;}
 493       SpoolData:= TINIFile.Create('spool\' + Name + '.dat');
 494       Envelope.ReturnPath:= SpoolData.ReadString('SpoolObject', 'Return-Path', '');
 495       FOriginator:= TIPNamePair.Create(SpoolData.ReadString('Originator', 'Name', ''),
 496          SpoolData.ReadString('Originator', 'IP', ''));
 497       FEMailProperties.Size:= GetMessageSize;
 498       FEMailProperties.Flags:= SpoolData.ReadInteger('SpoolObject', 'Flags', 0);
 499       FOpened:= true;
 500       Result:= true;
 501    except
 502       MailFile.Free;
 503       SpoolData.Free;
 504       {FileClose(LockFile);}
 505       Result:= false;
 506    end;
 507 end;
 508
 509 procedure TSpoolObjectReader.Close;
 510 begin
 511    inherited Close;
 512    {FileClose(LockFile);}
 513    DeleteFile('spool\' + FName + '.lck');
 514    FOriginator.Free;
 515 end;
 516
 517 procedure TSpoolObjectReader.Discard;
 518 { Discard should be called when the spool object is opened, and instead
 519   of Close! }
 520 begin
 521    MailFile.Free;
 522    SpoolData.Free;
 523    if SpoolConfig.KeepProcessedEnvelopes then
 524       RenameFile('spool\' + FName + '.dat', 'processed\' + FName + '.dat');
 525    if SpoolConfig.KeepProcessedEMails then
 526       RenameFile('spool\' + FName + '.eml', 'processed\' + FName + '.eml');
 527    DeleteFile('spool\' + FName + '.dat');
 528    DeleteFile('spool\' + FName + '.eml');
 529    {FileClose(LockFile);}
 530    DeleteFile('spool\' + FName + '.lck');
 531    FOriginator.Free;
 532 end;
 533
 534 function TSpoolObjectReader.GetHeaders: TStrings;
 535 var Strings: TStrings; S: string; EH: boolean;
 536 begin
 537    Strings:= TStringList.Create;
 538    MailFile.Seek(0, soFromBeginning);
 539    {repeat
 540       S:= ReadLineFromStream(MailFile);
 541       if S <> '' then Strings.Add(S);
 542    until (S = '') or (IsEOF);}
 543    EH:= false;
 544    while (not IsEOF) and (not EH) do begin
 545       S:= ReadLineFromStream(MailFile);
 546       if S <> '' then Strings.Add(S) else EH:= true;
 547    end;
 548    Result:= Strings;
 549 end;
 550
 551 function TSpoolObjectReader.IsEOF: boolean;
 552 begin
 553    Result:= (not Opened) or (MailFile.Position >= MailFile.Size);
 554 end;
 555
 556 procedure TSpoolObjectReader.ReadChunk(Strings: TStrings; Lines: integer);
 557 var S: string; C: integer;
 558 begin
 559    C:= 0;
 560    while (not IsEOF) and (C < Lines) do begin
 561       S:= ReadLineFromStream(MailFile);
 562       Strings.Add(S);
 563       Inc(C);
 564    end;
 565 end;
 566
 567 function TSpoolObjectReader.MakeEnvelopes(Relay: boolean): TEnvelopeArray;
 568 var HostList, Usernames: TStringList; i, j, f: integer; Pref, Host: string;
 569     Env: TEnvelope;
 570 begin
 571    if Opened then begin
 572       HostList:= TStringList.Create;
 573       SpoolData.ReadSections(HostList);
 574       i:= 0;
 575       while (i < HostList.Count) do begin
 576          if Relay then Pref:= 'Relay\' else Pref:= 'Local\';
 577          if pos(Pref, HostList.Strings[i]) <> 1 then
 578             HostList.Delete(i)
 579          else
 580             Inc(i);
 581       end;
 582       SetLength(Result, HostList.Count);
 583       Usernames:= TStringList.Create;
 584       f:= 0;
 585       for i:= 0 to HostList.Count - 1 do begin
 586          Usernames.Clear;
 587          Host:= Copy(HostList.Strings[i], 7, Length(HostList.Strings[i]) - 6);
 588          SpoolData.ReadSection(HostList.Strings[i], Usernames);
 589          if Usernames.Count > 0 then begin
 590             Env:= TEnvelope.Create;
 591             Env.SetReturnPath(SpoolData.ReadString('SpoolObject', 'Return-Path', ''));
 592             for j:= 0 to Usernames.Count - 1 do
 593                Env.AddRecipient(Usernames.Strings[j] + '@' + Host,
 594                   { It turned out we don't really need the status of the previous
 595                     attempt of delivery. It only caused confusion. }
 596                   {SpoolData.ReadInteger(HostList.Strings[i], Usernames.Strings[j], 0)}
 597                   0);
 598             Result[i-f]:= Env;
 599          end
 600          else begin
 601             { This is a faulty envelope which has no recipients, yet its INI section exists.
 602               Ignore it and go on. }
 603             SpoolData.EraseSection(HostList.Strings[i]);
 604             SetLength(Result, Length(Result) - 1);
 605             Inc(f);
 606          end;
 607       end;
 608       Usernames.Free;
 609       HostList.Free;
 610    end
 611    else SetLength(Result, 0);
 612 end;
 613
 614 procedure TSpoolObjectReader.QuickSetDeliveryStatus(IsLocal: boolean; Recipient: string; Status: integer; RMsg: string);
 615 { "Quick" because it bypasses the TEnvelope structures cached in memory, so
 616   it writes the data immediately into the spool data file. }
 617 var Pref, StatStr: string;
 618 begin
 619    if IsLocal then Pref:= 'Local\' else Pref:= 'Relay\';
 620    if (Status and (DS_DELIVERED or DS_PERMANENT)) <> 0 then begin
 621       SpoolData.DeleteKey(Pref + EMailHost(Recipient), EMailUserName(Recipient));
 622       if (Status and DS_DELIVERED) <> 0 then
 623          StatStr:= 'Delivered'
 624       else
 625          StatStr:= 'Failed';
 626       Pref:= StatStr + Pref;
 627       Logger.AddLine('Object ' + Name, 'Permanent status has been set on recipient <' + Recipient + '>: '
 628          + Pref + StatusToStr(Status) + ' (' + CleanEOLN(RMsg) + ')');
 629    end;
 630    SpoolData.WriteInteger(Pref + EMailHost(Recipient), EMailUserName(Recipient), Status);
 631 end;
 632
 633 procedure TSpoolObjectReader.SetDeliveryStatus(IsLocal: boolean; Envelope: TEnvelope; AddStatus: integer = 0);
 634 { It writes all data of an envelope to the spool data file. }
 635 var i: integer; Recipient: TRecipient;
 636 begin
 637    for i:= 0 to Envelope.GetNumberOfRecipients - 1 do begin
 638       Recipient:= Envelope.GetRecipient(i);
 639       QuickSetDeliveryStatus(IsLocal, Recipient.Address, Recipient.Data or AddStatus, Recipient.RMsg);
 640    end;
 641 end;
 642
 643
 644 function TDeliveryThread.DeliverLocalMessage(SpoolObject: TSpoolObjectReader; MailboxPtr: pointer; ReturnPath, Recipient: string): integer;
 645 var LockID: integer; Headers, Chunk: TStrings; R: boolean;
 646     { This absolute declaration is necessary to avoid circular unit depedency
 647       between Spool and Mailbox, ever since Mailbox creates spool objects
 648       to implement forwarding/remailing. }
 649     Mailbox: PMailbox absolute MailboxPtr;
 650 begin
 651    { !!! TODO: Change return values to named constants !!! }
 652    LockID:= Mailbox^.Lock;
 653    if LockID <> 0 then begin
 654       Headers:= SpoolObject.GetHeaders;
 655       if Mailbox^.BeginDeliverMessage(LockID, ReturnPath, Recipient, SpoolObject.Name, SpoolObject.EMailProperties, Headers) then begin
 656          Chunk:= TStringList.Create;
 657          R:= true;
 658          while (not SpoolObject.IsEOF) and R do begin
 659             { Maybe constant "32" should be configurable? }
 660             Chunk.Clear;
 661             SpoolObject.ReadChunk(Chunk, 32);
 662             R:= Mailbox^.DeliverMessagePart(LockID, Chunk);
 663          end;
 664          if R then begin
 665             if Mailbox^.FinishDeliverMessage(LockID) then begin
 666                Result:= 0;
 667                { It's better to set in Execute. }
 668                {SpoolObject.QuickSetDeliveryStatus(Recipient, DS_DELIVERED);}
 669             end
 670             else
 671                Result:= 4;
 672          end
 673          else
 674             Result:= 3;
 675          Chunk.Free;
 676       end
 677       else Result:= 2;
 678       Headers.Free;
 679       Mailbox^.Release(LockID);
 680    end
 681    else
 682       Result:= 1;
 683 end;
 684
 685 procedure TDeliveryThread.DeliverRelayMessage(SpoolObject: TSpoolObjectReader; Relayer: TRelayer);
 686 var Headers, Chunk: TStrings; R: boolean;
 687 begin
 688    if Relayer.PrepareSendMessage then begin
 689       Headers:= SpoolObject.GetHeaders;
 690       Chunk:= TStringList.Create;
 691       { Leave a line between the headers and the body. }
 692       Headers.Add('');
 693       R:= Relayer.DeliverMessagePart(Headers);
 694       while (not SpoolObject.IsEOF) and R do begin
 695          { Maybe constant "32" should be configurable? }
 696          Chunk.Clear;
 697          SpoolObject.ReadChunk(Chunk, 32);
 698          R:= Relayer.DeliverMessagePart(Chunk);
 699       end;
 700       if R then begin
 701          Relayer.FinishDeliverMessage;
 702       end
 703       else
 704          SpoolObject.SetDeliveryStatus(false, Relayer.Envelope, DS_DELAYED or DS_CONNECTIONFAIL);
 705       Chunk.Free;
 706       Headers.Free;
 707    end;
 708 end;
 709
 710 function TDeliveryThread.NeedSendReport(SpoolObject: TSpoolObject): boolean;
 711 { Check if there is necessary to send a temporary failure notification,
 712   according to the configuration. }
 713 var CurrentTryCount: integer;
 714 begin
 715    CurrentTryCount:= SpoolObject.GetCurrentTryCount;
 716    Result:= ((CurrentTryCount = 0) and SpoolConfig.TempFailNotifyFirst)
 717       or ((CurrentTryCount <> 0) and ((CurrentTryCount mod SpoolConfig.TempFailNotify) = 0));
 718 end;
 719
 720 procedure TDeliveryThread.HandleFailure(SpoolObject: TSpoolObjectReader; IsLocal: boolean; FailEnvelope: TEnvelope; FailedRecipient: TRecipient; AddStatus: integer; FailMsg: string);
 721 { Administer failure on a single recipient. }
 722 begin
 723    if Length(FailMsg) <> 0 then FailedRecipient.RMsg:= FailMsg;
 724    FailedRecipient.Data:= FailedRecipient.Data or AddStatus;
 725    {CreateBounceMessage(SpoolObject, FailedRecipient, ReturnPath, FailMsg);}
 726    FailEnvelope.AddRecipient(FailedRecipient);
 727    SpoolObject.QuickSetDeliveryStatus(IsLocal, FailedRecipient.Address, FailedRecipient.Data, FailedRecipient.RMsg);
 728 end;
 729
 730 procedure TDeliveryThread.HandleDeliveryResults(SpoolObject: TSpoolObjectReader; IsLocal: boolean; Envelope, FailEnvelope: TEnvelope; AddStatus: integer; FailMsg: string);
 731 { Administer results on multiple recipients (passed in a TEnvelope). }
 732 var i: integer; Recipient: TRecipient; Expired: boolean;
 733 begin
 734    Expired:= SpoolObject.IsExpired(SpoolConfig.TryCount, true);
 735    for i:= 0 to Envelope.GetNumberOfRecipients - 1 do begin
 736       Recipient:= Envelope.GetRecipient(i);
 737       Recipient.Data:= Recipient.Data or AddStatus;
 738       if Expired then
 739          Recipient.Data:= (Recipient.Data or DS_PERMANENT) and (DS_ALLFLAGS xor DS_DELAYED);
 740       if (Recipient.Data and DS_DELIVERED) <> 0 then
 741          SpoolObject.QuickSetDeliveryStatus(IsLocal, Recipient.Address, Recipient.Data, Recipient.RMsg)
 742       else begin
 743          if ((Recipient.Data and DS_PERMANENT) <> 0)
 744          or (((Recipient.Data and DS_DELAYED) <> 0) and NeedSendReport(SpoolObject)) then begin
 745             { In the case of failures, HandleFailure will call QuickSetDeliveryStatus. }
 746             HandleFailure(SpoolObject, IsLocal, FailEnvelope, Recipient, 0, FailMsg);
 747          end
 748          else
 749             SpoolObject.QuickSetDeliveryStatus(IsLocal, Recipient.Address, Recipient.Data, Recipient.RMsg);
 750       end;
 751    end;
 752 end;
 753
 754 procedure TDeliveryThread.CreateBounceMessage(SourceSpoolObject: TSpoolObjectReader; FailEnvelope: TEnvelope);
 755 { Generates failure notification messages, and places them into a new spool
 756   object to queue them for delivery. }
 757 var BounceSpoolObject: TSpoolObjectCreator; Headers, BounceMessage: TStrings; i: integer;
 758     FailedRecipient: TRecipient;
 759 begin
 760    { Don't do anything, if we don't have a return-path. }
 761    if (FailEnvelope.ReturnPath <> '') and (FailEnvelope.GetNumberOfRecipients <> 0) then begin
 762       BounceSpoolObject:= TSpoolObjectCreator.Create(SpoolConfig, 1024 * 1024, 32, TIPNamePair.Create('localhost', '127.0.0.1'));
 763       BounceSpoolObject.Envelope.SetReturnPath('');
 764       BounceSpoolObject.Envelope.AddRecipient(FailEnvelope.ReturnPath);
 765       if BounceSpoolObject.Open then begin
 766          Headers:= SourceSpoolObject.GetHeaders;
 767
 768          if FailEnvelope.GetNumberOfRecipients = 1 then
 769             BounceMessage:= GenerateBounceMessage(FailEnvelope.GetRecipient(0), Headers, FailEnvelope.ReturnPath)
 770          else
 771             BounceMessage:= GenerateBounceMessage(FailEnvelope, Headers);
 772
 773          for i:= 0 to BounceMessage.Count - 1 do
 774             BounceSpoolObject.DeliverMessagePart(BounceMessage.Strings[i]);
 775
 776          BounceSpoolObject.Close;
 777
 778          for i:= 0 to FailEnvelope.GetNumberOfRecipients - 1 do begin
 779             FailedRecipient:= FailEnvelope.GetRecipient(i);
 780             Logger.AddLine('Spool', 'Bounce message created in ' + BounceSpoolObject.Name
 781                + ' for object ' + SourceSpoolObject.Name
 782                + ' for address <' + FailEnvelope.ReturnPath
 783                + '>; concerning recipient <' + FailedRecipient.Address
 784                + '>; reported status: ' + StatusToStr(FailedRecipient.Data) + ' (' + CleanEOLN(FailedRecipient.RMsg) + ')');
 785          end;
 786
 787          BounceMessage.Free;
 788          Headers.Free;
 789       end;
 790       BounceSpoolObject.Free;
 791    end;
 792 end;
 793
 794 procedure TDeliveryThread.Execute;
 795 { This is a very important thread, because this delivers e-mails to local
 796   mailboxes and to remote servers. }
 797 var SearchRec: TSearchRec; SR: longint; SpoolObject: TSpoolObjectReader;
 798     Found: boolean; Envelopes: TEnvelopeArray;
 799     CurrEnv, FailEnv: TEnvelope; CurrRec: TRecipient;
 800     Mailbox: PMailbox; Relayer: TRelayer;
 801     NumOfEnvelopes: integer;
 802     a, i, j, r: integer;
 803 begin
 804    while not Terminated do begin
 805       for a:= 0 to Length(SpoolFilters) - 1 do begin
 806          if FindFirst('spool\' + SpoolFilters[a] + '*.dat', SEARCH_ATTR, SearchRec) = 0 then begin
 807             repeat
 808                Found:= false; SR:= 0;
 809                { Try to find a spool object that's not busy, and also actual. }
 810                repeat
 811                   SpoolObject:= TSpoolObjectReader.Create(Copy(SearchRec.Name, 1, Length(SearchRec.Name) - 4), SpoolConfig);
 812                   if not SpoolObject.Open then begin
 813                      SpoolObject.Free;
 814                      SR:= FindNext(SearchRec);
 815                   end
 816                   else if not SpoolObject.IsActual(SpoolConfig.TryDelay * 60) then begin
 817                      SpoolObject.Close;
 818                      SpoolObject.Free;
 819                      SR:= FindNext(SearchRec);
 820                   end
 821                   else Found:= true;
 822                until Found or (SR <> 0);
 823                if Found then begin
 824                   NumOfEnvelopes:= -1;
 825
 826                   FailEnv:= TEnvelope.Create;
 827                   FailEnv.ReturnPath:= SpoolObject.Envelope.ReturnPath;
 828
 829                   { Check local addresses first. }
 830                   Envelopes:= SpoolObject.MakeEnvelopes(false);
 831                   NumOfEnvelopes:= Length(Envelopes);
 832                   for i:= 0 to Length(Envelopes) - 1 do begin
 833                      CurrEnv:= Envelopes[i];
 834                      for j:= 0 to CurrEnv.GetNumberOfRecipients - 1 do begin
 835                         CurrRec:= CurrEnv.GetRecipient(j);
 836                         Mailbox:= MailboxManager.GetMailbox(EMailUserName(CurrRec.Address), EMailHost(CurrRec.Address));
 837                         if Mailbox <> nil then begin
 838                            if SpoolConfig.AllowExceedQuota or Mailbox^.CheckQuota(SpoolObject.GetMessageSize) then begin
 839                               r:= DeliverLocalMessage(SpoolObject, Mailbox, CurrEnv.ReturnPath, CurrRec.Address);
 840                               if r > 1 then
 841                                  HandleFailure(SpoolObject, true, FailEnv, CurrRec, DS_PERMANENT or DS_INTERNALFAIL,
 842                                     DSMSG_INTERNALFAIL + 'DeliverLocalMessage = ' + IntToStr(r))
 843                               else if r = 0 then
 844                                  SpoolObject.QuickSetDeliveryStatus(true, CurrRec.Address, DS_DELIVERED, CurrRec.RMsg)
 845                               else
 846                                  SpoolObject.QuickSetDeliveryStatus(true, CurrRec.Address, r, CurrRec.RMsg);
 847                            end
 848                            else
 849                               HandleFailure(SpoolObject, true, FailEnv, CurrRec, DS_PERMANENT, DSMSG_QUOTAEXCEEDED);
 850                         end
 851                         else
 852                            HandleFailure(SpoolObject, true, FailEnv, CurrRec, DS_PERMANENT, DSMSG_MAILBOXNOTEXISTS);
 853                      end;
 854                      { Free envelope. }
 855                      CurrEnv.Free;
 856                   end;
 857
 858                   { Check relay addresses as well. }
 859                   SetLength(Envelopes, 0);
 860                   Envelopes:= RelayManager.OrganizeEnvelopes(SpoolObject.MakeEnvelopes(true));
 861                   NumOfEnvelopes:= NumOfEnvelopes + Length(Envelopes);
 862                   for i:= 0 to Length(Envelopes) - 1 do begin
 863                      CurrEnv:= Envelopes[i];
 864                      Relayer:= RelayManager.CreateRelayer(CurrEnv, SpoolObject.EMailProperties);
 865                      if Relayer.OpenConnection then begin
 866                         if Relayer.Greet then
 867                            if Relayer.SendEnvelope then
 868                               DeliverRelayMessage(SpoolObject, Relayer);
 869                         Relayer.CloseConnection;
 870                         Relayer.Free;
 871                         AssignDeliveryStatusToSMTPCodes(CurrEnv);
 872                         HandleDeliveryResults(SpoolObject, false, CurrEnv, FailEnv, 0, '');
 873                      end
 874                      else begin
 875                         HandleDeliveryResults(SpoolObject, false, CurrEnv, FailEnv, DS_DELAYED or DS_CONNECTIONFAIL, DSMSG_CONNECTIONFAIL + Relayer.RelayServerName);
 876                      end;
 877                      { Free envelope. }
 878                      CurrEnv.Free;
 879                   end;
 880
 881                   { Create a bounce message if necessary. }
 882                   CreateBounceMessage(SpoolObject, FailEnv);
 883                   FailEnv.Free;
 884
 885                   SpoolObject.Actualize;
 886                   SpoolObject.SetThreadInfo(ThreadNum, ThreadID);
 887
 888                   if (NumOfEnvelopes <> 0) and (not SpoolObject.IsExpired(SpoolConfig.TryCount, false)) then
 889                      SpoolObject.Close
 890                   else begin
 891                      SpoolObject.Discard;
 892                      Logger.AddLine('Spool', 'Object ' + SpoolObject.Name + ' has been processed.');
 893                   end;
 894                   SpoolObject.Free;
 895                end;
 896             until (SR <> 0) or (FindNext(SearchRec) <> 0);
 897          end;
 898          FindClose(SearchRec);
 899       end;
 900       Sleep(SpoolConfig.ThreadWait);
 901    end;
 902    FFinished:= true;
 903 end;
 904
 905 procedure TDeliveryThread.CallExecute;
 906 begin
 907    Execute;
 908 end;
 909
 910
 911 function TSpoolManager.GetNumberOfDeliveryThreads: integer;
 912 begin
 913    Result:= Length(DeliveryThreads);
 914 end;
 915
 916 function TSpoolManager.CreateSpoolObject(Originator: TIPNamePair): TSpoolObjectCreator;
 917 begin
 918    Result:= TSpoolObjectCreator.Create(SpoolConfig, FDatabytes, FLineBuffer, Originator);
 919 end;
 920
 921 procedure TSpoolManager.DebugDeliveryThread;
 922 { You only need it when you need to trace the delivery thread.
 923   Normally it never gets called. Write a separate program to use it.
 924   (I've presented one, test_threaddebug.pas.) }
 925 var i: integer; Delivery: TDeliveryThread; SpoolFilters: TSpoolFilters;
 926     Alphabet: string;
 927 begin
 928    Alphabet:= GetAlphabetStr;
 929    SetLength(SpoolFilters, Length(Alphabet));
 930    for i:= 1 to Length(Alphabet) do SpoolFilters[i - 1]:= Alphabet[i];
 931
 932    Delivery:= TDeliveryThread.Create(true, 0, SpoolConfig, SpoolFilters);
 933    Delivery.CallExecute;
 934    Delivery.Free;
 935 end;
 936
 937 procedure TSpoolManager.StartDeliveryThreads;
 938 var i, j, n, x: integer; ThreadFilters: array of TSpoolFilters; Alphabet: string;
 939 begin
 940    n:= Length(DeliveryThreads);
 941    SetLength(ThreadFilters, n);
 942    Alphabet:= GetAlphabetStr;
 943
 944    if n > 0 then begin
 945       for i:= 1 to Length(Alphabet) do begin
 946          x:= (i - 1) mod n;
 947          j:= Length(ThreadFilters[x]);
 948          SetLength(ThreadFilters[x], j + 1);
 949          ThreadFilters[x][j]:= Alphabet[i];
 950       end;
 951    end;
 952
 953    Logger.AddStdLine('Spool', 'Starting ' + IntToStr(n) + ' delivery threads...');
 954    for i:= 0 to n - 1 do begin
 955       DeliveryThreads[i]:= TDeliveryThread.Create(false, i, SpoolConfig, ThreadFilters[i]);
 956       Sleep(25);
 957    end;
 958    Logger.AddStdLine('Spool', 'Delivery threads have been started.');
 959 end;
 960
 961 procedure TSpoolManager.StopDeliveryThreads;
 962 { Signals delivery threads to end, and waits for them to quit. }
 963 var i, Counter: integer; AllFinished: boolean;
 964 begin
 965    Logger.AddStdLine('Spool', 'Stopping delivery threads...');
 966    for i:= 0 to Length(DeliveryThreads) - 1 do
 967       DeliveryThreads[i].Terminate;
 968
 969    Counter:= 0;
 970
 971    repeat
 972       Sleep(50);
 973       AllFinished:= true;
 974       for i:= 0 to Length(DeliveryThreads) - 1 do
 975          if not DeliveryThreads[i].Finished then AllFinished:= false;
 976       Inc(Counter);
 977    until AllFinished or (Counter >= 600);
 978
 979    { Threads those didn't finish on time will be terminated. }
 980    for i:= 0 to Length(DeliveryThreads) - 1 do begin
 981       if not DeliveryThreads[i].Finished then begin
 982          Logger.AddStdLine('Spool', 'WARNING: Delivery thread #' + IntToStr(i) + ' hasn''t finished properly on time!');
 983          //DeliveryThreads[i].Suspend;    { Suspend has been deprecated, but we'll kill the thread regardless. }
 984          KillThread(DeliveryThreads[i].Handle);
 985       end;
 986       DeliveryThreads[i].Free;
 987    end;
 988    Logger.AddStdLine('Spool', 'Delivery threads have been stopped.');
 989 end;
 990
 991
 992 end.