📄 idimap4server.pas
字号:
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;
//
//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 SendOkCompleted(ASender: TIdCommand);
procedure SendBadReply(ASender: TIdCommand; AText: string);
procedure SendNoReply(ASender: TIdCommand; AText: string);
//
//The following are used internally by the default mechanism...
function ExpungeRecords(ASender: TIdCommand): Boolean;
function MessageSetToMessageNumbers(AUseUID: Boolean; ASender: TIdCommand; var AMessageNumbers: TIdStringList; AMessageSet: string): Boolean;
function GetRecordForUID(AMessageNumber: integer; AMailBox: TIdMailBox): integer;
procedure ProcessFetch(AUseUID: Boolean; ASender: TIdCommand; AParams: TIdStringList);
procedure ProcessCopy(AUseUID: Boolean; ASender: TIdCommand; AParams: TIdStringList);
function ProcessStore(AUseUID: Boolean; ASender: TIdCommand; AParams: TIdStringList): Boolean;
procedure ProcessSearch(AUseUID: Boolean; ASender: TIdCommand; AParams: TIdStringList);
function FlagStringToFlagList(var AFlagList: TIdStringList; AFlagString: string): Boolean;
function StripQuotesIfNecessary(AName: string): string;
function ReassembleParams(ASeparator: char; var AParams: TIdStringList; AParamToReassemble: integer): Boolean;
function ReinterpretParamAsMailBox(var AParams: TIdStringList; AMailBoxParam: integer): Boolean;
function ReinterpretParamAsFlags(var AParams: TIdStringList; AFlagsParam: integer): Boolean;
function ReinterpretParamAsDataItems(var AParams: TIdStringList; 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; AData: string);
//
//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
destructor Destroy; override;
published
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,
IdStreamVCL,
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 '+Self.GetVersion); {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.SendOkCompleted(ASender: TIdCommand);
begin
DoSendReply(ASender.Context, FLastCommand.SequenceNumber + ' OK Completed'); {Do not Localize}
end;
procedure TIdIMAP4Server.SendBadReply(ASender: TIdCommand; AText: string);
begin
DoSendReply(ASender.Context, FLastCommand.SequenceNumber + ' BAD '+AText); {Do not Localize}
end;
procedure TIdIMAP4Server.SendNoReply(ASender: TIdCommand; AText: string);
begin
DoSendReply(ASender.Context, FLastCommand.SequenceNumber + ' NO '+AText); {Do not Localize}
end;
procedure TIdIMAP4Server.InitComponent;
begin
inherited;
//Self.FGreeting.SetReply('OK', 'Welcome');
//Todo: Not sure which number is appropriate. Should be tested
FImplicitTLSProtPort := IdPORT_IMAP4S; //Id_PORT_imap4_ssl_dp;
FRegularProtPort := IdPORT_IMAP4;
DefaultPort := IdPORT_IMAP4;
ReplyUnknownCommand.SetReply('BAD','Unknown command'); {Do not Localize}
ContextClass := TIdIMAP4PeerContext;
FSaferMode := False;
FUseDefaultMechanismsForUnassignedCommands := True;
if FRootPath = '' then begin
{$IFDEF LINUX}
FRootPath := GPathDelim+'var'+PathDelim+'imapmail'; {Do not Localize}
{$ELSE}
FRootPath := GPathDelim+'imapmail'; {Do not Localize}
{$ENDIF}
end;
if FDefaultPassword = '' then begin
FDefaultPassword := 'admin'; {Do not Localize}
end;
FLastCommand := TIdReplyIMAP4.Create;
FMailBoxSeparator := '.'; {Do not Localize}
end;
destructor TIdIMAP4Server.Destroy;
begin
FreeAndNil(FLastCommand);
inherited;
end;
constructor TIdIMAP4PeerContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
FTagData := TIdIMAP4Tag.Create;
FConnectionState := csAny;
end;
destructor TIdIMAP4PeerContext.Destroy;
begin
FreeAndNil(FTagData);
inherited;
end;
function TIdIMAP4PeerContext.GetUsingTLS:boolean;
begin
Result:=Connection.IOHandler is TIdSSLIOHandlerSocketBase;
if result then
Result:=not TIdSSLIOHandlerSocketBase(Connection.IOHandler).PassThrough;
end;
procedure TIdIMAP4Server.DoReplyUnknownCommand(AContext: TIdContext; AText: string);
//AText is ignored by TIdIMAP4Server
var
LText: string;
begin
LText := '';
if FLastCommand.SequenceNumber = '' then begin
//This should not happen!
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -