2 MegaBrutal's SMTP Server (MgSMTP)
3 Copyright (C) 2010-2018 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
= 'BindAddress';
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 function ConsoleCtrlHandler(Signal
: dword
): longbool
; stdcall;
134 { Handle CTRL-C event in user mode. }
136 if Signal
= CTRL_C_EVENT
then begin
137 Out.writeln('Caught CTRL-C signal.');
143 procedure Service(Argc
: dword
; Argv
: pointer); stdcall;
144 var ProposedExitCode
: integer;
146 ProposedExitCode
:= 0;
151 hSvcStatusHandle
:= RegisterServiceCtrlHandlerEx('MgSMTP', @SvcCtrlHandlerEx
, nil);
153 if ServiceMode
and (hSvcStatusHandle
= 0) then
154 Out.writeln('RegisterServiceCtrlHandlerEx failed!'#13#10'Error code: ' + IntToStr(GetLastError
))
156 SvcStatus
.dwServiceType
:= SERVICE_WIN32_OWN_PROCESS
;
157 SvcStatus
.dwServiceSpecificExitCode
:= 0;
158 SvcStatus
.dwCheckPoint
:= 0;
160 ReportSvcStatus(SERVICE_START_PENDING
, 0, 1000);
162 if ServiceMode
then Out.writeln('Started in service mode.');
165 SetCurrentDir(ExtractFilePath(ParamStr(0)));
167 if not DirectoryExists('mail') then CreateDir('mail');
168 if not DirectoryExists('spool') then CreateDir('spool');
170 if FileExists('mgsmtp_server.ini') then begin
172 Config
:= TExtBoolINIFile
.Create('mgsmtp_server.ini');
174 if Config
.ReadString('Server', 'Name', '') <> '' then begin
175 MainServerConfig
:= TMainServerConfig
.Create(Config
);
176 Logger
:= TLogger
.Create(Config
);
177 MailboxManager
:= TMailboxManager
.Create(Config
);
178 RelayManager
:= TRelayManager
.Create(Config
);
179 SpoolManager
:= TSpoolManager
.Create(Config
);
180 PolicyManager
:= TPolicyManager
.Create(Config
);
182 AddDevComment(Logger
);
184 if (Config
.ReadString('Server', 'ListenAddress', '') = '')
185 and (Config
.ReadString('Server', 'ListenPort', '') <> '') then
186 Logger
.AddStdLine('WARNING! Server\ListenPort is deprecated. Use ListenAddress instead!');
188 if Config
.ReadBool('Spool', 'KeepProcessedEnvelopes', false)
189 or Config
.ReadBool('Spool', 'KeepProcessedEMails', false) then
190 if not DirectoryExists('processed') then CreateDir('processed');
194 Logger
.AddStdLine('Primary server name: ' + MainServerConfig
.Name
);
195 Logger
.AddStdLine('FCrDNS policy: ' + FCrDNSPolicyToStr(PolicyManager
.FCrDNSPolicy
));
196 if MailboxManager
.DomainSpecific
then
197 Logger
.AddStdLine('Domain-specific mailbox support is enabled.');
199 if not MailboxManager
.Verify('postmaster') then
200 ProposedExitCode
:= 3;
202 if SpoolManager
.DeliveryThreadNumber
> Length(GetAlphabetStr
) then
203 ProposedExitCode
:= 4;
205 if ProposedExitCode
= 0 then begin
206 SpoolManager
.StartDeliveryThreads
;
209 ReportSvcStatus(SERVICE_RUNNING
, 0, 0);
210 while not Stopping
do Sleep(1000);
212 ReportSvcStatus(SERVICE_STOP_PENDING
, 0, SpoolManager
.ThreadWait
* 2);
215 SpoolManager
.StopDeliveryThreads
;
218 case ProposedExitCode
of
219 3: Logger
.AddStdLine('Error: Mandatory mailbox missing. Create a mailbox for "postmaster"!');
220 4: Logger
.AddStdLine('Error: The maximum allowed number of delivery threads is ' + IntToStr(Length(GetAlphabetStr
)) + '.');
222 ReportSvcStatus(SERVICE_STOPPED
, ProposedExitCode
, 0);
225 ReportSvcStatus(SERVICE_STOP_PENDING
, 0, 2000);
227 Logger
.AddStdLine('Clean shutdown.');
234 MainServerConfig
.Free
;
235 ReportSvcStatus(SERVICE_STOPPED
, 0, 0);
239 Out.writeln('Error: Server\Name is a mandatory configuration entry.'#13#10
240 + 'Please configure the application properly, refer to the manual.');
241 ReportSvcStatus(SERVICE_STOPPED
, 2, 0);
245 Out.writeln('Error: Missing configuration file.');
246 ReportSvcStatus(SERVICE_STOPPED
, 1, 0);
253 Out.writeln('MegaBrutal''s SMTP Server, version ' + VERSION_STR
+ ', ' + IntToStr(PLATFORM_BITS
) + ' bits');
254 Out.writeln('Copyright (C) 2010-2018 MegaBrutal');
258 { TODO: Process arguments here. }
259 Cmdline
:= TArgumentParser
.Create(CmdlineToStringArray
, ArgumentPrefixes
);
260 WrongArgument
:= Cmdline
.ValidateArguments(ValidArguments
);
262 if WrongArgument
= -1 then begin
266 if Cmdline
.IsPresent('?') or Cmdline
.IsPresent('HELP') then begin
267 Out.writeln('Supported arguments:');
268 Out.writeln('/INSTALL - registers the actual MgSMTP binary');
269 Out.writeln(' as a Windows service.');
270 Out.writeln('/UNINSTALL - unregisters the MgSMTP service.');
271 Out.writeln('/USERMODE - starts MgSMTP in user mode');
272 Out.writeln(' (not recommended, should be only');
273 Out.writeln(' used for debugging).');
275 Out.writeln('For more information on usage, see readme.txt.');
276 Out.writeln('For license details, see license.txt.');
278 Out.writeln('If you can''t find any of these files, you');
279 Out.writeln('don''t have the complete distribution of');
280 Out.writeln('this software. In that case, download a');
281 Out.writeln('proper distribution from SourceForge:');
282 Out.writeln('https://sourceforge.net/projects/mgsmtp/');
285 else if (Cmdline
.IsPresent('INSTALL') or Cmdline
.IsPresent('UNINSTALL')) then begin
286 { Register / unregister service. }
287 hSCManager
:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS
);
288 if hSCManager
<> 0 then begin
289 if Cmdline
.IsPresent('INSTALL') then begin
290 if CreateService(hSCManager
, 'MgSMTP', 'MegaBrutal''s SMTP Server (MgSMTP)', SC_MANAGER_ALL_ACCESS
,
291 SERVICE_WIN32_OWN_PROCESS
,
292 SERVICE_AUTO_START
, SERVICE_ERROR_NORMAL
,
299 Out.writeln('Service registered successfully.')
301 Out.writeln('CreateService failed!');
303 else if Cmdline
.IsPresent('UNINSTALL') then begin
304 hService
:= OpenService(hSCManager
, 'MgSMTP', SC_MANAGER_ALL_ACCESS
);
305 if hService
<> 0 then begin
306 if DeleteService(hService
) then
307 Out.writeln('Service unregistered successfully.')
309 Out.writeln('DeleteService failed!');
311 else Out.writeln('OpenService failed!');
314 else Out.writeln('OpenSCManager failed!');
318 if Cmdline
.IsPresent('USERMODE') then begin
319 Out.writeln('Starting MgSMTP in user mode...');
320 SetConsoleCtrlHandler(ConsoleCtrlHandler
, true);
324 Out.writeln('Trying to contact Service Control Manager...');
325 Out.writeln('(If you see this message on console, you tried to');
326 Out.writeln('start up the program incorrectly. Your current');
327 Out.writeln('attempt will fail, or it may hang under Wine.)');
330 if not StartServiceCtrlDispatcher(ServiceTable
) then begin
332 Out.writeln('Failed!');
334 Out.writeln('You need to start MgSMTP as a service,');
335 Out.writeln('or supply proper arguments!');
336 Out.writeln('Issue with /? for more information.');
345 Out.writeln('Invalid argument: ' + Cmdline
.GetArgument(WrongArgument
).Option
+ '!');