{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  11699: IdPOP3.pas
{
    Rev 1.25    10/19/2003 5:42:36 PM  DSiders
  Added localization comments.
}
{
{   Rev 1.24    10/11/2003 7:14:34 PM  BGooijen
{ Changed IdCompilerDefines.inc path
}
{
{   Rev 1.23    10/10/2003 11:39:40 PM  BGooijen
{ Compiles in DotNet now
}
{
{   Rev 1.22    6/15/2003 01:17:10 PM  JPMugaas
{ Intermediate class no longer used.  We use the SASL functionality right from
{ the TIdSASLList.
}
{
{   Rev 1.21    6/4/2003 04:10:36 PM  JPMugaas
{ Removed hacked GetInternelResponse.
{
{ Updated to use Kudzu's new string reply code.
}
{
{   Rev 1.20    5/26/2003 04:28:16 PM  JPMugaas
{ Removed GenerateReply and ParseResponse calls because those functions are
{ being removed.
}
{
{   Rev 1.19    5/26/2003 12:23:58 PM  JPMugaas
}
{
{   Rev 1.18    5/25/2003 03:54:46 AM  JPMugaas
}
{
{   Rev 1.17    5/25/2003 03:45:56 AM  JPMugaas
}
{
{   Rev 1.16    5/22/2003 05:27:52 PM  JPMugaas
}
{
{   Rev 1.16    5/20/2003 02:29:42 PM  JPMugaas
{ Updated with POP3Reply object.
}
{
{   Rev 1.15    5/10/2003 10:10:46 PM  JPMugaas
{ Bug fixes.
}
{
{   Rev 1.14    5/8/2003 08:44:16 PM  JPMugaas
{ Moved some SASL authentication code down to an anscestor for reuse.  WIll
{ clean up soon.
}
{
{   Rev 1.13    5/8/2003 03:18:14 PM  JPMugaas
{ Flattened ou the SASL authentication API, made a custom descendant of SASL
{ enabled TIdMessageClient classes.
}
{
{   Rev 1.12    5/8/2003 11:28:10 AM  JPMugaas
{ Moved feature negoation properties down to the ExplicitTLSClient level as
{ feature negotiation goes hand in hand with explicit TLS support.
}
{
{   Rev 1.11    5/8/2003 03:03:00 AM  JPMugaas
{ Fixed a problem with SASL.  It turns out that what was being processed with
{ something from a previous command.  It also turned out that some charactors
{ were being removed from the SASL processing when they shouldn't have been.
}
{
{   Rev 1.10    5/8/2003 02:18:08 AM  JPMugaas
{ Fixed an AV in IdPOP3 with SASL list on forms.  Made exceptions for SASL
{ mechanisms missing more consistant, made IdPOP3 support feature feature
{ negotiation, and consolidated some duplicate code.
}
{
{   Rev 1.9    5/7/2003 04:58:34 AM  JPMugaas
{ We now use the initial greeting message from the server when calculating the
{ parameter for the APOP command.  Note that we were calling CAPA before APOP
{ and that could throw things off.
}
{
{   Rev 1.8    4/5/2003 02:06:24 PM  JPMugaas
{ TLS handshake itself can now be handled.
}
{
{   Rev 1.7    3/27/2003 05:46:40 AM  JPMugaas
{ Updated framework with an event if the TLS negotiation command fails.
{ Cleaned up some duplicate code in the clients.
}
{
{   Rev 1.6    3/19/2003 08:53:40 PM  JPMugaas
{ Now should work with new framework.
}
{
{   Rev 1.5    3/17/2003 02:25:26 PM  JPMugaas
{ Updated to use new TLS framework.  Now can require that users use TLS.  Note
{ that this setting create an incompatiability with Norton AntiVirus because
{ that does act as a "man in the middle" when intercepting E-Mail for virus
{ scanning.
}
{
{   Rev 1.4    3/13/2003 09:49:26 AM  JPMugaas
{ Now uses an abstract SSL base class instead of OpenSSL so 3rd-party vendors
{ can plug-in their products.
}
{
{   Rev 1.3    2/24/2003 09:27:58 PM  JPMugaas
}
{
{   Rev 1.2    12/15/2002 04:27:10 PM  JPMugaas
{ POP3 now compiles and works in Indy 10.
}
{
{   Rev 1.1    12-15-2002 12:57:40  BGooijen
{ Added Top-command
}
{
{   Rev 1.0    11/13/2002 07:58:22 AM  JPMugaas
}
unit IdPOP3;

{*

  POP 3 (Post Office Protocol Version 3)

  2002-08-18 - J. Berg
   - implement SASL, add CAPA and STLS

  02 August 2002 - A. Neillans
   - Bug fix:
     [ 574171 ] TIdMessage not cleared before a retreive

  11-10-2001 - J. Peter Mugaas
    Added suggested code from Andrew P.Rybin that does the following:
    -APOP Authentication Support
    -unrecognized text header now displayed in exception message
    -GetUIDL method

  2001-AUG-31 DSiders
    Changed TIdPOP3.Connect to use ATimeout when calling
    inherited Connect.

  2000-SEPT-28 SG
    Added GetUIDL as from code by

  2000-MAY-10 HH
    Added RetrieveMailBoxSize and renamed RetrieveSize to RetrieveMsgSize.
    Finished Connect.

  2000-MARCH-03 HH
    Converted to Indy
*}

{$I Core\IdCompilerDefines.inc}

interface

uses
  Classes,
  IdAssignedNumbers,
  IdCoreGlobal,
  IdException,
  {$IFNDEF DotNetExclude}
  IdExplicitTLSClientServerBase,
  {$ENDIF}
  IdGlobal,
  IdMessage,
  IdMessageClient,
  IdReply,
  {$IFNDEF DotNetExclude}
  IdSASL,
  IdSASLList,
  {$ENDIF}
  IdUserPassProvider;

type
  TIdPOP3AuthenticationType = (atUserPass, atAPOP, atSASL);
const
  DEF_POP3USE_IMPLICIT_TLS = False;
  DEF_ATYPE = atUserPass;
type
  TIdPOP3 = class(TIdMessageClient)
  protected
    FHasCAPA: boolean;
    FGreetingBanner : String;
  {$IFNDEF DotNetExclude}
    FSASLMechanisms : TIdSASLList;
  {$ENDIF}
    FAuthType : TIdPOP3AuthenticationType;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetReplyClass:TIdReplyClass; override;
  {$IFNDEF DotNetExclude}
    function GetSupportsTLS: Boolean; override;
  {$ENDIF}
  public
    function CheckMessages: longint;
    procedure Login; virtual;
    procedure Connect(const AAndLogin: boolean = true); reintroduce; virtual;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Delete(const MsgNum: Integer): Boolean;
    procedure Disconnect; override;
    procedure KeepAlive;
    function Reset: Boolean;
    function Retrieve(const MsgNum: Integer; AMsg: TIdMessage): Boolean;
    function RetrieveHeader(const MsgNum: Integer; AMsg: TIdMessage): Boolean;
    function RetrieveMsgSize(const MsgNum: Integer): Integer;
    function RetrieveMailBoxSize: integer;
    function RetrieveRaw(const MsgNum: Integer; const Dest: TStrings): boolean;
    function UIDL(const ADest: TStrings; const AMsgNum: Integer = -1): Boolean;
    function Top(const AMsgNum: Integer; const ADest: TStrings; const AMaxLines: Integer = 0): boolean;
    function CAPA: Boolean;
    property HasCAPA: boolean read FHasCAPA;
//    property Capabilities: TStrings read FCapabilities;

    function GetPassword: String;
    function GetUsername: String;
  published
    property Password;
    property Username;
    property Port default IdPORT_POP3;
  {$IFNDEF DotNetExclude}
    property UseTLS;
  {$ENDIF}
    property Host;
    property AuthType : TIdPOP3AuthenticationType read FAuthType write FAuthType default DEF_ATYPE;
  {$IFNDEF DotNetExclude}
    property SASLMechanisms: TIdSASLList read FSASLMechanisms write FSASLMechanisms;
  {$ENDIF}
  end;

type
  EIdPOP3Exception = class(EIdException);
  EIdDoesNotSupportAPOP = class(EIdPOP3Exception);
  EIdUnrecognizedReply = class(EIdPOP3Exception);

implementation

uses
  {$IFNDEF DotNetExclude}
  IdHash,
  IdHashMessageDigest,
  {$ENDIF}
  IdTCPConnection,
  {$IFNDEF DotNetExclude}
  IdSSL,
  {$ENDIF}
  IdResourceStrings,
  SysUtils, IdReplyPOP3,
  IdCoderMIME;

{ TIdPOP3 }

function TIdPOP3.CheckMessages: longint;
var
  s: string;

begin
  Result := 0;
  SendCmd('STAT', ST_OK);    {Do not Localize}

  // Only gets here if exception is not raised

  s := LastCmdResult.Text[0];
  if Length(s) > 0 then begin
    Result := StrToInt(Copy(s, 1, IndyPos(' ', s) - 1));    {Do not Localize}
  end;
end;

procedure TIdPOP3.Login;
var
  S: String;
  i: Integer;

begin
  try
  {$IFNDEF DotNetExclude}
    if UseTLS in ExplicitTLSVals then begin
      if SupportsTLS then
      begin
        if SendCmd('STLS','') = ST_OK then {Do not translate}
        begin
          TLSHandshake;
        end
        else
        begin
          ProcessTLSNegCmdFailed;
        end;
      end
      else
      begin
        ProcessTLSNotAvail;
      end;
    end;
  {$ENDIF}

    case FAuthType of
  {$IFNDEF DotNetExclude}
    atAPOP:  //APR
      begin
        S:= FGreetingBanner;  //read the initial greeting we stored
        i:=Pos('<',S);    {Do not Localize}
        if i>0 then begin
           S:=Copy(S,i,MaxInt); //?: System.Delete(S,1,i-1);
           i:=Pos('>',S);    {Do not Localize}
           if i>0 then
           begin
             S:=Copy(S,1,i)
           end
           else begin
             S:='';    {Do not Localize}
           end;
        end//if
        else begin
          S:=''; //no time-stamp    {Do not Localize}
        end;

        if Length(S) > 0 then
        begin
          with TIdHashMessageDigest5.Create do
          try
            S:=LowerCase(TIdHash128.AsHex(HashValue(S+Password)));
          finally
            Free;
          end;//try
          SendCmd('APOP '+Username+' '+S, ST_OK);    {Do not Localize}
        end
        else begin
          raise EIdDoesNotSupportAPOP.Create(RSPOP3ServerDoNotSupportAPOP);
        end;
      end;
  {$ENDIF}
    atUserPass:
      begin //classic method
        SendCmd('USER ' + Username, ST_OK);    {Do not Localize}
        SendCmd('PASS ' + Password, ST_OK);    {Do not Localize}
      end;//if APOP
  {$IFNDEF DotNetExclude}
    atSASL:
      begin
        if Assigned(FSASLMechanisms) or ( FSASLMechanisms.Count > 1) then
        begin
          FSASLMechanisms.LoginSASL('AUTH', [ST_OK], [ST_SASLCONTINUE], Self, Self.Capabilities, 'SASL'); {do not localize}
        end
        else
        begin
          raise EIdSASLMechNeeded.Create(RSASLRequired);
        end;
      end;
  {$ENDIF}
  end;
  except
    Disconnect;
    raise;
  end;
end;



constructor TIdPOP3.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  {$IFNDEF DotNetExclude}
  FRegularProtPort := IdPORT_POP3;
  FImplicitTLSProtPort := IdPORT_POP3S;
  {$ENDIF}
  Port := IdPORT_POP3;
  FAuthType := DEF_ATYPE;
end;

function TIdPOP3.Delete(const MsgNum: Integer): Boolean;
begin
  SendCmd('DELE ' + IntToStr(MsgNum), ST_OK);   {do not localize}
  Result := LastCmdResult.Code = ST_OK;
end;

procedure TIdPOP3.Disconnect;
begin
  try
    if Connected then begin
      IOHandler.WriteLn('QUIT');    {do not localize}
    end;
  finally
    inherited Disconnect;
  end;
end;

function TIdPOP3.GetReplyClass:TIdReplyClass;
begin
  result:=TIdReplyPOP3;
end;

procedure TIdPOP3.KeepAlive;
begin
  SendCmd('NOOP', ST_OK);    {Do not Localize}
end;

function TIdPOP3.Reset: Boolean;
begin
  SendCmd('RSET', '');    {Do not Localize}
  Result := LastCmdResult.Code = ST_OK;
end;

function TIdPOP3.RetrieveRaw(const MsgNum: Integer; const Dest: TStrings):
  boolean;
begin
  result := (SendCmd('RETR ' + IntToStr(MsgNum),'')=ST_OK);    {Do not Localize}
  if result then
  begin
    IOHandler.Capture(Dest);
    result := true;
  end;
end;

function TIdPOP3.Retrieve(const MsgNum: Integer; AMsg: TIdMessage): Boolean;
begin
  if SendCmd('RETR ' + IntToStr(MsgNum),'') = ST_OK then    {Do not Localize}
  begin
    AMsg.Clear;
    // This is because of a bug in Exchange? with empty messages. See comment in ReceiveHeader
    if Length(ReceiveHeader(AMsg)) = 0 then begin
      // Only retreive the body if we do not already have a full RFC
      ReceiveBody(AMsg);
    end;
  end;
  // Will only hit here if ok and NO exception, or IF is not executed
  Result := LastCmdResult.Code = ST_OK;
end;

function TIdPOP3.RetrieveHeader(const MsgNum: Integer; AMsg: TIdMessage): Boolean;
begin
//  Result := False;
  AMsg.Clear;
  SendCmd('TOP ' + IntToStr(MsgNum) + ' 0', ST_OK);    {Do not Localize}
  // Only gets here if no exception is raised
  ReceiveHeader(AMsg,'.');
  Result := True;
end;

function TIdPOP3.RetrieveMailBoxSize: integer;
var
  CurrentLine: string;
begin
  // Returns the size of the mailbox. Issues a LIST command and then
  // sums up each message size. The message sizes are returned in the format
  // 1 1400 2 405 3 100 etc....
  // With this routine, we prevent the user having to call REtrieveSize for
  // each message to get the mailbox size
  Result := 0;
  try
    SendCmd('LIST', ST_OK);    {Do not Localize}
    CurrentLine := IOHandler.ReadLn;
    while (CurrentLine <> '.') and (CurrentLine <> '') do    {Do not Localize}
    begin
      CurrentLine := Copy(CurrentLine, IndyPos(' ', CurrentLine) + 1,    {Do not Localize}
        Length(CurrentLine) - IndyPos(' ', CurrentLine) + 1);    {Do not Localize}
      Result := Result + StrToIntDef(CurrentLine, 0);
      CurrentLine := IOHandler.ReadLn;
    end;
  except
    Result := -1;
  end;
end;

function TIdPOP3.RetrieveMsgSize(const MsgNum: Integer): Integer;
var
  s: string;
begin
  Result := -1;
  // Returns the size of the message. if an error ocurrs, returns -1.
  SendCmd('LIST ' + IntToStr(MsgNum), ST_OK);    {Do not Localize}
  s := LastCmdResult.Text[0];
  if Length(s) > 0 then  begin
    Result := StrToIntDef(Copy(s, IndyPos(' ', s) + 1,    {Do not Localize}
     Length(s) - IndyPos(' ', s) + 1), -1);    {Do not Localize}
  end;
end;

function TIdPOP3.UIDL(const ADest: TStrings; const AMsgNum: Integer = -1): Boolean;
Begin
  if AMsgNum >= 0 then begin
    Result:=SendCmd('UIDL ' + IntToStr(AMsgNum), '') = ST_OK;    {Do not Localize}
    if Result then
    begin
      ADest.Assign(LastCmdResult.Text);
    end;
  end
  else begin
    Result:=SendCmd('UIDL','')=ST_OK;    {Do not Localize}
    if Result then
    begin
      IOHandler.Capture(ADest);
    end;
  end;
End;//TIdPOP3.GetUIDL

function TIdPOP3.Top(const AMsgNum: Integer; const ADest: TStrings; const AMaxLines: Integer = 0): boolean;
begin
  if AMaxLines = 0 then begin
    Result := SendCmd('TOP ' + IntToStr(AMsgNum),'') = ST_OK; {Do not Localize}
  end else begin
    Result := SendCmd('TOP ' + IntToStr(AMsgNum) + ' ' + IntToStr(AMaxLines),'') = ST_OK; {Do not Localize}
  end;
  if Result then begin
    IOHandler.Capture(ADest);
  end;
end;


destructor TIdPOP3.Destroy;
begin
  inherited;
end;

function TIdPOP3.CAPA: Boolean;
begin
  {$IFNDEF DotNetExclude}
  Result := SendCmd('CAPA','') = ST_OK;    {Do not Localize}
  if Result then
  begin
    IOHandler.Capture(FCapabilities);
  end;
  if FCapabilities.Count >0 then
  begin
    //dete the initial OK reply line
    FCapabilities.Delete(0);
  end;
  FHasCapa := Result;
 // ParseCapaReply(FCapabilities,'SASL');
  {$ELSE}
  result:=false;
  {$ENDIF}
end;

procedure TIdPOP3.Connect(const AAndLogin: boolean = true);

begin
  FHasCAPA := false;
  {$IFNDEF DotNetExclude}
  if UseTLS in ExplicitTLSVals then
  begin
    // TLS only enabled later in this case!
    (IOHandler as TIdSSLIOHandlerSocketBase).PassThrough := true;
  end;
  if (IOHandler is TIdSSLIOHandlerSocketBase) then begin
      case FUseTLS of
       utNoTLSSupport :
       begin
        (IOHandler as TIdSSLIOHandlerSocketBase).PassThrough := true;
       end;
       utUseImplicitTLS :
       begin
         (IOHandler as TIdSSLIOHandlerSocketBase).PassThrough := False;
       end
       else
        if FUseTLS<>utUseImplicitTLS then begin
         (IOHandler as TIdSSLIOHandlerSocketBase).PassThrough := true;
        end;
      end;
  end;
  {$ENDIF}
  inherited Connect;
  GetResponse(ST_OK);
  //we preserve the initial greeting text because that is needed by APOP
  //and we call the CAPA command before the APOP command.  That could throw off
  //code using LastCmdResult.Text[0] for parsing the timestamp.
  FGreetingBanner := LastCmdResult.Text[0];
  CAPA;
  if AAndLogin then begin
    Login;
  end;
end;


function TIdPOP3.GetPassword: String;
begin
  Result := Password;
end;

function TIdPOP3.GetUsername: String;
begin
  Result := Username;
end;

procedure TIdPOP3.Notification(AComponent: TComponent;
  Operation: TOperation);

begin
  if Operation = opRemove then begin
  {$IFNDEF DotNetExclude}
    if AComponent = FSASLMechanisms then begin
      FSASLMechanisms := nil;
    end;
  {$ENDIF}
  end;
  inherited;
end;

{$IFNDEF DotNetExclude}
function TIdPOP3.GetSupportsTLS: Boolean;
begin
   Result := ( FCapabilities.IndexOf('STLS')>-1); //do not localize
end;
{$ENDIF}

end.


