2 MegaBrutal's SMTP Server (MgSMTP)
3 Copyright (C) 2010-2014 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
;
93 FForwardHeaders
, FRemail
: boolean;
95 function CheckQuota(MailSize
: longint): boolean; override;
96 function BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean; override;
97 function DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean; override;
98 function FinishDeliverMessage(LockID
: longint): boolean; override;
99 function Lock
: longint; override;
100 function Release(LockID
: longint): boolean; override;
101 property ForwardHeaders
: boolean read FForwardHeaders
;
102 property Remail
: boolean read FRemail
;
106 TBoxes
= array of TMailbox
;
107 TDomainBoxes
= array of TBoxes
;
109 TMailboxContainer
= class(TStringList
)
111 destructor Destroy
; override;
113 DomainBoxes
: TDomainBoxes
;
115 procedure AddMailbox(const Domain
: string; Mailbox
: TMailbox
);
116 function GetMailbox(const Name
, Domain
: string): PMailbox
;
120 TMailboxManager
= class
121 constructor Create(Config
: TINIFile
);
122 destructor Destroy
; override;
124 MailboxContainer
: TMailboxContainer
;
125 DefaultQuota
: longint;
126 FDomainSpecific
: boolean;
127 FRewrite
, FForward
: boolean;
129 property DomainSpecific
: boolean read FDomainSpecific
;
130 property Rewrite
: boolean read FRewrite
;
131 property Forward: boolean read FForward
;
132 function CheckQuota(const Name
, Domain
: string; MailSize
: longint): boolean;
133 function GetMailbox(const Name
, Domain
: string): PMailbox
;
134 function IsLocalAddress(const EMail
: string): boolean;
135 function Verify(const EMail
: string): boolean;
136 function VerifyAlias(const EMail
: string): boolean;
142 MailboxManager
: TMailboxManager
;
149 { Search attributes: }
150 SEARCH_ATTR
= faAnyFile
- faDirectory
- faVolumeID
- faHidden
;
153 constructor TMailbox
.Create(const Name
, Domain
: string; Config
: TINIFile
; Slave
: boolean; DefaultQuota
: longint);
154 var Section
, BaseList
: string;
156 if Length(Domain
) = 0 then
157 Section
:= 'Mailbox\' + Name
159 Section
:= 'Mailbox\' + Name
+ '@' + Domain
;
161 inherited Create(Name
, Config
, Section
);
163 FQuota
:= Config
.ReadInteger(Section
, 'Quota', DefaultQuota
);
164 FQuota
:= StrToIntDef(GetMailboxConfig(Config
, Name
, Domain
, 'Quota', IntToStr(DefaultQuota
)), DefaultQuota
);
166 CriticalSection
:= TCriticalSection
.Create
;
168 if (not Slave
) then begin
169 FPlusAliases
:= GetMailboxConfig(Config
, Name
, Domain
, 'PlusAliases', true);
170 if FPlusAliases
then begin
171 PlusAliasExceptList
:= TStringList
.Create
;
172 PlusAliasExceptList
.Delimiter
:= ',';
173 BaseList
:= GetMailboxConfig(Config
, Name
, Domain
, 'PlusAliasExcept', '');
174 if Length(Domain
) > 0 then
175 PlusAliasExceptList
.DelimitedText
:= BaseList
+ ',' + Config
.ReadString('Mailbox\@' + Domain
, 'GlobalPlusAliasExcept', '')
177 PlusAliasExceptList
.DelimitedText
:= BaseList
+ ',' + Config
.ReadString('Mailbox', 'GlobalPlusAliasExcept', '');
182 if (not Slave
) and Config
.ReadBool('Mailbox', 'Rewrite', false) then begin
183 RewriteToList
:= TStringList
.Create
;
184 RewriteToList
.Delimiter
:= ',';
185 RewriteToList
.DelimitedText
:= GetMailboxConfig(Config
, Name
, Domain
, 'RewriteTo', '');
186 FRewritePassThru
:= GetMailboxConfig(Config
, Name
, Domain
, 'RewritePassThru', true);
188 else FRewritePassThru
:= true;
191 destructor TMailbox
.Destroy
;
193 CriticalSection
.Free
;
196 constructor TForwarderMailbox
.Create(const Name
, Domain
: string; Config
: TINIFile
; Slave
: boolean; DefaultQuota
: longint; PhysicalMailbox
: TMailbox
);
198 inherited Create(Name
, Domain
, Config
, Slave
, DefaultQuota
);
199 Self
.PhysicalMailbox
:= PhysicalMailbox
;
201 FForwardHeaders
:= GetMailboxConfig(Config
, Name
, Domain
, 'ForwardHeaders', true);
202 FRemail
:= GetMailboxConfig(Config
, Name
, Domain
, 'Remail', false);
204 ForwardToList
:= TStringList
.Create
;
205 ForwardToList
.Delimiter
:= ',';
206 ForwardToList
.DelimitedText
:= GetMailboxConfig(Config
, Name
, Domain
, 'ForwardTo', '');
209 destructor TForwarderMailbox
.Destroy
;
213 if (PhysicalMailbox
<> nil) then PhysicalMailbox
.Free
;
216 destructor TMailboxContainer
.Destroy
;
219 for i
:= Length(DomainBoxes
) - 1 downto 0 do begin
220 for j
:= Length(DomainBoxes
[i
]) - 1 downto 0 do begin
221 DomainBoxes
[i
][j
].Free
;
227 constructor TMailboxManager
.Create(Config
: TINIFile
);
228 var SearchRec
: TSearchRec
; i
: integer; BoxName
, BoxDomain
: string;
229 SlaveMailbox
: TMailBox
;
232 DefaultQuota
:= Config
.ReadInteger('Mailbox', 'Quota', 0);
233 FDomainSpecific
:= Config
.ReadBool('Mailbox', 'DomainSpecific', false);
234 FRewrite
:= Config
.ReadBool('Mailbox', 'Rewrite', false);
235 FForward
:= Config
.ReadBool('Mailbox', 'Forward', false);
236 MailboxContainer
:= TMailboxContainer
.Create
;
237 if FindFirst('mail\*', SEARCH_ATTR
, SearchRec
) = 0 then begin
240 if DomainSpecific
then begin
241 BoxName
:= EMailUserName(SearchRec
.Name
);
242 BoxDomain
:= EMailHost(SearchRec
.Name
);
245 BoxName
:= SearchRec
.Name
;
249 { If forwarding requested, set up a forwarder mailbox. }
251 if Forward and (Length(TMailbox
.GetMailboxConfig(Config
, BoxName
, BoxDomain
, 'ForwardTo', '')) > 0) then begin
253 if TMailbox
.GetMailboxConfig(Config
, BoxName
, BoxDomain
, 'StoreLocalCopy', true) then
254 SlaveMailbox
:= TMailbox_mbox
.Create(BoxName
, BoxDomain
, Config
, true, DefaultQuota
)
258 MailboxContainer
.AddMailbox(BoxDomain
, TForwarderMailbox
.Create(BoxName
, BoxDomain
, Config
, false, DefaultQuota
, SlaveMailbox
));
261 MailboxContainer
.AddMailbox(BoxDomain
, TMailbox_mbox
.Create(BoxName
, BoxDomain
, Config
, false, DefaultQuota
));
264 until FindNext(SearchRec
) <> 0;
266 FindClose(SearchRec
);
269 destructor TMailboxManager
.Destroy
;
271 MailboxContainer
.Free
;
276 procedure TMailbox
.AddTrackHeaders(EMail
, Recipient
: string; Headers
: TStrings
);
278 Headers
.Insert(0, 'Return-Path: <' + EMail
+ '>');
279 Headers
.Insert(0, 'X-Original-To: <' + Recipient
+ '>');
282 {class function TMailbox.GetConfigSectionName(const Name, Domain: string): string;
284 if Length(Domain) = 0 then
285 Result:= 'Mailbox\' + Name
287 Result:= 'Mailbox\' + Name + '@' + Domain;
290 class function TMailbox
.GetMailboxConfig(Config
: TINIFile
; const Name
, Domain
, Ident
, Default
: string): string;
292 if Length(Domain
) > 0 then
293 Result
:= Config
.ReadString('Mailbox\' + Name
+ '@' + Domain
, Ident
,
294 Config
.ReadString('Mailbox\@' + Domain
, Ident
,
295 Config
.ReadString('Mailbox', Ident
, Default
)))
297 Result
:= Config
.ReadString('Mailbox\' + Name
, Ident
,
298 Config
.ReadString('Mailbox', Ident
, Default
));
301 class function TMailbox
.GetMailboxConfig(Config
: TINIFile
; const Name
, Domain
, Ident
: string; Default
: boolean): boolean;
303 if Length(Domain
) > 0 then
304 Result
:= Config
.ReadBool('Mailbox\' + Name
+ '@' + Domain
, Ident
,
305 Config
.ReadBool('Mailbox\@' + Domain
, Ident
,
306 Config
.ReadBool('Mailbox', Ident
, Default
)))
308 Result
:= Config
.ReadBool('Mailbox\' + Name
, Ident
,
309 Config
.ReadBool('Mailbox', Ident
, Default
));
312 function TMailbox
.IsItYourName(const Name
: string): boolean;
315 if FPlusAliases
then begin
318 Result
:= inherited IsItYourName(Copy(Name
, 1, p
- 1))
320 Result
:= inherited IsItYourName(Name
);
323 Result
:= inherited IsItYourName(Name
);
326 function TMailbox
.GetMailboxAddress
: string;
328 if Length(Domain
) = 0 then
329 Result
:= Name
+ '@' + MainServerConfig
.Name
331 Result
:= Name
+ '@' + Domain
;
334 function TMailbox
.CheckAlias(const Name
: string): boolean;
339 Result
:= PlusAliasExceptList
.IndexOf(Copy(Name
, p
+ 1, Length(Name
) - p
)) = -1
344 function TMailbox
.GetRewriteCount
: integer;
346 Result
:= RewriteToList
.Count
;
349 function TMailbox
.GetRewriteToEntry(i
: integer): string;
351 Result
:= RewriteToList
.Strings
[i
];
354 function TMailbox
.GetRewriteToListStr
: string;
356 Result
:= RewriteToList
.DelimitedText
;
360 procedure TMailbox_mbox
.FromQuote(var Message: TStrings
);
363 for i
:= 0 to Message.Count
- 1 do
364 if pos('From ', Message.Strings
[i
]) = 1 then
365 Message.Strings
[i
]:= '>' + Message.Strings
[i
];
368 function TMailbox_mbox
.MakeMailboxFilename
: string;
370 if Length(Domain
) = 0 then
371 Result
:= 'mail\' + Name
373 Result
:= 'mail\' + Name
+ '@' + Domain
;
376 function TMailbox_mbox
.CheckQuota(MailSize
: longint): boolean;
377 { Returns FALSE if the given message size would exceed the quota. }
378 var SearchRec
: TSearchRec
;
380 if FindFirst(MakeMailboxFilename
, SEARCH_ATTR
, SearchRec
) = 0 then
381 Result
:= ((SearchRec
.Size
+ MailSize
) <= FQuota
) or (FQuota
= 0)
384 FindClose(SearchRec
);
387 function TMailbox_mbox
.BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean;
388 var NL
, Line
: string;
390 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
391 case DefaultTextLineBreakStyle
of
393 tlbsCRLF
: NL
:= #13#10;
397 {FromQuote(Headers);}
398 AddTrackHeaders(EMail
, Recipient
, Headers
);
399 Headers
.Insert(0, 'Delivered-To: ' + GetMailboxAddress
);
401 if Length(EMail
) = 0 then EMail
:= 'MAILER-DAEMON';
402 Line
:= 'From ' + EMail
+ ' ' + EMailTimeStamp(Now
) + NL
;
403 MailboxFile
.WriteBuffer(Pointer(Line
)^,Length(Line
));
404 Headers
.SaveToStream(MailboxFile
);
405 MailboxFile
.WriteBuffer(Pointer(NL
)^,Length(NL
));
414 function TMailbox_mbox
.DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean;
416 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
419 Message.SaveToStream(MailboxFile
);
428 function TMailbox_mbox
.FinishDeliverMessage(LockID
: longint): boolean;
430 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
432 MailboxFile
.WriteBuffer(#13#10, 2);
441 function TMailbox_mbox
.Lock
: longint;
443 CriticalSection
.Acquire
;
444 if FLockID
= 0 then begin
446 MailboxFile
:= TFileStream
.Create(MakeMailboxFilename
, fmOpenReadWrite
);
447 FLockID
:= (MailboxFile
as TFileStream
).Handle
;
448 MailboxFile
.Seek(0, soFromEnd
);
451 FreeAndNil(MailboxFile
);
459 CriticalSection
.Release
;
462 function TMailbox_mbox
.Release(LockID
: longint): boolean;
464 CriticalSection
.Acquire
;
465 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
466 FreeAndNil(MailboxFile
);
470 CriticalSection
.Release
;
474 function TForwarderMailbox
.CheckQuota(MailSize
: longint): boolean;
475 { Returns FALSE if the given message size would exceed the quota. }
477 if PhysicalMailbox
<> nil then
478 Result
:= PhysicalMailbox
.CheckQuota(MailSize
)
483 function TForwarderMailbox
.BeginDeliverMessage(LockID
: longint; EMail
, Recipient
, SpoolID
: string; EMailProperties
: TEMailProperties
; Headers
: TStrings
): boolean;
486 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
487 if PhysicalMailbox
= nil then begin
488 AddTrackHeaders(EMail
, Recipient
, Headers
);
492 Result
:= PhysicalMailbox
.BeginDeliverMessage(LockID
, EMail
, Recipient
, SpoolID
, EMailProperties
, Headers
);
496 SpoolObject
:= SpoolManager
.CreateSpoolObject(TIPNamePair
.Create('internal', ''));
497 //PrepareSpoolObject(EMail, ForwardSpoolObject, Headers);
498 SpoolObject
.Databytes
:= 0;
500 SpoolObject
.EMailProperties
.Size
:= EMailProperties
.Size
;
501 SpoolObject
.EMailProperties
.Flags
:= EMailProperties
.Flags
;
502 OrigSpoolID
:= SpoolID
;
504 { Forward or remail? Regardless of the settings, DSNs only get forwarded
505 and never get remailed. (Remailing them could cause a loop.) }
506 if (not Remail
) or (EMail
= '') then
507 SpoolObject
.Envelope
.ReturnPath
:= EMail
509 SpoolObject
.Envelope
.ReturnPath
:= Recipient
;
511 for i
:= 0 to ForwardToList
.Count
- 1 do
512 SpoolObject
.Envelope
.AddRecipient(ForwardToList
.Strings
[i
]);
514 if ForwardHeaders
then begin
515 Headers
.Insert(0, 'X-Forwarded-For: ' + Recipient
+ ' ' + ForwardToList
.DelimitedText
);
516 Headers
.Insert(0, 'X-Forwarded-To: ' + ForwardToList
.DelimitedText
);
520 for i
:= 0 to Headers
.Count
- 1 do
521 SpoolObject
.DeliverMessagePart(Headers
.Strings
[i
]);
523 SpoolObject
.DeliverMessagePart('');
530 function TForwarderMailbox
.DeliverMessagePart(LockID
: longint; Message: TStrings
): boolean;
533 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
534 if PhysicalMailbox
<> nil then
535 Result
:= PhysicalMailbox
.DeliverMessagePart(LockID
, Message)
539 for i
:= 0 to Message.Count
- 1 do
540 SpoolObject
.DeliverMessagePart(Message.Strings
[i
]);
546 function TForwarderMailbox
.FinishDeliverMessage(LockID
: longint): boolean;
549 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
550 if PhysicalMailbox
<> nil then
551 Result
:= PhysicalMailbox
.FinishDeliverMessage(LockID
)
555 if not Remail
then action
:= 'forwarding' else action
:= 'remailing';
557 if SpoolObject
.GetErrorCode
= SCE_NO_ERROR
then begin
558 Logger
.AddLine('Mailbox ' + GetMailboxAddress
, 'Message ' + OrigSpoolID
+ ' has been copied to '
559 + SpoolObject
.Name
+ ' for ' + action
+ ' to ' + ForwardToList
.DelimitedText
);
563 Logger
.AddLine('Mailbox ' + GetMailboxAddress
, 'Failed to copy message <' + SpoolObject
.OriginalMessageID
+ '> for '
564 + action
+ ' to ' + ForwardToList
.DelimitedText
565 + '; Spool error code: ' + IntToStr(SpoolObject
.GetErrorCode
));
574 function TForwarderMailbox
.Lock
: longint;
575 { Very-very sensitive method that induced lots of cursing.
576 Pay a lot of attention when you do any change to it! }
578 CriticalSection
.Acquire
;
579 if FLockID
= 0 then begin
580 if PhysicalMailbox
<> nil then begin
581 FLockID
:= PhysicalMailbox
.Lock
;
585 FLockID
:= GetCurrentThreadID
;
590 CriticalSection
.Release
;
593 function TForwarderMailbox
.Release(LockID
: longint): boolean;
595 CriticalSection
.Acquire
;
596 if (FLockID
<> 0) and (FLockID
= LockID
) then begin
597 if PhysicalMailbox
<> nil then
598 Result
:= PhysicalMailbox
.Release(LockID
)
604 if Result
then FLockID
:= 0;
605 CriticalSection
.Release
;
609 procedure TMailboxContainer
.AddMailbox(const Domain
: string; Mailbox
: TMailbox
);
612 { IndexOf is supposed to be case-insensitive, but it depends on locales.
613 It's safer to uppercase the string before passing to it.
614 See: http://62.166.198.202/view.php?id=15489 }
615 i
:= IndexOf(UpperCase(Domain
));
619 SetLength(DomainBoxes
, Count
);
621 j
:= Length(DomainBoxes
[i
]);
622 SetLength(DomainBoxes
[i
], j
+ 1);
623 DomainBoxes
[i
][j
]:= Mailbox
;
626 function TMailboxContainer
.GetMailbox(const Name
, Domain
: string): PMailbox
;
629 i
:= IndexOf(UpperCase(Domain
));
630 if i
<> -1 then begin
632 while (j
< Length(DomainBoxes
[i
])) and (not(DomainBoxes
[i
][j
].IsItYourName(Name
))) do Inc(j
);
633 if (j
< Length(DomainBoxes
[i
])) then Result
:= @DomainBoxes
[i
][j
]
634 else if Domain
<> '' then Result
:= GetMailbox(Name
, '')
637 else if Domain
<> '' then Result
:= GetMailbox(Name
, '')
642 function TMailboxManager
.CheckQuota(const Name
, Domain
: string; MailSize
: longint): boolean;
643 var Mailbox
: PMailbox
;
645 Mailbox
:= GetMailbox(Name
, Domain
);
646 if Mailbox
<> nil then
647 Result
:= Mailbox
^.CheckQuota(MailSize
)
652 function TMailboxManager
.GetMailbox(const Name
, Domain
: string): PMailbox
;
654 Result
:= MailboxContainer
.GetMailbox(Name
, Domain
);
657 function TMailboxManager
.IsLocalAddress(const EMail
: string): boolean;
659 Result
:= MainServerConfig
.IsItYourName(EMailHost(EMail
));
662 function TMailboxManager
.Verify(const EMail
: string): boolean;
664 Result
:= GetMailbox(EMailUserName(EMail
), EMailHost(EMail
)) <> nil;
667 function TMailboxManager
.VerifyAlias(const EMail
: string): boolean;
668 var Mailbox
: PMailbox
;
670 Mailbox
:= GetMailbox(EMailUserName(EMail
), EMailHost(EMail
));
671 if Mailbox
<> nil then
672 Result
:= Mailbox
^.CheckAlias(EMailUserName(EMail
))