MgSMTP.pas

   1 {
   2    MegaBrutal's SMTP Server (MgSMTP)
   3    Copyright (C) 2010-2015 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  =  'EHLO->HELO fallback';
  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 procedure Service(Argc: dword; Argv: pointer); stdcall;
 134 var ProposedExitCode: integer;
 135 begin
 136    ProposedExitCode:= 0;
 137    Stopping:= false;
 138    SetLastError(0);
 139
 140    if ServiceMode then
 141       hSvcStatusHandle:= RegisterServiceCtrlHandlerEx('MgSMTP', @SvcCtrlHandlerEx, nil);
 142
 143    if ServiceMode and (hSvcStatusHandle = 0) then
 144       Out.writeln('RegisterServiceCtrlHandlerEx failed!'#13#10'Error code: ' + IntToStr(GetLastError))
 145    else begin
 146       SvcStatus.dwServiceType:= SERVICE_WIN32_OWN_PROCESS;
 147       SvcStatus.dwServiceSpecificExitCode:= 0;
 148       SvcStatus.dwCheckPoint:= 0;
 149
 150       ReportSvcStatus(SERVICE_START_PENDING, 0, 1000);
 151
 152       if ServiceMode then Out.writeln('Started in service mode.');
 153
 154       Randomize;
 155       SetCurrentDir(ExtractFilePath(ParamStr(0)));
 156
 157       if not DirectoryExists('mail')  then CreateDir('mail');
 158       if not DirectoryExists('spool') then CreateDir('spool');
 159
 160       if FileExists('mgsmtp_server.ini') then begin
 161
 162          Config:= TExtBoolINIFile.Create('mgsmtp_server.ini');
 163
 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);
 171
 172             if Config.ReadBool('Spool', 'KeepProcessedEnvelopes', false)
 173             or Config.ReadBool('Spool', 'KeepProcessedEMails', false) then
 174                if not DirectoryExists('processed') then CreateDir('processed');
 175
 176             Config.Free;
 177
 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.');
 183
 184             if not MailboxManager.Verify('postmaster') then
 185                ProposedExitCode:= 3;
 186
 187             if SpoolManager.DeliveryThreadNumber > Length(GetAlphabetStr) then
 188                ProposedExitCode:= 4;
 189
 190             if ProposedExitCode = 0 then begin
 191                SpoolManager.StartDeliveryThreads;
 192                StartListeners;
 193
 194                ReportSvcStatus(SERVICE_RUNNING, 0, 0);
 195                while not Stopping do Sleep(1000);
 196
 197                ReportSvcStatus(SERVICE_STOP_PENDING, 0, SpoolManager.ThreadWait * 2);
 198
 199                StopListeners;
 200                SpoolManager.StopDeliveryThreads;
 201             end
 202             else begin
 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)) + '.');
 206                end;
 207                ReportSvcStatus(SERVICE_STOPPED, ProposedExitCode, 0);
 208             end;
 209
 210             ReportSvcStatus(SERVICE_STOP_PENDING, 0, 2000);
 211
 212             Logger.AddStdLine('Clean shutdown.');
 213
 214             PolicyManager.Free;
 215             SpoolManager.Free;
 216             RelayManager.Free;
 217             MailboxManager.Free;
 218             Logger.Free;
 219             MainServerConfig.Free;
 220             ReportSvcStatus(SERVICE_STOPPED, 0, 0);
 221          end
 222          else begin
 223             Config.Free;
 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);
 227          end;
 228       end
 229       else begin
 230          Out.writeln('Error: Missing configuration file.');
 231          ReportSvcStatus(SERVICE_STOPPED, 1, 0);
 232       end;
 233    end;
 234 end;
 235
 236
 237 begin
 238    Out.writeln('MegaBrutal''s SMTP Server, version ' + VERSION_STR + ', ' + IntToStr(PLATFORM_BITS) + ' bits');
 239    Out.writeln('Copyright (C) 2010-2014 MegaBrutal');
 240    AddDevComment(Out);
 241    Out.writeln;
 242
 243    { TODO: Process arguments here. }
 244    Cmdline:= TArgumentParser.Create(CmdlineToStringArray, ArgumentPrefixes);
 245    WrongArgument:= Cmdline.ValidateArguments(ValidArguments);
 246
 247    if WrongArgument = -1 then begin
 248
 249       ServiceMode:= false;
 250
 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).');
 259          Out.writeln;
 260          Out.writeln('For more information on usage, see readme.txt.');
 261          Out.writeln('For license details, see license.txt.');
 262          Out.writeln;
 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/');
 268       end
 269
 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,
 278                   PChar(ParamStr(0)),
 279                   nil,
 280                   nil,
 281                   nil,
 282                   nil,
 283                   nil) <> 0 then
 284                      Out.writeln('Service registered successfully.')
 285                   else
 286                      Out.writeln('CreateService failed!');
 287             end
 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.')
 293                   else
 294                      Out.writeln('DeleteService failed!');
 295                end
 296                else Out.writeln('OpenService failed!');
 297             end;
 298          end
 299          else Out.writeln('OpenSCManager failed!');
 300       end
 301
 302       else begin
 303          if Cmdline.IsPresent('USERMODE') then begin
 304             Out.writeln('Starting MgSMTP in user mode...');
 305             Service(0, nil);
 306          end
 307          else begin
 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.)');
 312             Out.writeln;
 313             ServiceMode:= true;
 314             if not StartServiceCtrlDispatcher(ServiceTable) then begin
 315                ServiceMode:= false;
 316                Out.writeln('Failed!');
 317                Out.writeln;
 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.');
 321             end;
 322          end;
 323       end
 324
 325    end
 326
 327    else begin
 328
 329       Out.writeln('Invalid argument: ' + Cmdline.GetArgument(WrongArgument).Option + '!');
 330
 331    end;
 332 end.