Simba/trunk/Units/Synapse/pop3send.pas

{==============================================================================|
| Project : Ararat Synapse                                       | 002.006.000 |
|==============================================================================|
| Content: POP3 client                                                         |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2007.                |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{:@abstract(POP3 protocol client)

Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$H+}

unit pop3send;

interface

uses
  SysUtils, Classes,
  blcksock, synautil, synacode;

const
  cPop3Protocol = '110';

type

  {:The three types of possible authorization methods for "logging in" to a POP3
   server.}
  TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);

  {:@abstract(Implementation of POP3 client protocol.)

   Note: Are you missing properties for setting Username and Password? Look to
   parent @link(TSynaClient) object!

   Are you missing properties for specify server address and port? Look to
   parent @link(TSynaClient) too!}
  TPOP3Send = class(TSynaClient)
  private
    FSock: TTCPBlockSocket;
    FResultCode: Integer;
    FResultString: string;
    FFullResult: TStringList;
    FStatCount: Integer;
    FStatSize: Integer;
    FListSize: Integer;
    FTimeStamp: string;
    FAuthType: TPOP3AuthType;
    FPOP3cap: TStringList;
    FAutoTLS: Boolean;
    FFullSSL: Boolean;
    function ReadResult(Full: Boolean): Integer;
    function Connect: Boolean;
    function AuthLogin: Boolean;
    function AuthApop: Boolean;
  public
    constructor Create;
    destructor Destroy; override;

    {:You can call any custom by this method. Call Command without trailing CRLF.
      If MultiLine parameter is @true, multilined response are expected.
      Result is @true on sucess.}
    function CustomCommand(const Command: string; MultiLine: Boolean): boolean;

    {:Call CAPA command for get POP3 server capabilites.
     note: not all servers support this command!}
    function Capability: Boolean;

    {:Connect to remote POP3 host. If all OK, result is @true.}
    function Login: Boolean;

    {:Disconnects from POP3 server.}
    function Logout: Boolean;

    {:Send RSET command. If all OK, result is @true.}
    function Reset: Boolean;

    {:Send NOOP command. If all OK, result is @true.}
    function NoOp: Boolean;

    {:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
     If all OK, result is @true.}
    function Stat: Boolean;

    {:Send LIST command. If Value is 0, LIST is for all messages. After
     successful operation is listing in FullResult. If all OK, result is @True.}
    function List(Value: Integer): Boolean;

    {:Send RETR command. After successful operation dowloaded message in
     @link(FullResult). If all OK, result is @true.}
    function Retr(Value: Integer): Boolean;

    {:Send RETR command. After successful operation dowloaded message in
     @link(Stream). If all OK, result is @true.}
    function RetrStream(Value: Integer; Stream: TStream): Boolean;

    {:Send DELE command for delete specified message. If all OK, result is @true.}
    function Dele(Value: Integer): Boolean;

    {:Send TOP command. After successful operation dowloaded headers of message
     and maxlines count of message in @link(FullResult). If all OK, result is
     @true.}
    function Top(Value, Maxlines: Integer): Boolean;

    {:Send UIDL command. If Value is 0, UIDL is for all messages. After
     successful operation is listing in FullResult. If all OK, result is @True.}
    function Uidl(Value: Integer): Boolean;

    {:Call STLS command for upgrade connection to SSL/TLS mode.}
    function StartTLS: Boolean;

    {:Try to find given capabily in capabilty string returned from POP3 server
     by CAPA command.}
    function FindCap(const Value: string): string;
  published
    {:Result code of last POP3 operation. 0 - error, 1 - OK.}
    property ResultCode: Integer read FResultCode;

    {:Result string of last POP3 operation.}
    property ResultString: string read FResultString;

    {:Stringlist with full lines returned as result of POP3 operation. I.e. if
     operation is LIST, this property is filled by list of messages. If
     operation is RETR, this property have downloaded message.}
    property FullResult: TStringList read FFullResult;

    {:After STAT command is there count of messages in inbox.}
    property StatCount: Integer read FStatCount;

    {:After STAT command is there size of all messages in inbox.}
    property StatSize: Integer read  FStatSize;

    {:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
    property ListSize: Integer read  FListSize;

    {:If server support this, after comnnect is in this property timestamp of
     remote server.}
    property TimeStamp: string read FTimeStamp;

    {:Type of authorisation for login to POP3 server. Dafault is autodetect one
     of possible authorisation. Autodetect do this:

     If remote POP3 server support APOP, try login by APOP method. If APOP is
     not supported, or if APOP login failed, try classic USER+PASS login method.}
    property AuthType: TPOP3AuthType read FAuthType Write FAuthType;

    {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;

    {:SSL/TLS mode is used from first contact to server. Servers with full
     SSL/TLS mode usualy using non-standard TCP port!}
    property FullSSL: Boolean read FFullSSL Write FFullSSL;
    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
    property Sock: TTCPBlockSocket read FSock;
  end;

implementation

constructor TPOP3Send.Create;
begin
  inherited Create;
  FFullResult := TStringList.Create;
  FPOP3cap := TStringList.Create;
  FSock := TTCPBlockSocket.Create;
  FSock.ConvertLineEnd := true;
  FTimeout := 60000;
  FTargetPort := cPop3Protocol;
  FStatCount := 0;
  FStatSize := 0;
  FListSize := 0;
  FAuthType := POP3AuthAll;
  FAutoTLS := False;
  FFullSSL := False;
end;

destructor TPOP3Send.Destroy;
begin
  FSock.Free;
  FPOP3cap.Free;
  FullResult.Free;
  inherited Destroy;
end;

function TPOP3Send.ReadResult(Full: Boolean): Integer;
var
  s: string;
begin
  Result := 0;
  FFullResult.Clear;
  s := FSock.RecvString(FTimeout);
  if Pos('+OK', s) = 1 then
    Result := 1;
  FResultString := s;
  if Full and (Result = 1) then
    repeat
      s := FSock.RecvString(FTimeout);
      if s = '.' then
        Break;
      if s <> '' then
        if s[1] = '.' then
          Delete(s, 1, 1);
      FFullResult.Add(s);
    until FSock.LastError <> 0;
  if not Full and (Result = 1) then
    FFullResult.Add(SeparateRight(FResultString, ' '));
  if FSock.LastError <> 0 then
    Result := 0;
  FResultCode := Result;
end;

function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
begin
  FSock.SendString(Command + CRLF);
  Result := ReadResult(MultiLine) <> 0;
end;

function TPOP3Send.AuthLogin: Boolean;
begin
  Result := False;
  if not CustomCommand('USER ' + FUserName, False) then
    exit;
  Result := CustomCommand('PASS ' + FPassword, False)
end;

function TPOP3Send.AuthAPOP: Boolean;
var
  s: string;
begin
  s := StrToHex(MD5(FTimeStamp + FPassWord));
  Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
end;

function TPOP3Send.Connect: Boolean;
begin
  // Do not call this function! It is calling by LOGIN method!
  FStatCount := 0;
  FStatSize := 0;
  FSock.CloseSocket;
  FSock.LineBuffer := '';
  FSock.Bind(FIPInterface, cAnyPort);
  if FSock.LastError = 0 then
    FSock.Connect(FTargetHost, FTargetPort);
  if FSock.LastError = 0 then
    if FFullSSL then
      FSock.SSLDoConnect;
  Result := FSock.LastError = 0;
end;

function TPOP3Send.Capability: Boolean;
begin
  FPOP3cap.Clear;
  Result := CustomCommand('CAPA', True);
  if Result then
    FPOP3cap.AddStrings(FFullResult);
end;

function TPOP3Send.Login: Boolean;
var
  s, s1: string;
begin
  Result := False;
  FTimeStamp := '';
  if not Connect then
    Exit;
  if ReadResult(False) <> 1 then
    Exit;
  s := SeparateRight(FResultString, '<');
  if s <> FResultString then
  begin
    s1 := Trim(SeparateLeft(s, '>'));
    if s1 <> s then
      FTimeStamp := '<' + s1 + '>';
  end;
  Result := False;
  if Capability then
    if FAutoTLS and (Findcap('STLS') <> '') then
      if StartTLS then
        Capability
      else
      begin
        Result := False;
        Exit;
      end;
  if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
  begin
    Result := AuthApop;
    if not Result then
    begin
      if not Connect then
        Exit;
      if ReadResult(False) <> 1 then
        Exit;
    end;
  end;
  if not Result and not (FAuthType = POP3AuthAPOP) then
    Result := AuthLogin;
end;

function TPOP3Send.Logout: Boolean;
begin
  Result := CustomCommand('QUIT', False);
  FSock.CloseSocket;
end;

function TPOP3Send.Reset: Boolean;
begin
  Result := CustomCommand('RSET', False);
end;

function TPOP3Send.NoOp: Boolean;
begin
  Result := CustomCommand('NOOP', False);
end;

function TPOP3Send.Stat: Boolean;
var
  s: string;
begin
  Result := CustomCommand('STAT', False);
  if Result then
  begin
    s := SeparateRight(ResultString, '+OK ');
    FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
    FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
  end;
end;

function TPOP3Send.List(Value: Integer): Boolean;
var
  s: string;
  n: integer;
begin
  if Value = 0 then
    s := 'LIST'
  else
    s := 'LIST ' + IntToStr(Value);
  Result := CustomCommand(s, Value = 0);
  FListSize := 0;
  if Result then
    if Value <> 0 then
    begin
      s := SeparateRight(ResultString, '+OK ');
      FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
    end
    else
      for n := 0 to FFullResult.Count - 1 do
        FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
end;

function TPOP3Send.Retr(Value: Integer): Boolean;
begin
  Result := CustomCommand('RETR ' + IntToStr(Value), True);
end;

//based on code by Miha Vrhovnik
function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
var
  s: string;
begin
  Result := False;
  FFullResult.Clear;
  Stream.Size := 0;
  FSock.SendString('RETR ' + IntToStr(Value) + CRLF);

  s := FSock.RecvString(FTimeout);
  if Pos('+OK', s) = 1 then
    Result := True;
  FResultString := s;
  if Result then begin
    repeat
      s := FSock.RecvString(FTimeout);
      if s = '.' then
        Break;
      if s <> '' then begin
        if s[1] = '.' then
          Delete(s, 1, 1);
      end;
      WriteStrToStream(Stream, s);
      WriteStrToStream(Stream, CRLF);
    until FSock.LastError <> 0;
  end;

  if Result then
    FResultCode := 1
  else
    FResultCode := 0;
end;

function TPOP3Send.Dele(Value: Integer): Boolean;
begin
  Result := CustomCommand('DELE ' + IntToStr(Value), False);
end;

function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
begin
  Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
end;

function TPOP3Send.Uidl(Value: Integer): Boolean;
var
  s: string;
begin
  if Value = 0 then
    s := 'UIDL'
  else
    s := 'UIDL ' + IntToStr(Value);
  Result := CustomCommand(s, Value = 0);
end;

function TPOP3Send.StartTLS: Boolean;
begin
  Result := False;
  if CustomCommand('STLS', False) then
  begin
    Fsock.SSLDoConnect;
    Result := FSock.LastError = 0;
  end;
end;

function TPOP3Send.FindCap(const Value: string): string;
var
  n: Integer;
  s: string;
begin
  s := UpperCase(Value);
  Result := '';
  for n := 0 to FPOP3cap.Count - 1 do
    if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
    begin
      Result := FPOP3cap[n];
      Break;
    end;
end;

end.