MgSMTP.pas

   1 {
   2    MegaBrutal's SMTP Server (MgSMTP)
   3    Copyright (C) 2010-2016 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  =  'Catch CTRL-C in user mode';
  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             if Config.ReadBool('Spool', 'KeepProcessedEnvelopes', false)
 183             or Config.ReadBool('Spool', 'KeepProcessedEMails', false) then
 184                if not DirectoryExists('processed') then CreateDir('processed');
 185
 186             Config.Free;
 187
 188             AddDevComment(Logger);
 189             Logger.AddStdLine('Primary server name: ' + MainServerConfig.Name);
 190             Logger.AddStdLine('FCrDNS policy: ' + FCrDNSPolicyToStr(PolicyManager.FCrDNSPolicy));
 191             if MailboxManager.DomainSpecific then
 192                Logger.AddStdLine('Domain-specific mailbox support is enabled.');
 193
 194             if not MailboxManager.Verify('postmaster') then
 195                ProposedExitCode:= 3;
 196
 197             if SpoolManager.DeliveryThreadNumber > Length(GetAlphabetStr) then
 198                ProposedExitCode:= 4;
 199
 200             if ProposedExitCode = 0 then begin
 201                SpoolManager.StartDeliveryThreads;
 202                StartListeners;
 203
 204                ReportSvcStatus(SERVICE_RUNNING, 0, 0);
 205                while not Stopping do Sleep(1000);
 206
 207                ReportSvcStatus(SERVICE_STOP_PENDING, 0, SpoolManager.ThreadWait * 2);
 208
 209                StopListeners;
 210                SpoolManager.StopDeliveryThreads;
 211             end
 212             else begin
 213                case ProposedExitCode of
 214                3: Logger.AddStdLine('Error: Mandatory mailbox missing. Create a mailbox for "postmaster"!');
 215                4: Logger.AddStdLine('Error: The maximum allowed number of delivery threads is ' + IntToStr(Length(GetAlphabetStr)) + '.');
 216                end;
 217                ReportSvcStatus(SERVICE_STOPPED, ProposedExitCode, 0);
 218             end;
 219
 220             ReportSvcStatus(SERVICE_STOP_PENDING, 0, 2000);
 221
 222             Logger.AddStdLine('Clean shutdown.');
 223
 224             PolicyManager.Free;
 225             SpoolManager.Free;
 226             RelayManager.Free;
 227             MailboxManager.Free;
 228             Logger.Free;
 229             MainServerConfig.Free;
 230             ReportSvcStatus(SERVICE_STOPPED, 0, 0);
 231          end
 232          else begin
 233             Config.Free;
 234             Out.writeln('Error: Server/Name is a mandatory configuration entry.'#13#10
 235                + 'Please configure the application properly, refer to the manual.');
 236             ReportSvcStatus(SERVICE_STOPPED, 2, 0);
 237          end;
 238       end
 239       else begin
 240          Out.writeln('Error: Missing configuration file.');
 241          ReportSvcStatus(SERVICE_STOPPED, 1, 0);
 242       end;
 243    end;
 244 end;
 245
 246
 247 begin
 248    Out.writeln('MegaBrutal''s SMTP Server, version ' + VERSION_STR + ', ' + IntToStr(PLATFORM_BITS) + ' bits');
 249    Out.writeln('Copyright (C) 2010-2014 MegaBrutal');
 250    AddDevComment(Out);
 251    Out.writeln;
 252
 253    { TODO: Process arguments here. }
 254    Cmdline:= TArgumentParser.Create(CmdlineToStringArray, ArgumentPrefixes);
 255    WrongArgument:= Cmdline.ValidateArguments(ValidArguments);
 256
 257    if WrongArgument = -1 then begin
 258
 259       ServiceMode:= false;
 260
 261       if Cmdline.IsPresent('?') or Cmdline.IsPresent('HELP') then begin
 262          Out.writeln('Supported arguments:');
 263          Out.writeln('/INSTALL   - registers the actual MgSMTP binary');
 264          Out.writeln('             as a Windows service.');
 265          Out.writeln('/UNINSTALL - unregisters the MgSMTP service.');
 266          Out.writeln('/USERMODE  - starts MgSMTP in user mode');
 267          Out.writeln('             (not recommended, should be only');
 268          Out.writeln('             used for debugging).');
 269          Out.writeln;
 270          Out.writeln('For more information on usage, see readme.txt.');
 271          Out.writeln('For license details, see license.txt.');
 272          Out.writeln;
 273          Out.writeln('If you can''t find any of these files, you');
 274          Out.writeln('don''t have the complete distribution of');
 275          Out.writeln('this software. In that case, download a');
 276          Out.writeln('proper distribution from SourceForge:');
 277          Out.writeln('https://sourceforge.net/projects/mgsmtp/');
 278       end
 279
 280       else if (Cmdline.IsPresent('INSTALL') or Cmdline.IsPresent('UNINSTALL')) then begin
 281          { Register / unregister service. }
 282          hSCManager:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
 283          if hSCManager <> 0 then begin
 284             if Cmdline.IsPresent('INSTALL') then begin
 285                if CreateService(hSCManager, 'MgSMTP', 'MegaBrutal''s SMTP Server (MgSMTP)', SC_MANAGER_ALL_ACCESS,
 286                   SERVICE_WIN32_OWN_PROCESS,
 287                   SERVICE_AUTO_START, SERVICE_ERROR_NORMAL,
 288                   PChar(ParamStr(0)),
 289                   nil,
 290                   nil,
 291                   nil,
 292                   nil,
 293                   nil) <> 0 then
 294                      Out.writeln('Service registered successfully.')
 295                   else
 296                      Out.writeln('CreateService failed!');
 297             end
 298             else if Cmdline.IsPresent('UNINSTALL') then begin
 299                hService:= OpenService(hSCManager, 'MgSMTP', SC_MANAGER_ALL_ACCESS);
 300                if hService <> 0 then begin
 301                   if DeleteService(hService) then
 302                      Out.writeln('Service unregistered successfully.')
 303                   else
 304                      Out.writeln('DeleteService failed!');
 305                end
 306                else Out.writeln('OpenService failed!');
 307             end;
 308          end
 309          else Out.writeln('OpenSCManager failed!');
 310       end
 311
 312       else begin
 313          if Cmdline.IsPresent('USERMODE') then begin
 314             Out.writeln('Starting MgSMTP in user mode...');
 315             SetConsoleCtrlHandler(ConsoleCtrlHandler, true);
 316             Service(0, nil);
 317          end
 318          else begin
 319             Out.writeln('Trying to contact Service Control Manager...');
 320             Out.writeln('(If you see this message on console, you tried to');
 321             Out.writeln('start up the program incorrectly. Your current');
 322             Out.writeln('attempt will fail, or it may hang under Wine.)');
 323             Out.writeln;
 324             ServiceMode:= true;
 325             if not StartServiceCtrlDispatcher(ServiceTable) then begin
 326                ServiceMode:= false;
 327                Out.writeln('Failed!');
 328                Out.writeln;
 329                Out.writeln('You need to start MgSMTP as a service,');
 330                Out.writeln('or supply proper arguments!');
 331                Out.writeln('Issue with /? for more information.');
 332             end;
 333          end;
 334       end
 335
 336    end
 337
 338    else begin
 339
 340       Out.writeln('Invalid argument: ' + Cmdline.GetArgument(WrongArgument).Option + '!');
 341
 342    end;
 343 end.