{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Implementation of the SMTP protocol.         | }
{ |                https://tools.ietf.org/html/rfc5321          | }
{ |                                                             | }
{ |   Copyright (C) - 2013 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code dstributed under MIT license.                 | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }


{$INCLUDE GMCompilerSettings.inc}

{.$DEFINE AUTH_CRAM_MD5}

unit GMSmtp;

interface

uses {$IFDEF JEDIAPI}{$IFNDEF FPC}jwaWinType,{$ENDIF}{$ELSE}Windows,{$ENDIF}
     GMStrDef, GMActiveX, GMIntf, GMCommon, GMINetBase, GMSockets;

const

  cSmtpDfltPort = '25';
  cMaxMailLineLen = 998;
  cMailTerm: AnsiString = '.';


type

  EGMSmtpException = class(EGMINetException);
  
  TSmtpExtension = (seAuth, seSize, se8Bit);

  TSmtpAuthKind = ({$IFDEF AUTH_CRAM_MD5}sakCramMd5,{$ENDIF} sakPlain, sakLogin);
  TSmtpAuthKinds = set of TSmtpAuthKind;


  TGMSmtpClient = class;

  IGMSmtpClient = interface(IUnknown)
    ['{0BEA826F-4B28-4F53-9C3E-A8FD7C6DE78F}']
    function Obj: TGMSmtpClient;
  end;

  TGMSmtpClient = class(TGMINetProtocolBase, IGMSmtpClient)
   protected
    FHelloMsgHandshakeDone: Boolean;
    FAuthKinds: TSmtpAuthKinds;
    FServerMaxMsgSize: LongInt;
    F8BitMime: Boolean;
    FOwnAddr: TGMString;
    FTransportLayer: ISequentialStream;

    function IsHeaderTermLine(const ALine: AnsiString): Boolean; override;
    procedure SendTextBody(const AText: TGMString);
    procedure ParseForExtensions(const ALines: TGMStringArray);
    procedure DoHelloMsgHandshake;

   public
    constructor Create(const ARefLifeTime: Boolean = True); overload; override;
    constructor Create(const ATransportLayer: ISequentialStream; const AOwnAddr: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload;
    function ProtocolDisplayName: TGMString; override;
    destructor Destroy; override;
    function Obj: TGMSmtpClient;
    procedure Login(const AUsername, APassword: TGMString);
    procedure SendMail(AFrom, ATo, ASubject, AText: TGMString);
    procedure Quit;
    procedure Reset;
    function Help(const ATopic: TGMString): TGMString;
  end;



procedure GMSendMail(const AFrom, ATo, AHost, AUser, APwd, ASubject, AText: TGMString; const AAskCanceled: IUnknown = nil; APort: TGMString = '');


implementation

uses SysUtils, GMCharCoding
     {$IFDEF TLS_SUPPORT}, GMOpenSSL{$ENDIF}
     {$IFDEF AUTH_CRAM_MD5}, GMWinCrypt{$ENDIF};

const

  cUnlimitedMsgSize = -1;


resourcestring

  RStrAuthFailed = 'Authentication failed';
  RStrMsgTooLarge = 'Message size %d exeeds maximum size (%d) supprted by the server';


{ ------------------------- }
{ ---- Global Routines ---- }
{ ------------------------- }

procedure GMSendMail(const AFrom, ATo, AHost, AUser, APwd, ASubject, AText: TGMString; const AAskCanceled: IUnknown; APort: TGMString);
var socket: IGMSocket; smtp: IGMSmtpClient; strm: ISequentialStream; // host: TGMString; //uri, protocol, user, password, host, port, path, parameter: TGMString;
begin
//protocol := cStrHttp;
//uri := GMSplitURL(AUrl, protocol, user, password, host, port, path, parameter);

  if Length(APort) <= 0 then APort := cSmtpDfltPort;

  socket := TGMTcpSocket.Create(vDfltInetAddrFamily, AAskCanceled);
  socket.Connect(AHost, APort);

  strm := TGMSocketStream.Create(socket);

//host := Socket.LocalAddress.Obj.ResolvedHost;

  smtp := TGMSmtpClient.Create(strm, Socket.LocalAddress.Obj.ResolvedHost);
  smtp.Obj.Login(AUser, APwd);
  smtp.Obj.SendMail(AFrom, ATo, ASubject, AText);


//httpRequest := TGMHttpClientRequest.Create(socket);
//Result := httpRequest.Obj.Execute(cHttpMethodGET, uri, protocol);
//Result := 0;
end;

function GMQuoteEMailaddress(const AEMailaddress: TGMString): TGMString;
begin
  Result := '<' + GMStripRight(GMStripLeft(AEMailaddress, '<' + cWhiteSpace), '>' + cWhiteSpace) + '>';
end;




{ --------------------------------- }
{ ---- Authentication Routines ---- }
{ --------------------------------- }

function SmtpAuthLogin(const AProtokol: TGMINetProtocolBase; const ATransportLayer: ISequentialStream; const AUsername, APassword: TGMString): Boolean;
var cmdResponse: TCmdResponse;
begin
  Result := False;
  if AProtokol = nil then Exit;
  cmdResponse := AProtokol.ExecCommandStr(ATransportLayer, 'AUTH LOGIN', cStrDigits);
  if cmdResponse.Code[1] <> '3' then Exit;
  vfGMTrace(cStrCommand  + ': ' + '*hidden*', AProtokol.ProtocolDisplayName);
  cmdResponse := AProtokol.ExecCommandStr(ATransportLayer, GMEncodeBase64Str(AUsername), cStrDigits, {$I %CurrentRoutine%}, False);
  if cmdResponse.Code[1] <> '3' then Exit;
  vfGMTrace(cStrCommand  + ': ' + '*hidden*', AProtokol.ProtocolDisplayName);
  cmdResponse := AProtokol.ExecCommandStr(ATransportLayer, GMEncodeBase64Str(APassword), cStrDigits, {$I %CurrentRoutine%}, False);
  Result := cmdResponse.Code[1] = '2';
end;

function SmtpAuthPlain(const AProtokol: TGMINetProtocolBase; const ATransportLayer: ISequentialStream; const AUsername, APassword: TGMString): Boolean;
var cmdResponse: TCmdResponse;
begin
  Result := False;
  if AProtokol = nil then Exit;
  vfGMTrace(cStrCommand  + ': ' + 'AUTH PLAIN *hidden*', AProtokol.ProtocolDisplayName);
  cmdResponse := AProtokol.ExecCommandStr(ATransportLayer, 'AUTH PLAIN ' + GMEncodeBase64Str(#0 + AUsername + #0 + APassword), cStrDigits, {$I %CurrentRoutine%}, False);
  Result := cmdResponse.Code[1] = '2';
end;

{$IFDEF AUTH_CRAM_MD5}
function AuthCramMd5(const ASmtp: TGMSmtpClient; const AUsername, APassword: TGMString): Boolean;
var cmdResponse: TCmdResponse; line, authVal: ansistring;
begin
  Result := False;
  cmdResponse := ASmtp.ExecCommandStr(ASmtp.FTransportLayer, 'AUTH CRAM-MD5', cStrDigits);
  if cmdResponse.Code[1] <> '3' then Exit;
  line := cmdResponse.Text[Low(cmdResponse.Text)];
  authVal := AUsername + ' ' + GMStrToHexStr(GMHmacMd5(GMDecodeBase64Str(Copy(line, 5, Length(line) - 4)), APassword));
  cmdResponse := ASmtp.ExecCommandStr(ASmtp.FNetStream, GMEncodeBase64Str(authVal), cStrDigits);
  Result := cmdResponse.Code[1] = '2';
end;
{$ENDIF}


{ ----------------------- }
{ ---- TGMSmtpClient ---- }
{ ----------------------- }

type

  TAuthFunc = function (const AProtokol: TGMINetProtocolBase; const ATransportLayer: ISequentialStream; const AUsername, APassword: TGMString): Boolean;

  TAuthData = record
    Verb: TGMString;
    Func: TAuthFunc;
  end;

const

  cAuthData: array [TSmtpAuthKind] of TAuthData = (
    {$IFDEF AUTH_CRAM_MD5}(Verb: 'CRAM-MD5'; Func: AuthCramMd5),{$ENDIF}
    (Verb: 'PLAIN'; Func: SmtpAuthPlain),
    (Verb: 'LOGIN'; Func: SmtpAuthLogin));


constructor TGMSmtpClient.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FServerMaxMsgSize := cUnlimitedMsgSize;
end;

constructor TGMSmtpClient.Create(const ATransportLayer: ISequentialStream; const AOwnAddr: TGMString; const ARefLifeTime: Boolean);
begin
  Create(ARefLifeTime); // ATransportLayer
  FOwnAddr := GMStrip(AOwnAddr);
  if Length(FOwnAddr) <= 0 then FOwnAddr := GMThisComputerName;
  FOwnAddr := GMDeleteChars(FOwnAddr, cWhiteSpace);
  FTransportLayer := ATransportLayer;
end;

destructor TGMSmtpClient.Destroy;
begin
  try Quit; except end; // <- never raise in destructors!
  inherited;
end;

function TGMSmtpClient.Obj: TGMSmtpClient;
begin
  Result := Self;
end;

function TGMSmtpClient.ProtocolDisplayName: TGMString;
begin
  Result := 'SMTP';
end;

procedure TGMSmtpClient.Quit;
begin
  ExecCommandStr(FTransportLayer, 'QUIT', '2');
  FHelloMsgHandshakeDone := False;
end;

procedure TGMSmtpClient.Reset;
begin
  ExecCommandStr(FTransportLayer, 'RSET', '2');
end;

function TGMSmtpClient.IsHeaderTermLine(const ALine: AnsiString): Boolean;
begin
  Result := (Length(ALine) <= 0) or (ALine = cMailTerm);
end;

function TGMSmtpClient.Help(const ATopic: TGMString): TGMString;
var cmdResponse: TCmdResponse; cmd: AnsiString;
begin
  cmd := 'HELP';
  if Length(ATopic) > 0 then cmd := cmd + ' ' + ATopic;
  cmdResponse := ExecCommandStr(FTransportLayer, cmd, '2');
  Result := GMStrArrayAsText(cmdResponse.Text);
end;

procedure TGMSmtpClient.ParseForExtensions(const ALines: TGMStringArray);
const cSep = cWhiteSpace + '^�!%&/\()=?{}[]*+~#-.:,;|<>'; cExtAUTH = 'AUTH'; cExtSIZE = 'SIZE'; cExt8BitMime = '8BITMIME';
var i, chPos: PtrInt; token, extVerb: TGMString; a: TSmtpAuthKind;
begin
  FAuthKinds := [];
  FServerMaxMsgSize := cUnlimitedMsgSize;
  F8BitMime := False;
  for i:=Low(ALines) to High(ALines) do
   begin
    chPos := 4;
    extVerb := GMNextWord(chPos, ALines[i], cWhiteSpace);
//  if GMFindToken(ALines[i], cExtAUTH, chPos, cSep) then
    if GMSameText(extVerb, cExtAUTH) then
     begin
//    Inc(chPos, Length(cExtAUTH));
      repeat
       token := GMNextWord(chPos, ALines[i], cSep);
       if Length(token) > 0 then
        for a:=Low(cAuthData) to High(cAuthData) do
         if GMSameText(token, cAuthData[a].Verb) then Include(FAuthKinds, a);
      until length(token) <= 0;
     end
    else
    if GMSameText(extVerb, cExtSIZE) then
     begin
//    Inc(chPos, Length(cExtSIZE));
      FServerMaxMsgSize := GMStrToInt(GMMakeDezInt(GMNextWord(chPos, ALines[i], cSep), cUnlimitedMsgSize));
     end
    else
    if GMSameText(extVerb, cExt8BitMime) then F8BitMime := True;
   end;
end;

procedure TGMSmtpClient.DoHelloMsgHandshake;
var cmdResponse: TCmdResponse;
begin
  if FHelloMsgHandshakeDone then Exit;
  ExecCommandStr(FTransportLayer, '', '2'); // <- retrieve greeting message from server
  FAuthKinds := [];
  cmdResponse := ExecCommandStr(FTransportLayer, 'EHLO '+FOwnAddr, cStrDigits);
  try
   if cmdResponse.Code[1] = '2' then
    ParseForExtensions(cmdResponse.Text)
   else
    ExecCommandStr(FTransportLayer, 'HELO '+FOwnAddr, '2');
  finally
   FHelloMsgHandshakeDone := True;
  end;
end;

procedure TGMSmtpClient.Login(const AUsername, APassword: TGMString);
var a: TSmtpAuthKind; authenticated: Boolean;
begin
  DoHelloMsgHandshake;

  authenticated := False;
  for a:=Low(a) to High(a) do
   if (a in FAuthKinds) and Assigned(cAuthData[a].Func) then
    begin
     authenticated := cAuthData[a].Func(Self, FTransportLayer, AUsername, APassword);
     if authenticated then Break;
    end;

  if (FAuthKinds <> []) and not authenticated then raise EGMSmtpException.ObjError(RStrAuthFailed, Self, {$I %CurrentRoutine%});
end;

function SendLine(const ALine: TGMString; const ALastLine: Boolean; const AData: Pointer): Boolean;
var chPos, i: Integer; ansiLine: AnsiString; smtp: TGMSmtpClient;
begin
  Result := True;
  if (AData = nil) or not (TObject(AData) is TGMSmtpClient) then Exit;

  smtp := TObject(AData) as TGMSmtpClient;

  ansiLine := ALine;

  if not smtp.F8BitMime then for i:=1 to Length(ansiLine) do ansiLine[i] := Chr(Ord(ansiLine[i]) and $7f);

  chPos := 1;
  repeat
   if chPos <= Length(ansiLine) then
    begin
     if ansiLine[chPos] = cMailTerm then GMSafeIStreamWrite(smtp.FTransportLayer, PAnsiChar(cMailTerm), Length(cMailTerm), {$I %CurrentRoutine%});
     GMSafeIStreamWrite(smtp.FTransportLayer, @ansiLine[chPos], Max(0, Min(cMaxMailLineLen, Length(ansiLine) - chPos + 1)), {$I %CurrentRoutine%});
    end;
   GMSafeIStreamWrite(smtp.FTransportLayer, PAnsiChar(CRLF), Length(CRLF), {$I %CurrentRoutine%});
   Inc(chPos, cMaxMailLineLen);
  until chPos > Length(ansiLine);
//ln := ansiLine + CRLF;
//if (Length(ln) > 0) and (ln[1] = '.') then ln := '.' + ln;
//GMSafeIStreamWrite(smtp.FTransportLayer, PAnsiChar(ln), Length(ln), {$I %CurrentRoutine%});
end;

procedure TGMSmtpClient.SendTextBody(const AText: TGMString);
begin
  GMParseLines(AText, SendLine, Self, True);
end;

procedure TGMSmtpClient.SendMail(AFrom, ATo, ASubject, AText: TGMString);
var headers, cmdFrom, term: AnsiString; msgSize: LongInt;
begin
  DoHelloMsgHandshake;

  AFrom := GMStrip(AFrom, '<>');
  ATo := GMStrip(ATo, '<>');

  GMAddINetHeader(HeadersToSend, 'Subject', ASubject);
  GMAddINetHeader(HeadersToSend, 'Date', GMEncodeUtcToINetTime(GMLocalTimeToUTC(Now), Self));
  GMAddINetHeader(HeadersToSend, 'From', AFrom);
  GMAddINetHeader(HeadersToSend, 'To', ATo);

  headers := GMHeadersAsString(HeadersToSend) + CRLF;

  cmdFrom := 'MAIL FROM:' + GMQuoteEMailaddress(AFrom);
  if F8BitMime then cmdFrom := cmdFrom + ' BODY=8BITMIME';
  if FServerMaxMsgSize >= 0 then
   begin
    msgSize := Length(headers) + Length(AText);
    if (FServerMaxMsgSize > 0) and (msgSize > FServerMaxMsgSize) then
       raise EGMSmtpException.ObjError(GMFormat(RStrMsgTooLarge, [msgSize, FServerMaxMsgSize]), Self, {$I %CurrentRoutine%});
    cmdFrom := cmdFrom + ' SIZE=' + IntToStr(msgSize);
   end;

  ExecCommandStr(FTransportLayer, cmdFrom, '2');
  ExecCommandStr(FTransportLayer, 'RCPT TO:' + GMQuoteEMailaddress(ATo), '2');
  ExecCommandStr(FTransportLayer, 'DATA', '3');

  vfGMTrace(headers, ProtocolDisplayName);
  GMSafeIStreamWrite(FTransportLayer, PAnsiChar(headers), Length(headers), {$I %CurrentRoutine%});

  vfGMTrace(GMMakeSingleLine(Atext, '<CRLF>', True), ProtocolDisplayName);
  if Length(AText) > 0 then SendTextBody(CRLF + AText);

  term := '.' + CRLF;
  GMSafeIStreamWrite(FTransportLayer, PAnsiChar(term), Length(term), {$I %CurrentRoutine%});

  ExecCommandStr(FTransportLayer, '', '2');
end;


end.