program sendmail;
{
<license.txt>
fake sendmail for windows
Copyright (c) 2004-2011, Byron Jones, sendmail@glob.com.au
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of the glob nor the names of its contributors may
be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
</license.txt>
<ChangeLog.txt>
version 32 (18 june 2011)
- fix handling of invalid recipients
version 31 (15 sep, 2010)
- fix encoding of 8-bit data
version 30 (30 aug, 2010)
- update to latest indy version (fixes many issues)
- add about/version
version 29 (sep 8, 2009)
- fix for another indy 10 "range check error" (when using ssl)
version 28 (aug 12, 2009)
- set ERRORLEVEL to -1 to assist php
version 27 (aug 3, 2009)
- don't treat log write errors as fatal
version 26 (apr 1, 2009)
- no longer require -t parameter
- skip first line if it starts with "from " (mail spool delimiting line)
version 25 (mar 29, 2009)
- added force_recipient
version 24 (dec 2, 2008)
- fixes for ssl
version 23 (apr 24, 2008)
- fix timezone in date header
version 22 (jan 14, 2008)
- fixes to error handling
version 21 (jan 2, 2008)
- added TLS support
version 20 (apr 3, 2007)
- fixed race condition in IIS's pickup delivery
version 19 (jul 24, 2006)
- added support for delivery via IIS's pickup directory
- optionally reads settings from the registry (in absense of the ini file)
version 18 (may 1, 2006)
- fix for indy 10 "range check error"
version 17 (nov 2, 2005)
- only process message header
- optionally use madexcept for detailed crash dumps
version 16 (sep 12, 2005)
- send hostname and domain with HELO/EHLO
- configurable HELO/EHLO hostname
- upgraded to indy 10
version 15 (aug 23, 2005)
- fixes error messages when debug_logfile is not specified
version 14 (jun 28, 2005)
- errors output to STDERR
- fixes for delphi 7 compilation
- added 'connecting to..' debug logging
- reworked error and debug log format
version 13 (jun 8, 2005)
- added fix to work around invalid multiple header instances
version 12 (apr 30, 2005)
- added cc and bcc support
version 11 (feb 17, 2005)
- added pop3 support (for pop before smtp authentication)
version 10 (feb 11, 2005)
- added support for specifying a different smtp port
version 9 (sep 22, 2004)
- added force_sender
version 8 (sep 22, 2004)
- *really* fixes broken smtp auth
version 7 (sep 22, 2004)
- fixes broken smtp auth
version 6 (sep 22, 2004)
- correctly quotes MAIL FROM and RCPT TO addresses in <>
version 5 (sep 16, 2004)
- now sends the message unchanged (rather than getting indy
to regenerate it)
version 4 (aug 17, 2004)
- added debug_logfile parameter
- improved error messages
version 3 (jul 15, 2004)
- smtp authentication support
- clearer error message when missing from or to address
- optional error logging
- adds date: if missing
version 2 (jul 6, 2004)
- reads default domain from registry (.ini setting overrides)
version 1 (jul 1, 2004)
- initial release
</ChangeLog.txt>
requires indy 10.2 or higher
i use a Tiburon branch svn pull
https://svn.atozed.com:444/svn/Indy10/branches/Tiburon
http://www.indyproject.org/Sockets/Docs/Indy10Installation.EN.aspx
}
{$APPTYPE CONSOLE}
{$I IdCompilerDefines.inc}
{$IFNDEF INDY100}indy version 10 is required; built against 10_5_6{$ENDIF}
{$DEFINE USE_MADEXCEPT}
uses
Windows, Classes, SysUtils, Registry, IniFiles,
IdGlobal, IdResourceStringsCore, IdGlobalProtocols, IdResourceStrings, IdExplicitTLSClientServerBase,
IDSmtp, IDPOP3, IdMessage, IdEmailAddress, IdLogFile, IdWinSock2, IdIOHandler, IdSSLOpenSSL, IdException
{$IFDEF USE_MADEXCEPT}
, madExcept, madLinkDisAsm, madListHardware, madListProcesses, madListModules
{$ENDIF}
;
// ---------------------------------------------------------------------------
const
VERSION = '32';
// ---------------------------------------------------------------------------
function buildLogLine(data, prefix: string) : string;
// ensure the output of error and debug logs are in the same format, regardless of source
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
// TidLogFile using buildLogLine function
TlogFile = class(TidLogFile)
protected
procedure LogReceivedData(const AText, AData: string); override;
procedure LogSentData(const AText, AData: string); override;
procedure LogStatus(const AText: string); override;
public
procedure LogWriteString(const AText: string); override;
end;
// ---------------------------------------------------------------------------
procedure TlogFile.LogReceivedData(const AText, AData: string);
begin
// ignore AText as it contains the date/time
LogWriteString(buildLogLine(Adata, '<<'));
end;
// ---------------------------------------------------------------------------
procedure TlogFile.LogSentData(const AText, AData: string);
begin
// ignore AText as it contains the date/time
LogWriteString(buildLogLine(Adata, '>>'));
end;
// ---------------------------------------------------------------------------
procedure TlogFile.LogStatus(const AText: string);
begin
LogWriteString(buildLogLine(AText, '**'));
end;
// ---------------------------------------------------------------------------
procedure TlogFile.LogWriteString(const AText: string);
begin
// protected --> public
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;
// the rfc says that some fields are only allowed once in a message header
// for example, to, from, subject
// this function joins multiple instances of the specified field into a single comma seperated line
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 := '';
// only modify the header if there's more than one instance of the field
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;
// more than on instance of the field, combine into single entry, ignore fields with empty values
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: TDateTime): 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),
UTCOffsetToStr(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;
ExitProcess(DWORD(-1));
end;
{$ENDIF}
// ---------------------------------------------------------------------------
var
smtpServer : string;
smtpPort : string;
smtpSSL : (ssAuto, ssSSL, ssTLS, ssNone);
defaultDomain : string;
messageContent: string;
authUsername : string;
authPassword : string;
forceSender : string;
forceRcpt : string;
pop3server : string;
pop3username : string;
pop3password : string;
hostname : string;
isPickup : boolean;
reg : TRegistry;
ini : TCustomIniFile;
pop3: TIdPop3;
smtp: TIdSmtp;
i : integer;
s : string;
ss : TStringStream;
msg : TIdMessage;
sl : TStringList;
header: boolean;
fs : TFileStream;
validRecipientCount: integer;
begin
// command line help
if (ParamStr(1) = '-h') then
begin
writeln('fake sendmail version ' + VERSION);
writeln('http://glob.com.au/sendmail');
halt(1);
end;
// read default domain from registry
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;
// read ini
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', '');
forceRcpt := ini.ReadString('sendmail', 'force_recipient', '');
pop3server := ini.ReadString('sendmail', 'pop3_server', '');
pop3username := ini.ReadString('sendmail', 'pop3_username', '');
pop3password := ini.ReadString('sendmail', 'pop3_password', '');
s := LowerCase(ini.ReadString('sendmail', 'smtp_ssl', 'auto'));
if (s = 'ssl') then
smtpSSL := ssSSL
else if (s = 'tls') then
smtpSSL := ssTLS
else if (s = 'none') then
smtpSSL := ssNone
else
smtpSSL := ssAuto;
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');
ExitProcess(DWORD(-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);
s := ParamStr(1);
if (s <> '') and (s[1] <> '-') and (FileExists(s)) then
begin
// read email from file
fs := TFileStream.Create(ParamStr(1), fmOpenRead + fmShareDenyWrite);
try
setLength(messageContent, fs.Size);
fs.Read(messageContent[1], length(messageContent));
finally
fs.Free;
end;
end
else
begin
// read email from stdin
messageContent := '';
while (not eof(Input)) do
begin
readln(Input, s);
if (messageContent = '') and (copy(s, 1, 5) = 'From ') then
continue;
messageContent := messageContent + s + #13#10;
end;
end;
// make sure message is CRLF delimited
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;
// fix multiple to, cc, bcc and subject fields
messageContent := joinMultiple(messageContent, 'to');
messageContent := joinMultiple(messageContent, 'cc');
messageContent := joinMultiple(messageContent, 'bcc');
messageContent := joinMultiple(messageContent, 'subject');
// deliver message
{$IFDEF USE_MADEXCEPT}
RegisterExceptionHandler(madExceptionHandler, stTrySyncCallAlways);
{$ENDIF}
try
if (isPickup) then
begin
// drop to IIS's pickup directory
ForceDirectories(smtpServer + 'Temp');
// generate filename (in the temp directory)
setLength(s, MAX_PATH);
if (GetTempFileName(pChar(smtpServer + 'Temp'), 'sm', 0, @s[1]) = 0) then
RaiseLastOSError;
s := strPas(pChar(s));
// write
fs := TFileStream.Create(s, fmCreate);
try
fs.Write(messageContent[1], length(messageContent));
finally
fs.free;
end;
// move into the real pickup directory
if (not RenameFile(s, smtpServer + ChangeFileExt(ExtractFileName(s), '.eml'))) then
RaiseLastOSError;
RemoveDir(smtpServer + 'Temp');
end
else
begin
// deliver via smtp
// load message into stream
ss := TStringStream.Create(messageContent);
msg := nil;
try
// load message
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;
// check for from and to
if (forceSender = '') and (Msg.From.Address = '') then
raise Exception.Create('Message is missing sender''s address');
if (forceRcpt = '') and (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
try
debug := TlogFile.Create(nil);
debug.FileName := debugLogFile;
debug.Active := True;
except
// silently ignore
debug := nil;
end;
end
else
debug := nil;
if ((pop3server <> '') and (pop3username <> '')) then
begin
// pop3 before smtp auth
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
// if openSSL libraries are available, use SSL for TLS support
smtp.IOHandler := nil;
smtp.ManagedIOHandler := True;
if (smtpSSL <> ssNone) then
begin
try
TIdSSLContext.Create.Free;
smtp.IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(smtp);
if (smtpSSL = ssAuto) then
if (strToIntDef(smtpPort, 25) = 465) then
smtpSSL := ssSSL
else
smtpSSL := ssTLS;
if (smtpSSL = ssSSL) then
smtp.UseTLS := utUseImplicitTLS
else
smtp.UseTLS := utUseExplicitTLS;
except
on e:exception do
begin
debugLog('Failed to load SSL libraries: ' + e.message);
smtp.IOHandler := nil;
end;
end;
end;
if (smtp.IOHandler = nil) then
begin
smtp.IOHandler := TIdIOHandler.MakeDefaultIOHandler(smtp);
smtp.UseTLS := utNoTLSSupport;
end;
if (debug <> nil) then
begin
smtp.IOHandler.Intercept := debug;
smtp.IOHandler.OnStatus := smtp.OnStatus;
end;
// set host, port
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;
// set hostname (for helo/ehlo)
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;
// connect to server
debugLog('Connecting to ' + smtp.Host + ':' + intToStr(smtp.Port));
smtp.ConnectTimeout := 10 * 1000;
smtp.Connect;
// set up authentication
if (authUsername <> '') then
begin
debugLog('Authenticating as ' + authUsername);
smtp.AuthType := satDefault;
smtp.Username := authUsername;
smtp.Password := authPassword;
end;
// authenticate and start tls
smtp.Authenticate;
// sender and recipients
validRecipientCount := 0;
if (forceSender = '') then
smtp.SendCmd('MAIL FROM: <' + appendDomain(Msg.From.Address, defaultDomain) + '>', [250])
else
smtp.SendCmd('MAIL FROM: <' + appendDomain(forceSender, defaultDomain) + '>', [250]);
if (forceRcpt = '') then
begin
for i := 0 to msg.Recipients.Count - 1 do
if (smtp.SendCmd('RCPT TO: <' + appendDomain(Msg.Recipients[i].Address, defaultDomain) + '>', [250, 550]) = 250) then
inc(validRecipientCount)
else
errorLog('Invalid recipient <' + appendDomain(Msg.Recipients[i].Address, defaultDomain) + '>');
for i := 0 to msg.ccList.Count - 1 do
if (smtp.SendCmd('RCPT TO: <' + appendDomain(Msg.ccList[i].Address, defaultDomain) + '>', [250, 550]) = 250) then
inc(validRecipientCount)
else
errorLog('Invalid recipient <' + appendDomain(Msg.ccList[i].Address, defaultDomain) + '>');
for i := 0 to msg.BccList.Count - 1 do
if (smtp.SendCmd('RCPT TO: <' + appendDomain(Msg.BccList[i].Address, defaultDomain) + '>', [250, 550]) = 250) then
inc(validRecipientCount)
else
errorLog('Invalid recipient <' + appendDomain(Msg.BccList[i].Address, defaultDomain) + '>');
end
else
if (smtp.SendCmd('RCPT TO: <' + appendDomain(forceRcpt, defaultDomain) + '>', [250, 550]) = 250) then
inc(validRecipientCount)
else
errorLog('Invalid recipient <' + appendDomain(forceRcpt, defaultDomain) + '>');
if (validRecipientCount = 0) then
raise Exception.Create('No valid recipients were found');
// start message content
smtp.SendCmd('DATA', [354]);
// add date header if missing
if (Msg.Headers.Values['date'] = '') then
smtp.IOHandler.WriteLn('Date: ' + DateTimeToInternetStr(Now));
// send message line by line
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], TIdTextEncoding.Default);
end;
finally
sl.Free;
end;
// done
smtp.SendCmd('.', [250]);
try
smtp.SendCmd('QUIT');
except
on e:EIdConnClosedGracefully do
;// ignore
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}
ExitProcess(DWORD(-1));
{$ENDIF}
end;
end;
end.