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 Administers mailboxes. It implements methods to place messages into the
31 uses SysUtils
, SyncObjs
, Classes
, INIFiles
, Common
, Log
, Spool
;
36 TMailbox
= class(TNamedObject
)
37 constructor Create(const Name
, Domain
: string; Config
: TINIFile
; Slave
: boolean; DefaultQuota
: longint);
38 destructor Destroy
; override;
41 FQuota
, FLockID
: longint;
42 CriticalSection
: TCriticalSection
;
44 FPlusAliases
: boolean;
45 FRewritePassThru
: boolean;
46 PlusAliasExceptList
: TStringList
;
47 RewriteToList
: TStringList
;
49 procedure AddTrackHeaders(EMail
, Recipient
: string; Headers
: TStrings
);
50 { class function GetConfigSectionName(const Name, Domain: string): string; }
51 class function GetMailboxConfig(Config
: TINIFile
; const Name
, Domain
, Ident
, Default
: string): string; overload
;
52 class function GetMailboxConfig(Config
: TINIFile
; const Name
, Domain
, Ident
: string; Default
: boolean): boolean; overload
;
54 function IsItYourName(const Name
: string): boolean; override;
55 function GetMailboxAddress
: string;
56 function CheckAlias(const Name
: string): boolean;
57 function CheckQuota(MailSize
: longint): boolean; virtual; abstract;
58 function BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean; virtual; abstract;
59 function DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean; virtual; abstract;
60 function FinishDeliverMessage(LockID
: longint): boolean; virtual; abstract;
61 function Lock
: longint; virtual; abstract;
62 function Release(LockID
: longint): boolean; virtual; abstract;
63 function GetRewriteCount
: integer;
64 function GetRewriteToEntry(i
: integer): string;
65 function GetRewriteToListStr
: string;
66 property Domain
: string read FDomain
;
67 property Quota
: longint read FQuota
;
68 property RewriteCount
: integer read GetRewriteCount
;
69 property RewritePassThru
: boolean read FRewritePassThru
;
72 TMailbox_mbox
= class(TMailbox
)
74 procedure FromQuote(var Message: TStrings
);
75 function MakeMailboxFilename
: string;
77 function CheckQuota(MailSize
: longint): boolean; override;
78 function BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean; override;
79 function DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean; override;
80 function FinishDeliverMessage(LockID
: longint): boolean; override;
81 function Lock
: longint; override;
82 function Release(LockID
: longint): boolean; override;
85 TForwarderMailbox
= class(TMailbox
)
86 constructor Create(const Name
, Domain
: string; Config
: TINIFile
; Slave
: boolean; DefaultQuota
: longint; PhysicalMailbox
: TMailbox
);
87 destructor Destroy
; override;
89 PhysicalMailbox
: TMailbox
;
90 ForwardToList
: TStringList
;
91 SpoolObject
: TSpoolObjectCreator
;
94 FForwardHeaders
, FRemail
: boolean;
96 function CheckQuota(MailSize
: longint): boolean; override;
97 function BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean; override;
98 function DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean; override;
99 function FinishDeliverMessage(LockID
: longint): boolean; override;
100 function Lock
: longint; override;
101 function Release(LockID
: longint): boolean; override;
102 property ReplyTo
: string read FReplyTo
;
103 property ForwardHeaders
: boolean read FForwardHeaders
;
104 property Remail
: boolean read FRemail
;
108 TBoxes
= array of TMailbox
;
109 TDomainBoxes
= array of TBoxes
;
111 TMailboxContainer
= class(TStringList
)
113 destructor Destroy
; override;
115 DomainBoxes
: TDomainBoxes
;
117 procedure AddMailbox(const Domain
: string; Mailbox
: TMailbox
);
118 function GetMailbox(const Name
, Domain
: string): PMailbox
;
122 TMailboxManager
= class
123 constructor Create(Config
: TINIFile
);
124 destructor Destroy
; override;
126 MailboxContainer
: TMailboxContainer
;
127 DefaultQuota
: longint;
128 FDomainSpecific
: boolean;
129 FRewrite
, FForward
: boolean;
131 property DomainSpecific
: boolean read FDomainSpecific
;
132 property Rewrite
: boolean read FRewrite
;
133 property Forward: boolean read FForward
;
134 function CheckQuota(const Name
, Domain
: string; MailSize
: longint): boolean;
135 function GetMailbox(const Name
, Domain
: string): PMailbox
;
136 function IsLocalAddress(const EMail
: string): boolean;
137 function Verify(const EMail
: string): boolean;
138 function VerifyAlias(const EMail
: string): boolean;
144 MailboxManager
: TMailboxManager
;
151 { Search attributes: }
152 SEARCH_ATTR
= faAnyFile
- faDirectory
- faVolumeID
- faHidden
;
155 constructor TMailbox
.Create(const Name
, Domain
: string; Config
: TINIFile
; Slave
: boolean; DefaultQuota
: longint);
156 var Section
, BaseList
: string;
158 if Length(Domain
) = 0 then
159 Section
:= 'Mailbox\' + Name
161 Section
:= 'Mailbox\' + Name
+ '@' + Domain
;
163 inherited Create(Name
, Config
, Section
);
165 FQuota
:= Config
.ReadInteger(Section
, 'Quota', DefaultQuota
);
166 FQuota
:= StrToIntDef(GetMailboxConfig(Config
, Name
, Domain
, 'Quota', IntToStr(DefaultQuota
)), DefaultQuota
);
168 CriticalSection
:= TCriticalSection
.Create
;
170 if (not Slave
) then begin
171 FPlusAliases
:= GetMailboxConfig(Config
, Name
, Domain
, 'PlusAliases', true);
172 if FPlusAliases
then begin
173 PlusAliasExceptList
:= TStringList
.Create
;
174 PlusAliasExceptList
.Delimiter
:= ',';
175 BaseList
:= GetMailboxConfig(Config
, Name
, Domain
, 'PlusAliasExcept', '');
176 if Length(Domain
) > 0 then
177 PlusAliasExceptList
.DelimitedText
:= BaseList
+ ',' + Config
.ReadString('Mailbox\@' + Domain
, 'GlobalPlusAliasExcept', '')
179 PlusAliasExceptList
.DelimitedText
:= BaseList
+ ',' + Config
.ReadString('Mailbox', 'GlobalPlusAliasExcept', '');
184 if (not Slave
) and Config
.ReadBool('Mailbox', 'Rewrite', false) then begin
185 RewriteToList
:= TStringList
.Create
;
186 RewriteToList
.Delimiter
:= ',';
187 RewriteToList
.DelimitedText
:= GetMailboxConfig(Config
, Name
, Domain
, 'RewriteTo', '');
188 FRewritePassThru
:= GetMailboxConfig(Config
, Name
, Domain
, 'RewritePassThru', true);
190 else FRewritePassThru
:= true;
193 destructor TMailbox
.Destroy
;
195 CriticalSection
.Free
;
198 constructor TForwarderMailbox
.Create(const Name
, Domain
: string; Config
: TINIFile
; Slave
: boolean; DefaultQuota
: longint; PhysicalMailbox
: TMailbox
);
200 inherited Create(Name
, Domain
, Config
, Slave
, DefaultQuota
);
201 Self
.PhysicalMailbox
:= PhysicalMailbox
;
203 FReplyTo
:= GetMailboxConfig(Config
, Name
, Domain
, 'ReplyTo', '');
204 FForwardHeaders
:= GetMailboxConfig(Config
, Name
, Domain
, 'ForwardHeaders', true);
205 FRemail
:= GetMailboxConfig(Config
, Name
, Domain
, 'Remail', false);
207 ForwardToList
:= TStringList
.Create
;
208 ForwardToList
.Delimiter
:= ',';
209 ForwardToList
.DelimitedText
:= GetMailboxConfig(Config
, Name
, Domain
, 'ForwardTo', '');
212 destructor TForwarderMailbox
.Destroy
;
216 if (PhysicalMailbox
<> nil) then PhysicalMailbox
.Free
;
219 destructor TMailboxContainer
.Destroy
;
222 for i
:= Length(DomainBoxes
) - 1 downto 0 do begin
223 for j
:= Length(DomainBoxes
[i
]) - 1 downto 0 do begin
224 DomainBoxes
[i
][j
].Free
;
230 constructor TMailboxManager
.Create(Config
: TINIFile
);
231 var SearchRec
: TSearchRec
; i
: integer; BoxName
, BoxDomain
: string;
232 SlaveMailbox
: TMailBox
;
235 DefaultQuota
:= Config
.ReadInteger('Mailbox', 'Quota', 0);
236 FDomainSpecific
:= Config
.ReadBool('Mailbox', 'DomainSpecific', false);
237 FRewrite
:= Config
.ReadBool('Mailbox', 'Rewrite', false);
238 FForward
:= Config
.ReadBool('Mailbox', 'Forward', false);
239 MailboxContainer
:= TMailboxContainer
.Create
;
240 if FindFirst('mail\*', SEARCH_ATTR
, SearchRec
) = 0 then begin
243 if DomainSpecific
then begin
244 BoxName
:= EMailUserName(SearchRec
.Name
);
245 BoxDomain
:= EMailHost(SearchRec
.Name
);
248 BoxName
:= SearchRec
.Name
;
252 { If forwarding requested, set up a forwarder mailbox. }
254 if Forward and (Length(TMailbox
.GetMailboxConfig(Config
, BoxName
, BoxDomain
, 'ForwardTo', '')) > 0) then begin
256 if TMailbox
.GetMailboxConfig(Config
, BoxName
, BoxDomain
, 'StoreLocalCopy', true) then
257 SlaveMailbox
:= TMailbox_mbox
.Create(BoxName
, BoxDomain
, Config
, true, DefaultQuota
)
261 MailboxContainer
.AddMailbox(BoxDomain
, TForwarderMailbox
.Create(BoxName
, BoxDomain
, Config
, false, DefaultQuota
, SlaveMailbox
));
264 MailboxContainer
.AddMailbox(BoxDomain
, TMailbox_mbox
.Create(BoxName
, BoxDomain
, Config
, false, DefaultQuota
));
267 until FindNext(SearchRec
) <> 0;
269 FindClose(SearchRec
);
272 destructor TMailboxManager
.Destroy
;
274 MailboxContainer
.Free
;
279 procedure TMailbox
.AddTrackHeaders(EMail
, Recipient
: string; Headers
: TStrings
);
281 Headers
.Insert(0, 'Return-Path: <' + EMail
+ '>');
282 Headers
.Insert(0, 'X-Original-To: <' + Recipient
+ '>');
285 {class function TMailbox.GetConfigSectionName(const Name, Domain: string): string;
287 if Length(Domain) = 0 then
288 Result:= 'Mailbox\' + Name
290 Result:= 'Mailbox\' + Name + '@' + Domain;
293 class function TMailbox
.GetMailboxConfig(Config
: TINIFile
; const Name
, Domain
, Ident
, Default
: string): string;
295 if Length(Domain
) > 0 then
296 Result
:= Config
.ReadString('Mailbox\' + Name
+ '@' + Domain
, Ident
,
297 Config
.ReadString('Mailbox\@' + Domain
, Ident
,
298 Config
.ReadString('Mailbox', Ident
, Default
)))
300 Result
:= Config
.ReadString('Mailbox\' + Name
, Ident
,
301 Config
.ReadString('Mailbox', Ident
, Default
));
304 class function TMailbox
.GetMailboxConfig(Config
: TINIFile
; const Name
, Domain
, Ident
: string; Default
: boolean): boolean;
306 if Length(Domain
) > 0 then
307 Result
:= Config
.ReadBool('Mailbox\' + Name
+ '@' + Domain
, Ident
,
308 Config
.ReadBool('Mailbox\@' + Domain
, Ident
,
309 Config
.ReadBool('Mailbox', Ident
, Default
)))
311 Result
:= Config
.ReadBool('Mailbox\' + Name
, Ident
,
312 Config
.ReadBool('Mailbox', Ident
, Default
));
315 function TMailbox
.IsItYourName(const Name
: string): boolean;
318 if FPlusAliases
then begin
321 Result
:= inherited IsItYourName(Copy(Name
, 1, p
- 1))
323 Result
:= inherited IsItYourName(Name
);
326 Result
:= inherited IsItYourName(Name
);
329 function TMailbox
.GetMailboxAddress
: string;
331 if Length(Domain
) = 0 then
332 Result
:= Name
+ '@' + MainServerConfig
.Name
334 Result
:= Name
+ '@' + Domain
;
337 function TMailbox
.CheckAlias(const Name
: string): boolean;
342 Result
:= PlusAliasExceptList
.IndexOf(Copy(Name
, p
+ 1, Length(Name
) - p
)) = -1
347 function TMailbox
.GetRewriteCount
: integer;
349 Result
:= RewriteToList
.Count
;
352 function TMailbox
.GetRewriteToEntry(i
: integer): string;
354 Result
:= RewriteToList
.Strings
[i
];
357 function TMailbox
.GetRewriteToListStr
: string;
359 Result
:= RewriteToList
.DelimitedText
;
363 procedure TMailbox_mbox
.FromQuote(var Message: TStrings
);
366 for i
:= 0 to Message.Count
- 1 do
367 if pos('From ', Message.Strings
[i
]) = 1 then
368 Message.Strings
[i
]:= '>' + Message.Strings
[i
];
371 function TMailbox_mbox
.MakeMailboxFilename
: string;
373 if Length(Domain
) = 0 then
374 Result
:= 'mail\' + Name
376 Result
:= 'mail\' + Name
+ '@' + Domain
;
379 function TMailbox_mbox
.CheckQuota(MailSize
: longint): boolean;
380 { Returns FALSE if the given message size would exceed the quota. }
381 var SearchRec
: TSearchRec
;
383 if FindFirst(MakeMailboxFilename
, SEARCH_ATTR
, SearchRec
) = 0 then
384 Result
:= ((SearchRec
.Size
+ MailSize
) <= FQuota
) or (FQuota
= 0)
387 FindClose(SearchRec
);
390 function TMailbox_mbox
.BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean;
391 var NL
, Line
: string;
393 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
394 case DefaultTextLineBreakStyle
of
396 tlbsCRLF
: NL
:= #13#10;
400 {FromQuote(Headers);}
401 AddTrackHeaders(EMail
, Recipient
, Headers
);
402 Headers
.Insert(0, 'Delivered-To: ' + GetMailboxAddress
);
404 if Length(EMail
) = 0 then EMail
:= 'MAILER-DAEMON';
405 Line
:= 'From ' + EMail
+ ' ' + EMailTimeStamp(Now
) + NL
;
406 MailboxFile
.WriteBuffer(Pointer(Line
)^,Length(Line
));
407 Headers
.SaveToStream(MailboxFile
);
408 MailboxFile
.WriteBuffer(Pointer(NL
)^,Length(NL
));
417 function TMailbox_mbox
.DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean;
419 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
422 Message.SaveToStream(MailboxFile
);
431 function TMailbox_mbox
.FinishDeliverMessage(LockID
: longint): boolean;
433 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
435 MailboxFile
.WriteBuffer(#13#10, 2);
444 function TMailbox_mbox
.Lock
: longint;
446 CriticalSection
.Acquire
;
447 if FLockID
= 0 then begin
449 MailboxFile
:= TFileStream
.Create(MakeMailboxFilename
, fmOpenReadWrite
);
450 FLockID
:= (MailboxFile
as TFileStream
).Handle
;
451 MailboxFile
.Seek(0, soFromEnd
);
454 FreeAndNil(MailboxFile
);
462 CriticalSection
.Release
;
465 function TMailbox_mbox
.Release(LockID
: longint): boolean;
467 CriticalSection
.Acquire
;
468 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
469 FreeAndNil(MailboxFile
);
473 CriticalSection
.Release
;
477 function TForwarderMailbox
.CheckQuota(MailSize
: longint): boolean;
478 { Returns FALSE if the given message size would exceed the quota. }
480 if PhysicalMailbox
<> nil then
481 Result
:= PhysicalMailbox
.CheckQuota(MailSize
)
486 function TForwarderMailbox
.BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean;
489 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
490 if PhysicalMailbox
= nil then begin
491 AddTrackHeaders(EMail
, Recipient
, Headers
);
495 Result
:= PhysicalMailbox
.BeginDeliverMessage(LockID
, EMail
, Recipient
, SpoolID
, EMailProperties
, Headers
);
499 SpoolObject
:= SpoolManager
.CreateSpoolObject(TIPNamePair
.Create('internal', ''));
500 //PrepareSpoolObject(EMail, ForwardSpoolObject, Headers);
501 SpoolObject
.Databytes
:= 0;
503 SpoolObject
.EMailProperties
.Size
:= EMailProperties
.Size
;
504 SpoolObject
.EMailProperties
.Flags
:= EMailProperties
.Flags
;
505 OrigSpoolID
:= SpoolID
;
507 { Forward or remail? Regardless of the settings, DSNs only get forwarded
508 and never get remailed. (Remailing them could cause a loop.) }
509 if (not Remail
) or (EMail
= '') then
510 SpoolObject
.Envelope
.ReturnPath
:= EMail
512 SpoolObject
.Envelope
.ReturnPath
:= Recipient
;
514 for i
:= 0 to ForwardToList
.Count
- 1 do
515 SpoolObject
.Envelope
.AddRecipient(ForwardToList
.Strings
[i
]);
517 if ForwardHeaders
then begin
518 Headers
.Insert(0, 'X-Forwarded-For: ' + Recipient
+ ' ' + ForwardToList
.DelimitedText
);
519 Headers
.Insert(0, 'X-Forwarded-To: ' + ForwardToList
.DelimitedText
);
522 if ReplyTo
<> '' then begin
523 if ReplyTo
= '!' then
524 Headers
.Insert(0, 'Reply-To: <' + Recipient
+ '>')
526 Headers
.Insert(0, 'Reply-To: ' + ReplyTo
);
530 for i
:= 0 to Headers
.Count
- 1 do
531 SpoolObject
.DeliverMessagePart(Headers
.Strings
[i
]);
533 SpoolObject
.DeliverMessagePart('');
540 function TForwarderMailbox
.DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean;
543 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
544 if PhysicalMailbox
<> nil then
545 Result
:= PhysicalMailbox
.DeliverMessagePart(LockID
, Message)
549 for i
:= 0 to Message.Count
- 1 do
550 SpoolObject
.DeliverMessagePart(Message.Strings
[i
]);
556 function TForwarderMailbox
.FinishDeliverMessage(LockID
: longint): boolean;
559 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
560 if PhysicalMailbox
<> nil then
561 Result
:= PhysicalMailbox
.FinishDeliverMessage(LockID
)
565 if not Remail
then action
:= 'forwarding' else action
:= 'remailing';
567 if SpoolObject
.GetErrorCode
= SCE_NO_ERROR
then begin
568 Logger
.AddLine('Mailbox ' + GetMailboxAddress
, 'Message ' + OrigSpoolID
+ ' has been copied to '
569 + SpoolObject
.Name
+ ' for ' + action
+ ' to ' + ForwardToList
.DelimitedText
);
573 Logger
.AddLine('Mailbox ' + GetMailboxAddress
, 'Failed to copy message <' + SpoolObject
.OriginalMessageID
+ '> for '
574 + action
+ ' to ' + ForwardToList
.DelimitedText
575 + '; Spool error code: ' + IntToStr(SpoolObject
.GetErrorCode
));
584 function TForwarderMailbox
.Lock
: longint;
585 { Very-very sensitive method that induced lots of cursing.
586 Pay a lot of attention when you do any change to it! }
588 CriticalSection
.Acquire
;
589 if FLockID
= 0 then begin
590 if PhysicalMailbox
<> nil then begin
591 FLockID
:= PhysicalMailbox
.Lock
;
595 FLockID
:= GetCurrentThreadID
;
600 CriticalSection
.Release
;
603 function TForwarderMailbox
.Release(LockID
: longint): boolean;
605 CriticalSection
.Acquire
;
606 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
607 if PhysicalMailbox
<> nil then
608 Result
:= PhysicalMailbox
.Release(LockID
)
614 if Result
then FLockID
:= 0;
615 CriticalSection
.Release
;
619 procedure TMailboxContainer
.AddMailbox(const Domain
: string; Mailbox
: TMailbox
);
622 { IndexOf is supposed to be case-insensitive, but it depends on locales.
623 It's safer to uppercase the string before passing to it.
624 See: http://62.166.198.202/view.php?id=15489 }
625 i
:= IndexOf(UpperCase(Domain
));
629 SetLength(DomainBoxes
, Count
);
631 j
:= Length(DomainBoxes
[i
]);
632 SetLength(DomainBoxes
[i
], j
+ 1);
633 DomainBoxes
[i
][j
]:= Mailbox
;
636 function TMailboxContainer
.GetMailbox(const Name
, Domain
: string): PMailbox
;
639 i
:= IndexOf(UpperCase(Domain
));
640 if i
<> -1 then begin
642 while (j
< Length(DomainBoxes
[i
])) and (not(DomainBoxes
[i
][j
].IsItYourName(Name
))) do Inc(j
);
643 if (j
< Length(DomainBoxes
[i
])) then Result
:= @DomainBoxes
[i
][j
]
644 else if Domain
<> '' then Result
:= GetMailbox(Name
, '')
647 else if Domain
<> '' then Result
:= GetMailbox(Name
, '')
652 function TMailboxManager
.CheckQuota(const Name
, Domain
: string; MailSize
: longint): boolean;
653 var Mailbox
: PMailbox
;
655 Mailbox
:= GetMailbox(Name
, Domain
);
656 if Mailbox
<> nil then
657 Result
:= Mailbox
^.CheckQuota(MailSize
)
662 function TMailboxManager
.GetMailbox(const Name
, Domain
: string): PMailbox
;
664 Result
:= MailboxContainer
.GetMailbox(Name
, Domain
);
667 function TMailboxManager
.IsLocalAddress(const EMail
: string): boolean;
669 Result
:= MainServerConfig
.IsItYourName(EMailHost(EMail
));
672 function TMailboxManager
.Verify(const EMail
: string): boolean;
674 Result
:= GetMailbox(EMailUserName(EMail
), EMailHost(EMail
)) <> nil;
677 function TMailboxManager
.VerifyAlias(const EMail
: string): boolean;
678 var Mailbox
: PMailbox
;
680 Mailbox
:= GetMailbox(EMailUserName(EMail
), EMailHost(EMail
));
681 if Mailbox
<> nil then
682 Result
:= Mailbox
^.CheckAlias(EMailUserName(EMail
))