smtpsend.pas

Synapse The synchronyous socket library. File content: 1.) About Synapse 2.) Distribution pa

{==============================================================================|
| Project : Ararat Synapse                                       | 003.004.002 |
|==============================================================================|
| Content: SMTP client                                                         |
|==============================================================================|
| Copyright (c)1999-2005, 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) 1999-2005.               |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{:@abstract(SMTP client)

Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
 RFC-2554, RFC-2821
}

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

unit smtpsend;

interface

uses
  SysUtils, Classes,
  blcksock, synautil, synacode;

const
  cSmtpProtocol = 'smtp';

type
  {:@abstract(Implementation of SMTP and ESMTP procotol),
   include some ESMTP extensions, include SSL/TLS too.

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

   Are you missing properties for specify server address and port? Look to
   parent @link(TSynaClient) too!}
  TSMTPSend = class(TSynaClient)
  private
    FSock: TTCPBlockSocket;
    FResultCode: Integer;
    FResultString: string;
    FFullResult: TStringList;
    FESMTPcap: TStringList;
    FESMTP: Boolean;
    FAuthDone: Boolean;
    FESMTPSize: Boolean;
    FMaxSize: Integer;
    FEnhCode1: Integer;
    FEnhCode2: Integer;
    FEnhCode3: Integer;
    FSystemName: string;
    FAutoTLS: Boolean;
    FFullSSL: Boolean;
    procedure EnhancedCode(const Value: string);
    function ReadResult: Integer;
    function AuthLogin: Boolean;
    function AuthCram: Boolean;
    function Helo: Boolean;
    function Ehlo: Boolean;
    function Connect: Boolean;
  public
    constructor Create;
    destructor Destroy; override;

    {:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and
     begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses
     ESMTP capabilites and if you specified Username and password and remote
     server can handle AUTH command, try login by AUTH command. Preffered login
     method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is
     @false.}
    function Login: Boolean;

    {:Close SMTP session (QUIT command) and disconnect from SMTP server.}
    function Logout: Boolean;

    {:Send RSET SMTP command for reset SMTP session. If all OK, result is @true,
     else result is @false.}
    function Reset: Boolean;

    {:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true,
     else result is @false.}
    function NoOp: Boolean;

    {:Send MAIL FROM SMTP command for set sender e-mail address. If sender's
     e-mail address is empty string, transmited message is error message.

     If size not 0 and remote server can handle SIZE parameter, append SIZE
     parameter to request. If all OK, result is @true, else result is @false.}
    function MailFrom(const Value: string; Size: Integer): Boolean;

    {:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an
     empty string. If all OK, result is @true, else result is @false.}
    function MailTo(const Value: string): Boolean;

    {:Send DATA SMTP command and transmit message data. If all OK, result is
     @true, else result is @false.}
    function MailData(const Value: Tstrings): Boolean;

    {:Send ETRN SMTP command for start sending of remote queue for domain in
     Value. If all OK, result is @true, else result is @false.}
    function Etrn(const Value: string): Boolean;

    {:Send VRFY SMTP command for check receiver e-mail address. It cannot be
     an empty string. If all OK, result is @true, else result is @false.}
    function Verify(const Value: string): Boolean;

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

    {:Return string descriptive text for enhanced result codes stored in
     @link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).}
    function EnhCodeString: string;

    {:Try to find specified capability in ESMTP response.}
    function FindCap(const Value: string): string;
  published
    {:result code of last SMTP command.}
    property ResultCode: Integer read FResultCode;

    {:result string of last SMTP command (begin with string representation of
     result code).}
    property ResultString: string read FResultString;

    {:All result strings of last SMTP command (result is maybe multiline!).}
    property FullResult: TStringList read FFullResult;

    {:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP
     server only!).}
    property ESMTPcap: TStringList read FESMTPcap;

    {:@TRUE if you successfuly logged to ESMTP server.}
    property ESMTP: Boolean read FESMTP;

    {:@TRUE if you successfuly pass authorisation to remote server.}
    property AuthDone: Boolean read FAuthDone;

    {:@TRUE if remote server can handle SIZE parameter.}
    property ESMTPSize: Boolean read FESMTPSize;

    {:When @link(ESMTPsize) is @TRUE, contains max length of message that remote
     server can handle.}
    property MaxSize: Integer read FMaxSize;

    {:First digit of Enhanced result code. If last operation does not have
     enhanced result code, values is 0.}
    property EnhCode1: Integer read FEnhCode1;

    {:Second digit of Enhanced result code. If last operation does not have
     enhanced result code, values is 0.}
    property EnhCode2: Integer read FEnhCode2;

    {:Third digit of Enhanced result code. If last operation does not have
     enhanced result code, values is 0.}
    property EnhCode3: Integer read FEnhCode3;

    {:name of our system used in HELO and EHLO command. Implicit value is
     internet address of your machine.}
    property SystemName: string read FSystemName Write FSystemName;

    {: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;

{:A very useful function and example of its use would be found in the TSMTPsend
 object. Send maildata (text of e-mail with all SMTP headers! For example when
 text of message is created by @link(TMimemess) object) from "MailFrom" e-mail
 address to "MailTo" e-mail address (If you need more then one receiver, then
 separate their addresses by comma).

 Function sends e-mail to a SMTP server defined in "SMTPhost" parameter.
 Username and password are used for authorization to the "SMTPhost". If you
 don't want authorization, set "Username" and "Password" to empty strings. If
 e-mail message is successfully sent, the result returns @true.

 If you need use different port number then standard, then add this port number
 to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
  const MailData: TStrings; const Username, Password: string): Boolean;

{:A very useful function and example of its use would be found in the TSMTPsend
 object. Send "Maildata" (text of e-mail without any SMTP headers!) from
 "MailFrom" e-mail address to "MailTo" e-mail address with "Subject".  (If you
 need more then one receiver, then separate their addresses by comma).

 This function constructs all needed SMTP headers (with DATE header) and sends
 the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the
 e-mail message is successfully sent, the result will be @TRUE.

 If you need use different port number then standard, then add this port number
 to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
  const MailData: TStrings): Boolean;

{:A very useful function and example of its use would be found in the TSMTPsend
 object. Sends "MailData" (text of e-mail without any SMTP headers!) from
 "MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one
 receiver, then separate their addresses by comma).

 This function sends the e-mail to the SMTP server defined in the "SMTPhost"
 parameter. Username and password are used for authorization to the "SMTPhost".
 If you dont want authorization, set "Username" and "Password" to empty Strings.
 If the e-mail message is successfully sent, the result will be @TRUE.

 If you need use different port number then standard, then add this port number
 to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
  const MailData: TStrings; const Username, Password: string): Boolean;

