2 MegaBrutal's SMTP Server (MgSMTP)
3 Copyright (C) 2010-2015 MegaBrutal
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU Affero General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU Affero General Public License for more details.
15 You should have received a copy of the GNU Affero General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
21 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.
32 uses SysUtils
, Classes
, INIFiles
, Common
, Log
, Relay
, Bounce
;
36 TSpoolFilters
= array of string;
39 AllowExceedQuota
: boolean;
40 MaxReceivedHeaders
: integer;
42 TryCount
, TryDelay
: integer;
43 TempFailNotifyFirst
: boolean;
44 TempFailNotify
: integer;
45 KeepProcessedEnvelopes
: boolean;
46 KeepProcessedEMails
: boolean;
50 PSpoolObject
= ^TSpoolObject
;
52 constructor Create(const Name
: string; const SpoolConfig
: TSpoolConfig
);
53 destructor Destroy
; override;
58 FOriginator
: TIPNamePair
;
59 FEMailProperties
: TEMailProperties
;
60 SpoolConfig
: TSpoolConfig
;
63 StringBuffer
: TStrings
;
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;
84 TSpoolObjectCreator
= class(TSpoolObject
)
85 constructor Create(const SpoolConfig
: TSpoolConfig
; Databytes
: longint; LineBuffer
: integer; Originator
: TIPNamePair
);
86 destructor Destroy
; override;
89 FDatabytesCounter
: longint;
91 FOriginalMessageID
: string;
92 ReceivedCount
: integer;
93 ReceivingHeaders
: boolean;
94 HasDate
, HasMessageID
: boolean;
96 procedure AddNewHeaders
;
97 procedure TransferEnvelope
;
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
;
110 TSpoolObjectReader
= class(TSpoolObject
)
111 constructor Create(const Name
: string; const SpoolConfig
: TSpoolConfig
);
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;
127 TDeliveryThread
= class(TThread
)
128 constructor Create(CreateSuspended
: boolean; ThreadNum
: integer; const SpoolConfig
: TSpoolConfig
; const SpoolFilters
: TSpoolFilters
);
129 destructor Destroy
; override;
133 SpoolConfig
: TSpoolConfig
;
134 SpoolFilters
: TSpoolFilters
;
135 function DeliverLocalMessage(SpoolObject
: TSpoolObjectReader
; MailboxPtr
: pointer; ReturnPath
, Recipient
: string): integer;
136 function DeliverRelayMessage(SpoolObject
: TSpoolObjectReader
; Relayer
: TRelayer
): boolean;
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;
143 procedure CallExecute
;
144 property Finished
: boolean read FFinished
;
145 property ThreadNum
: integer read FThreadNum
;
149 TSpoolManager
= class
150 constructor Create(Config
: TINIFile
);
153 FLineBuffer
: integer;
154 SpoolConfig
: TSpoolConfig
;
155 DeliveryThreads
: array of TDeliveryThread
;
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
;
171 { SpoolObjectCreator errors: }
173 SCE_SIZE_EXCEEDED
= 1;
174 SCE_LOOP_DETECTED
= 2;
180 SpoolManager
: TSpoolManager
;
188 { Search attributes: }
189 SEARCH_ATTR
= faAnyFile
- faDirectory
- faVolumeID
- faHidden
;
192 constructor TSpoolObject
.Create(const Name
: string; const SpoolConfig
: TSpoolConfig
);
197 FEnvelope
:= TEnvelope
.Create
;
198 FEMailProperties
:= TEMailProperties
.Create
;
199 Self
.SpoolConfig
:= SpoolConfig
;
202 destructor TSpoolObject
.Destroy
;
204 FEMailProperties
.Free
;
209 constructor TSpoolObjectCreator
.Create(const SpoolConfig
: TSpoolConfig
; Databytes
: longint; LineBuffer
: integer; Originator
: TIPNamePair
);
211 inherited Create(GenerateRandomString(16), SpoolConfig
);
212 FDatabytes
:= Databytes
;
213 FLineBuffer
:= LineBuffer
;
214 FOriginator
:= Originator
;
218 destructor TSpoolObjectCreator
.Destroy
;
224 constructor TSpoolObjectReader
.Create(const Name
: string; const SpoolConfig
: TSpoolConfig
);
226 inherited Create(Name
, SpoolConfig
);
229 constructor TDeliveryThread
.Create(CreateSuspended
: boolean; ThreadNum
: integer; const SpoolConfig
: TSpoolConfig
; const SpoolFilters
: TSpoolFilters
);
231 FreeOnTerminate
:= false;
233 FThreadNum
:= ThreadNum
;
234 Self
.SpoolConfig
:= SpoolConfig
;
235 Self
.SpoolFilters
:= SpoolFilters
;
236 inherited Create(CreateSuspended
);
239 destructor TDeliveryThread
.Destroy
;
241 SetLength(SpoolFilters
, 0);
245 constructor TSpoolManager
.Create(Config
: TINIFile
);
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);
263 procedure TSpoolObject
.Close
;
270 function TSpoolObject
.IsActual(DelaySeconds
: TUnixTimeStamp
): boolean;
272 Result
:= UnixTimeStamp(Now
) >= (GetAccessTime
+ DelaySeconds
);
275 function TSpoolObject
.IsExpired(MaxTryCount
: integer; BeforeIncrement
: boolean): boolean;
277 if MaxTryCount
> 0 then begin
278 if BeforeIncrement
then Dec(MaxTryCount
);
279 Result
:= GetCurrentTryCount
>= MaxTryCount
;
285 function TSpoolObject
.GetAccessTime
: TUnixTimeStamp
;
287 Result
:= SpoolData
.ReadInteger('SpoolObject', 'AccessTime', 0);
290 function TSpoolObject
.GetCurrentTryCount
: integer;
292 Result
:= SpoolData
.ReadInteger('SpoolObject', 'TryCount', 0);
295 procedure TSpoolObject
.IncrementTryCount
;
297 SpoolData
.WriteInteger('SpoolObject', 'TryCount', GetCurrentTryCount
+ 1);
300 procedure TSpoolObject
.SetAccessTime(TimeStamp
: TUnixTimeStamp
);
302 SpoolData
.WriteInteger('SpoolObject', 'AccessTime', TimeStamp
);
305 procedure TSpoolObject
.SetThreadInfo(ThreadNum
: integer; ThreadOSID
: TThreadID
);
307 SpoolData
.WriteString('SpoolObject', 'ThreadInfo', IntToStr(ThreadNum
) + ',' + IntToStr(ThreadOSID
));
310 procedure TSpoolObject
.Actualize
;
313 SetAccessTime(UnixTimeStamp(Now
));
316 function TSpoolObject
.GetMessageSize
: longint;
317 var SearchRec
: TSearchRec
;
319 if FindFirst('spool\' + FName
+ '.eml', SEARCH_ATTR
, SearchRec
) = 0 then
320 Result
:= SearchRec
.Size
323 FindClose(SearchRec
);
327 procedure TSpoolObjectCreator
.AddNewHeaders
;
329 { Add a date, if not present. }
330 if not HasDate
then StringBuffer
.Insert(0, 'Date: ' + EMailTimeStampCorrected(Now
));
332 { Add Message-Id, if not present. }
333 if not HasMessageID
then StringBuffer
.Insert(0,
334 'Message-Id: <' + OriginalMessageID
+ '>');
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
));
343 { Flush it to the file. }
345 StringBuffer
.SaveToStream(MailFile
);
349 ReceivingHeaders
:= false;
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;
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
),
371 procedure TSpoolObjectCreator
.SetDatabytes(DatabytesLimit
: longint);
373 FDatabytes
:= DatabytesLimit
;
376 function TSpoolObjectCreator
.GetOriginalMessageID
: string;
379 Result
:= FOriginalMessageID
381 Result
:= Name
+ '@' + MainServerConfig
.Name
;
384 function TSpoolObjectCreator
.GetErrorCode
: integer;
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
393 Result
:= SCE_NO_ERROR
;
396 function TSpoolObjectCreator
.DeliverMessagePart(Line
: string): boolean;
397 var Header
, Value
: string;
399 if Opened
and (not WriteFail
) then begin
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
409 else if pos('MESSAGE-ID:', UpperCase(Line
)) = 1 then begin
411 SplitParameters(Line
, Header
, Value
, ':');
412 FOriginalMessageID
:= CleanEMailAddress(Value
);
414 else if pos('DATE:', UpperCase(Line
)) = 1 then HasDate
:= true
415 else if pos('RECEIVED:', UpperCase(Line
)) = 1 then Inc(ReceivedCount
);
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
426 StringBuffer
.SaveToStream(MailFile
);
441 function TSpoolObjectCreator
.Open
: boolean;
444 MailFile
:= TFileStream
.Create('spool\' + Name
+ '.eml', fmCreate
);
445 SpoolData
:= TINIFile
.Create('spool\' + Name
+ '.tmp');
447 StringBuffer
:= TStringList
.Create
;
449 ReceivingHeaders
:= true;
450 HasDate
:= false; HasMessageID
:= false;
451 FDatabytesCounter
:= 0;
461 procedure TSpoolObjectCreator
.Close
;
463 SpoolData
.WriteInteger('SpoolObject', 'Flags', EMailProperties
.Flags
);
464 SpoolData
.WriteInteger('SpoolObject', 'TryCount', 0);
465 if ReceivingHeaders
then AddNewHeaders
;
466 StringBuffer
.SaveToStream(MailFile
);
469 RenameFile('spool\' + Name
+ '.tmp', 'spool\' + Name
+ '.dat');
472 procedure TSpoolObjectCreator
.Discard
;
476 DeleteFile('spool\' + FName
+ '.tmp');
477 DeleteFile('spool\' + FName
+ '.eml');
483 function TSpoolObjectReader
.Open
: boolean;
485 {LockFile:= FileCreate('spool\' + FName + '.lck', fmShareExclusive);
486 if LockFile <> feInvalidHandle then begin}
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);
504 {FileClose(LockFile);}
509 procedure TSpoolObjectReader
.Close
;
512 {FileClose(LockFile);}
513 DeleteFile('spool\' + FName
+ '.lck');
517 procedure TSpoolObjectReader
.Discard
;
518 { Discard should be called when the spool object is opened, and instead
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');
534 function TSpoolObjectReader
.GetHeaders
: TStrings
;
535 var Strings
: TStrings
; S
: string; EH
: boolean;
537 Strings
:= TStringList
.Create
;
538 MailFile
.Seek(0, soFromBeginning
);
540 S:= ReadLineFromStream(MailFile);
541 if S <> '' then Strings.Add(S);
542 until (S = '') or (IsEOF);}
544 while (not IsEOF
) and (not EH
) do begin
545 S
:= ReadLineFromStream(MailFile
);
546 if S
<> '' then Strings
.Add(S
) else EH
:= true;
551 function TSpoolObjectReader
.IsEOF
: boolean;
553 Result
:= (not Opened
) or (MailFile
.Position
>= MailFile
.Size
);
556 procedure TSpoolObjectReader
.ReadChunk(Strings
: TStrings
; Lines
: integer);
557 var S
: string; C
: integer;
560 while (not IsEOF
) and (C
< Lines
) do begin
561 S
:= ReadLineFromStream(MailFile
);
567 function TSpoolObjectReader
.MakeEnvelopes(Relay
: boolean): TEnvelopeArray
;
568 var HostList
, Usernames
: TStringList
; i
, j
, f
: integer; Pref
, Host
: string;
572 HostList
:= TStringList
.Create
;
573 SpoolData
.ReadSections(HostList
);
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
582 SetLength(Result
, HostList
.Count
);
583 Usernames
:= TStringList
.Create
;
585 for i
:= 0 to HostList
.Count
- 1 do begin
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)}
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);
611 else SetLength(Result
, 0);
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;
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'
626 Pref
:= StatStr
+ Pref
;
627 Logger
.AddLine('Object ' + Name
, 'Permanent status has been set on recipient <' + Recipient
+ '>: '
628 + Pref
+ StatusToStr(Status
) + ' (' + CleanEOLN(RMsg
) + ')');
630 SpoolData
.WriteInteger(Pref
+ EMailHost(Recipient
), EMailUserName(Recipient
), Status
);
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
;
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
);
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
;
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
;
658 while (not SpoolObject
.IsEOF
) and R
do begin
659 { Maybe constant "32" should be configurable? }
661 SpoolObject
.ReadChunk(Chunk
, 32);
662 R
:= Mailbox
^.DeliverMessagePart(LockID
, Chunk
);
665 if Mailbox
^.FinishDeliverMessage(LockID
) then
676 Mailbox
^.Release(LockID
);
682 function TDeliveryThread
.DeliverRelayMessage(SpoolObject
: TSpoolObjectReader
; Relayer
: TRelayer
): boolean;
683 { Relay message to remote server.
684 Returns true if the transaction went through (doesn't necessarily mean
685 that the message was actually accepted). }
686 var Headers
, Chunk
: TStrings
; R
: boolean;
688 if Relayer
.PrepareSendMessage
then begin
689 Headers
:= SpoolObject
.GetHeaders
;
690 Chunk
:= TStringList
.Create
;
691 { Leave a line between the headers and the body. }
694 R
:= Relayer
.DeliverMessagePart(Headers
);
695 while (not SpoolObject
.IsEOF
) and R
do begin
696 { Maybe constant "64" should be configurable? }
698 SpoolObject
.ReadChunk(Chunk
, 64);
699 R
:= Relayer
.DeliverMessagePart(Chunk
);
702 Relayer
.FinishDeliverMessage
;
705 SpoolObject
.SetDeliveryStatus(false, Relayer
.Envelope
, DS_DELAYED
or DS_CONNECTIONFAIL
);
714 function TDeliveryThread
.NeedSendReport(SpoolObject
: TSpoolObject
): boolean;
715 { Check if there is necessary to send a temporary failure notification,
716 according to the configuration. }
717 var CurrentTryCount
: integer;
719 CurrentTryCount
:= SpoolObject
.GetCurrentTryCount
;
720 Result
:= ((CurrentTryCount
= 0) and SpoolConfig
.TempFailNotifyFirst
)
721 or ((CurrentTryCount
<> 0) and ((CurrentTryCount
mod SpoolConfig
.TempFailNotify
) = 0));
724 procedure TDeliveryThread
.HandleFailure(SpoolObject
: TSpoolObjectReader
; IsLocal
: boolean; FailEnvelope
: TEnvelope
; FailedRecipient
: TRecipient
; AddStatus
: integer; FailMsg
: string);
725 { Administer failure on a single recipient. }
727 if Length(FailMsg
) <> 0 then FailedRecipient
.RMsg
:= FailMsg
;
728 FailedRecipient
.Data
:= FailedRecipient
.Data
or AddStatus
;
729 {CreateBounceMessage(SpoolObject, FailedRecipient, ReturnPath, FailMsg);}
730 FailEnvelope
.AddRecipient(FailedRecipient
);
731 SpoolObject
.QuickSetDeliveryStatus(IsLocal
, FailedRecipient
.Address
, FailedRecipient
.Data
, FailedRecipient
.RMsg
);
734 procedure TDeliveryThread
.HandleDeliveryResults(SpoolObject
: TSpoolObjectReader
; IsLocal
: boolean; Envelope
, FailEnvelope
: TEnvelope
; AddStatus
: integer; FailMsg
: string);
735 { Administer results on multiple recipients (passed in a TEnvelope). }
736 var i
: integer; Recipient
: TRecipient
; Expired
: boolean;
738 Expired
:= SpoolObject
.IsExpired(SpoolConfig
.TryCount
, true);
739 for i
:= 0 to Envelope
.GetNumberOfRecipients
- 1 do begin
740 Recipient
:= Envelope
.GetRecipient(i
);
741 Recipient
.Data
:= Recipient
.Data
or AddStatus
;
743 Recipient
.Data
:= (Recipient
.Data
or DS_PERMANENT
) and (DS_ALLFLAGS
xor DS_DELAYED
);
744 if (Recipient
.Data
and DS_DELIVERED
) <> 0 then
745 SpoolObject
.QuickSetDeliveryStatus(IsLocal
, Recipient
.Address
, Recipient
.Data
, Recipient
.RMsg
)
747 if ((Recipient
.Data
and DS_PERMANENT
) <> 0)
748 or (((Recipient
.Data
and DS_DELAYED
) <> 0) and NeedSendReport(SpoolObject
)) then begin
749 { In the case of failures, HandleFailure will call QuickSetDeliveryStatus. }
750 HandleFailure(SpoolObject
, IsLocal
, FailEnvelope
, Recipient
, 0, FailMsg
);
753 SpoolObject
.QuickSetDeliveryStatus(IsLocal
, Recipient
.Address
, Recipient
.Data
, Recipient
.RMsg
);
758 procedure TDeliveryThread
.CreateBounceMessage(SourceSpoolObject
: TSpoolObjectReader
; FailEnvelope
: TEnvelope
);
759 { Generates failure notification messages, and places them into a new spool
760 object to queue them for delivery. }
761 var BounceSpoolObject
: TSpoolObjectCreator
; Headers
, BounceMessage
: TStrings
; i
: integer;
762 FailedRecipient
: TRecipient
;
764 { Don't do anything, if we don't have a return-path. }
765 if (FailEnvelope
.ReturnPath
<> '') and (FailEnvelope
.GetNumberOfRecipients
<> 0) then begin
766 BounceSpoolObject
:= TSpoolObjectCreator
.Create(SpoolConfig
, 1024 * 1024, 32, TIPNamePair
.Create('localhost', '127.0.0.1'));
767 BounceSpoolObject
.Envelope
.SetReturnPath('');
768 BounceSpoolObject
.Envelope
.AddRecipient(FailEnvelope
.ReturnPath
);
769 if BounceSpoolObject
.Open
then begin
770 Headers
:= SourceSpoolObject
.GetHeaders
;
772 if FailEnvelope
.GetNumberOfRecipients
= 1 then
773 BounceMessage
:= GenerateBounceMessage(FailEnvelope
.GetRecipient(0), Headers
, FailEnvelope
.ReturnPath
)
775 BounceMessage
:= GenerateBounceMessage(FailEnvelope
, Headers
);
777 for i
:= 0 to BounceMessage
.Count
- 1 do
778 BounceSpoolObject
.DeliverMessagePart(BounceMessage
.Strings
[i
]);
780 BounceSpoolObject
.Close
;
782 for i
:= 0 to FailEnvelope
.GetNumberOfRecipients
- 1 do begin
783 FailedRecipient
:= FailEnvelope
.GetRecipient(i
);
784 Logger
.AddLine('Spool', 'Bounce message created in ' + BounceSpoolObject
.Name
785 + ' for object ' + SourceSpoolObject
.Name
786 + ' for address <' + FailEnvelope
.ReturnPath
787 + '>; concerning recipient <' + FailedRecipient
.Address
788 + '>; reported status: ' + StatusToStr(FailedRecipient
.Data
) + ' (' + CleanEOLN(FailedRecipient
.RMsg
) + ')');
794 BounceSpoolObject
.Free
;
798 procedure TDeliveryThread
.Execute
;
799 { This is a very important thread, because this delivers e-mails to local
800 mailboxes and to remote servers. }
801 var SearchRec
: TSearchRec
; SR
: longint; SpoolObject
: TSpoolObjectReader
;
802 Found
: boolean; Envelopes
: TEnvelopeArray
;
803 CurrEnv
, FailEnv
: TEnvelope
; CurrRec
: TRecipient
;
804 Mailbox
: PMailbox
; Relayer
: TRelayer
;
805 NumOfEnvelopes
: integer;
808 while not Terminated
do begin
809 for a
:= 0 to Length(SpoolFilters
) - 1 do begin
810 if FindFirst('spool\' + SpoolFilters
[a
] + '*.dat', SEARCH_ATTR
, SearchRec
) = 0 then begin
812 Found
:= false; SR
:= 0;
813 { Try to find a spool object that's not busy, and also actual. }
815 SpoolObject
:= TSpoolObjectReader
.Create(Copy(SearchRec
.Name
, 1, Length(SearchRec
.Name
) - 4), SpoolConfig
);
816 if not SpoolObject
.Open
then begin
818 SR
:= FindNext(SearchRec
);
820 else if not SpoolObject
.IsActual(SpoolConfig
.TryDelay
* 60) then begin
823 SR
:= FindNext(SearchRec
);
826 until Found
or (SR
<> 0);
830 FailEnv
:= TEnvelope
.Create
;
831 FailEnv
.ReturnPath
:= SpoolObject
.Envelope
.ReturnPath
;
833 { Check local addresses first. }
834 Envelopes
:= SpoolObject
.MakeEnvelopes(false);
835 NumOfEnvelopes
:= Length(Envelopes
);
836 for i
:= 0 to Length(Envelopes
) - 1 do begin
837 CurrEnv
:= Envelopes
[i
];
838 for j
:= 0 to CurrEnv
.GetNumberOfRecipients
- 1 do begin
839 CurrRec
:= CurrEnv
.GetRecipient(j
);
840 Mailbox
:= MailboxManager
.GetMailbox(EMailUserName(CurrRec
.Address
), EMailHost(CurrRec
.Address
));
841 if Mailbox
<> nil then begin
842 if SpoolConfig
.AllowExceedQuota
or Mailbox
^.CheckQuota(SpoolObject
.GetMessageSize
) then begin
843 r
:= DeliverLocalMessage(SpoolObject
, Mailbox
, CurrEnv
.ReturnPath
, CurrRec
.Address
);
845 HandleFailure(SpoolObject
, true, FailEnv
, CurrRec
, DS_PERMANENT
or DS_INTERNALFAIL
,
846 DSMSG_INTERNALFAIL
+ 'DeliverLocalMessage = ' + IntToStr(r
))
848 SpoolObject
.QuickSetDeliveryStatus(true, CurrRec
.Address
, DS_DELIVERED
, CurrRec
.RMsg
)
850 SpoolObject
.QuickSetDeliveryStatus(true, CurrRec
.Address
, r
, CurrRec
.RMsg
);
853 HandleFailure(SpoolObject
, true, FailEnv
, CurrRec
, DS_PERMANENT
, DSMSG_QUOTAEXCEEDED
);
856 HandleFailure(SpoolObject
, true, FailEnv
, CurrRec
, DS_PERMANENT
, DSMSG_MAILBOXNOTEXISTS
);
862 { Check relay addresses as well. }
863 SetLength(Envelopes
, 0);
864 Envelopes
:= RelayManager
.OrganizeEnvelopes(SpoolObject
.MakeEnvelopes(true));
865 NumOfEnvelopes
:= NumOfEnvelopes
+ Length(Envelopes
);
866 for i
:= 0 to Length(Envelopes
) - 1 do begin
867 CurrEnv
:= Envelopes
[i
];
868 Relayer
:= RelayManager
.CreateRelayer(CurrEnv
, SpoolObject
.EMailProperties
);
869 if Relayer
.OpenConnection
then begin
870 if Relayer
.Greet
then
871 if Relayer
.SendEnvelope
then
872 DeliverRelayMessage(SpoolObject
, Relayer
);
874 AssignDeliveryStatusToSMTPCodes(CurrEnv
, Relayer
.IsTransactionComplete
);
875 Relayer
.CloseConnection
;
877 HandleDeliveryResults(SpoolObject
, false, CurrEnv
, FailEnv
, 0, '');
880 HandleDeliveryResults(SpoolObject
, false, CurrEnv
, FailEnv
, DS_DELAYED
or DS_CONNECTIONFAIL
, DSMSG_CONNECTIONFAIL
+ Relayer
.RelayServerName
);
886 { Create a bounce message if necessary. }
887 CreateBounceMessage(SpoolObject
, FailEnv
);
890 SpoolObject
.Actualize
;
891 SpoolObject
.SetThreadInfo(ThreadNum
, ThreadID
);
893 if (NumOfEnvelopes
<> 0) and (not SpoolObject
.IsExpired(SpoolConfig
.TryCount
, false)) then
897 Logger
.AddLine('Spool', 'Object ' + SpoolObject
.Name
+ ' has been processed.');
901 until (SR
<> 0) or (FindNext(SearchRec
) <> 0);
903 FindClose(SearchRec
);
905 Sleep(SpoolConfig
.ThreadWait
);
910 procedure TDeliveryThread
.CallExecute
;
916 function TSpoolManager
.GetNumberOfDeliveryThreads
: integer;
918 Result
:= Length(DeliveryThreads
);
921 function TSpoolManager
.CreateSpoolObject(Originator
: TIPNamePair
): TSpoolObjectCreator
;
923 Result
:= TSpoolObjectCreator
.Create(SpoolConfig
, FDatabytes
, FLineBuffer
, Originator
);
926 procedure TSpoolManager
.DebugDeliveryThread
;
927 { You only need it when you need to trace the delivery thread.
928 Normally it never gets called. Write a separate program to use it.
929 (I've presented one, test_threaddebug.pas.) }
930 var i
: integer; Delivery
: TDeliveryThread
; SpoolFilters
: TSpoolFilters
;
933 Alphabet
:= GetAlphabetStr
;
934 SetLength(SpoolFilters
, Length(Alphabet
));
935 for i
:= 1 to Length(Alphabet
) do SpoolFilters
[i
- 1]:= Alphabet
[i
];
937 Delivery
:= TDeliveryThread
.Create(true, 0, SpoolConfig
, SpoolFilters
);
938 Delivery
.CallExecute
;
942 procedure TSpoolManager
.StartDeliveryThreads
;
943 var i
, j
, n
, x
: integer; ThreadFilters
: array of TSpoolFilters
; Alphabet
: string;
945 n
:= Length(DeliveryThreads
);
946 SetLength(ThreadFilters
, n
);
947 Alphabet
:= GetAlphabetStr
;
950 for i
:= 1 to Length(Alphabet
) do begin
952 j
:= Length(ThreadFilters
[x
]);
953 SetLength(ThreadFilters
[x
], j
+ 1);
954 ThreadFilters
[x
][j
]:= Alphabet
[i
];
958 Logger
.AddStdLine('Spool', 'Starting ' + IntToStr(n
) + ' delivery threads...');
959 for i
:= 0 to n
- 1 do begin
960 DeliveryThreads
[i
]:= TDeliveryThread
.Create(false, i
, SpoolConfig
, ThreadFilters
[i
]);
963 Logger
.AddStdLine('Spool', 'Delivery threads have been started.');
966 procedure TSpoolManager
.StopDeliveryThreads
;
967 { Signals delivery threads to end, and waits for them to quit. }
968 var i
, Counter
: integer; AllFinished
: boolean;
970 Logger
.AddStdLine('Spool', 'Stopping delivery threads...');
971 for i
:= 0 to Length(DeliveryThreads
) - 1 do
972 DeliveryThreads
[i
].Terminate
;
979 for i
:= 0 to Length(DeliveryThreads
) - 1 do
980 if not DeliveryThreads
[i
].Finished
then AllFinished
:= false;
982 until AllFinished
or (Counter
>= 600);
984 { Threads those didn't finish on time will be terminated. }
985 for i
:= 0 to Length(DeliveryThreads
) - 1 do begin
986 if not DeliveryThreads
[i
].Finished
then begin
987 Logger
.AddStdLine('Spool', 'WARNING: Delivery thread #' + IntToStr(i
) + ' hasn''t finished properly on time!');
988 //DeliveryThreads[i].Suspend; { Suspend has been deprecated, but we'll kill the thread regardless. }
989 KillThread(DeliveryThreads
[i
].Handle
);
991 DeliveryThreads
[i
].Free
;
993 Logger
.AddStdLine('Spool', 'Delivery threads have been stopped.');