{
  $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$
}
{
  Rev 1.39    1/7/05 3:29:12 PM  RLebeau
  Fix for AV in Notification()

  Rev 1.38    12/21/04 1:51:42 AM  RLebeau
  Bug fix for Capa() method.

  Rev 1.37    11/27/04 2:48:22 AM  RLebeau
  Fixed bug in ownership of SASLMechanisms property

  Rev 1.36    10/26/2004 10:35:42 PM  JPMugaas
  Updated ref.

  Rev 1.35    2004.04.18 1:39:26 PM  czhower
  Bug fix for .NET with attachments, and several other issues found along the
  way.

  Rev 1.34    2004.04.07 6:02:42 PM  czhower
  Implemented AutoLogin in a better manner.

  Rev 1.33    2004.04.07 5:53:56 PM  czhower
  .NET overload

  Rev 1.32    2004.03.06 1:31:48 PM  czhower
  To match Disconnect changes to core.

  Rev 1.31    2004.02.03 5:44:12 PM  czhower
  Name changes

  Rev 1.30    2004.02.03 2:12:18 PM  czhower
  $I path change

  Rev 1.29    1/25/2004 3:11:36 PM  JPMugaas
  SASL Interface reworked to make it easier for developers to use.
  SSL and SASL reenabled components.

  Rev 1.28    1/21/2004 3:27:06 PM  JPMugaas
  InitComponent

  Rev 1.27    1/12/04 12:22:40 PM  RLebeau
  Updated RetrieveMailboxSize() and RetrieveMsgSize() to support responses that
  contain additional data after the octet values.

  Rev 1.26    22/12/2003 00:45:12  CCostelloe
  .NET fixes

    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

  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
}

unit IdPOP3;

{ POP 3 (Post Office Protocol Version 3) }

interface

{$i IdCompilerDefines.inc}

uses
  Classes,
  IdAssignedNumbers,
  IdGlobal,
  IdException,
  IdExplicitTLSClientServerBase,
  IdGlobalProtocols,
  IdMessage,
  IdMessageClient,
  IdReply,
  IdSASL,
  IdSASLCollection,
  IdBaseComponent,
  IdUserPassProvider;

type
  TIdPOP3AuthenticationType = (patUserPass, patAPOP, patSASL);

const
  DEF_POP3USE_IMPLICIT_TLS = False;
  DEF_ATYPE = patUserPass;

type
  TIdPOP3 = class(TIdMessageClient)
  protected
    FAuthType : TIdPOP3AuthenticationType;
    FAutoLogin: Boolean;
    FAPOPToken : String; 
    FHasAPOP: Boolean;
    FHasCAPA: Boolean;
    FSASLMechanisms : TIdSASLEntries;
    //
    function GetReplyClass:TIdReplyClass; override;
    function GetSupportsTLS: Boolean; override;
    procedure SetSASLMechanisms(AValue: TIdSASLEntries);
    procedure InitComponent; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    function CheckMessages: LongInt;
    procedure Connect; override;
    procedure Login; virtual;
    destructor Destroy; override;
    function Delete(const MsgNum: Integer): Boolean;
    procedure DisconnectNotifyPeer; 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 aMsgNo: Integer; const aDest: TStrings): boolean; overload;
    function RetrieveRaw(const aMsgNo: Integer; const aDest: TStream): boolean; overload;
    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 HasAPOP: boolean read FHasAPOP;
    property HasCAPA: boolean read FHasCAPA;
  published
    property AuthType : TIdPOP3AuthenticationType read FAuthType write FAuthType default DEF_ATYPE;
    property AutoLogin: Boolean read FAutoLogin write FAutoLogin;
    property Host;
    property Username;
    property UseTLS;
    property Password;
    property Port default IdPORT_POP3;
    property SASLMechanisms : TIdSASLEntries read FSASLMechanisms write SetSASLMechanisms;
  end;

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

implementation

uses
  IdHash,
  IdHashMessageDigest,
  IdTCPConnection,
  IdSSL,
  IdResourceStringsProtocols,
  IdReplyPOP3,
  IdCoderMIME, SysUtils;