implementation

constructor TSMTPSend.Create;
begin
  inherited Create;
  FFullResult := TStringList.Create;
  FESMTPcap := TStringList.Create;
  FSock := TTCPBlockSocket.Create;
  FSock.ConvertLineEnd := true;
  FTimeout := 60000;
  FTargetPort := cSmtpProtocol;
  FSystemName := FSock.LocalName;
  FAutoTLS := False;
  FFullSSL := False;
end;

destructor TSMTPSend.Destroy;
begin
  FSock.Free;
  FESMTPcap.Free;
  FFullResult.Free;
  inherited Destroy;
end;

procedure TSMTPSend.EnhancedCode(const Value: string);
var
  s, t: string;
  e1, e2, e3: Integer;
begin
  FEnhCode1 := 0;
  FEnhCode2 := 0;
  FEnhCode3 := 0;
  s := Copy(Value, 5, Length(Value) - 4);
  t := Trim(SeparateLeft(s, '.'));
  s := Trim(SeparateRight(s, '.'));
  if t = '' then
    Exit;
  if Length(t) > 1 then
    Exit;
  e1 := StrToIntDef(t, 0);
  if e1 = 0 then
    Exit;
  t := Trim(SeparateLeft(s, '.'));
  s := Trim(SeparateRight(s, '.'));
  if t = '' then
    Exit;
  if Length(t) > 3 then
    Exit;
  e2 := StrToIntDef(t, 0);
  t := Trim(SeparateLeft(s, ' '));
  if t = '' then
    Exit;
  if Length(t) > 3 then
    Exit;
  e3 := StrToIntDef(t, 0);
  FEnhCode1 := e1;
  FEnhCode2 := e2;
  FEnhCode3 := e3;
end;

function TSMTPSend.ReadResult: Integer;
var
  s: string;
begin
  Result := 0;
  FFullResult.Clear;
  repeat
    s := FSock.RecvString(FTimeout);
    FResultString := s;
    FFullResult.Add(s);
    if FSock.LastError <> 0 then
      Break;
  until Pos('-', s) <> 4;
  s := FFullResult[0];
  if Length(s) >= 3 then
    Result := StrToIntDef(Copy(s, 1, 3), 0);
  FResultCode := Result;
  EnhancedCode(s);
end;

function TSMTPSend.AuthLogin: Boolean;
begin
  Result := False;
  FSock.SendString('AUTH LOGIN' + CRLF);
  if ReadResult <> 334 then
    Exit;
  FSock.SendString(EncodeBase64(FUsername) + CRLF);
  if ReadResult <> 334 then
    Exit;
  FSock.SendString(EncodeBase64(FPassword) + CRLF);
  Result := ReadResult = 235;
end;

function TSMTPSend.AuthCram: Boolean;
var
  s: string;
begin
  Result := False;
  FSock.SendString('AUTH CRAM-MD5' + CRLF);
  if ReadResult <> 334 then