 | 
|
|
|
{ }
{ POP3 Server v3.03 }
{ }
{ This unit is copyright © 2000-2004 by David J Butler }
{ }
{ This unit is part of Delphi Fundamentals. }
{ Its original file name is cPOP3Client.pas }
{ The latest version is available from the Fundamentals home page }
{ http://fundementals.sourceforge.net/ }
{ }
{ I invite you to use this unit, free of charge. }
{ I invite you to distibute this unit, but it must be for free. }
{ I also invite you to contribute to its development, }
{ but do not distribute a modified copy of this file. }
{ }
{ A forum is available on SourceForge for general discussion }
{ http://sourceforge.net/forum/forum.php?forum_id=2117 }
{ }
{ }
{ Revision history: }
{ 2000/10/21 0.01 Addded TPop3Server. }
{ 2002/09/09 0.02 Refactored. }
{ 2004/02/07 3.03 Included in Fundamentals 3. }
{ }
{$INCLUDE ..\cDefines.inc}
unit cPOP3Server;
interface
uses
{ Delphi }
Classes,
{ Fundamentals }
cUtils,
cStreams,
cTCPServer;
{ }
{ TPop3Server }
{ }
type
TPop3ServerClient = class;
TPop3ServerNotifyEvent = procedure (Sender: TPop3ServerClient) of object;
TPop3ServerAuthenticationEvent = procedure (Sender: TPop3ServerClient;
UserName: String; var Password: String; var ValidUser: Boolean) of object;
TPop3ServerLoginAction = (la_AllowAccess, la_MailboxInUse, la_MailboxNotAvail);
TPop3ServerLoginEvent = procedure (Sender: TPop3ServerClient;
var MessageSizes: Int64Array; var MessageUIDs: StringArray;
var Action: TPop3ServerLoginAction) of object;
TPop3ServerGetMessageEvent = procedure (Sender: TPop3ServerClient;
MsgIdx: Integer; var MessageHeader, MessageBody: String;
var MessageBodyStream: AStream) of object;
TPop3ServerDeleteMessageEvent = procedure (Sender: TPop3ServerClient;
MsgIdx: Integer) of object;
TPop3ServerMessage = class
Size : Int64;
UID : String;
Deleted : Boolean;
end;
{ TPop3ServerClient }
TPop3ServerClient = class(TTCPServerClient)
private
FMsgSizes : Int64Array;
FMsgUIDs : StringArray;
FMsgIdx : Integer;
FMsgHdr : String;
FMsgBody : String;
FMsgBodyStream : AStream;
FValidUser : Boolean;
FLoginAction : TPop3ServerLoginAction;
protected
FUserName : String;
FPassword : String;
FAuthenticated : Boolean;
FMessages : Array of TPop3ServerMessage;
procedure NotifyAuthentication;
procedure NotifyLogin;
procedure NotifyLogout;
procedure NotifyGetMessage;
procedure NotifyDeleteMessage;
function IsConnected: Boolean;
procedure SendLine(const Msg: String);
procedure SendResponse(const OK: Boolean; const Msg: String);
function GetCommand (var Cmd, Param: String): Boolean;
procedure ThreadRun; override;
public
destructor Destroy; override;
property UserName: String read FUserName;
property Password: String read FPassword;
property Authenticated: Boolean read FAuthenticated write FAuthenticated;
end;
{ TPop3Server }
CPop3ServerClientThread = class of TPop3ServerClient;
TPop3ServerOptions = Set of (psoLogDebug);
TPop3Server = class(ATCPServer)
protected
FOptions : TPop3ServerOptions;
FAppName : String;
FHostName : String;
FServerReady : Boolean;
FGreeting : String;
FOnAuthentication : TPop3ServerAuthenticationEvent;
FOnLogin : TPop3ServerLoginEvent;
FOnLogout : TPop3ServerNotifyEvent;
FOnGetMessage : TPop3ServerGetMessageEvent;
FOnDelMessage : TPop3ServerDeleteMessageEvent;
FEnableAPOP : Boolean;
FRequireAPOP : Boolean;
function GetHostName: String;
function GetPop3Greeting (var APOPStamp: String): String;
procedure Init; override;
public
property Options: TPop3ServerOptions read FOptions write FOptions default [];
property AppName: String read FAppName write FAppName;
property HostName: String read GetHostName write FHostName;
property ServerReady: Boolean read FServerReady write FServerReady default True;
property Greeting: String read FGreeting write FGreeting;
property OnAuthentication: TPop3ServerAuthenticationEvent read FOnAuthentication write FOnAuthentication;
property OnLogin: TPop3ServerLoginEvent read FOnLogin write FOnLogin;
property OnLogout: TPop3ServerNotifyEvent read FOnLogout write FOnLogout;
property EnableAPOP: Boolean read FEnableAPOP write FEnableAPOP default True;
property RequireAPOP: Boolean read FRequireAPOP write FRequireAPOP default False;
property OnGetMessage: TPop3ServerGetMessageEvent read FOnGetMessage write FOnGetMessage;
property OnDeleteMessage: TPop3ServerDeleteMessageEvent read FOnDelMessage write FOnDelMessage;
end;
{ }
{ TfndPop3Server }
{ }
type
TfndPop3Server = class(TPop3Server)
published
property LogTo;
property OnLog;
property LocalHost;
property ListenPort;
property MaxBacklog;
property TimeOut;
property Active;
property OnActive;
property OnInactive;
property ThrottleClientRead;
property ThrottleClientReadRate;
property ThrottleClientWrite;
property ThrottleClientWriteRate;
property Options;
property AppName;
property HostName;
property ServerReady;
property Greeting;
property OnAuthentication;
property OnLogin;
property OnLogout;
property EnableAPOP;
property RequireAPOP;
property OnGetMessage;
property OnDeleteMessage;
end;
implementation
uses
{ Delphi }
SysUtils,
{ Fundamentals }
cStrings,
cHash,
cReaders,
cLog,
cPOP3,
cInternetUtils,
cTCPStream;
{ }
{ TPop3Server }
{ }
procedure TPop3Server.Init;
begin
inherited Init;
FOptions := [];
FServerReady := True;
FListenPort := DefaultPOP3PortStr;
FEnableAPOP := True;
FRequireAPOP := False;
FServerMode := smAcceptClientThread;
FClientClass := TPop3ServerClient;
end;
function TPop3Server.GetHostName: String;
begin
if FHostName <> '' then
Result := FHostName else
begin
Result := LocalHost;
if Result = '' then
Result := LocalHostName;
end;
end;
destructor TPop3ServerClient.Destroy;
begin
FreeAndNil(FMsgBodyStream);
FreeObjectArray(FMessages);
inherited Destroy;
end;
function TPop3Server.GetPop3Greeting(var APOPStamp: String): String;
begin
if FGreeting <> '' then
Result := FGreeting else
begin
Result := HostName + iif(FServerReady, ' ready', ' not ready') + '.';
if FAppName <> '' then
Result := Result + ' ' + FAppName;
end;
Result := Result + ' (' + POP3Version + ')';
if FEnableAPOP then
begin
APOPStamp := MessageIDFieldBody('', HostName);
Result := Result + ' ' + APOPStamp;
end else
APOPStamp := '';
end;
{ }
{ TPop3ServerClient }
{ }
procedure TPop3ServerClient.NotifyAuthentication;
begin
FPassword := '';
FValidUser := False;
if Assigned(TPop3Server(FServer).FOnAuthentication) then
TPop3Server(FServer).FOnAuthentication(self, FUserName, FPassword, FValidUser);
end;
procedure TPop3ServerClient.NotifyLogin;
begin
FMsgSizes := nil;
FMsgUIDs := nil;
FLoginAction := la_MailboxNotAvail;
if Assigned(TPop3Server(FServer).FOnLogin) then
TPop3Server(FServer).FOnLogin(self, FMsgSizes, FMsgUIDs, FLoginAction);
end;
procedure TPop3ServerClient.NotifyLogout;
begin
if Assigned(TPop3Server(FServer).FOnLogout) then
TPop3Server(FServer).FOnLogout(self);
end;
procedure TPop3ServerClient.NotifyGetMessage;
begin
FMsgHdr := '';
FMsgBody := '';
FreeAndNil(FMsgBodyStream);
if Assigned(TPop3Server(FServer).FOnGetMessage) then
TPop3Server(FServer).FOnGetMessage(self, FMsgIdx, FMsgHdr, FMsgBody, FMsgBodyStream);
end;
procedure TPop3ServerClient.NotifyDeleteMessage;
begin
if Assigned(TPop3Server(FServer).FOnDelMessage) then
TPop3Server(FServer).FOnDelMessage(self, FMsgIdx);
end;
function TPop3ServerClient.IsConnected: Boolean;
begin
Result := not Terminated and Assigned(FStream) and FStream.Connected;
end;
procedure TPop3ServerClient.SendLine(const Msg: String);
begin
if not IsConnected then
exit;
FStream.WriteStr(Msg + CRLF)
end;
procedure TPop3ServerClient.SendResponse(const OK: Boolean; const Msg: String);
var S : String;
begin
S := EncodePop3Response(OK, Msg);
if psoLogDebug in TPop3Server(FServer).Options then
Log(lcDebug, iif(FUserName <> '', FUserName + ' ', '') + 'S: ' + S);
SendLine(S);
end;
function TPop3ServerClient.GetCommand(var Cmd, Param: String): Boolean;
var R : Boolean;
S : String;
begin
Cmd := '';
Param := '';
Repeat
Repeat
if not IsConnected then
Result := False else
try
S := FStream.Reader.ExtractLine(MaxPop3LineLength, [eolEOF, eolCRLF]);
Result := True;
except
Result := False;
end;
if not Result then
exit;
Until S <> '';
if psoLogDebug in TPop3Server(FServer).Options then
Log(lcDebug, iif(FUserName <> '', FUserName + ' ', '') + 'C: ' + Cmd);
StrSplitAt(S, ' ', Cmd, Param, True, True);
TrimInPlace(Cmd);
ConvertUpper(Cmd);
TrimInPlace(Param);
R := False;
if Cmd = 'NOOP' then
SendResponse(True, 'Did nothing') else
if Cmd = 'CAPA' then
begin
SendResponse(True, 'This server is capable of');
SendLine('TOP');
SendLine('USER');
SendLine('PIPELINING');
SendLine('UIDL');
SendLine('RESP-CODES');
SendLine('IMPLEMENTATION ' + POP3Version);
SendLine('.');
end else
R := True;
Until R;
end;
procedure TPop3ServerClient.ThreadRun;
var POP3Server : TPop3Server;
APOPStamp : String;
MsgCount : Integer;
function GetMailboxSize: Int64;
var I : Integer;
begin
Result := 0;
For I := 0 to Length(FMessages) - 1 do
if not FMessages[I].Deleted then
Result := Result + FMessages[I].Size;
end;
function GetMessageCount: Integer;
var I : Integer;
begin
Result := 0;
For I := 0 to Length(FMessages) - 1 do
if not FMessages[I].Deleted then
Inc(Result);
end;
function VerboseMaildropStats: String;
begin
Result := IntToStr(GetMessageCount) + ' messages (' + IntToStr(GetMailboxSize) + ' octets)';
end;
function CheckValidMsgNum(const Cmd: String; const Param: String; var MsgNum: Integer; const CheckDeleted: Boolean): Boolean;
begin
MsgNum := StrToIntDef(Param, -1);
Result := False;
if MsgNum <= 0 then
SendResponse(False, 'Invalid argument to ' + Cmd + ' command.') else
if MsgNum > MsgCount then
SendResponse(False, 'Invalid message number, only ' + IntToStr(MsgCount) + ' messages in mailbox.') else
if CheckDeleted and (FMessages [MsgNum - 1].Deleted) then
SendResponse(False, 'Message does not exist.') else
Result := True;
end;
var Cmd, Param : String;
I, J : Integer;
Fin : Boolean;
S : String;
begin
try
Pop3Server := FServer as TPop3Server;
try try
SendResponse(POP3Server.ServerReady, POP3Server.GetPop3Greeting(APOPStamp));
if not POP3Server.ServerReady then
exit;
// Authentication
Repeat
FUserName := '';
FPassword := '';
FAuthenticated := False;
While not FAuthenticated do
begin
if Terminated or FStream.EOF then
exit;
if not GetCommand(Cmd, Param) then
exit;
if Cmd = 'QUIT' then
begin
SendResponse(True, FServer.LocalHost + ' Bye.');
exit;
end else
if POP3Server.FEnableAPOP and (Cmd = 'APOP') then
begin
FUserName := StrBeforeChar(Param, [' '], True);
S := LowerCase(StrAfterChar(Param, [' ']));
if (FUserName = '') or (S = '') then
SendResponse(False, 'Invalid argument to APOP command.') else
begin
Synchronize(NotifyAuthentication);
if Terminated then
exit;
if not FValidUser then
SendResponse(False, 'Invalid user.') else
begin
FAuthenticated := S = LowerCase(MD5DigestToHex(CalcMD5(APOPStamp + FPassword)));
if not FAuthenticated then
begin
SendResponse(False, 'Authentication failed.');
Log(lcInfo, FUserName + ' APOP authentication failed.');
end;
end;
end;
end else
if Cmd = 'USER' then
begin
if POP3Server.FEnableAPOP and POP3Server.FRequireAPOP then
begin
Log(lcInfo, Param + ' Plain login attempt rejected.');
SendResponse(False, 'APOP authentication required.');
end else
begin
FUserName := Param;
Synchronize(NotifyAuthentication);
if Terminated then
exit;
if not FValidUser then
begin
SendResponse(False, 'Invalid user.');
FUserName := '';
end
else
SendResponse(True, 'Proceed with PASS command.');
end;
end else
if Cmd = 'PASS' then
begin
if FUserName = '' then
SendResponse(False, 'Username required first.') else
begin
FAuthenticated := Param = FPassword;
if not FAuthenticated then
begin
SendResponse(False, 'Authentication failed.');
Log(lcInfo, FUserName + ' Authentication failed.');
FUserName := '';
end;
end;
end else
if Cmd = 'AUTH' then
SendResponse(False, 'AUTH command not supported.')
else
SendResponse(False, 'Authentication required.');
end;
Synchronize(NotifyLogin);
if Terminated then
exit;
Fin := FLoginAction = la_AllowAccess;
if not Fin then
if FLoginAction = la_MailboxInUse then
SendResponse(False, '[IN-USE] Mailbox in use.') else
if FLoginAction = la_MailboxNotAvail then
SendResponse(False, 'Mailbox not available.');
Until Fin;
// Logged in
try
Assert(Length(FMsgSizes) = Length(FMsgUIDs), 'Message sizes and UIDs must be of equal length.');
MsgCount := Length(FMsgSizes);
SetLength(FMessages, MsgCount);
For I := 0 to MsgCount - 1 do
begin
FMessages[I] := TPop3ServerMessage.Create;
FMessages[I].Size := FMsgSizes[I];
FMessages[I].UID := FMsgUIDs[I];
end;
SendResponse(True, POP3Server.HostName + ' Welcome ' + FUserName + ', ' + VerboseMaildropStats);
Log(lcUserEventbegin, FUserName + ' Logged in.');
// Transaction mode
Fin := False;
Repeat
if not IsConnected then
exit;
if not GetCommand(Cmd, Param) then
exit;
if (Cmd = 'LIST') or (Cmd = 'UIDL') then
begin
if Param = '' then
begin
SendResponse(True, VerboseMaildropStats);
For I := 0 to MsgCount - 1 do
if not FMessages[I].Deleted then
if Cmd = 'LIST' then
SendLine(IntToStr(I + 1) + ' ' + IntToStr(FMessages[I].Size))
else
SendLine(IntToStr(I + 1) + ' ' + FMessages[I].UID);
SendLine('.');
end else
begin
if CheckValidMsgNum(Cmd, Param, I, True) then
if Cmd = 'LIST' then
SendResponse(True, IntToStr(I) + ' ' + IntToStr(FMessages [I - 1].Size))
else
SendResponse(True, IntToStr(I) + ' ' + FMessages [I - 1].UID);
end;
end else
if Cmd = 'STAT' then
SendResponse(True, IntToStr(GetMessageCount) + ' ' + IntToStr(GetMailboxSize)) else
if Cmd = 'DELE' then
begin
if CheckValidMsgNum(Cmd, Param, I, True) then
begin
FMessages [I - 1].Deleted := True;
SendResponse(True, 'Message deleted.');
end;
end else
if Cmd = 'RSET' then
begin
For I := 0 to MsgCount - 1 do
FMessages[I].Deleted := False;
SendResponse(True, VerboseMaildropStats);
end else
if (Cmd = 'RETR') or (Cmd = 'TOP') then
begin
if CheckValidMsgNum(Cmd, StrBeforeChar(Param, [' '], True), I, True) then
begin
FMsgIdx := I - 1;
Synchronize(NotifyGetMessage);
if Terminated then
exit;
if Cmd = 'RETR' then
begin
if Assigned(FMsgBodyStream) then
begin
SendResponse(True, IntToStr(Length(FMsgHdr) + FMsgBodyStream.Size) + ' octets in message.');
FStream.WriteStr(FMsgHdr);
StreamDotLineTerminated(FMsgBodyStream, FStream);
end else
begin
SendResponse(True, IntToStr(Length(FMsgHdr) + Length(FMsgBody)) + ' octets in message.');
FStream.WriteStr(FMsgHdr);
StreamDotLineTerminated(FMsgBody, FStream);
end;
end else
begin
I := StrToIntDef(StrAfterChar(Param, ' '), 0);
SendResponse(True, 'Header and top ' + IntToStr(I) + ' lines of body follow.');
FStream.WriteStr(FMsgHdr);
if I = 0 then
FStream.WriteStr('.' + CRLF) else
begin
if Assigned(FMsgBodyStream) then
FMsgBody := FMsgBodyStream.Reader.ReadStr(MinI(MaxPop3LineLength * I, MaxPop3ServerTopLength));
I := PosStr(CRLF, FMsgBody, 1);
if I = 0 then
StreamDotLineTerminated(FMsgBody, FStream)
else
StreamDotLineTerminated(CopyLeft(FMsgBody, I + 1), FStream);
end;
end;
end;
end else
if Cmd = 'QUIT' then
Fin := True
else
SendResponse(False, 'Unrecognized command (' + Cmd + ').');
Until Fin;
SendResponse(True, POP3Server.HostName + ' Bye.');
// Update mode
J := 0;
For I := MsgCount - 1 downto 0 do
if FMessages[I].Deleted then
begin
FMsgIdx := I;
Synchronize(NotifyDeleteMessage);
if Terminated then
exit;
Inc(J);
end;
Log(lcInfo, FUserName + ' ' + iif(J = 0, 'No', IntToStr(J)) + ' message' + iif(J <> 1, 's', '') + ' deleted.');
finally
Synchronize(NotifyLogout);
end;
except
on E : Exception do
try
if not Terminated and FStream.Connected then
begin
Log(lcError, 'Internal server error: ' + E.Message);
SendResponse(False, 'Internal server error: ' + E.Message);
end;
except end;
end;
finally
end;
finally
if FUserName <> '' then
Log(lcUserEventend, FUserName + ' Session finished.');
if Assigned(FStream) and not Terminated then
FStream.Flush;
end;
end;
end.