{ 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 := IndyStrToInt(Copy(s, 1, IndyPos(' ', s) - 1));    {Do not Localize}
  end;
end;

procedure TIdPOP3.Login;
var
  S: String;
begin
  if UseTLS in ExplicitTLSVals then begin
    if SupportsTLS then begin
      if SendCmd('STLS','') = ST_OK then begin {Do not translate}
        TLSHandshake;
      end else begin
        ProcessTLSNegCmdFailed;
      end;
    end else begin
      ProcessTLSNotAvail;
    end;
  end;

  case FAuthType of
    patAPOP:  //APR
      begin
        if FHasAPOP then begin
          with TIdHashMessageDigest5.Create do
          try
            S := LowerCase(HashStringAsHex(FAPOPToken+Password));
          finally
            Free;
          end;//try
          SendCmd('APOP ' + Username + ' ' + S, ST_OK);    {Do not Localize}
        end else begin
          raise EIdDoesNotSupportAPOP.Create(RSPOP3ServerDoNotSupportAPOP);
        end;
      end;
    patUserPass:
      begin //classic method
        SendCmd('USER ' + Username, ST_OK);    {Do not Localize}
        SendCmd('PASS ' + Password, ST_OK);    {Do not Localize}
      end;//if APOP
    patSASL:
      begin
        EIdSASLMechNeeded.IfTrue(FSASLMechanisms.Count = 0, RSASLRequired);
        FSASLMechanisms.LoginSASL('AUTH', FHost, IdGSKSSN_pop, [ST_OK], [ST_SASLCONTINUE], Self, Capabilities, 'SASL'); {do not localize}
      end;
  end;
end;

procedure TIdPOP3.InitComponent;
begin
  inherited;
  FAutoLogin := True;
  FSASLMechanisms := TIdSASLEntries.Create(Self);
  FRegularProtPort := IdPORT_POP3;
  FImplicitTLSProtPort := IdPORT_POP3S;
  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.DisconnectNotifyPeer;
begin
  inherited;
  SendCmd('QUIT', ST_OK);    {do not localize}
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 aMsgNo: Integer; const aDest: TStrings):
  boolean;
begin
  Result := (SendCmd('RETR ' + IntToStr(aMsgNo), '') = ST_OK);    {Do not Localize}
  if Result then begin
    IOHandler.Capture(aDest);
  end;
end;

function TIdPOP3.RetrieveRaw(const aMsgNo: Integer;
  const aDest: TStream): boolean;
begin
  Result := (SendCmd('RETR ' + IntToStr(aMsgNo), '') = ST_OK);    {Do not Localize}
  if Result then begin
    IOHandler.Capture(aDest);
  end;
end;

function TIdPOP3.Retrieve(const MsgNum: Integer; AMsg: TIdMessage): Boolean;
begin
  if SendCmd('RETR ' + IntToStr(MsgNum), '') = ST_OK then begin   {Do not Localize}
    AMsg.Clear;
    // This is because of a bug in Exchange? with empty messages. See comment in ReceiveHeader
    if ReceiveHeader(AMsg) = '' 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
  // Kudzu: Why is this needed? Stat returns this value....
  //
  // 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
      // RL - ignore the message number, grab just the octets,
      // and ignore everything else that may be present
      Fetch(CurrentLine);
      Result := Result + IndyStrToInt(Fetch(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
    // RL - ignore the message number, grab just the octets,
    // and ignore everything else that may be present
    Fetch(s);
    Result := IndyStrToInt(Fetch(s), -1);
  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
  FreeAndNil(FSASLMechanisms);
  inherited;
end;

function TIdPOP3.CAPA: Boolean;
begin
  FCapabilities.Clear;
  Result := SendCmd('CAPA','') = ST_OK;    {Do not Localize}
  if Result then
  begin
    IOHandler.Capture(FCapabilities);
  end;
// RLebeau - do not delete here!  The +OK reply line is handled
// by SendCmd() above.  Deleting here is removing an actual capability entry.
{
  if FCapabilities.Count >0 then
  begin
    //dete the initial OK reply line
    FCapabilities.Delete(0);
  end;
  FHasCapa := Result;
}
  FHasCapa := (FCapabilities.Count > 0);
 // ParseCapaReply(FCapabilities,'SASL');
end;

procedure TIdPOP3.Notification(AComponent: TComponent; Operation: TOperation);
begin
  if (Operation = opRemove) and (FSASLMechanisms <> nil) then begin
    FSASLMechanisms.RemoveByComp(AComponent);
  end;
  inherited Notification(AComponent,Operation);
end;

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

procedure TIdPOP3.SetSASLMechanisms(AValue: TIdSASLEntries);
begin
  FSASLMechanisms.Assign(AValue);
end;

procedure TIdPOP3.Connect;
var
  S: String;
  I: Integer;
begin
  FHasAPOP := False;
  FHasCAPA := False;
  FAPOPToken := '';

  if (IOHandler is TIdSSLIOHandlerSocketBase) then begin
    (IOHandler as TIdSSLIOHandlerSocketBase).PassThrough := (FUseTLS <> utUseImplicitTLS);
  end;

  inherited Connect;
  try
    GetResponse(ST_OK);

    // the initial greeting text is needed to determine APOP availability
    S := LastCmdResult.Text.Strings[0];  //read response
    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
        FAPOPToken := Copy(S, 1, I);
      end;
    end;
    FHasAPOP := (Length(FAPOPToken) > 0);
    CAPA;
    if FAutoLogin then begin
      Login;
    end;
  except
    Disconnect(False);
    raise;
  end;
end;

end.


