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/>.
24 uses Windows
, SysUtils
, INIFiles
, EINIFiles
,
25 Common
, Log
, Spool
, Listener
, Mailbox
, Relay
, Policies
;
28 function RegisterServiceCtrlHandlerEx(lpServiceName
: LPCSTR
; lpHandlerProc
: pointer; lpContext
: LPVOID
): SERVICE_STATUS_HANDLE
; stdcall; external 'advapi32.dll' name
'RegisterServiceCtrlHandlerExA';
29 procedure Service(Argc
: dword
; Argv
: pointer); stdcall; forward;
33 ServiceTable
: array[0..1] of TServiceTableEntry
=
36 lpServiceName
: 'MgSMTP';
37 lpServiceProc
: @Service
;
45 ArgumentPrefixes
: array[0..2] of string = ('/', '--', '-');
46 ValidArguments
: array[0..4] of string = ('?', 'HELP', 'INSTALL', 'UNINSTALL', 'USERMODE');
48 { For development test builds, you can add a developer comment here to
49 document what bugfix/feature are you testing with the actual build.
50 This will be logged to help you differentiate outputs of subsequent
51 builds in your logs. If left empty, it won't be added to the logs. }
52 DEVCOMMENT
= 'Escaping dots';
56 Cmdline
: TArgumentParser
;
58 hSCManager
, hService
: THandle
;
59 hSvcStatusHandle
: THandle
;
60 SvcStatus
: TServiceStatus
;
61 ServiceMode
, Stopping
: boolean;
62 WrongArgument
: integer;
65 procedure AddDevComment(Log
: TStreamLogger
);
67 if DEVCOMMENT
<> '' then begin
68 Log
.writeln('Build: ' + {$INCLUDE %DATE%} + ' ' + {$INCLUDE %TIME%});
69 Log
.writeln('Developer note: ' + DEVCOMMENT
);
73 procedure ReportSvcStatus(CurrentState
, WinExitCode
, WaitHint
: dword
);
74 { Report a service status to the Windows SCM. }
76 if ServiceMode
then begin
77 SvcStatus
.dwCurrentState
:= CurrentState
;
78 SvcStatus
.dwWaitHint
:= WaitHint
;
79 if WinExitCode
<> 0 then begin
80 SvcStatus
.dwWin32ExitCode
:= ERROR_SERVICE_SPECIFIC_ERROR
;
81 SvcStatus
.dwServiceSpecificExitCode
:= WinExitCode
;
84 SvcStatus
.dwWin32ExitCode
:= NO_ERROR
;
87 if CurrentState
= SERVICE_START_PENDING
then
88 SvcStatus
.dwControlsAccepted
:= 0
90 if GetWinMajorVersion
>= 6 then begin
91 SvcStatus
.dwControlsAccepted
:=
92 SERVICE_ACCEPT_STOP
or SERVICE_ACCEPT_SHUTDOWN
or SERVICE_ACCEPT_PRESHUTDOWN
;
95 SvcStatus
.dwControlsAccepted
:=
96 SERVICE_ACCEPT_STOP
or SERVICE_ACCEPT_SHUTDOWN
;
100 if (CurrentState
= SERVICE_RUNNING
) or (CurrentState
= SERVICE_STOPPED
) then
101 SvcStatus
.dwCheckPoint
:= 0
103 Inc(SvcStatus
.dwCheckPoint
);
105 SetServiceStatus(hSvcStatusHandle
, SvcStatus
);
109 procedure SvcCtrlHandlerEx(Ctrl
, EventType
: dword
; EventData
, Context
: pointer); stdcall;
110 { Receive a service control code from the Windows SCM, and handle it. }
113 SERVICE_CONTROL_STOP
,
114 SERVICE_CONTROL_SHUTDOWN
,
115 SERVICE_CONTROL_PRESHUTDOWN
:
117 Out.writeln('Received service control: ' + GetServiceCodeStr(Ctrl
));
118 ReportSvcStatus(SERVICE_STOP_PENDING
, 0, 1500);
122 SERVICE_CONTROL_INTERROGATE
:
123 ReportSvcStatus(SERVICE_RUNNING
, 0, 0);
126 Out.writeln('Received unknown service control: ' + IntToStr(Ctrl
));
127 ReportSvcStatus(SERVICE_STOPPED
, 1, 0);
133 procedure Service(Argc
: dword
; Argv
: pointer); stdcall;
134 var ProposedExitCode
: integer;
136 ProposedExitCode
:= 0;
141 hSvcStatusHandle
:= RegisterServiceCtrlHandlerEx('MgSMTP', @SvcCtrlHandlerEx
, nil);
143 if ServiceMode
and (hSvcStatusHandle
= 0) then
144 Out.writeln('RegisterServiceCtrlHandlerEx failed!'#13#10'Error code: ' + IntToStr(GetLastError
))
146 SvcStatus
.dwServiceType
:= SERVICE_WIN32_OWN_PROCESS
;
147 SvcStatus
.dwServiceSpecificExitCode
:= 0;
148 SvcStatus
.dwCheckPoint
:= 0;
150 ReportSvcStatus(SERVICE_START_PENDING
, 0, 1000);
152 if ServiceMode
then Out.writeln('Started in service mode.');
155 SetCurrentDir(ExtractFilePath(ParamStr(0)));
157 if not DirectoryExists('mail') then CreateDir('mail');
158 if not DirectoryExists('spool') then CreateDir('spool');
160 if FileExists('mgsmtp_server.ini') then begin
162 Config
:= TExtBoolINIFile
.Create('mgsmtp_server.ini');
164 if Config
.ReadString('Server', 'Name', '') <> '' then begin
165 MainServerConfig
:= TMainServerConfig
.Create(Config
);
166 Logger
:= TLogger
.Create(Config
);
167 MailboxManager
:= TMailboxManager
.Create(Config
);
168 RelayManager
:= TRelayManager
.Create(Config
);
169 SpoolManager
:= TSpoolManager
.Create(Config
);
170 PolicyManager
:= TPolicyManager
.Create(Config
);
172 if Config
.ReadBool('Spool', 'KeepProcessedEnvelopes', false)
173 or Config
.ReadBool('Spool', 'KeepProcessedEMails', false) then
174 if not DirectoryExists('processed') then CreateDir('processed');
178 AddDevComment(Logger
);
179 Logger
.AddStdLine('Primary server name: ' + MainServerConfig
.Name
);
180 Logger
.AddStdLine('FCrDNS policy: ' + FCrDNSPolicyToStr(PolicyManager
.FCrDNSPolicy
));
181 if MailboxManager
.DomainSpecific
then
182 Logger
.AddStdLine('Domain-specific mailbox support is enabled.');
184 if not MailboxManager
.Verify('postmaster') then
185 ProposedExitCode
:= 3;
187 if SpoolManager
.DeliveryThreadNumber
> Length(GetAlphabetStr
) then
188 ProposedExitCode
:= 4;
190 if ProposedExitCode
= 0 then begin
191 SpoolManager
.StartDeliveryThreads
;
194 ReportSvcStatus(SERVICE_RUNNING
, 0, 0);
195 while not Stopping
do Sleep(1000);
197 ReportSvcStatus(SERVICE_STOP_PENDING
, 0, SpoolManager
.ThreadWait
* 2);
200 SpoolManager
.StopDeliveryThreads
;
203 case ProposedExitCode
of
204 3: Logger
.AddStdLine('Error: Mandatory mailbox missing. Create a mailbox for "postmaster"!');
205 4: Logger
.AddStdLine('Error: The maximum allowed number of delivery threads is ' + IntToStr(Length(GetAlphabetStr
)) + '.');
207 ReportSvcStatus(SERVICE_STOPPED
, ProposedExitCode
, 0);
210 ReportSvcStatus(SERVICE_STOP_PENDING
, 0, 2000);
212 Logger
.AddStdLine('Clean shutdown.');
219 MainServerConfig
.Free
;
220 ReportSvcStatus(SERVICE_STOPPED
, 0, 0);
224 Out.writeln('Error: Server/Name is a mandatory configuration entry.'#13#10
225 + 'Please configure the application properly, refer to the manual.');
226 ReportSvcStatus(SERVICE_STOPPED
, 2, 0);
230 Out.writeln('Error: Missing configuration file.');
231 ReportSvcStatus(SERVICE_STOPPED
, 1, 0);
238 Out.writeln('MegaBrutal''s SMTP Server, version ' + VERSION_STR
+ ', ' + IntToStr(PLATFORM_BITS
) + ' bits');
239 Out.writeln('Copyright (C) 2010-2014 MegaBrutal');
243 { TODO: Process arguments here. }
244 Cmdline
:= TArgumentParser
.Create(CmdlineToStringArray
, ArgumentPrefixes
);
245 WrongArgument
:= Cmdline
.ValidateArguments(ValidArguments
);
247 if WrongArgument
= -1 then begin
251 if Cmdline
.IsPresent('?') or Cmdline
.IsPresent('HELP') then begin
252 Out.writeln('Supported arguments:');
253 Out.writeln('/INSTALL - registers the actual MgSMTP binary');
254 Out.writeln(' as a Windows service.');
255 Out.writeln('/UNINSTALL - unregisters the MgSMTP service.');
256 Out.writeln('/USERMODE - starts MgSMTP in user mode');
257 Out.writeln(' (not recommended, should be only');
258 Out.writeln(' used for debugging).');
260 Out.writeln('For more information on usage, see readme.txt.');
261 Out.writeln('For license details, see license.txt.');
263 Out.writeln('If you can''t find any of these files, you');
264 Out.writeln('don''t have the complete distribution of');
265 Out.writeln('this software. In that case, download a');
266 Out.writeln('proper distribution from SourceForge:');
267 Out.writeln('https://sourceforge.net/projects/mgsmtp/');
270 else if (Cmdline
.IsPresent('INSTALL') or Cmdline
.IsPresent('UNINSTALL')) then begin
271 { Register / unregister service. }
272 hSCManager
:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS
);
273 if hSCManager
<> 0 then begin
274 if Cmdline
.IsPresent('INSTALL') then begin
275 if CreateService(hSCManager
, 'MgSMTP', 'MegaBrutal''s SMTP Server (MgSMTP)', SC_MANAGER_ALL_ACCESS
,
276 SERVICE_WIN32_OWN_PROCESS
,
277 SERVICE_AUTO_START
, SERVICE_ERROR_NORMAL
,
284 Out.writeln('Service registered successfully.')
286 Out.writeln('CreateService failed!');
288 else if Cmdline
.IsPresent('UNINSTALL') then begin
289 hService
:= OpenService(hSCManager
, 'MgSMTP', SC_MANAGER_ALL_ACCESS
);
290 if hService
<> 0 then begin
291 if DeleteService(hService
) then
292 Out.writeln('Service unregistered successfully.')
294 Out.writeln('DeleteService failed!');
296 else Out.writeln('OpenService failed!');
299 else Out.writeln('OpenSCManager failed!');
303 if Cmdline
.IsPresent('USERMODE') then begin
304 Out.writeln('Starting MgSMTP in user mode...');
308 Out.writeln('Trying to contact Service Control Manager...');
309 Out.writeln('(If you see this message on console, you tried to');
310 Out.writeln('start up the program incorrectly. Your current');
311 Out.writeln('attempt will fail, or it may hang under Wine.)');
314 if not StartServiceCtrlDispatcher(ServiceTable
) then begin
316 Out.writeln('Failed!');
318 Out.writeln('You need to start MgSMTP as a service,');
319 Out.writeln('or supply proper arguments!');
320 Out.writeln('Issue with /? for more information.');
329 Out.writeln('Invalid argument: ' + Cmdline
.GetArgument(WrongArgument
).Option
+ '!');