program sendmail;
{$APPTYPE CONSOLE}
{$I IdCompilerDefines.inc}
{$IFNDEF INDY100}indy version 10 is required{$ENDIF}
{$DEFINE USE_MADEXCEPT}
uses
Windows, Classes, SysUtils, Registry, IniFiles,
IdGlobal, IdResourceStringsCore, IdGlobalProtocols, IdResourceStrings, IdExplicitTLSClientServerBase,
IDSmtp, IDPOP3, IdMessage, IdEmailAddress, IdLogFile, IdWinSock2, IdIOHandler, IdSys, IdSSLOpenSSL, IdException, IdSysWin32
{$IFDEF USE_MADEXCEPT}
, madExcept, madLinkDisAsm, madListHardware, madListProcesses, madListModules
{$ENDIF}
;
function buildLogLine(data, prefix: string) : string;
begin
data := StringReplace(data, EOL, RSLogEOL, [rfReplaceAll]);
data := StringReplace(data, CR, RSLogCR, [rfReplaceAll]);
data := StringReplace(data, LF, RSLogLF, [rfReplaceAll]);
result := FormatDateTime('yy/mm/dd hh:nn:ss', now) + ' ';
if (prefix <> '') then
result := result + prefix + ' ';
result := result + data + EOL;
end;
type
TlogFile = class(TidLogFile)
protected
procedure LogReceivedData(AText: string; AData: string); override;
procedure LogSentData(AText: string; AData: string); override;
procedure LogStatus(AText: string); override;
public
procedure LogWriteString(AText: string); override;
end;
procedure TlogFile.LogReceivedData(AText: string; AData: string);
begin
LogWriteString(buildLogLine(Adata, '<<'));
end;
procedure TlogFile.LogSentData(AText: string; AData: string);
begin
LogWriteString(buildLogLine(Adata, '>>'));
end;
procedure TlogFile.LogStatus(AText: string);
begin
LogWriteString(buildLogLine(AText, '**'));
end;
procedure TlogFile.LogWriteString(AText: string);
begin
inherited;
end;
var
errorLogFile: string;
debugLogFile: string;
debug : TlogFile;
procedure writeToLog(const logFilename, logMessage: string; const prefix: string = '');
var
f: TextFile;
begin
AssignFile(f, logFilename);
try
if (not FileExists(logFilename)) then
begin
ForceDirectories(ExtractFilePath(logFilename));
Rewrite(f);
end
else
Append(f);
write(f, buildLogLine(logMessage, prefix));
closeFile(f);
except
on e:Exception do
writeln(ErrOutput, 'sendmail: Error writing to ' + logFilename + ': ' + logMessage);
end;
end;
procedure debugLog(const logMessage: string);
begin
if (debug <> nil) and (debug.Active) then
debug.LogWriteString(buildLogLine(logMessage, '**'))
else if (debugLogFile <> '') then
writeToLog(debugLogFile, logMessage, '**');
end;
procedure errorLog(const logMessage: string);
begin
if (errorLogFile <> '') then
writeToLog(errorLogFile, logMessage, ':');
debugLog(logMessage);
end;
function appendDomain(const address, domain: string): string;
begin
Result := address;
if (Pos('@', address) <> 0) then
Exit;
Result := Result + '@' + domain;
end;
function joinMultiple(const messageContent: string; fieldName: string): string;
var
sl : TstringList;
i : integer;
s : string;
n : integer;
count : integer;
values: TstringList;
begin
fieldName := LowerCase(fieldName);
sl := TStringList.Create;
values := TStringList.Create;
try
sl.text := messageContent;
result := '';
count := 0;
for i := 0 to sl.count - 1 do
begin
s := sl[i];
if (s = '') then
break;
n := pos(':', s);
if (n = 0) then
break;
if (lowerCase(copy(s, 1, n - 1)) = fieldName) then
inc(count);
end;
if (count <= 1) then
begin
result := messageContent;
exit;
end;
while (sl.count > 0) do
begin
s := sl[0];
if (s = '') then
break;
n := pos(':', s);
if (n = 0) then
break;
if (lowerCase(copy(s, 1, n - 1)) = fieldName) then
begin
s := trim(copy(s, n + 1, length(s)));
if (s <> '') then
values.Add(s);
end
else
result := result + s + #13#10;
sl.Delete(0);
end;
if (values.count <> 0) then
begin
s := UpCaseFirst(fieldName) + ': ';
for i := 0 to values.count - 1 do
s := s + values[i] + ', ';
setLength(s, length(s) - 2);
result := result + s + #13#10;
end;
result := result + sl.Text;
finally
values.Free;
sl.free;
end;
end;
function DateTimeToInternetStr(const Value: TIdDateTimeBase): string;
var
day : word;
month: word;
year : word;
begin
DecodeDate(Value, year, month, day);
Result := Format(
'%s, %d %s %d %s %s',
[
wdays[DayOfWeek(Value)],
day,
monthnames[month],
year,
FormatDateTime('HH":"mm":"ss', Value),
Sys.DateTimeToGmtOffSetStr(TIdSysWin32.OffsetFromUTC, false)
]
);
end;
{$IFDEF USE_MADEXCEPT}
procedure madExceptionHandler(const exceptIntf: IMEException; var handled: boolean);
var
path: string;
i : integer;
fs : TFileStream;
s : string;
begin
handled := true;
path := extractFilePath(debugLogFile);
deleteFile(path + 'crash-5.txt');
for i := 4 downto 1 do
if (fileExists(path + 'crash-' + intToStr(i) + '.txt')) then
RenameFile(path + 'crash-'+ intToStr(i) + '.txt', path + 'crash-' + intToStr(i + 1) + '.txt');
if (fileExists(path + 'crash.txt')) then
RenameFile(path + 'crash.txt', path + 'crash-1.txt');
fs := TFileStream.Create(path + 'crash.txt', fmCreate);
try
s := exceptIntf.GetBugReport;
fs.Write(s[1], length(s));
finally
fs.free;
end;
halt(1);
end;
{$ENDIF}
var
smtpServer : string;
smtpPort : string;
defaultDomain : string;
messageContent: string;
authUsername : string;
authPassword : string;
forceSender : string;
pop3server : string;
pop3username : string;
pop3password : string;
hostname : string;
isPickup : boolean;
reg : TRegistry;
ini : TCustomIniFile;
pop3: TIdPop3;
smtp: TIdSmtp;
i : integer;
s : string;
found : boolean;
ss : TStringStream;
msg : TIdMessage;
sl : TStringList;
header: boolean;
fs : TFileStream;
begin
found := False;
for i := 1 to ParamCount do
if (ParamStr(i) = '-t') then
begin
found := True;
break;
end;
if (not found) then
begin
writeln(ErrOutput, 'sendmail requires -t parameter');
halt(1);
end;
reg := TRegistry.Create;
try
reg.RootKey := HKEY_LOCAL_MACHINE;
if (reg.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters')) then
defaultDomain := reg.ReadString('Domain');
finally
reg.Free;
end;
s := ChangeFileExt(ParamStr(0), '.ini');
if (FileExists(s)) then
ini := TIniFile.Create(s)
else
begin
ini := TRegistryIniFile.Create('\software');
TRegistryIniFile(ini).RegIniFile.RootKey := HKEY_LOCAL_MACHINE;
TRegistryIniFile(ini).RegIniFile.OpenKey(TRegistryIniFile(ini).FileName, true);
end;
try
smtpServer := ini.ReadString('sendmail', 'smtp_server', 'mail.mydomain.com');
smtpPort := ini.ReadString('sendmail', 'smtp_port', '25');
defaultDomain := ini.ReadString('sendmail', 'default_domain', defaultDomain);
hostname := ini.ReadString('sendmail', 'hostname', '');
errorLogFile := ini.ReadString('sendmail', 'error_logfile', '');
debugLogFile := ini.ReadString('sendmail', 'debug_logfile', '');
authUsername := ini.ReadString('sendmail', 'auth_username', '');
authPassword := ini.ReadString('sendmail', 'auth_password', '');
forceSender := ini.ReadString('sendmail', 'force_sender', '');
pop3server := ini.ReadString('sendmail', 'pop3_server', '');
pop3username := ini.ReadString('sendmail', 'pop3_username', '');
pop3password := ini.ReadString('sendmail', 'pop3_password', '');
if (smtpServer = 'mail.mydomain.com') or (defaultDomain = 'mydomain.com') then
begin
writeln(ErrOutput, 'You must configure the smtp_server and default_domain in:');
writeln(ErrOutput, ' ' + ini.fileName);
writeln(ErrOutput, ' or');
writeln(ErrOutput, ' HKLM\Software\Sendmail');
halt(1);
end;
finally
ini.Free;
end;
if (errorLogFile <> '') and (ExtractFilePath(errorLogFile) = '') then
errorLogFile := ExtractFilePath(ParamStr(0)) + errorLogFile;
if (debugLogFile <> '') and (ExtractFilePath(debugLogFile) = '') then
debugLogFile := ExtractFilePath(ParamStr(0)) + debugLogFile;
isPickup := DirectoryExists(smtpServer);
if (isPickup) then
smtpServer := IncludeTrailingPathDelimiter(smtpServer);
messageContent := '';
while (not eof(Input)) do
begin
readln(Input, s);
messageContent := messageContent + s + #13#10;
end;
if (pos(#10, messageContent) = 0) then
messageContent := stringReplace(messageContent, #13, #13#10, [rfReplaceAll]);
if (debugLogFile <> '') then
begin
debugLog('--- MESSAGE BEGIN ---');
sl := TStringList.Create;
try
sl.Text := messageContent;
for i := 0 to sl.Count - 1 do
debugLog(sl[i]);
finally
sl.Free;
end;
debugLog('--- MESSAGE END ---');
end;
messageContent := joinMultiple(messageContent, 'to');
messageContent := joinMultiple(messageContent, 'cc');
messageContent := joinMultiple(messageContent, 'bcc');
messageContent := joinMultiple(messageContent, 'subject');
{$IFDEF USE_MADEXCEPT}
RegisterExceptionHandler(madExceptionHandler, stTrySyncCallAlways);
{$ENDIF}
try
if (isPickup) then
begin
ForceDirectories(smtpServer + 'Temp');
setLength(s, MAX_PATH);
if (GetTempFileName(pChar(smtpServer + 'Temp'), 'sm', 0, @s[1]) = 0) then
RaiseLastOSError;
s := strPas(pChar(s));
fs := TFileStream.Create(s, fmCreate);
try
fs.Write(messageContent[1], length(messageContent));
finally
fs.free;
end;
if (not RenameFile(s, smtpServer + ChangeFileExt(ExtractFileName(s), '.eml'))) then
RaiseLastOSError;
RemoveDir(smtpServer + 'Temp');
end
else
begin
ss := TStringStream.Create(messageContent);
msg := nil;
try
msg := TIdMessage.Create(nil);
try
msg.LoadFromStream(ss, true);
except
on e:exception do
raise exception.create('Failed to read email message: ' + e.message);
end;
if (forceSender = '') and (Msg.From.Address = '') then
raise Exception.Create('Message is missing sender''s address');
if (Msg.Recipients.Count = 0) and (Msg.CCList.Count = 0) and (Msg.BccList.Count = 0) then
raise Exception.Create('Message is missing recipient''s address');
if (debugLogFile <> '') then
begin
debug := TlogFile.Create(nil);
debug.FileName := debugLogFile;
debug.Active := True;
end
else
debug := nil;
if ((pop3server <> '') and (pop3username <> '')) then
begin
debugLog('Authenticating with POP3 server');
pop3 := TIdPOP3.Create(nil);
try
if (debug <> nil) then
begin
pop3.IOHandler := TIdIOHandler.MakeDefaultIOHandler(pop3);
pop3.IOHandler.Intercept := debug;
pop3.IOHandler.OnStatus := pop3.OnStatus;
pop3.ManagedIOHandler := True;
end;
pop3.Host := pop3server;
pop3.Username := pop3username;
pop3.Password := pop3password;
pop3.ConnectTimeout := 10 * 1000;
pop3.Connect;
pop3.Disconnect;
finally
pop3.free;
end;
end;
smtp := TIdSMTP.Create(nil);
try
try
TIdSSLContext.Create.Free;
smtp.IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(smtp);
smtp.UseTLS := utUseExplicitTLS;
except
smtp.IOHandler := TIdIOHandler.MakeDefaultIOHandler(smtp);
smtp.UseTLS := utNoTLSSupport;
end;
smtp.ManagedIOHandler := True;
if (debug <> nil) then
begin
smtp.IOHandler.Intercept := debug;
smtp.IOHandler.OnStatus := smtp.OnStatus;
end;
i := pos(':', smtpServer);
if (i = 0) then
begin
smtp.host := smtpServer;
smtp.port := strToIntDef(smtpPort, 25);
end
else
begin
smtp.host := copy(smtpServer, 1, i - 1);
smtp.port := strToIntDef(copy(smtpServer, i + 1, length(smtpServer)), 25);
end;
if (hostname = '') then
begin
setLength(hostname, 255);
GetHostName(pChar(hostname), length(hostname));
hostname := string(pChar(hostname));
if (pos('.', hostname) = 0) and (defaultDomain <> '') then
hostname := hostname + '.' + defaultDomain;
end;
smtp.HeloName := hostname;
debugLog('Connecting to ' + smtp.Host + ':' + intToStr(smtp.Port));
smtp.ConnectTimeout := 10 * 1000;
smtp.Connect;
if (authUsername <> '') then
begin
debugLog('Authenticating as ' + authUsername);
smtp.AuthType := atDefault;
smtp.Username := authUsername;
smtp.Password := authPassword;
end;
smtp.Authenticate;
if (forceSender = '') then
smtp.SendCmd('MAIL FROM: <' + appendDomain(Msg.From.Address, defaultDomain) + '>', [250])
else
smtp.SendCmd('MAIL FROM: <' + appendDomain(forceSender, defaultDomain) + '>', [250]);
for i := 0 to msg.Recipients.Count - 1 do
smtp.SendCmd('RCPT TO: <' + appendDomain(Msg.Recipients[i].Address, defaultDomain) + '>', [250]);
for i := 0 to msg.ccList.Count - 1 do
smtp.SendCmd('RCPT TO: <' + appendDomain(Msg.ccList[i].Address, defaultDomain) + '>', [250]);
for i := 0 to msg.BccList.Count - 1 do
smtp.SendCmd('RCPT TO: <' + appendDomain(Msg.BccList[i].Address, defaultDomain) + '>', [250]);
smtp.SendCmd('DATA', [354]);
if (Msg.Headers.Values['date'] = '') then
smtp.IOHandler.WriteLn('Date: ' + DateTimeToInternetStr(Now));
sl := TStringList.Create;
try
sl.Text := messageContent;
header := true;
for i := 0 to sl.Count - 1 do
begin
if (i = 0) and (sl[i] = '') then
continue;
if (sl[i] = '') then
header := false;
if (header) and (LowerCase(copy(sl[i], 1, 5)) = 'bcc: ') then
continue;
smtp.IOHandler.WriteLn(sl[i]);
end;
finally
sl.Free;
end;
smtp.SendCmd('.', [250]);
try
smtp.SendCmd('QUIT');
except
on e:EIdConnClosedGracefully do
; on e:Exception do
raise;
end;
finally
if (smtp.Connected) then
debugLog('Disconnecting from ' + smtp.Host + ':' + intToStr(smtp.Port));
smtp.Free;
end;
finally
msg.Free;
ss.Free;
end;
end;
except
on e:Exception do
begin
writeln(ErrOutput, 'sendmail: Error during delivery: ' + e.message);
errorLog(e.Message);
{$IFDEF USE_MADEXCEPT}
raise;
{$ELSE}
halt(1);
{$ENDIF}
end;
end;
end.