2701 lines
101 KiB
Plaintext
2701 lines
101 KiB
Plaintext
{
|
|
$Project$
|
|
$Workfile$
|
|
$Revision$
|
|
$DateUTC$
|
|
$Id$
|
|
|
|
This file is part of the Indy (Internet Direct) project, and is offered
|
|
under the dual-licensing agreement described on the Indy website.
|
|
(http://www.indyproject.org/)
|
|
|
|
Copyright:
|
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
|
}
|
|
{
|
|
$Log$
|
|
}
|
|
{
|
|
Prior revision history
|
|
|
|
Rev 1.31 2/9/2005 11:44:20 AM JPMugaas
|
|
Fixed compiler problem and removed some warnings about virtual
|
|
methods hiding stuff in the base class.
|
|
|
|
Rev 1.30 2/8/05 6:20:16 PM RLebeau
|
|
Added additional overriden methods.
|
|
|
|
Rev 1.29 10/26/2004 11:08:06 PM JPMugaas
|
|
Updated refs.
|
|
|
|
Rev 1.28 10/21/2004 1:49:12 PM BGooijen
|
|
Raid 214213
|
|
|
|
Rev 1.27 09/06/2004 09:54:56 CCostelloe
|
|
Kylix 3 patch
|
|
|
|
Rev 1.26 2004.05.20 11:37:34 AM czhower
|
|
IdStreamVCL
|
|
|
|
Rev 1.25 4/8/2004 11:49:56 AM BGooijen
|
|
Fix for D5
|
|
|
|
Rev 1.24 03/03/2004 01:16:20 CCostelloe
|
|
Yet another check-in as part of continuing development
|
|
|
|
Rev 1.23 01/03/2004 23:32:24 CCostelloe
|
|
Another check-in as part of continuing development
|
|
|
|
Rev 1.22 3/1/2004 12:55:28 PM JPMugaas
|
|
Updated for problem with new code.
|
|
|
|
Rev 1.21 26/02/2004 02:01:14 CCostelloe
|
|
Another intermediate check-in, approx half of functions are debugged
|
|
|
|
Rev 1.20 24/02/2004 10:34:50 CCostelloe
|
|
Storage-specific code moved to IdIMAP4ServerDemo
|
|
|
|
Rev 1.19 2/22/2004 12:09:54 AM JPMugaas
|
|
Fixes for IMAP4Server compile failure in DotNET. This also fixes
|
|
a potential problem where file handles can be leaked in the server
|
|
needlessly.
|
|
|
|
Rev 1.18 12/02/2004 02:40:56 CCostelloe
|
|
Minor bugfix
|
|
|
|
Rev 1.17 12/02/2004 02:24:30 CCostelloe
|
|
Completed revision, apart from parts support and BODYSTRUCTURE, not
|
|
yet debugged.
|
|
|
|
Rev 1.16 05/02/2004 00:25:32 CCostelloe
|
|
This version actually works!
|
|
|
|
Rev 1.15 2/4/2004 2:37:38 AM JPMugaas
|
|
Moved more units down to the implementation clause in the units to
|
|
make them easier to compile.
|
|
|
|
Rev 1.14 2/3/2004 4:12:42 PM JPMugaas
|
|
Fixed up units so they should compile.
|
|
|
|
Rev 1.13 1/29/2004 9:07:54 PM JPMugaas
|
|
Now uses TIdExplicitTLSServer so it can take advantage of that framework.
|
|
|
|
Rev 1.12 1/21/2004 3:11:02 PM JPMugaas
|
|
InitComponent
|
|
|
|
Rev 1.11 27/12/2003 22:28:48 ANeillans
|
|
Design fix, Login event only passed the username (first param)
|
|
|
|
Rev 1.10 2003.10.21 9:13:08 PM czhower
|
|
Now compiles.
|
|
|
|
Rev 1.9 10/19/2003 6:00:24 PM DSiders
|
|
Added localization coimments.
|
|
|
|
Rev 1.8 9/19/2003 03:29:58 PM JPMugaas
|
|
Now should compile again.
|
|
|
|
Rev 1.7 07/09/2003 12:29:08 CCostelloe
|
|
Warning that variable LIO is declared but never used in
|
|
TIdIMAP4Server.DoCommandSTARTTLS fixed.
|
|
|
|
Rev 1.6 7/20/2003 6:20:06 PM SPerry
|
|
Switched to IdCmdTCPServer, also some modifications
|
|
|
|
Rev 1.5 3/14/2003 10:44:36 PM BGooijen
|
|
Removed warnings, changed StartSSL to PassThrough:=false;
|
|
|
|
Rev 1.4 3/14/2003 10:04:10 PM BGooijen
|
|
Removed TIdServerIOHandlerSSLBase.PeerPassthrough, the ssl is now
|
|
enabled in the server-protocol-files
|
|
|
|
Rev 1.3 3/13/2003 09:49:20 AM JPMugaas
|
|
Now uses an abstract SSL base class instead of OpenSSL so
|
|
3rd-party vendors can plug-in their products.
|
|
|
|
Rev 1.2 2/24/2003 09:03:14 PM JPMugaas
|
|
|
|
Rev 1.1 2/6/2003 03:18:14 AM JPMugaas
|
|
Updated components that compile with Indy 10.
|
|
|
|
Rev 1.0 11/13/2002 07:55:02 AM JPMugaas
|
|
|
|
2002-Apr-21 - J. Berg
|
|
use fetch()
|
|
|
|
2000-May-18 - J. Peter Mugaas
|
|
Ported to Indy
|
|
|
|
2000-Jan-13 - MTL
|
|
Moved to new Palette Scheme (Winshoes Servers)
|
|
|
|
1999-Aug-26 - Ray Malone
|
|
Started unit
|
|
}
|
|
|
|
unit IdIMAP4Server;
|
|
|
|
{
|
|
TODO (ex RFC 3501):
|
|
|
|
Dont allow & to be used as a mailbox separator.
|
|
|
|
Certain server data (unsolicited responses) MUST be recorded,
|
|
see Server Responses section.
|
|
|
|
UIDs must be unique to a mailbox AND any subsequent mailbox with
|
|
the same name - record in a text file.
|
|
|
|
\Recent cannot be changed by STORE or APPEND.
|
|
|
|
COPY should preserve the date of the original message.
|
|
|
|
|
|
TODO (ccostelloe):
|
|
|
|
Add a file recording the UIDVALIDITY in each mailbox.
|
|
|
|
Emails should be ordered in date order.
|
|
|
|
Optional date/time param to be implemented in APPEND.
|
|
|
|
Consider integrating IdUserAccounts into login mechanism
|
|
(or per-user passwords).
|
|
|
|
Implement utf mailbox encoding.
|
|
|
|
Implement * in message numbers.
|
|
|
|
Implement multiple-option FETCH commands (will need breaking out some
|
|
options which are abbreviations into their subsets).
|
|
|
|
Need some method of preserving flags permanently.
|
|
}
|
|
|
|
{
|
|
IMPLEMENTATION NOTES:
|
|
|
|
Major rewrite started 2nd February 2004, Ciaran Costelloe, ccostelloe@flogas.ie.
|
|
Prior to this, it was a simple wrapper class with a few problems.
|
|
|
|
Note that IMAP servers should return BAD for an unknown command or
|
|
invalid arguments (synthax errors and unsupported commands) and BAD
|
|
if the command is valid but there was some problem in executing
|
|
(e.g. trying a change an email's flag if it is a read-only mailbox).
|
|
|
|
FUseDefaultMechanismsForUnassignedCommands defaults to True: if you
|
|
set it to False, you need to implement command handlers for all the
|
|
commands you need to implement. If True, this class implements a
|
|
default mechanism and provides default behaviour for all commands.
|
|
It does not include any filesystem-specific functions, which you
|
|
need to implement.
|
|
|
|
The default behaviour uses a default password of 'admin' - change this
|
|
if you have any consideration for security!
|
|
|
|
FSaferMode defaults to False: you should probably leave it False for
|
|
testing, because this generates diagnostically-useful error messages.
|
|
However, setting it True generates minimal responses for the greeting
|
|
and for login failures, making life more difficult for a hacker.
|
|
|
|
WARNING: you should also implement one of the Indy-provided more-secure
|
|
logins than the default plaintext password login!
|
|
|
|
You may want to assign handlers to the OnBeforeCmd and OnBeforeSend
|
|
events to easily log data in & out of the server.
|
|
|
|
WARNING: TIdIMAP4PeerContext has a TIdMailBox which holds various
|
|
status info, including UIDs in its message collection. Do NOT use the
|
|
message collection for loading messages into, or you may thrash message
|
|
UIDs or flags!
|
|
}
|
|
|
|
interface
|
|
|
|
{$i IdCompilerDefines.inc}
|
|
|
|
{$IFDEF DOTNET}
|
|
{$I IdUnitPlatformOff.inc}
|
|
{$I IdSymbolPlatformOff.inc}
|
|
{$ENDIF}
|
|
|
|
uses
|
|
Classes,
|
|
IdAssignedNumbers,
|
|
IdCustomTCPServer, //for TIdServerContext
|
|
IdCmdTCPServer,
|
|
IdContext,
|
|
IdCommandHandlers,
|
|
IdException,
|
|
IdExplicitTLSClientServerBase,
|
|
IdIMAP4, //For some defines like TIdIMAP4ConnectionState
|
|
IdMailBox,
|
|
IdMessage,
|
|
IdReply,
|
|
IdReplyIMAP4,
|
|
IdTCPConnection,
|
|
IdYarn;
|
|
|
|
const
|
|
DEF_IMAP4_IMPLICIT_TLS = False;
|
|
|
|
type
|
|
TIMAP4CommandEvent = procedure(AContext: TIdContext; const ATag, ACmd: String) of object;
|
|
TIdIMAP4CommandBeforeEvent = procedure(ASender: TIdCommandHandlers; var AData: string; AContext: TIdContext) of object;
|
|
TIdIMAP4CommandBeforeSendEvent = procedure(AContext: TIdContext; AData: string) of object;
|
|
|
|
//For default mechanisms..
|
|
TIdIMAP4DefMech1 = function(ALoginName, AMailbox: string): Boolean of object;
|
|
TIdIMAP4DefMech2 = function(ALoginName, AMailBoxName: string; AMailBox: TIdMailBox): Boolean of object;
|
|
TIdIMAP4DefMech3 = function(ALoginName, AMailbox: string): string of object;
|
|
TIdIMAP4DefMech4 = function(ALoginName, AOldMailboxName, ANewMailboxName: string): Boolean of object;
|
|
TIdIMAP4DefMech5 = function(ALoginName, AMailBoxName: string; AMailBoxNames: TStrings; AMailBoxFlags: TStrings): Boolean of object;
|
|
TIdIMAP4DefMech6 = function(ALoginName, AMailbox: string; AMessage: TIdMessage): Boolean of object;
|
|
TIdIMAP4DefMech7 = function(ALoginName, ASourceMailBox, AMessageUID, ADestinationMailbox: string): Boolean of object;
|
|
TIdIMAP4DefMech8 = function(ALoginName, AMailbox: string; AMessage: TIdMessage): integer of object;
|
|
TIdIMAP4DefMech9 = function(ALoginName, AMailbox: string; AMessage, ATargetMessage: TIdMessage): Boolean of object;
|
|
TIdIMAP4DefMech10 = function(ALoginName, AMailbox: string; AMessage: TIdMessage; ALines: TStrings): Boolean of object;
|
|
TIdIMAP4DefMech11 = function(ASender: TIdCommand; AReadOnly: Boolean): Boolean of object;
|
|
TIdIMAP4DefMech12 = function(AParams: TStrings; AMailBoxParam: Integer): Boolean of object;
|
|
TIdIMAP4DefMech13 = function(ALoginName, AMailBoxName, ANewUIDNext: string): Boolean of object;
|
|
TIdIMAP4DefMech14 = function(ALoginName, AMailBoxName, AUID: string): string of object;
|
|
|
|
EIdIMAP4ServerException = class(EIdException);
|
|
EIdIMAP4ImplicitTLSRequiresSSL = class(EIdIMAP4ServerException);
|
|
|
|
{ custom IMAP4 context }
|
|
TIdIMAP4PeerContext = class(TIdServerContext)
|
|
protected
|
|
FConnectionState : TIdIMAP4ConnectionState;
|
|
FLoginName: string;
|
|
FMailBox: TIdMailBox;
|
|
FIMAP4Tag: String;
|
|
FLastCommand: TIdReplyIMAP4; //Used to record the client command we are currently processing
|
|
function GetUsingTLS: Boolean;
|
|
public
|
|
constructor Create(
|
|
AConnection: TIdTCPConnection;
|
|
AYarn: TIdYarn;
|
|
AList: TIdContextThreadList = nil
|
|
); override;
|
|
destructor Destroy; override;
|
|
property ConnectionState: TIdIMAP4ConnectionState read FConnectionState;
|
|
property UsingTLS : Boolean read GetUsingTLS;
|
|
property IMAP4Tag: String read FIMAP4Tag;
|
|
property MailBox: TIdMailBox read FMailBox;
|
|
property LoginName: string read FLoginName write FLoginName;
|
|
end;
|
|
|
|
{ TIdIMAP4Server }
|
|
TIdIMAP4Server = class(TIdExplicitTLSServer)
|
|
protected
|
|
//
|
|
FSaferMode: Boolean; //See IMPLEMENTATION NOTES above
|
|
FUseDefaultMechanismsForUnassignedCommands: Boolean; //See IMPLEMENTATION NOTES above
|
|
FRootPath: string; //See IMPLEMENTATION NOTES above
|
|
FDefaultPassword: string; //See IMPLEMENTATION NOTES above
|
|
FMailBoxSeparator: Char;
|
|
//
|
|
fOnDefMechDoesImapMailBoxExist: TIdIMAP4DefMech1;
|
|
fOnDefMechCreateMailBox: TIdIMAP4DefMech1;
|
|
fOnDefMechDeleteMailBox: TIdIMAP4DefMech1;
|
|
fOnDefMechIsMailBoxOpen: TIdIMAP4DefMech1;
|
|
fOnDefMechSetupMailbox: TIdIMAP4DefMech2;
|
|
fOnDefMechNameAndMailBoxToPath: TIdIMAP4DefMech3;
|
|
fOnDefMechGetNextFreeUID: TIdIMAP4DefMech3;
|
|
fOnDefMechRenameMailBox: TIdIMAP4DefMech4;
|
|
fOnDefMechListMailBox: TIdIMAP4DefMech5;
|
|
fOnDefMechDeleteMessage: TIdIMAP4DefMech6;
|
|
fOnDefMechCopyMessage: TIdIMAP4DefMech7;
|
|
fOnDefMechGetMessageSize: TIdIMAP4DefMech8;
|
|
fOnDefMechGetMessageHeader: TIdIMAP4DefMech9;
|
|
fOnDefMechGetMessageRaw: TIdIMAP4DefMech10;
|
|
fOnDefMechOpenMailBox: TIdIMAP4DefMech11;
|
|
fOnDefMechReinterpretParamAsMailBox: TIdIMAP4DefMech12;
|
|
fOnDefMechUpdateNextFreeUID: TIdIMAP4DefMech13;
|
|
fOnDefMechGetFileNameToWriteAppendMessage: TIdIMAP4DefMech14;
|
|
//
|
|
fOnBeforeCmd: TIdIMAP4CommandBeforeEvent;
|
|
fOnBeforeSend: TIdIMAP4CommandBeforeSendEvent;
|
|
fOnCommandCAPABILITY: TIMAP4CommandEvent;
|
|
fONCommandNOOP: TIMAP4CommandEvent;
|
|
fONCommandLOGOUT: TIMAP4CommandEvent;
|
|
fONCommandAUTHENTICATE: TIMAP4CommandEvent;
|
|
fONCommandLOGIN: TIMAP4CommandEvent;
|
|
fONCommandSELECT: TIMAP4CommandEvent;
|
|
fONCommandEXAMINE: TIMAP4CommandEvent;
|
|
fONCommandCREATE: TIMAP4CommandEvent;
|
|
fONCommandDELETE: TIMAP4CommandEvent;
|
|
fONCommandRENAME: TIMAP4CommandEvent;
|
|
fONCommandSUBSCRIBE: TIMAP4CommandEvent;
|
|
fONCommandUNSUBSCRIBE: TIMAP4CommandEvent;
|
|
fONCommandLIST: TIMAP4CommandEvent;
|
|
fONCommandLSUB: TIMAP4CommandEvent;
|
|
fONCommandSTATUS: TIMAP4CommandEvent;
|
|
fONCommandAPPEND: TIMAP4CommandEvent;
|
|
fONCommandCHECK: TIMAP4CommandEvent;
|
|
fONCommandCLOSE: TIMAP4CommandEvent;
|
|
fONCommandEXPUNGE: TIMAP4CommandEvent;
|
|
fONCommandSEARCH: TIMAP4CommandEvent;
|
|
fONCommandFETCH: TIMAP4CommandEvent;
|
|
fONCommandSTORE: TIMAP4CommandEvent;
|
|
fONCommandCOPY: TIMAP4CommandEvent;
|
|
fONCommandUID: TIMAP4CommandEvent;
|
|
fONCommandX: TIMAP4CommandEvent;
|
|
fOnCommandError: TIMAP4CommandEvent;
|
|
//
|
|
function CreateExceptionReply: TIdReply; override;
|
|
function CreateGreeting: TIdReply; override;
|
|
function CreateHelpReply: TIdReply; override;
|
|
function CreateMaxConnectionReply: TIdReply; override;
|
|
function CreateReplyUnknownCommand: TIdReply; override;
|
|
//
|
|
//The following are internal commands that help support the IMAP protocol...
|
|
procedure InitializeCommandHandlers; override;
|
|
function GetReplyClass:TIdReplyClass; override;
|
|
function GetRepliesClass:TIdRepliesClass; override;
|
|
procedure SendGreeting(AContext: TIdContext; AGreeting: TIdReply); override;
|
|
procedure SendWrongConnectionState(ASender: TIdCommand);
|
|
procedure SendUnsupportedCommand(ASender: TIdCommand);
|
|
procedure SendIncorrectNumberOfParameters(ASender: TIdCommand);
|
|
procedure SendUnassignedDefaultMechanism(ASender: TIdCommand);
|
|
procedure DoReplyUnknownCommand(AContext: TIdContext; AText: string); override;
|
|
procedure SendErrorOpenedReadOnly(ASender: TIdCommand);
|
|
procedure SendOkReply(ASender: TIdCommand; const AText: string);
|
|
procedure SendBadReply(ASender: TIdCommand; const AText: string); overload;
|
|
procedure SendBadReply(ASender: TIdCommand; const AFormat: string; const Args: array of const); overload;
|
|
procedure SendNoReply(ASender: TIdCommand; const AText: string = ''); overload;
|
|
procedure SendNoReply(ASender: TIdCommand; const AFormat: string; const Args: array of const); overload;
|
|
//
|
|
//The following are used internally by the default mechanism...
|
|
function ExpungeRecords(ASender: TIdCommand): Boolean;
|
|
function MessageSetToMessageNumbers(AUseUID: Boolean; ASender: TIdCommand; AMessageNumbers: TStrings; AMessageSet: string): Boolean;
|
|
function GetRecordForUID(const AUID: String; AMailBox: TIdMailBox): Integer;
|
|
procedure ProcessFetch(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings);
|
|
procedure ProcessCopy(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings);
|
|
function ProcessStore(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings): Boolean;
|
|
procedure ProcessSearch(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings);
|
|
function FlagStringToFlagList(AFlagList: TStrings; AFlagString: string): Boolean;
|
|
function StripQuotesIfNecessary(AName: string): string;
|
|
function ReassembleParams(ASeparator: char; AParams: TStrings; AParamToReassemble: integer): Boolean;
|
|
function ReinterpretParamAsMailBox(AParams: TStrings; AMailBoxParam: integer): Boolean;
|
|
function ReinterpretParamAsFlags(AParams: TStrings; AFlagsParam: integer): Boolean;
|
|
function ReinterpretParamAsQuotedStr(AParams: TStrings; AFlagsParam: integer): Boolean;
|
|
function ReinterpretParamAsDataItems(AParams: TStrings; AFlagsParam: integer): Boolean;
|
|
//
|
|
//The following are used internally by our default mechanism and are copies of
|
|
//the same function in TIdIMAP4 (move to a base class?)...
|
|
function MessageFlagSetToStr(const AFlags: TIdMessageFlagsSet): String;
|
|
//
|
|
//DoBeforeCmd & DoSendReply are useful for a server to log all commands and
|
|
//responses for debugging...
|
|
procedure DoBeforeCmd(ASender: TIdCommandHandlers; var AData: string; AContext: TIdContext);
|
|
procedure DoSendReply(AContext: TIdContext; const AData: string); overload;
|
|
procedure DoSendReply(AContext: TIdContext; const AFormat: string; const Args: array of const); overload;
|
|
//
|
|
//Command handlers...
|
|
procedure DoCmdHandlersException(ACommand: String; AContext: TIdContext);
|
|
procedure DoCommandCAPABILITY(ASender: TIdCommand);
|
|
procedure DoCommandNOOP(ASender: TIdCommand);
|
|
procedure DoCommandLOGOUT(ASender: TIdCommand);
|
|
procedure DoCommandAUTHENTICATE(ASender: TIdCommand);
|
|
procedure DoCommandLOGIN(ASender: TIdCommand);
|
|
procedure DoCommandSELECT(ASender: TIdCommand);
|
|
procedure DoCommandEXAMINE(ASender: TIdCommand);
|
|
procedure DoCommandCREATE(ASender: TIdCommand);
|
|
procedure DoCommandDELETE(ASender: TIdCommand);
|
|
procedure DoCommandRENAME(ASender: TIdCommand);
|
|
procedure DoCommandSUBSCRIBE(ASender: TIdCommand);
|
|
procedure DoCommandUNSUBSCRIBE(ASender: TIdCommand);
|
|
procedure DoCommandLIST(ASender: TIdCommand);
|
|
procedure DoCommandLSUB(ASender: TIdCommand);
|
|
procedure DoCommandSTATUS(ASender: TIdCommand);
|
|
procedure DoCommandAPPEND(ASender: TIdCommand);
|
|
procedure DoCommandCHECK(ASender: TIdCommand);
|
|
procedure DoCommandCLOSE(ASender: TIdCommand);
|
|
procedure DoCommandEXPUNGE(ASender: TIdCommand);
|
|
procedure DoCommandSEARCH(ASender: TIdCommand);
|
|
procedure DoCommandFETCH(ASender: TIdCommand);
|
|
procedure DoCommandSTORE(ASender: TIdCommand);
|
|
procedure DoCommandCOPY(ASender: TIdCommand);
|
|
procedure DoCommandUID(ASender: TIdCommand);
|
|
procedure DoCommandX(ASender: TIdCommand);
|
|
procedure DoCommandSTARTTLS(ASender: TIdCommand);
|
|
// common code for command handlers
|
|
procedure MustUseTLS(ASender: TIdCommand);
|
|
//
|
|
procedure InitComponent; override;
|
|
public
|
|
{$IFDEF WORKAROUND_INLINE_CONSTRUCTORS}
|
|
constructor Create(AOwner: TComponent); reintroduce; overload;
|
|
{$ENDIF}
|
|
destructor Destroy; override;
|
|
published
|
|
property DefaultPort default IdPORT_IMAP4;
|
|
property SaferMode: Boolean read FSaferMode write FSaferMode default False;
|
|
property UseDefaultMechanismsForUnassignedCommands: Boolean read FUseDefaultMechanismsForUnassignedCommands write FUseDefaultMechanismsForUnassignedCommands default True;
|
|
property RootPath: string read FRootPath write FRootPath;
|
|
property DefaultPassword: string read FDefaultPassword write FDefaultPassword;
|
|
property MailBoxSeparator: Char read FMailBoxSeparator;
|
|
{Default mechansisms}
|
|
property OnDefMechDoesImapMailBoxExist: TIdIMAP4DefMech1 read fOnDefMechDoesImapMailBoxExist write fOnDefMechDoesImapMailBoxExist;
|
|
property OnDefMechCreateMailBox: TIdIMAP4DefMech1 read fOnDefMechCreateMailBox write fOnDefMechCreateMailBox;
|
|
property OnDefMechDeleteMailBox: TIdIMAP4DefMech1 read fOnDefMechDeleteMailBox write fOnDefMechDeleteMailBox;
|
|
property OnDefMechIsMailBoxOpen: TIdIMAP4DefMech1 read fOnDefMechIsMailBoxOpen write fOnDefMechIsMailBoxOpen;
|
|
property OnDefMechSetupMailbox: TIdIMAP4DefMech2 read fOnDefMechSetupMailbox write fOnDefMechSetupMailbox;
|
|
property OnDefMechNameAndMailBoxToPath: TIdIMAP4DefMech3 read fOnDefMechNameAndMailBoxToPath write fOnDefMechNameAndMailBoxToPath;
|
|
property OnDefMechGetNextFreeUID: TIdIMAP4DefMech3 read fOnDefMechGetNextFreeUID write fOnDefMechGetNextFreeUID;
|
|
property OnDefMechRenameMailBox: TIdIMAP4DefMech4 read fOnDefMechRenameMailBox write fOnDefMechRenameMailBox;
|
|
property OnDefMechListMailBox: TIdIMAP4DefMech5 read fOnDefMechListMailBox write fOnDefMechListMailBox;
|
|
property OnDefMechDeleteMessage: TIdIMAP4DefMech6 read fOnDefMechDeleteMessage write fOnDefMechDeleteMessage;
|
|
property OnDefMechCopyMessage: TIdIMAP4DefMech7 read fOnDefMechCopyMessage write fOnDefMechCopyMessage;
|
|
property OnDefMechGetMessageSize: TIdIMAP4DefMech8 read fOnDefMechGetMessageSize write fOnDefMechGetMessageSize;
|
|
property OnDefMechGetMessageHeader: TIdIMAP4DefMech9 read fOnDefMechGetMessageHeader write fOnDefMechGetMessageHeader;
|
|
property OnDefMechGetMessageRaw: TIdIMAP4DefMech10 read fOnDefMechGetMessageRaw write fOnDefMechGetMessageRaw;
|
|
property OnDefMechOpenMailBox: TIdIMAP4DefMech11 read fOnDefMechOpenMailBox write fOnDefMechOpenMailBox;
|
|
property OnDefMechReinterpretParamAsMailBox: TIdIMAP4DefMech12 read fOnDefMechReinterpretParamAsMailBox write fOnDefMechReinterpretParamAsMailBox;
|
|
property OnDefMechUpdateNextFreeUID: TIdIMAP4DefMech13 read fOnDefMechUpdateNextFreeUID write fOnDefMechUpdateNextFreeUID;
|
|
property OnDefMechGetFileNameToWriteAppendMessage: TIdIMAP4DefMech14 read fOnDefMechGetFileNameToWriteAppendMessage write fOnDefMechGetFileNameToWriteAppendMessage;
|
|
{ Events }
|
|
property OnBeforeCmd: TIdIMAP4CommandBeforeEvent read fOnBeforeCmd write fOnBeforeCmd;
|
|
property OnBeforeSend: TIdIMAP4CommandBeforeSendEvent read fOnBeforeSend write fOnBeforeSend;
|
|
property OnCommandCAPABILITY: TIMAP4CommandEvent read fOnCommandCAPABILITY write fOnCommandCAPABILITY;
|
|
property OnCommandNOOP: TIMAP4CommandEvent read fONCommandNOOP write fONCommandNOOP;
|
|
property OnCommandLOGOUT: TIMAP4CommandEvent read fONCommandLOGOUT write fONCommandLOGOUT;
|
|
property OnCommandAUTHENTICATE: TIMAP4CommandEvent read fONCommandAUTHENTICATE write fONCommandAUTHENTICATE;
|
|
property OnCommandLOGIN: TIMAP4CommandEvent read fONCommandLOGIN write fONCommandLOGIN;
|
|
property OnCommandSELECT: TIMAP4CommandEvent read fONCommandSELECT write fONCommandSELECT;
|
|
property OnCommandEXAMINE:TIMAP4CommandEvent read fOnCommandEXAMINE write fOnCommandEXAMINE;
|
|
property OnCommandCREATE: TIMAP4CommandEvent read fONCommandCREATE write fONCommandCREATE;
|
|
property OnCommandDELETE: TIMAP4CommandEvent read fONCommandDELETE write fONCommandDELETE;
|
|
property OnCommandRENAME: TIMAP4CommandEvent read fOnCommandRENAME write fOnCommandRENAME;
|
|
property OnCommandSUBSCRIBE: TIMAP4CommandEvent read fONCommandSUBSCRIBE write fONCommandSUBSCRIBE;
|
|
property OnCommandUNSUBSCRIBE: TIMAP4CommandEvent read fONCommandUNSUBSCRIBE write fONCommandUNSUBSCRIBE;
|
|
property OnCommandLIST: TIMAP4CommandEvent read fONCommandLIST write fONCommandLIST;
|
|
property OnCommandLSUB: TIMAP4CommandEvent read fOnCommandLSUB write fOnCommandLSUB;
|
|
property OnCommandSTATUS: TIMAP4CommandEvent read fONCommandSTATUS write fONCommandSTATUS;
|
|
property OnCommandAPPEND: TIMAP4CommandEvent read fOnCommandAPPEND write fOnCommandAPPEND;
|
|
property OnCommandCHECK: TIMAP4CommandEvent read fONCommandCHECK write fONCommandCHECK;
|
|
property OnCommandCLOSE: TIMAP4CommandEvent read fOnCommandCLOSE write fOnCommandCLOSE;
|
|
property OnCommandEXPUNGE: TIMAP4CommandEvent read fONCommandEXPUNGE write fONCommandEXPUNGE;
|
|
property OnCommandSEARCH: TIMAP4CommandEvent read fOnCommandSEARCH write fOnCommandSEARCH;
|
|
property OnCommandFETCH: TIMAP4CommandEvent read fONCommandFETCH write fONCommandFETCH;
|
|
property OnCommandSTORE: TIMAP4CommandEvent read fOnCommandSTORE write fOnCommandSTORE;
|
|
property OnCommandCOPY: TIMAP4CommandEvent read fOnCommandCOPY write fOnCommandCOPY;
|
|
property OnCommandUID: TIMAP4CommandEvent read fONCommandUID write fONCommandUID;
|
|
property OnCommandX: TIMAP4CommandEvent read fOnCommandX write fOnCommandX;
|
|
property OnCommandError: TIMAP4CommandEvent read fOnCommandError write fOnCommandError;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
IdGlobal,
|
|
IdGlobalProtocols,
|
|
IdMessageCollection,
|
|
IdResourceStrings,
|
|
IdResourceStringsProtocols,
|
|
IdSSL,
|
|
IdStream,
|
|
SysUtils;
|
|
|
|
function TIdIMAP4Server.GetReplyClass: TIdReplyClass;
|
|
begin
|
|
Result := TIdReplyIMAP4;
|
|
end;
|
|
|
|
function TIdIMAP4Server.GetRepliesClass: TIdRepliesClass;
|
|
begin
|
|
Result := TIdRepliesIMAP4;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendGreeting(AContext: TIdContext; AGreeting: TIdReply);
|
|
begin
|
|
if FSaferMode then begin
|
|
DoSendReply(AContext, '* OK'); {Do not Localize}
|
|
end else begin
|
|
DoSendReply(AContext, '* OK Indy IMAP server version ' + GetIndyVersion); {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendWrongConnectionState(ASender: TIdCommand);
|
|
begin
|
|
SendNoReply(ASender, 'Wrong connection state'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendErrorOpenedReadOnly(ASender: TIdCommand);
|
|
begin
|
|
SendNoReply(ASender, 'Mailbox was opened read-only'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendUnsupportedCommand(ASender: TIdCommand);
|
|
begin
|
|
SendBadReply(ASender, 'Unsupported command'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendIncorrectNumberOfParameters(ASender: TIdCommand);
|
|
begin
|
|
SendBadReply(ASender, 'Incorrect number of parameters'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendUnassignedDefaultMechanism(ASender: TIdCommand);
|
|
begin
|
|
SendBadReply(ASender, 'Server internal error: unassigned procedure'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendOkReply(ASender: TIdCommand; const AText: string);
|
|
begin
|
|
DoSendReply(ASender.Context, TIdIMAP4PeerContext(ASender.Context).FLastCommand.SequenceNumber + ' OK ' + AText); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendBadReply(ASender: TIdCommand; const AText: string);
|
|
begin
|
|
DoSendReply(ASender.Context, TIdIMAP4PeerContext(ASender.Context).FLastCommand.SequenceNumber + ' BAD ' + AText); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendBadReply(ASender: TIdCommand; const AFormat: string; const Args: array of const);
|
|
begin
|
|
SendBadReply(ASender, IndyFormat(AFormat, Args));
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendNoReply(ASender: TIdCommand; const AText: string = '');
|
|
begin
|
|
if AText <> '' then begin
|
|
DoSendReply(ASender.Context, TIdIMAP4PeerContext(ASender.Context).FLastCommand.SequenceNumber + ' NO ' + AText); {Do not Localize}
|
|
end else begin
|
|
DoSendReply(ASender.Context, TIdIMAP4PeerContext(ASender.Context).FLastCommand.SequenceNumber + ' NO'); {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.SendNoReply(ASender: TIdCommand; const AFormat: string; const Args: array of const);
|
|
begin
|
|
SendNoReply(ASender, IndyFormat(AFormat, Args));
|
|
end;
|
|
|
|
{$IFDEF WORKAROUND_INLINE_CONSTRUCTORS}
|
|
constructor TIdIMAP4Server.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TIdIMAP4Server.InitComponent;
|
|
begin
|
|
inherited InitComponent;
|
|
//Todo: Not sure which number is appropriate. Should be tested
|
|
FImplicitTLSProtPort := IdPORT_IMAP4S; //Id_PORT_imap4_ssl_dp;
|
|
FRegularProtPort := IdPORT_IMAP4;
|
|
DefaultPort := IdPORT_IMAP4;
|
|
ContextClass := TIdIMAP4PeerContext;
|
|
FSaferMode := False;
|
|
FUseDefaultMechanismsForUnassignedCommands := True;
|
|
{$IFDEF UNIX}
|
|
FRootPath := GPathDelim + 'var' + GPathDelim + 'imapmail'; {Do not Localize}
|
|
{$ELSE}
|
|
FRootPath := GPathDelim + 'imapmail'; {Do not Localize}
|
|
{$ENDIF}
|
|
FDefaultPassword := 'admin'; {Do not Localize}
|
|
FMailBoxSeparator := '.'; {Do not Localize}
|
|
end;
|
|
|
|
destructor TIdIMAP4Server.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TIdIMAP4Server.CreateExceptionReply: TIdReply;
|
|
begin
|
|
Result := TIdReplyIMAP4.CreateWithReplyTexts(nil, ReplyTexts);
|
|
Result.SetReply(IMAP_BAD, 'Unknown Internal Error'); {do not localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.CreateGreeting: TIdReply;
|
|
begin
|
|
Result := TIdReplyIMAP4.CreateWithReplyTexts(nil, ReplyTexts);
|
|
Result.SetReply(IMAP_OK, 'Welcome'); {do not localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.CreateHelpReply: TIdReply;
|
|
begin
|
|
Result := TIdReplyIMAP4.CreateWithReplyTexts(nil, ReplyTexts);
|
|
Result.SetReply(IMAP_OK, 'Help follows'); {do not localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.CreateMaxConnectionReply: TIdReply;
|
|
begin
|
|
Result := TIdReplyIMAP4.CreateWithReplyTexts(nil, ReplyTexts);
|
|
Result.SetReply(IMAP_BAD, 'Too many connections. Try again later.'); {do not localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.CreateReplyUnknownCommand: TIdReply;
|
|
begin
|
|
Result := TIdReplyIMAP4.CreateWithReplyTexts(nil, ReplyTexts);
|
|
Result.SetReply(IMAP_BAD, 'Unknown command'); {do not localize}
|
|
end;
|
|
|
|
constructor TIdIMAP4PeerContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
|
|
begin
|
|
inherited Create(AConnection, AYarn, AList);
|
|
FMailBox := TIdMailBox.Create;
|
|
FLastCommand := TIdReplyIMAP4.Create(nil);
|
|
FConnectionState := csAny;
|
|
end;
|
|
|
|
destructor TIdIMAP4PeerContext.Destroy;
|
|
begin
|
|
FreeAndNil(FLastCommand);
|
|
FreeAndNil(FMailBox);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TIdIMAP4PeerContext.GetUsingTLS: Boolean;
|
|
begin
|
|
if Connection.IOHandler is TIdSSLIOHandlerSocketBase then begin
|
|
Result := not TIdSSLIOHandlerSocketBase(Connection.IOHandler).PassThrough;
|
|
end else begin
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoReplyUnknownCommand(AContext: TIdContext; AText: string);
|
|
//AText is ignored by TIdIMAP4Server
|
|
var
|
|
LText: string;
|
|
begin
|
|
LText := TIdIMAP4PeerContext(AContext).FLastCommand.SequenceNumber;
|
|
if LText = '' then begin
|
|
//This should not happen!
|
|
LText := '*'; {Do not Localize}
|
|
end;
|
|
DoSendReply(AContext, LText + ' NO Unknown command'); {Do not Localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.ExpungeRecords(ASender: TIdCommand): Boolean;
|
|
var
|
|
LN: integer;
|
|
LMessage: TIdMessage;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
//Delete all records that have the deleted flag set...
|
|
LN := 0;
|
|
Result := True;
|
|
while LN < LContext.MailBox.MessageList.Count do begin
|
|
LMessage := LContext.MailBox.MessageList.Messages[LN];
|
|
if mfDeleted in LMessage.Flags then begin
|
|
if not OnDefMechDeleteMessage(LContext.LoginName, LContext.MailBox.Name, LMessage) then
|
|
begin
|
|
Result := False;
|
|
end;
|
|
LContext.MailBox.MessageList.Delete(LN);
|
|
LContext.MailBox.TotalMsgs := LContext.MailBox.TotalMsgs - 1;
|
|
end else begin
|
|
Inc(LN);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIdIMAP4Server.MessageSetToMessageNumbers(AUseUID: Boolean; ASender: TIdCommand;
|
|
AMessageNumbers: TStrings; AMessageSet: string): Boolean;
|
|
{AMessageNumbers may be '7' or maybe '2:4' (2, 3 & 4) or maybe '2,4,6' (2, 4 & 6)
|
|
or maybe '1:*'}
|
|
var
|
|
LPos: integer;
|
|
LStart: integer;
|
|
LN: integer;
|
|
LEnd: integer;
|
|
LTemp: string;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
AMessageNumbers.Clear;
|
|
//See is it a sequence like 2:4 ...
|
|
LPos := IndyPos(':', AMessageSet); {Do not Localize}
|
|
if LPos > 0 then begin
|
|
LTemp := Copy(AMessageSet, 1, LPos-1);
|
|
LStart := IndyStrToInt(LTemp);
|
|
LTemp := Copy(AMessageSet, LPos+1, MAXINT);
|
|
if LTemp = '*' then begin {Do not Localize}
|
|
if AUseUID then begin
|
|
LEnd := IndyStrToInt(LContext.MailBox.UIDNext)-1;
|
|
for LN := LStart to LEnd do begin
|
|
AMessageNumbers.Add(IntToStr(LN));
|
|
end;
|
|
end else begin
|
|
LEnd := LContext.MailBox.MessageList.Count;
|
|
for LN := LStart to LEnd do begin
|
|
AMessageNumbers.Add(IntToStr(LN));
|
|
end;
|
|
end;
|
|
end else begin
|
|
LEnd := IndyStrToInt(LTemp);
|
|
for LN := LStart to LEnd do begin
|
|
AMessageNumbers.Add(IntToStr(LN));
|
|
end;
|
|
end;
|
|
end else begin
|
|
//See is it a comma-separated list...
|
|
LPos := IndyPos(',', AMessageSet); {Do not Localize}
|
|
if LPos = 0 then begin
|
|
AMessageNumbers.Add(AMessageSet);
|
|
end else begin
|
|
BreakApart(AMessageSet, ',', AMessageNumbers); {Do not Localize}
|
|
end;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
//Return -1 if not found
|
|
function TIdIMAP4Server.GetRecordForUID(const AUID: String; AMailBox: TIdMailBox): Integer;
|
|
var
|
|
LN, LUID: Integer;
|
|
begin
|
|
// TODO: do string comparisons instead so that conversions are not needed?
|
|
LUID := IndyStrToInt(AUID);
|
|
for LN := 0 to AMailBox.MessageList.Count-1 do begin
|
|
if IndyStrToInt(AMailBox.MessageList.Messages[LN].UID) = LUID then begin
|
|
Result := LN;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function TIdIMAP4Server.StripQuotesIfNecessary(AName: string): string;
|
|
begin
|
|
if Length(AName) > 0 then begin
|
|
if (AName[1] = '"') and (AName[Length(Result)] = '"') then begin {Do not Localize}
|
|
Result := Copy(AName, 2, Length(AName)-2);
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := AName;
|
|
end;
|
|
|
|
function TIdIMAP4Server.ReassembleParams(ASeparator: Char; AParams: TStrings;
|
|
AParamToReassemble: Integer): Boolean;
|
|
var
|
|
LEndSeparator: char;
|
|
LTemp: string;
|
|
LN: integer;
|
|
LReassembledParam: string;
|
|
begin
|
|
Result := False;
|
|
case ASeparator of
|
|
'(': LEndSeparator := ')'; {Do not Localize}
|
|
'[': LEndSeparator := ']'; {Do not Localize}
|
|
else LEndSeparator := ASeparator;
|
|
end;
|
|
LTemp := AParams[AParamToReassemble];
|
|
if (LTemp = '') or (LTemp[1] <> ASeparator) then begin
|
|
Exit;
|
|
end;
|
|
if LTemp[Length(LTemp)] = LEndSeparator then begin
|
|
AParams[AParamToReassemble] := Copy(LTemp, 2, Length(LTemp)-2);
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
LReassembledParam := Copy(LTemp, 2, MAXINT);
|
|
LN := AParamToReassemble + 1;
|
|
repeat
|
|
if LN >= AParams.Count - 1 then begin
|
|
Result := False;
|
|
Exit; //Error
|
|
end;
|
|
LTemp := AParams[LN];
|
|
AParams.Delete(LN);
|
|
if LTemp[Length(LTemp)] = LEndSeparator then begin
|
|
AParams[AParamToReassemble] := LReassembledParam + ' ' + Copy(LTemp, 1, Length(LTemp)-1); {Do not Localize}
|
|
Result := True;
|
|
Exit; //This is example 1
|
|
end;
|
|
LReassembledParam := LReassembledParam + ' ' + LTemp; {Do not Localize}
|
|
until False;
|
|
end;
|
|
|
|
//This reorganizes the parameter list on the basis that AMailBoxParam is a
|
|
//mailbox name, which may (if enclosed in quotes) be in more than one param.
|
|
//Example 1: '43' '"My' 'Documents"' '5' -> '43' 'My Documents' '5'
|
|
//Example 2: '43' '"MyDocs"' '5' -> '43' 'MyDocs' '5'
|
|
//Example 3: '43' 'MyDocs' '5' -> '43' 'MyDocs' '5'
|
|
function TIdIMAP4Server.ReinterpretParamAsMailBox(AParams: TStrings; AMailBoxParam: Integer): Boolean;
|
|
var
|
|
LTemp: string;
|
|
begin
|
|
if (AMailBoxParam < 0) or (AMailBoxParam >= AParams.Count) then begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
LTemp := AParams[AMailBoxParam];
|
|
if LTemp = '' then begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
if LTemp[1] <> '"' then begin {Do not Localize}
|
|
Result := True;
|
|
Exit; //This is example 3, no change.
|
|
end;
|
|
Result := ReassembleParams('"', AParams, AMailBoxParam); {Do not Localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.ReinterpretParamAsFlags(AParams: TStrings; AFlagsParam: Integer): Boolean;
|
|
begin
|
|
Result := ReassembleParams('(', AParams, AFlagsParam); {Do not Localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.ReinterpretParamAsQuotedStr(AParams: TStrings; AFlagsParam: integer): Boolean;
|
|
begin
|
|
Result := ReassembleParams('"', AParams, AFlagsParam); {Do not Localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.ReinterpretParamAsDataItems(AParams: TStrings; AFlagsParam: Integer): Boolean;
|
|
begin
|
|
Result := ReassembleParams('(', AParams, AFlagsParam); {Do not Localize}
|
|
end;
|
|
|
|
function TIdIMAP4Server.FlagStringToFlagList(AFlagList: TStrings; AFlagString: string): Boolean;
|
|
var
|
|
LTemp: string;
|
|
begin
|
|
AFlagList.Clear;
|
|
if (AFlagString <> '') and (AFlagString[1] = '(') and (AFlagString[Length(AFlagString)] = ')') then begin {Do not Localize}
|
|
LTemp := Copy(AFlagString, 2, Length(AFlagString)-2);
|
|
BreakApart(LTemp, ' ', AFlagList); {Do not Localize}
|
|
Result := True;
|
|
end else begin
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.ProcessFetch(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings);
|
|
//There are a pile of options for this.
|
|
var
|
|
LMessageNumbers: TStringList;
|
|
LDataItems: TStringList;
|
|
LM: integer;
|
|
LN: integer;
|
|
LLO: integer;
|
|
LRecord: integer;
|
|
LSize: integer;
|
|
LMessageToCheck, LMessageTemp: TIdMessage;
|
|
LMessageRaw: TStringList;
|
|
LTemp: string;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
//First param is a message set, e.g. 41 or 2:5 (which is 2, 3, 4 & 5)
|
|
LMessageNumbers := TStringList.Create;
|
|
try
|
|
if not MessageSetToMessageNumbers(AUseUID, ASender, LMessageNumbers, AParams[0]) then begin
|
|
SendBadReply(ASender, 'Error in syntax of message set parameter'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if not ReinterpretParamAsDataItems(AParams, 1) then begin
|
|
SendBadReply(ASender, 'Fetch data items parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LDataItems := TStringList.Create;
|
|
try
|
|
BreakApart(AParams[1], ' ', LDataItems);
|
|
for LN := 0 to LMessageNumbers.Count-1 do begin
|
|
if AUseUID then begin
|
|
LRecord := GetRecordForUID(LMessageNumbers[LN], LContext.MailBox);
|
|
if LRecord = -1 then begin //It is OK to skip non-existent UID records
|
|
Continue;
|
|
end;
|
|
end else begin
|
|
LRecord := IndyStrToInt(LMessageNumbers[LN])-1;
|
|
end;
|
|
if (LRecord < 0) or (LRecord > LContext.MailBox.MessageList.Count) then begin
|
|
SendBadReply(ASender, 'Message number %d does not exist', [LRecord+1]); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LMessageToCheck := LContext.MailBox.MessageList.Messages[LRecord];
|
|
for LLO := 0 to LDataItems.Count-1 do begin
|
|
if TextIsSame(LDataItems[LLO], 'UID') then begin {Do not Localize}
|
|
//Format:
|
|
//C9 FETCH 490 (UID)
|
|
//* 490 FETCH (UID 6545)
|
|
//C9 OK Completed
|
|
DoSendReply(ASender.Context, '* FETCH (UID %s)', [LMessageToCheck.UID]); {Do not Localize}
|
|
end
|
|
else if TextIsSame(LDataItems[LLO], 'FLAGS') then begin {Do not Localize}
|
|
//Format:
|
|
//C10 UID FETCH 6545 (FLAGS)
|
|
//* 490 FETCH (FLAGS (\Recent) UID 6545)
|
|
//C10 OK Completed
|
|
if AUseUID then begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (FLAGS (%s) UID %s)', {Do not Localize}
|
|
[LRecord+1, MessageFlagSetToStr(LMessageToCheck.Flags), LMessageNumbers[LN]]);
|
|
end else begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (FLAGS (%s))', {Do not Localize}
|
|
[LRecord+1, MessageFlagSetToStr(LMessageToCheck.Flags)]);
|
|
end;
|
|
end
|
|
else if TextIsSame(LDataItems[LLO], 'RFC822.HEADER') then begin {Do not Localize}
|
|
//Format:
|
|
//C11 UID FETCH 6545 (RFC822.HEADER)
|
|
//* 490 FETCH (UID 6545 RFC822.HEADER {1654}
|
|
//Return-Path: <Christina_Powell@secondhandcars.com>
|
|
//...
|
|
//Content-Type: multipart/alternative;
|
|
// boundary="----=_NextPart_000_70BE_C8606D03.F4EA24EE"
|
|
//C10 OK Completed
|
|
//We don't want to thrash UIDs and flags in MailBox message, so load into LMessage
|
|
LMessageTemp := TIdMessage.Create;
|
|
try
|
|
if not OnDefMechGetMessageHeader(LContext.LoginName, LContext.MailBox.Name, LMessageToCheck, LMessageTemp) then begin
|
|
SendNoReply(ASender, 'Failed to get message header'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
//Need to calculate the size of the headers...
|
|
LSize := 0;
|
|
for LM := 0 to LMessageTemp.Headers.Count-1 do begin
|
|
Inc(LSize, Length(LMessageTemp.Headers.Strings[LM]) + 2); //Allow for CR+LF
|
|
end;
|
|
if AUseUID then begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (UID %s RFC822.HEADER {%d}', {Do not Localize}
|
|
[LRecord+1, LMessageNumbers[LN], LSize]);
|
|
end else begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (RFC822.HEADER {%d}', {Do not Localize}
|
|
[LRecord+1, LSize]);
|
|
end;
|
|
for LM := 0 to LMessageTemp.Headers.Count-1 do begin
|
|
DoSendReply(ASender.Context, LMessageTemp.Headers.Strings[LM]);
|
|
end;
|
|
DoSendReply(ASender.Context, ')'); {Do not Localize}
|
|
//Finished with the headers, free the memory...
|
|
finally
|
|
FreeAndNil(LMessageTemp);
|
|
end;
|
|
end
|
|
else if TextIsSame(LDataItems[LLO], 'RFC822.SIZE') then begin {Do not Localize}
|
|
//Format:
|
|
//C12 UID FETCH 6545 (RFC822.SIZE)
|
|
//* 490 FETCH (UID 6545 RFC822.SIZE 3447)
|
|
//C12 OK Completed
|
|
LSize := OnDefMechGetMessageSize(LContext.LoginName, LContext.MailBox.Name, LMessageToCheck);
|
|
if LSize = -1 then begin
|
|
SendNoReply(ASender, 'Failed to get message size'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if AUseUID then begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (UID %s RFC822.SIZE %d)', {Do not Localize}
|
|
[LRecord+1, LMessageNumbers[LN], LSize]);
|
|
end else begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (RFC822.SIZE %d)', {Do not Localize}
|
|
[LRecord+1, LSize]);
|
|
end;
|
|
end
|
|
else if PosInStrArray(LDataItems[LLO], ['BODY.PEEK[]', 'BODY[]', 'RFC822', 'RFC822.PEEK'], False) <> -1 then {Do not Localize}
|
|
begin
|
|
//All are the same, except the return string is different...
|
|
LMessageRaw := TStringList.Create;
|
|
try
|
|
if not OnDefMechGetMessageRaw(LContext.LoginName, LContext.MailBox.Name, LMessageToCheck, LMessageRaw) then
|
|
begin
|
|
SendNoReply(ASender, 'Failed to get raw message'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LSize := 0;
|
|
for LM := 0 to LMessageToCheck.Headers.Count-1 do begin
|
|
Inc(LSize, Length(LMessageRaw.Strings[LM]) + 2); //Allow for CR+LF
|
|
end;
|
|
Inc(LSize, 3); //The message terminator '.CRLF'
|
|
LTemp := Copy(AParams[1], 2, Length(AParams[1])-2);
|
|
if AUseUID then begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (FLAGS (%s) UID %s %s {%d}', {Do not Localize}
|
|
[LRecord+1, MessageFlagSetToStr(LMessageToCheck.Flags), LMessageNumbers[LN], LTemp, LSize]);
|
|
end else begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (FLAGS (%s) %s {%d}', {Do not Localize}
|
|
[LRecord+1, MessageFlagSetToStr(LMessageToCheck.Flags), LTemp, LSize]);
|
|
end;
|
|
for LM := 0 to LMessageToCheck.Headers.Count-1 do begin
|
|
DoSendReply(ASender.Context, LMessageRaw.Strings[LM]);
|
|
end;
|
|
DoSendReply(ASender.Context, '.'); {Do not Localize}
|
|
DoSendReply(ASender.Context, ')'); {Do not Localize}
|
|
//Free the memory...
|
|
finally
|
|
FreeAndNil(LMessageRaw);
|
|
end;
|
|
end
|
|
else if TextIsSame(LDataItems[LLO], 'BODYSTRUCTURE') then begin {Do not Localize}
|
|
//Format:
|
|
//C49 UID FETCH 6545 (BODYSTRUCTURE)
|
|
//* 490 FETCH (UID 6545 BODYSTRUCTURE (("TEXT" "PLAIN" ("CHARSET" "iso-8859-1") NIL NIL "7BIT" 290 8 NIL NIL NIL)("TEXT" "HTML" ("CHARSET" "iso-8859-1") NIL NIL "7BIT" 1125 41 NIL NIL NIL) "ALTERNATIVE" ("BOUNDARY"
|
|
//C12 OK Completed
|
|
SendBadReply(ASender, 'Parameter not supported: ' + AParams[1]); {Do not Localize}
|
|
end
|
|
else if TextStartsWith(LDataItems[LLO], 'BODY[') or TextStartsWith(LDataItems[LLO], 'BODY.PEEK[') then begin {Do not Localize}
|
|
//Format:
|
|
//C50 UID FETCH 6545 (BODY[1])
|
|
//* 490 FETCH (FLAGS (\Recent \Seen) UID 6545 BODY[1] {290}
|
|
//...
|
|
//)
|
|
//C50 OK Completed
|
|
SendBadReply(ASender, 'Parameter not supported: ' + AParams[1]); {Do not Localize}
|
|
end
|
|
else begin
|
|
SendBadReply(ASender, 'Parameter not supported: ' + AParams[1]); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeAndNil(LDataItems);
|
|
end;
|
|
finally
|
|
FreeAndNil(LMessageNumbers);
|
|
end;
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.ProcessSearch(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings);
|
|
//if AUseUID is True, return UIDs rather than relative message numbers.
|
|
var
|
|
LSearchString: string;
|
|
LN: Integer;
|
|
LM: Integer;
|
|
LItem: Integer;
|
|
LMessageToCheck, LMessageTemp: TIdMessage;
|
|
LHits: string;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
//Watch out: you could become an old man trying to implement all the IMAP
|
|
//search options, just do a subset.
|
|
//Format:
|
|
//C1065 UID SEARCH FROM "visible"
|
|
//* SEARCH 5769 5878
|
|
//C1065 OK Completed (2 msgs in 0.010 secs)
|
|
if AParams.Count < 2 then begin //The only search options we support are 2-param ones
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
//LParams.Free;
|
|
Exit;
|
|
end;
|
|
LItem := PosInStrArray(AParams[0], ['FROM', 'TO', 'CC', 'BCC', 'SUBJECT'], False);
|
|
if LItem = -1 then begin {Do not Localize}
|
|
SendBadReply(ASender, 'Unsupported search method'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
//Reassemble the other params into a line, because "Ciaran Costelloe" will be params 1 & 2...
|
|
LSearchString := AParams[1];
|
|
for LN := 2 to AParams.Count-1 do begin
|
|
LSearchString := LSearchString + ' ' + AParams[LN]; {Do not Localize}
|
|
end;
|
|
if (LSearchString[1] = '"') and (LSearchString[Length(LSearchString)] = '"') then begin {Do not Localize}
|
|
LSearchString := Copy(LSearchString, 2, Length(LSearchString)-2);
|
|
end;
|
|
|
|
LHits := '';
|
|
LMessageTemp := TIdMessage.Create;
|
|
try
|
|
for LN := 0 to LContext.MailBox.MessageList.Count-1 do begin
|
|
LMessageToCheck := LContext.MailBox.MessageList.Messages[LN];
|
|
if not OnDefMechGetMessageHeader(LContext.LoginName, LContext.MailBox.Name, LMessageToCheck, LMessageTemp) then
|
|
begin
|
|
SendNoReply(ASender, 'Failed to get message header'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
case LItem of
|
|
0: // FROM {Do not Localize}
|
|
begin
|
|
if Pos(UpperCase(LSearchString), UpperCase(LMessageTemp.From.Address)) > 0 then begin
|
|
if AUseUID then begin
|
|
LHits := LHits + LMessageToCheck.UID + ' '; {Do not Localize}
|
|
end else begin
|
|
LHits := LHits + IntToStr(LN+1) + ' '; {Do not Localize}
|
|
end;
|
|
end;
|
|
end;
|
|
1: // TO {Do not Localize}
|
|
begin
|
|
for LM := 0 to LMessageTemp.Recipients.Count-1 do begin
|
|
if Pos(UpperCase(LSearchString), UpperCase(LMessageTemp.Recipients.Items[LM].Address)) > 0 then begin
|
|
if AUseUID then begin
|
|
LHits := LHits + LMessageToCheck.UID + ' '; {Do not Localize}
|
|
end else begin
|
|
LHits := LHits + IntToStr(LN+1) + ' '; {Do not Localize}
|
|
end;
|
|
Break; //Don't want more than 1 hit on this record
|
|
end;
|
|
end;
|
|
end;
|
|
2: // CC {Do not Localize}
|
|
begin
|
|
for LM := 0 to LMessageTemp.Recipients.Count-1 do begin
|
|
if Pos(UpperCase(LSearchString), UpperCase(LMessageTemp.CCList.Items[LM].Address)) > 0 then begin
|
|
if AUseUID then begin
|
|
LHits := LHits + LMessageToCheck.UID + ' '; {Do not Localize}
|
|
end else begin
|
|
LHits := LHits + IntToStr(LN+1) + ' '; {Do not Localize}
|
|
end;
|
|
Break; //Don't want more than 1 hit on this record
|
|
end;
|
|
end;
|
|
end;
|
|
3: // BCC {Do not Localize}
|
|
begin
|
|
for LM := 0 to LMessageTemp.Recipients.Count-1 do begin
|
|
if Pos(UpperCase(LSearchString), UpperCase(LMessageTemp.BCCList.Items[LM].Address)) > 0 then begin
|
|
if AUseUID then begin
|
|
LHits := LHits + LMessageToCheck.UID + ' '; {Do not Localize}
|
|
end else begin
|
|
LHits := LHits + IntToStr(LN+1) + ' '; {Do not Localize}
|
|
end;
|
|
Break; //Don't want more than 1 hit on this record
|
|
end;
|
|
end;
|
|
end;
|
|
else // SUBJECT {Do not Localize}
|
|
begin
|
|
if Pos(UpperCase(LSearchString), UpperCase(LMessageTemp.Subject)) > 0 then begin
|
|
if AUseUID then begin
|
|
LHits := LHits + LMessageToCheck.UID + ' '; {Do not Localize}
|
|
end else begin
|
|
LHits := LHits + IntToStr(LN+1) + ' '; {Do not Localize}
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeAndNil(LMessageTemp);
|
|
end;
|
|
DoSendReply(ASender.Context, '* SEARCH ' + TrimRight(LHits)); {Do not Localize}
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.ProcessCopy(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings);
|
|
var
|
|
LMessageNumbers: TStringList;
|
|
LN: Integer;
|
|
LRecord: integer;
|
|
LResult: Boolean;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
//Format is "C1 COPY 2:4 MEETINGFOLDER"
|
|
if AParams.Count < 2 then begin
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if not OnDefMechReinterpretParamAsMailBox(AParams, 1) then begin
|
|
SendBadReply(ASender, 'Mailbox parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
//First param is a message set, e.g. 41 or 2:5 (which is 2, 3, 4 & 5)
|
|
LMessageNumbers := TStringList.Create;
|
|
try
|
|
if not MessageSetToMessageNumbers(AUseUID, ASender, LMessageNumbers, AParams[0]) then begin
|
|
SendBadReply(ASender, 'Error in syntax of message set parameter'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechDoesImapMailBoxExist) then begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
if not OnDefMechDoesImapMailBoxExist(LContext.LoginName, AParams[1]) then begin
|
|
SendNoReply(ASender, 'Mailbox does not exist.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LResult := True;
|
|
for LN := 0 to LMessageNumbers.Count-1 do begin
|
|
if AUseUID then begin
|
|
LRecord := GetRecordForUID(LMessageNumbers[LN], LContext.MailBox);
|
|
if LRecord = -1 then begin //It is OK to skip non-existent UID records
|
|
Continue;
|
|
end;
|
|
end else begin
|
|
LRecord := IndyStrToInt(LMessageNumbers[LN])-1;
|
|
end;
|
|
if (LRecord < 0) or (LRecord >= LContext.MailBox.MessageList.Count) then begin
|
|
LResult := False;
|
|
end
|
|
else if not OnDefMechCopyMessage(LContext.LoginName, LContext.MailBox.Name,
|
|
LContext.MailBox.MessageList.Messages[LRecord].UID, AParams[1]) then
|
|
begin
|
|
LResult := False;
|
|
end;
|
|
end;
|
|
if LResult then begin
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'Copy failed for one or more messages'); {Do not Localize}
|
|
end;
|
|
finally
|
|
FreeAndNil(LMessageNumbers);
|
|
end;
|
|
end;
|
|
|
|
function TIdIMAP4Server.ProcessStore(AUseUID: Boolean; ASender: TIdCommand; AParams: TStrings): Boolean;
|
|
const
|
|
LCMsgFlags: array[0..4] of TIdMessageFlags = ( mfAnswered, mfFlagged, mfDeleted, mfDraft, mfSeen );
|
|
var
|
|
LMessageNumbers: TStringList;
|
|
LFlagList: TStringList;
|
|
LN: integer;
|
|
LM: integer;
|
|
LRecord: integer;
|
|
LFlag: integer;
|
|
LTemp: string;
|
|
LStoreMethod: TIdIMAP4StoreDataItem;
|
|
LSilent: Boolean;
|
|
LMessage: TIdMessage;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
//Format is:
|
|
//C53 UID STORE 6545,6544 +FLAGS.SILENT (\Deleted)
|
|
//C53 OK Completed
|
|
Result := False;
|
|
if AParams.Count < 3 then begin
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
//First param is a message set, e.g. 41 or 2:5 (which is 2, 3, 4 & 5)
|
|
LMessageNumbers := TStringList.Create;
|
|
try
|
|
if not MessageSetToMessageNumbers(AUseUID, ASender, LMessageNumbers, AParams[0]) then begin
|
|
SendBadReply(ASender, 'Error in syntax of message set parameter'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LTemp := AParams[1];
|
|
if LTemp[1] = '+' then begin {Do not Localize}
|
|
LStoreMethod := sdAdd;
|
|
LTemp := Copy(LTemp, 2, MaxInt);
|
|
end else if LTemp[1] = '-' then begin {Do not Localize}
|
|
LStoreMethod := sdRemove;
|
|
LTemp := Copy(LTemp, 2, MaxInt);
|
|
end else begin
|
|
LStoreMethod := sdReplace;
|
|
end;
|
|
if TextIsSame(LTemp, 'FLAGS') then begin {Do not Localize}
|
|
LSilent := False;
|
|
end else if TextIsSame(LTemp, 'FLAGS.SILENT') then begin {Do not Localize}
|
|
LSilent := True;
|
|
end else begin
|
|
SendBadReply(ASender, 'Error in syntax of FLAGS parameter'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LFlagList := TStringList.Create;
|
|
try
|
|
//Assemble remaining flags back into a string...
|
|
LTemp := AParams[2];
|
|
for LN := 3 to AParams.Count-1 do begin
|
|
LTemp := ' ' + AParams[LN]; {Do not Localize}
|
|
end;
|
|
if not FlagStringToFlagList(LFlagList, LTemp) then begin
|
|
SendBadReply(ASender, 'Error in syntax of flag set parameter'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
for LN := 0 to LMessageNumbers.Count-1 do begin
|
|
if AUseUID then begin
|
|
LRecord := GetRecordForUID(LMessageNumbers[LN], LContext.MailBox);
|
|
if LRecord = -1 then begin //It is OK to skip non-existent UID records
|
|
Continue;
|
|
end;
|
|
end else begin
|
|
LRecord := IndyStrToInt(LMessageNumbers[LN])-1;
|
|
end;
|
|
if (LRecord < 0) or (LRecord > LContext.MailBox.MessageList.Count) then begin
|
|
SendBadReply(ASender, 'Message number %d does not exist', [LRecord+1]); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LMessage := LContext.MailBox.MessageList.Messages[LRecord];
|
|
if LStoreMethod = sdReplace then begin
|
|
LMessage.Flags := [];
|
|
end;
|
|
for LM := 0 to LFlagList.Count-1 do begin
|
|
//Support \Answered \Flagged \Deleted \Draft \Seen
|
|
LFlag := PosInStrArray(LFlagList[LM], ['\Answered', '\Flagged', '\Deleted', '\Draft', '\Seen'], False); {Do not Localize}
|
|
if LFlag = -1 then begin
|
|
Continue;
|
|
end;
|
|
case LStoreMethod of
|
|
sdAdd, sdReplace:
|
|
begin
|
|
LMessage.Flags := LMessage.Flags + [LCMsgFlags[LFlag]];
|
|
end;
|
|
sdRemove:
|
|
begin
|
|
LMessage.Flags := LMessage.Flags - [LCMsgFlags[LFlag]];
|
|
end;
|
|
end;
|
|
end;
|
|
if not LSilent then begin
|
|
//In this case, send to the client the current flags.
|
|
//The response is '* 43 FETCH (FLAGS (\Seen))' with the UID version
|
|
//being '* 43 FETCH (FLAGS (\Seen) UID 1234)'. Note the first number is the
|
|
//relative message number in BOTH cases.
|
|
if AUseUID then begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (FLAGS (%s) UID %s)', {Do not Localize}
|
|
[LRecord+1, MessageFlagSetToStr(LMessage.Flags), LMessageNumbers[LN]]);
|
|
end else begin
|
|
DoSendReply(ASender.Context, '* %d FETCH (FLAGS (%s))', {Do not Localize}
|
|
[LRecord+1, MessageFlagSetToStr(LMessage.Flags)]);
|
|
end;
|
|
end;
|
|
end;
|
|
SendOkReply(ASender, 'STORE Completed'); {Do not Localize}
|
|
finally
|
|
FreeAndNil(LFlagList);
|
|
end;
|
|
finally
|
|
FreeAndNil(LMessageNumbers);
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.InitializeCommandHandlers;
|
|
var
|
|
LCommandHandler: TIdCommandHandler;
|
|
begin
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'CAPABILITY'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandCAPABILITY;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'NOOP'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandNOOP;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'LOGOUT'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandLOGOUT;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'AUTHENTICATE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandAUTHENTICATE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'LOGIN'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandLOGIN;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'SELECT'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandSELECT;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'EXAMINE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandEXAMINE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'CREATE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandCREATE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'DELETE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandDELETE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'RENAME'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandRENAME;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'SUBSCRIBE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandSUBSCRIBE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'UNSUBSCRIBE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandUNSUBSCRIBE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'LIST'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandLIST;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'LSUB'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandLSUB;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'STATUS'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandSTATUS;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'APPEND'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandAPPEND;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'CHECK'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandCHECK;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'CLOSE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandCLOSE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'EXPUNGE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandEXPUNGE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'SEARCH'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandSEARCH;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'FETCH'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandFETCH;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'STORE'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandSTORE;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'COPY'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandCOPY;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'UID'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandUID;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'X'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandX;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
LCommandHandler := CommandHandlers.Add;
|
|
LCommandHandler.Command := 'STARTTLS'; {do not localize}
|
|
LCommandHandler.OnCommand := DoCommandSTARTTLS;
|
|
LCommandHandler.NormalReply.Code := IMAP_OK;
|
|
|
|
FCommandHandlers.OnBeforeCommandHandler := DoBeforeCmd;
|
|
FCommandHandlers.OnCommandHandlersException := DoCmdHandlersException;
|
|
end;
|
|
|
|
//Command handlers
|
|
|
|
procedure TIdIMAP4Server.DoBeforeCmd(ASender: TIdCommandHandlers; var AData: string;
|
|
AContext: TIdContext);
|
|
begin
|
|
TIdIMAP4PeerContext(AContext).FLastCommand.ParseRequest(AData); //Main purpose is to get sequence number, like C11 from 'C11 CAPABILITY'
|
|
TIdIMAP4PeerContext(AContext).FIMAP4Tag := Fetch(AData, ' ');
|
|
AData := Trim(AData);
|
|
if Assigned(FOnBeforeCmd) then begin
|
|
FOnBeforeCmd(ASender, AData, AContext);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoSendReply(AContext: TIdContext; const AData: string);
|
|
begin
|
|
if Assigned(FOnBeforeSend) then begin
|
|
FOnBeforeSend(AContext, AData);
|
|
end;
|
|
AContext.Connection.IOHandler.WriteLn(AData);
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoSendReply(AContext: TIdContext; const AFormat: string; const Args: array of const);
|
|
begin
|
|
DoSendReply(AContext, IndyFormat(AFormat, Args));
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCmdHandlersException(ACommand: String; AContext: TIdContext);
|
|
var
|
|
LTag, LCmd: String;
|
|
begin
|
|
if Assigned(FOnCommandError) then begin
|
|
LTag := Fetch(ACommand, ' ');
|
|
LCmd := Fetch(ACommand, ' ');
|
|
OnCommandError(AContext, LTag, LCmd);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandCAPABILITY(ASender: TIdCommand);
|
|
begin
|
|
if Assigned(FOnCommandCAPABILITY) then begin
|
|
OnCommandCAPABILITY(ASender.Context, TIdIMAP4PeerContext(ASender.Context).IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
{Tell the client our capabilities...}
|
|
DoSendReply(ASender.Context, '* CAPABILITY IMAP4rev1 AUTH=PLAIN'); {Do not Localize}
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandNOOP(ASender: TIdCommand);
|
|
begin
|
|
if Assigned(FOnCommandNOOP) then begin
|
|
OnCommandNOOP(ASender.Context, TIdIMAP4PeerContext(ASender.Context).IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
{On most servers, this does nothing (they use a timeout to disconnect users,
|
|
irrespective of NOOP commands, so they always return OK. If you really
|
|
want to implement it, use a countdown timer to force disconnects but reset
|
|
the counter if ANY command received, including NOOP.}
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandLOGOUT(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if Assigned(FOnCommandLOGOUT) then begin
|
|
OnCommandLOGOUT(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
{Be nice and say ByeBye first...}
|
|
DoSendReply(ASender.Context, '* BYE May your God go with you.'); {Do not Localize}
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
LContext.Connection.Disconnect(False);
|
|
LContext.MailBox.Clear;
|
|
LContext.RemoveFromList;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandAUTHENTICATE(ASender: TIdCommand);
|
|
begin
|
|
if Assigned(FOnCommandAUTHENTICATE) then begin
|
|
{
|
|
Important, when usng TLS and FUseTLS=utUseRequireTLS, do not accept any authentication
|
|
information until TLS negotiation is completed. This insistance is a security feature.
|
|
|
|
Some networks should choose security over interoperability while other places may
|
|
sacrafice interoperability over security. It comes down to sensible administrative
|
|
judgement.
|
|
}
|
|
if (FUseTLS = utUseRequireTLS) and (ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase).PassThrough then begin
|
|
MustUseTLS(ASender);
|
|
end else begin
|
|
OnCommandAUTHENTICATE(ASender.Context, TIdIMAP4PeerContext(ASender.Context).IMAP4Tag, ASender.UnparsedParams);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.MustUseTLS(ASender: TIdCommand);
|
|
begin
|
|
DoSendReply(ASender.Context, 'NO ' + RSSMTPSvrReqSTARTTLS); {Do not Localize}
|
|
ASender.Disconnect := True;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandLOGIN(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
|
|
if Assigned(fOnCommandLOGIN) then begin
|
|
{
|
|
Important, when using TLS and FUseTLS=utUseRequireTLS, do not accept any authentication
|
|
information until TLS negotiation is completed. This insistance is a security feature.
|
|
|
|
Some networks should choose security over interoperability while other places may
|
|
sacrafice interoperability over security. It comes down to sensible administrative
|
|
judgement.
|
|
}
|
|
if (FUseTLS = utUseRequireTLS) and (ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase).PassThrough then begin
|
|
MustUseTLS(ASender);
|
|
end else begin
|
|
OnCommandLOGIN(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
end;
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechDoesImapMailBoxExist) then begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 2 then begin
|
|
//Incorrect number of params...
|
|
if FSaferMode then begin
|
|
SendNoReply(ASender);
|
|
end else begin
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
end;
|
|
Exit;
|
|
end;
|
|
//See if we have a directory under FRootPath of that user's name...
|
|
//if DoesImapMailBoxExist(LParams[0], '') = False then begin
|
|
if not OnDefMechDoesImapMailBoxExist(LParams[0], '') then begin
|
|
if FSaferMode then begin
|
|
SendNoReply(ASender);
|
|
end else begin
|
|
SendNoReply(ASender, 'Unknown username'); {Do not Localize}
|
|
end;
|
|
Exit;
|
|
end;
|
|
//See is it the correct password...
|
|
if not TextIsSame(FDefaultPassword, LParams[1]) then begin
|
|
if FSaferMode then begin
|
|
SendNoReply(ASender);
|
|
end else begin
|
|
SendNoReply(ASender, 'Incorrect password'); {Do not Localize}
|
|
end;
|
|
Exit;
|
|
end;
|
|
//Successful login, change context's state to logged in...
|
|
LContext.LoginName := LParams[0];
|
|
LContext.FConnectionState := csAuthenticated;
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
//SELECT and EXAMINE are the same except EXAMINE opens the mailbox read-only
|
|
procedure TIdIMAP4Server.DoCommandSELECT(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState = csSelected then begin
|
|
LContext.MailBox.Clear;
|
|
LContext.FConnectionState := csAuthenticated;
|
|
end;
|
|
if LContext.ConnectionState <> csAuthenticated then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandSELECT) then begin
|
|
OnCommandSELECT(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechOpenMailBox) then begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
if OnDefMechOpenMailBox(ASender, False) then begin //SELECT opens the mailbox read-write
|
|
LContext.FConnectionState := csSelected;
|
|
SendOkReply(ASender, '[READ-WRITE] Completed'); {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
//SELECT and EXAMINE are the same except EXAMINE opens the mailbox read-only
|
|
procedure TIdIMAP4Server.DoCommandEXAMINE(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if not (LContext.ConnectionState in [csAuthenticated, csSelected]) then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandEXAMINE) then begin
|
|
OnCommandEXAMINE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechOpenMailBox) then begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
if OnDefMechOpenMailBox(ASender, True) then begin //EXAMINE opens the mailbox read-only
|
|
LContext.FConnectionState := csSelected;
|
|
SendOkReply(ASender, '[READ-ONLY] Completed'); {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandCREATE(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
|
|
if not (LContext.ConnectionState in [csAuthenticated, csSelected]) then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
{
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
}
|
|
if Assigned(FOnCommandCREATE) then begin
|
|
OnCommandCREATE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if (not Assigned(OnDefMechReinterpretParamAsMailBox))
|
|
or (not Assigned(OnDefMechDoesImapMailBoxExist))
|
|
or (not Assigned(OnDefMechCreateMailBox)) then
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 1 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if not OnDefMechReinterpretParamAsMailBox(LParams, 0) then begin
|
|
SendBadReply(ASender, 'Mailbox parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if OnDefMechDoesImapMailBoxExist(LContext.LoginName, LParams[0]) then begin
|
|
SendBadReply(ASender, 'Mailbox already exists.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if OnDefMechCreateMailBox(LContext.LoginName, LParams[0]) then begin
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'Create failed'); {Do not Localize}
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandDELETE(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
|
|
if not (LContext.ConnectionState in [csAuthenticated, csSelected]) then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
{
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
}
|
|
if Assigned(FOnCommandDELETE) then begin
|
|
OnCommandDELETE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if (not Assigned(OnDefMechDoesImapMailBoxExist))
|
|
or (not Assigned(OnDefMechReinterpretParamAsMailBox))
|
|
or (not Assigned(OnDefMechDeleteMailBox))
|
|
or (not Assigned(OnDefMechIsMailBoxOpen)) then
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
//Make sure we don't have the mailbox open by anyone
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 1 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if not OnDefMechReinterpretParamAsMailBox(LParams, 0) then begin
|
|
SendBadReply(ASender, 'Mailbox parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if OnDefMechIsMailBoxOpen(LContext.LoginName, LParams[0]) then begin
|
|
SendNoReply(ASender, 'Mailbox is in use.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if not OnDefMechDoesImapMailBoxExist(LContext.LoginName, LParams[0]) then begin
|
|
SendNoReply(ASender, 'Mailbox does not exist.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if OnDefMechDeleteMailBox(LContext.LoginName, LParams[0]) then begin
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'Delete failed'); {Do not Localize}
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandRENAME(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if not (LContext.ConnectionState in [csAuthenticated, csSelected]) then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
{
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
}
|
|
if Assigned(FOnCommandRENAME) then begin
|
|
OnCommandRENAME(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if (not Assigned(OnDefMechDoesImapMailBoxExist))
|
|
or (not Assigned(OnDefMechReinterpretParamAsMailBox))
|
|
or (not Assigned(OnDefMechRenameMailBox))
|
|
or (not Assigned(OnDefMechIsMailBoxOpen)) then
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
//Make sure we don't have the mailbox open by anyone
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 2 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if not OnDefMechReinterpretParamAsMailBox(LParams, 0) then begin
|
|
SendBadReply(ASender, 'First mailbox parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if OnDefMechIsMailBoxOpen(LContext.LoginName, LParams[0]) then begin
|
|
SendNoReply(ASender, 'Mailbox is in use.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if not OnDefMechReinterpretParamAsMailBox(LParams, 1) then begin
|
|
SendBadReply(ASender, 'Second mailbox parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if not OnDefMechDoesImapMailBoxExist(LContext.LoginName, LParams[0]) then begin
|
|
SendNoReply(ASender, 'Mailbox to be renamed does not exist.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if OnDefMechDoesImapMailBoxExist(LContext.LoginName, LParams[1]) then begin
|
|
SendNoReply(ASender, 'Destination mailbox already exists.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if OnDefMechRenameMailBox(LContext.LoginName, LParams[0], LParams[1]) then begin
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'Delete failed'); {Do not Localize}
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandSUBSCRIBE(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandSUBSCRIBE) then begin
|
|
OnCommandSUBSCRIBE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
{Not clear exactly what this would do in this sample mechanism...}
|
|
SendUnsupportedCommand(ASender);
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandUNSUBSCRIBE(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandUNSUBSCRIBE) then begin
|
|
OnCommandUNSUBSCRIBE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
{Not clear exactly what this would do in this sample mechanism...}
|
|
SendUnsupportedCommand(ASender);
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandLIST(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LMailBoxNames: TStringList;
|
|
LMailBoxFlags: TStringList;
|
|
LN: integer;
|
|
LEntry: string;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if not (LContext.ConnectionState in [csAuthenticated, csSelected]) then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandLIST) then begin
|
|
OnCommandLIST(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechListMailBox) then begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
//The default mechanism only supports the following format:
|
|
// LIST "" *
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 2 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if LParams[1] <> '*' then begin {Do not Localize}
|
|
SendBadReply(ASender, 'Parameter not supported, 2nd (last) parameter must be *'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LMailBoxNames := TStringList.Create;
|
|
try
|
|
LMailBoxFlags := TStringList.Create;
|
|
try
|
|
if OnDefMechListMailBox(LContext.LoginName, LParams[0], LMailBoxNames, LMailBoxFlags) then begin
|
|
for LN := 0 to LMailBoxNames.Count-1 do begin
|
|
//Replies are of the form:
|
|
//* LIST (\HasNoChildren) "." "INBOX.CreatedFolder"
|
|
LEntry := '* LIST ('; {Do not Localize}
|
|
if LMailBoxFlags[LN] <> '' then begin
|
|
LEntry := LEntry + LMailBoxFlags[LN];
|
|
end;
|
|
LEntry := LEntry + ') "' + MailBoxSeparator + '" "' + LMailBoxNames[LN] + '"'; {Do not Localize}
|
|
DoSendReply(ASender.Context, LEntry); {Do not Localize}
|
|
end;
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'List failed'); {Do not Localize}
|
|
end;
|
|
finally
|
|
FreeAndNil(LMailBoxFlags);
|
|
end;
|
|
finally
|
|
FreeAndNil(LMailBoxNames);
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandLSUB(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LMailBoxNames: TStringList;
|
|
LMailBoxFlags: TStringList;
|
|
LN: integer;
|
|
LEntry: string;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if not (LContext.ConnectionState in [csAuthenticated, csSelected]) then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandLSUB) then begin
|
|
OnCommandLSUB(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechListMailBox) then begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
//Treat this the same as LIST...
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 2 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if LParams[1] <> '*' then begin {Do not Localize}
|
|
SendBadReply(ASender, 'Parameter not supported, 2nd (last) parameter must be *'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LMailBoxNames := TStringList.Create;
|
|
try
|
|
LMailBoxFlags := TStringList.Create;
|
|
try
|
|
if OnDefMechListMailBox(LContext.LoginName, LParams[0], LMailBoxNames, LMailBoxFlags) then begin
|
|
for LN := 0 to LMailBoxNames.Count-1 do begin
|
|
//Replies are of the form:
|
|
//* LIST (\HasNoChildren) "." "INBOX.CreatedFolder"
|
|
LEntry := '* LIST ('; {Do not Localize}
|
|
if LMailBoxFlags[LN] <> '' then begin
|
|
LEntry := LEntry + LMailBoxFlags[LN];
|
|
end;
|
|
LEntry := LEntry + ') "' + MailBoxSeparator + '" "' + LMailBoxNames[LN] + '"'; {Do not Localize}
|
|
DoSendReply(ASender.Context, LEntry); {Do not Localize}
|
|
end;
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'List failed'); {Do not Localize}
|
|
end;
|
|
finally
|
|
FreeAndNil(LMailBoxFlags);
|
|
end;
|
|
finally
|
|
FreeAndNil(LMailBoxNames);
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandSTATUS(ASender: TIdCommand);
|
|
var
|
|
LMailBox: TIdMailBox;
|
|
LN: integer;
|
|
LParams: TStringList;
|
|
LTemp: string;
|
|
LAnswer: string;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if not (LContext.ConnectionState in [csAuthenticated, csSelected]) then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandSTATUS) then begin
|
|
OnCommandSTATUS(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if (not Assigned(OnDefMechDoesImapMailBoxExist))
|
|
or (not Assigned(OnDefMechReinterpretParamAsMailBox))
|
|
or (not Assigned(OnDefMechSetupMailbox)) then
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
//This can be issued for ANY mailbox, not just the currently selected one.
|
|
//The format is:
|
|
//C5 STATUS "INBOX" (MESSAGES RECENT UIDNEXT UIDVALIDITY UNSEEN)
|
|
//* STATUS INBOX (MESSAGES 490 RECENT 132 UIDNEXT 6546 UIDVALIDITY 1065090323 UNSEEN 167)
|
|
//C5 OK Completed
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 1 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if not OnDefMechReinterpretParamAsMailBox(LParams, 0) then begin
|
|
SendBadReply(ASender, 'Mailbox parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
if not OnDefMechDoesImapMailBoxExist(LContext.LoginName, LParams[0]) then begin
|
|
SendNoReply(ASender, 'Mailbox does not exist.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
{Get everything you need for this mailbox...}
|
|
LMailBox := TIdMailBox.Create;
|
|
try
|
|
OnDefMechSetupMailbox(LContext.LoginName, LParams[0], LMailBox);
|
|
{Send the stats...}
|
|
LAnswer := '* STATUS ' + LParams[0] + ' ('; {Do not Localize}
|
|
for LN := 1 to LParams.Count-1 do begin
|
|
LTemp := LParams[LN];
|
|
if LTemp <> '' then begin
|
|
//Strip brackets (will be on 1st & last param)
|
|
if LTemp[1] = '(' then begin {Do not Localize}
|
|
LTemp := Copy(LTemp, 2, MaxInt);
|
|
end;
|
|
if (LTemp <> '') and (LTemp[Length(LTemp)] = ')') then begin {Do not Localize}
|
|
LTemp := Copy(LTemp, 1, Length(LTemp)-1);
|
|
end;
|
|
case PosInStrArray(LTemp, ['MESSAGES', 'RECENT', 'UIDNEXT', 'UIDVALIDITY', 'UNSEEN'], False) of
|
|
0: // MESSAGES {Do not Localize}
|
|
begin
|
|
LAnswer := LAnswer + LTemp + ' ' + IntToStr(LMailBox.TotalMsgs) + ' '; {Do not Localize}
|
|
end;
|
|
1: // RECENT {Do not Localize}
|
|
begin
|
|
LAnswer := LAnswer + LTemp + ' ' + IntToStr(LMailBox.RecentMsgs) + ' '; {Do not Localize}
|
|
end;
|
|
2: // UIDNEXT {Do not Localize}
|
|
begin
|
|
LAnswer := LAnswer + LTemp + ' ' + LMailBox.UIDNext + ' '; {Do not Localize}
|
|
end;
|
|
3: // UIDVALIDITY {Do not Localize}
|
|
begin
|
|
LAnswer := LAnswer + LTemp + ' ' + LMailBox.UIDValidity + ' '; {Do not Localize}
|
|
end;
|
|
4: // UNSEEN {Do not Localize}
|
|
begin
|
|
LAnswer := LAnswer + LTemp + ' ' + IntToStr(LMailBox.UnseenMsgs) + ' '; {Do not Localize}
|
|
end;
|
|
else
|
|
begin
|
|
SendBadReply(ASender, 'Parameter not supported: ' + LTemp); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if LAnswer[Length(LAnswer)] = ' ' then begin {Do not Localize}
|
|
LAnswer := Copy(LAnswer, 1, Length(LAnswer)-1);
|
|
end;
|
|
LAnswer := LAnswer + ')'; {Do not Localize}
|
|
DoSendReply(ASender.Context, LAnswer);
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
finally
|
|
FreeAndNil(LMailBox);
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandAPPEND(ASender: TIdCommand);
|
|
var
|
|
LUID: string;
|
|
LStream: TStream;
|
|
LFile: string;
|
|
LTemp: string;
|
|
LParams: TStringList;
|
|
LParams2: TStringList;
|
|
LFlagsList: TStringList;
|
|
LSize: integer;
|
|
LFlags, LInternalDateTime: string;
|
|
LN: integer;
|
|
LMessage: TIdMessage;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
//You do NOT need to be in selected state for this.
|
|
if LContext.ConnectionState <> csAuthenticated then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandAPPEND) then begin
|
|
OnCommandAPPEND(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if (not Assigned(OnDefMechGetNextFreeUID))
|
|
or (not Assigned(OnDefMechReinterpretParamAsMailBox))
|
|
or (not Assigned(OnDefMechUpdateNextFreeUID))
|
|
or (not Assigned(OnDefMechDeleteMessage)) //Needed to reverse out a save if setting flags fail
|
|
or (not Assigned(OnDefMechGetFileNameToWriteAppendMessage)) then
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
//Format (the flags and date/time are optional):
|
|
//C323 APPEND "INBOX.Sent" (\Seen) "internal date/time" {1876}
|
|
//+ go ahead
|
|
//...
|
|
//C323 OK [APPENDUID 1065095982 105] Completed
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 2 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
if not OnDefMechReinterpretParamAsMailBox(LParams, 0) then begin
|
|
SendBadReply(ASender, 'Mailbox parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LFlags := '';
|
|
LInternalDateTime := '';
|
|
LN := 1;
|
|
LTemp := LParams[Ln];
|
|
if TextStartsWith(LTemp, '(') then begin {Do not Localize}
|
|
if not ReinterpretParamAsFlags(LParams, Ln) then begin
|
|
SendBadReply(ASender, 'Flags parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LFlags := LParams[Ln];
|
|
Inc(Ln);
|
|
end
|
|
else if TextIsSame(LTemp, 'NIL') then begin {Do not Localize}
|
|
Inc(Ln);
|
|
end;
|
|
LTemp := LParams[Ln];
|
|
if TextStartsWith(LTemp, '"') then begin {Do not Localize}
|
|
if not ReinterpretParamAsQuotedStr(LParams, Ln) then begin
|
|
SendBadReply(ASender, 'InternalDateTime parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LInternalDateTime := LParams[Ln];
|
|
end;
|
|
LTemp := LParams[LParams.Count-1];
|
|
if not TextStartsWith(LTemp, '{') then begin {Do not Localize}
|
|
SendBadReply(ASender, 'Size parameter is invalid.'); {Do not Localize}
|
|
Exit;
|
|
end;
|
|
LSize := IndyStrToInt(Copy(LTemp, 2, Length(LTemp)-2));
|
|
//Grab the next UID...
|
|
LUID := OnDefMechGetNextFreeUID(LContext.LoginName, LParams[0]);
|
|
//Get the message...
|
|
LFile := OnDefMechGetFileNameToWriteAppendMessage(LContext.LoginName, LContext.MailBox.Name, LUID);
|
|
LStream := TIdFileCreateStream.Create(LFile);
|
|
try
|
|
ASender.Context.Connection.IOHandler.ReadStream(LStream, LSize);
|
|
if LFlags = '' then begin
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
//Update the (optional) flags...
|
|
LParams2 := TStringList.Create;
|
|
try
|
|
LParams2.Add(LUID);
|
|
LParams2.Add('FLAGS.SILENT'); {Do not Localize}
|
|
{
|
|
for LN := 1 to LParams.Count-2 do begin
|
|
LParams2.Add(LParams[LN]);
|
|
end;
|
|
}
|
|
//The flags are in a string, need to reassemble...
|
|
LFlagsList := TStringList.Create;
|
|
try
|
|
BreakApart(LFlags, ' ', LFlagsList); {Do not Localize}
|
|
for LN := 0 to LFlagsList.Count-1 do begin
|
|
LTemp := LFlagsList[LN];
|
|
if LN = 0 then begin
|
|
LTemp := '(' + LTemp; {Do not Localize}
|
|
end;
|
|
if LN = LFlagsList.Count-1 then begin
|
|
LTemp := LTemp + ')'; {Do not Localize}
|
|
end;
|
|
LParams2.Add(LTemp);
|
|
end;
|
|
if not ProcessStore(True, ASender, LParams2) then begin
|
|
//Have to reverse out our changes if ANYTHING fails..
|
|
LMessage := TIdMessage.Create(Self);
|
|
try
|
|
LMessage.UID := LUID; //This is all we need for deletion
|
|
OnDefMechDeleteMessage(LContext.LoginName, LContext.MailBox.Name, LMessage);
|
|
finally
|
|
FreeAndNil(LMessage);
|
|
end;
|
|
Exit;
|
|
end;
|
|
finally
|
|
FreeAndNil(LFlagsList);
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams2);
|
|
end;
|
|
end;
|
|
//Update the next free UID in the .uid file...
|
|
OnDefMechUpdateNextFreeUID(LContext.LoginName, LContext.MailBox.Name, IntToStr(IndyStrToInt(LUID)+1));
|
|
// TODO: implement this
|
|
{
|
|
if LInternalDateTime <> '' then
|
|
begin
|
|
// what to do here?
|
|
end;
|
|
}
|
|
finally
|
|
FreeAndNil(LStream);
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandCHECK(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(fOnCommandCHECK) then begin
|
|
OnCommandCHECK(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
{On most servers, this does nothing, they always return OK...}
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandCLOSE(ASender: TIdCommand);
|
|
var
|
|
LResult: Boolean;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(fOnCommandCLOSE) then begin
|
|
OnCommandCLOSE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechDeleteMessage) then begin //Used by ExpungeRecords
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
{This is an implicit expunge...}
|
|
LResult := ExpungeRecords(ASender);
|
|
{Now close it...}
|
|
LContext.MailBox.Clear;
|
|
LContext.FConnectionState := csAuthenticated;
|
|
if LResult then begin
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'Implicit expunge failed for one or more messages'); {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandEXPUNGE(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandEXPUNGE) then begin
|
|
OnCommandEXPUNGE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechDeleteMessage) then begin //Used by ExpungeRecords
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
if ExpungeRecords(ASender) then begin
|
|
SendOkReply(ASender, 'Completed'); {Do not Localize}
|
|
end else begin
|
|
SendNoReply(ASender, 'Expunge failed for one or more messages'); {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandSEARCH(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(fOnCommandSEARCH) then begin
|
|
OnCommandSEARCH(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if not Assigned(OnDefMechGetMessageHeader) then begin //Used by ProcessSearch
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
ProcessSearch(False, ASender, LParams);
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandFETCH(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandFETCH) then begin
|
|
OnCommandFETCH(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
if (not Assigned(OnDefMechGetMessageHeader)) //Used by ProcessFetch
|
|
or (not Assigned(OnDefMechGetMessageSize))
|
|
or (not Assigned(OnDefMechGetMessageRaw)) then
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
ProcessFetch(False, ASender, LParams);
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandSTORE(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(fOnCommandSTORE) then begin
|
|
OnCommandSTORE(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
ProcessStore(False, ASender, LParams);
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
function TIdIMAP4Server.MessageFlagSetToStr(const AFlags: TIdMessageFlagsSet): String;
|
|
begin
|
|
Result := '';
|
|
if mfAnswered in AFlags then begin
|
|
Result := Result + MessageFlags[mfAnswered] + ' '; {Do not Localize}
|
|
end;
|
|
if mfFlagged in AFlags then begin
|
|
Result := Result + MessageFlags[mfFlagged] + ' '; {Do not Localize}
|
|
end;
|
|
if mfDeleted in AFlags then begin
|
|
Result := Result + MessageFlags[mfDeleted] + ' '; {Do not Localize}
|
|
end;
|
|
if mfDraft in AFlags then begin
|
|
Result := Result + MessageFlags[mfDraft] + ' '; {Do not Localize}
|
|
end;
|
|
if mfSeen in AFlags then begin
|
|
Result := Result + MessageFlags[mfSeen] + ' '; {Do not Localize}
|
|
end;
|
|
if Result <> '' then begin
|
|
Result := TrimRight(Result);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandCOPY(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if LContext.MailBox.State = msReadOnly then begin
|
|
SendErrorOpenedReadOnly(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(FOnCommandCOPY) then begin
|
|
OnCommandCOPY(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
//Format is COPY 2:4 DestinationMailBoxName
|
|
if (not Assigned(OnDefMechReinterpretParamAsMailBox))
|
|
or (not Assigned(OnDefMechCopyMessage)) then //Needed for ProcessCopy
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
ProcessCopy(False, ASender, LParams);
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
{UID before COPY, FETCH or STORE means the record numbers are UIDs.
|
|
UID before SEARCH means SEARCH is to _return_ UIDs rather than relative numbers.}
|
|
procedure TIdIMAP4Server.DoCommandUID(ASender: TIdCommand);
|
|
var
|
|
LParams: TStringList;
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if LContext.ConnectionState <> csSelected then begin
|
|
SendWrongConnectionState(ASender);
|
|
Exit;
|
|
end;
|
|
if Assigned(fOnCommandUID) then begin
|
|
OnCommandUID(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if not FUseDefaultMechanismsForUnassignedCommands then begin
|
|
Exit;
|
|
end;
|
|
LParams := TStringList.Create;
|
|
try
|
|
BreakApart(ASender.UnparsedParams, ' ', LParams); {Do not Localize}
|
|
if LParams.Count < 1 then begin
|
|
//Incorrect number of params...
|
|
SendIncorrectNumberOfParameters(ASender);
|
|
Exit;
|
|
end;
|
|
//Map the commands to the general handler but remove the FETCH or whatever...
|
|
case PosInStrArray(LParams[0], ['FETCH', 'COPY', 'STORE', 'SEARCH'], False) of
|
|
0: // FETCH {Do not Localize}
|
|
begin
|
|
if (not Assigned(OnDefMechGetMessageHeader)) //Used by ProcessFetch
|
|
or (not Assigned(OnDefMechGetMessageSize))
|
|
or (not Assigned(OnDefMechGetMessageRaw)) then
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams.Delete(0);
|
|
ProcessFetch(True, ASender, LParams);
|
|
end;
|
|
1: // COPY {Do not Localize}
|
|
begin
|
|
if (not Assigned(OnDefMechReinterpretParamAsMailBox))
|
|
or (not Assigned(OnDefMechCopyMessage)) then //Needed for ProcessCopy
|
|
begin
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams.Delete(0);
|
|
ProcessCopy(True, ASender, LParams);
|
|
end;
|
|
2: // STORE {Do not Localize}
|
|
begin
|
|
LParams.Delete(0);
|
|
ProcessStore(True, ASender, LParams);
|
|
end;
|
|
3: // SEARCH {Do not Localize}
|
|
begin
|
|
if not Assigned(OnDefMechGetMessageHeader) then begin //Used by ProcessSearch
|
|
SendUnassignedDefaultMechanism(ASender);
|
|
Exit;
|
|
end;
|
|
LParams.Delete(0);
|
|
ProcessSearch(True, ASender, LParams);
|
|
end;
|
|
else
|
|
begin
|
|
SendUnsupportedCommand(ASender);
|
|
end;
|
|
end;
|
|
finally
|
|
FreeAndNil(LParams);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandX(ASender: TIdCommand);
|
|
begin
|
|
if not Assigned(fOnCommandX) then begin
|
|
OnCommandX(ASender.Context, TIdIMAP4PeerContext(ASender.Context).IMAP4Tag, ASender.UnparsedParams);
|
|
end else if FUseDefaultMechanismsForUnassignedCommands then begin
|
|
SendUnsupportedCommand(ASender);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdIMAP4Server.DoCommandSTARTTLS(ASender: TIdCommand);
|
|
var
|
|
LContext: TIdIMAP4PeerContext;
|
|
begin
|
|
LContext := TIdIMAP4PeerContext(ASender.Context);
|
|
if (not (IOHandler is TIdServerIOHandlerSSLBase)) or (not (FUseTLS in ExplicitTLSVals)) then begin
|
|
OnCommandError(ASender.Context, LContext.IMAP4Tag, ASender.UnparsedParams);
|
|
Exit;
|
|
end;
|
|
if LContext.UsingTLS then begin // we are already using TLS
|
|
DoSendReply(ASender.Context, 'BAD %s', [RSIMAP4SvrNotPermittedWithTLS]); {do not localize}
|
|
Exit;
|
|
end;
|
|
// TODO: STARTTLS may only be issued in auth-state
|
|
DoSendReply(ASender.Context, 'OK %s', [RSIMAP4SvrBeginTLSNegotiation]); {do not localize}
|
|
(ASender.Context.Connection.IOHandler as TIdSSLIOHandlerSocketBase).Passthrough := False;
|
|
end;
|
|
|
|
end.
|