MgSMTP.pas

   1 {
   2    MegaBrutal's SMTP Server (MgSMTP)
   3    Copyright (C) 2010-2018 MegaBrutal
   4
   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.
   9
  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.
  14
  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/>.
  17 }
  18
  19
  20 {$MODE DELPHI}
  21 {$APPTYPE CONSOLE}
  22
  23 program MgSMTP;
  24 uses Windows, SysUtils, INIFiles, EINIFiles,
  25      Common, Log, Spool, Listener, Mailbox, Relay, Policies;
  26
  27
  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;
  30
  31 const
  32
  33    ServiceTable: array[0..1] of TServiceTableEntry =
  34       (
  35          (
  36             lpServiceName: 'MgSMTP';
  37             lpServiceProc: @Service;
  38          ),
  39          (
  40             lpServiceName: nil;
  41             lpServiceProc: nil;
  42          )
  43       );
  44
  45    ArgumentPrefixes: array[0..2] of string = ('/', '--', '-');
  46    ValidArguments: array[0..4] of string = ('?', 'HELP', 'INSTALL', 'UNINSTALL', 'USERMODE');
  47
  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';
  53
  54 var
  55
  56    Cmdline: TArgumentParser;
  57    Config: TINIFile;
  58    hSCManager, hService: THandle;
  59    hSvcStatusHandle: THandle;
  60    SvcStatus: TServiceStatus;
  61    ServiceMode, Stopping: boolean;
  62    WrongArgument: integer;
  63
  64
  65 procedure AddDevComment(Log: TStreamLogger);
  66 begin
  67    if DEVCOMMENT <> '' then begin
  68       Log.writeln('Build: ' + {$INCLUDE %DATE%} + ' ' + {$INCLUDE %TIME%});
  69       Log.writeln('Developer note: ' + DEVCOMMENT);
  70    end;
  71 end;
  72
  73 procedure ReportSvcStatus(CurrentState, WinExitCode, WaitHint: dword);
  74 { Report a service status to the Windows SCM. }
  75 begin
  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;
  82       end
  83       else begin
  84          SvcStatus.dwWin32ExitCode:= NO_ERROR;
  85       end;
  86
  87       if CurrentState = SERVICE_START_PENDING then
  88          SvcStatus.dwControlsAccepted:= 0
  89       else begin
  90          if GetWinMajorVersion >= 6 then begin
  91             SvcStatus.dwControlsAccepted:=
  92                SERVICE_ACCEPT_STOP or SERVICE_ACCEPT_SHUTDOWN or SERVICE_ACCEPT_PRESHUTDOWN;
  93          end
  94          else begin
  95             SvcStatus.dwControlsAccepted:=
  96                SERVICE_ACCEPT_STOP or SERVICE_ACCEPT_SHUTDOWN;
  97          end;
  98       end;
  99
 100       if (CurrentState = SERVICE_RUNNING) or (CurrentState = SERVICE_STOPPED) then
 101          SvcStatus.dwCheckPoint:= 0
 102       else
 103          Inc(SvcStatus.dwCheckPoint);
 104
 105       SetServiceStatus(hSvcStatusHandle, SvcStatus);
 106    end;
 107 end;
 108
 109 procedure SvcCtrlHandlerEx(Ctrl, EventType: dword; EventData, Context: pointer); stdcall;
 110 { Receive a service control code from the Windows SCM, and handle it. }
 111 begin
 112    case Ctrl of
 113    SERVICE_CONTROL_STOP,
 114    SERVICE_CONTROL_SHUTDOWN,
 115    SERVICE_CONTROL_PRESHUTDOWN:
 116    begin
 117       Out.writeln('Received service control: ' + GetServiceCodeStr(Ctrl));
 118       ReportSvcStatus(SERVICE_STOP_PENDING, 0, 1500);
 119       Stopping:= true;
 120    end;
 121
 122    SERVICE_CONTROL_INTERROGATE:
 123       ReportSvcStatus(SERVICE_RUNNING, 0, 0);
 124
 125    else begin
 126       Out.writeln('Received unknown service control: ' + IntToStr(Ctrl));
 127       ReportSvcStatus(SERVICE_STOPPED, 1, 0);
 128       Stopping:= true;
 129    end;
 130    end;
 131 end;
 132
 133 function ConsoleCtrlHandler(Signal: dword): longbool; stdcall;
 134 { Handle CTRL-C event in user mode. }
 135 begin
 136    if Signal = CTRL_C_EVENT then begin
 137       Out.writeln('Caught CTRL-C signal.');
 138       Stopping:= true;
 139    end;
 140    Result:= true;
 141 end;
 142
 143 procedure Service(Argc: dword; Argv: pointer); stdcall;
 144 var ProposedExitCode: integer;
 145 begin
 146    ProposedExitCode:= 0;
 147    Stopping:= false;
 148    SetLastError(0);
 149
 150    if ServiceMode then
 151       hSvcStatusHandle:= RegisterServiceCtrlHandlerEx('MgSMTP', @SvcCtrlHandlerEx, nil);
 152
 153    if ServiceMode and (hSvcStatusHandle = 0) then
 154       Out.writeln('RegisterServiceCtrlHandlerEx failed!'#13#10'Error code: ' + IntToStr(GetLastError))
 155    else begin
 156       SvcStatus.dwServiceType:= SERVICE_WIN32_OWN_PROCESS;
 157       SvcStatus.dwServiceSpecificExitCode:= 0;
 158       SvcStatus.dwCheckPoint:= 0;
 159
 160       ReportSvcStatus(SERVICE_START_PENDING, 0, 1000);
 161
 162       if ServiceMode then Out.writeln('Started in service mode.');
 163
 164       Randomize;
 165       SetCurrentDir(ExtractFilePath(ParamStr(0)));
 166
 167       if not DirectoryExists('mail')  then CreateDir('mail');
 168       if not DirectoryExists('spool') then CreateDir('spool');
 169
 170       if FileExists('mgsmtp_server.ini') then begin
 171
 172          Config:= TExtBoolINIFile.Create('mgsmtp_server.ini');
 173
 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);
 181
 182             AddDevComment(Logger);
 183
 184             if (Config.ReadString('Server', 'ListenAddress', '') = '')
 185             and (Config.ReadString('Server', 'ListenPort', '') <> '') then
 186                Logger.AddStdLine('WARNING! Server\ListenPort is deprecated. Use ListenAddress instead!');
 187
 188             if Config.ReadBool('Spool', 'KeepProcessedEnvelopes', false)
 189             or Config.ReadBool('Spool', 'KeepProcessedEMails', false) then
 190                if not DirectoryExists('processed') then CreateDir('processed');
 191
 192             Config.Free;
 193
 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.');
 198
 199             if not MailboxManager.Verify('postmaster') then
 200                ProposedExitCode:= 3;
 201
 202             if SpoolManager.DeliveryThreadNumber > Length(GetAlphabetStr) then
 203                ProposedExitCode:= 4;
 204
 205             if ProposedExitCode = 0 then begin
 206                SpoolManager.StartDeliveryThreads;
 207                StartListeners;
 208
 209                ReportSvcStatus(SERVICE_RUNNING, 0, 0);
 210                while not Stopping do Sleep(1000);
 211
 212                ReportSvcStatus(SERVICE_STOP_PENDING, 0, SpoolManager.ThreadWait * 2);
 213
 214                StopListeners;
 215                SpoolManager.StopDeliveryThreads;
 216             end
 217             else begin
 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)) + '.');
 221                end;
 222                ReportSvcStatus(SERVICE_STOPPED, ProposedExitCode, 0);
 223             end;
 224
 225             ReportSvcStatus(SERVICE_STOP_PENDING, 0, 2000);
 226
 227             Logger.AddStdLine('Clean shutdown.');
 228
 229             PolicyManager.Free;
 230             SpoolManager.Free;
 231             RelayManager.Free;
 232             MailboxManager.Free;
 233             Logger.Free;
 234             MainServerConfig.Free;
 235             ReportSvcStatus(SERVICE_STOPPED, 0, 0);
 236          end
 237          else begin
 238             Config.Free;
 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);
 242          end;
 243       end
 244       else begin
 245          Out.writeln('Error: Missing configuration file.');
 246          ReportSvcStatus(SERVICE_STOPPED, 1, 0);
 247       end;
 248    end;
 249 end;
 250
 251
 252 begin
 253    Out.writeln('MegaBrutal''s SMTP Server, version ' + VERSION_STR + ', ' + IntToStr(PLATFORM_BITS) + ' bits');
 254    Out.writeln('Copyright (C) 2010-2018 MegaBrutal');
 255    AddDevComment(Out);
 256    Out.writeln;
 257
 258    { TODO: Process arguments here. }
 259    Cmdline:= TArgumentParser.Create(CmdlineToStringArray, ArgumentPrefixes);
 260    WrongArgument:= Cmdline.ValidateArguments(ValidArguments);
 261
 262    if WrongArgument = -1 then begin
 263
 264       ServiceMode:= false;
 265
 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).');
 274          Out.writeln;
 275          Out.writeln('For more information on usage, see readme.txt.');
 276          Out.writeln('For license details, see license.txt.');
 277          Out.writeln;
 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/');
 283       end
 284
 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,
 293                   PChar(ParamStr(0)),
 294                   nil,
 295                   nil,
 296                   nil,
 297                   nil,
 298                   nil) <> 0 then
 299                      Out.writeln('Service registered successfully.')
 300                   else
 301                      Out.writeln('CreateService failed!');
 302             end
 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.')
 308                   else
 309                      Out.writeln('DeleteService failed!');
 310                end
 311                else Out.writeln('OpenService failed!');
 312             end;
 313          end
 314          else Out.writeln('OpenSCManager failed!');
 315       end
 316
 317       else begin
 318          if Cmdline.IsPresent('USERMODE') then begin
 319             Out.writeln('Starting MgSMTP in user mode...');
 320             SetConsoleCtrlHandler(ConsoleCtrlHandler, true);
 321             Service(0, nil);
 322          end
 323          else begin
 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.)');
 328             Out.writeln;
 329             ServiceMode:= true;
 330             if not StartServiceCtrlDispatcher(ServiceTable) then begin
 331                ServiceMode:= false;
 332                Out.writeln('Failed!');
 333                Out.writeln;
 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.');
 337             end;
 338          end;
 339       end
 340
 341    end
 342
 343    else begin
 344
 345       Out.writeln('Invalid argument: ' + Cmdline.GetArgument(WrongArgument).Option + '!');
 346
 347    end;
 348 end.