//===============================================================
//
//       SakSMTP unit, part of SakEmail
//
//       Contains: TSakSMTP
//
//
//---------------------------------------------------------------
//
//      Copyrigth (c) 1997, 1998, 1999 Sergio A. Kessler
//      and authors cited
//      http://sak.org.ar
//
//===============================================================


unit SakSMTP;

interface

uses SysUtils, Classes, scktcomp, sak_util, SakMsg;

{=============== SakSMTP ===============}

type
  longword = longint;

  TOnSendProgressEvent = procedure( Sender: TObject; Percent: word) of object;
  TToFromSocketEvent = procedure( Sender: TObject; s: string) of object;

  TSakSMTP = class(TComponent)
  private
    { Private declarations }
    FSocket: TClientSocket;

    FPort: string;
    FHost: String;
    FLocalizedDates: boolean;
    FSMTPError: boolean;
    FConnected: boolean;
    FReplyCode: string;
    FReplyString: string;
    FSendProgress: word;
    FSendProgressStep: word;
    FEncodeProgress: word;
    FEncodeProgressStep: word;
    FCanceled: boolean;
    FTimeOut: longword;
    SocketOkToRead: boolean;
    SocketOkToWrite: boolean;

    FOnConnect: TNotifyEvent;
    FOnDisconnect: TNotifyEvent;
    FOnBeforeSend: TNotifyEvent;
    FOnAfterSend: TNotifyEvent;
    FOnError: TOnError;
    FOnSendProgress: TOnSendProgressEvent;
    FOnEncodeStart: TOnCodeStartEvent;
    FOnEncodeProgress: TOnCodeProgressEvent;
    FOnEncodeEnd: TNotifyEvent;
    FOnLookup: TSocketNotifyEvent;
    FOnConnecting: TSocketNotifyEvent;
    FOnSendTextToSocket: TToFromSocketEvent;
    FOnReceiveTextFromSocket: TToFromSocketEvent;

    procedure FDoConnect( Sender: TObject; Socket: TCustomWinSocket);
    procedure FDoDisconnect( Sender: TObject; Socket: TCustomWinSocket);
    procedure FDoError( Sender: TObject; Socket: TCustomWinSocket;
                        ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure FDoErr( ErrorEvent: TErrorEvent);
    procedure FDoEncodeStart( const FileName: string; Size: longint);
    procedure FDoEncodeProgress( const Percent: word);
    procedure FDoEncodeEnd;
    procedure FDoSendProgress( const Percent: word);
    procedure DoOnBeforeSend;
    procedure DoOnAfterSend;
    procedure FDoLookup( Sender: TObject; Socket: TCustomWinSocket);
    procedure FDoConnecting( Sender: TObject; Socket: TCustomWinSocket);
    procedure FSendTextToSocket( const txt: string);
    function  FPrepareText( var aMsg: TSakMsg): TStringList;
    function  FReceiveTextFromSocket: string;
    function  FSendMail( const From: string; AddressList, data: TStringList): integer;
  protected
    { Protected declarations }
    procedure Base64Encode( var AttachedFile: TAttachedFile);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    procedure Connect;
    procedure Quit;
    function  SendMessage( var aMsg: TSakMsg): boolean;
    property  Connected: boolean read FConnected;
    property  ReplyCode: string read FReplyCode;
    property  ReplyString: string read FReplyString;
    property  SMTPError: boolean read FSMTPError;
    property  Canceled: boolean read FCanceled write FCanceled;
  published
    { Published declarations }
    property  Port: string read FPort write FPort;
    property  Host: string read FHost write FHost;
    property  LocalizedDates: boolean read FLocalizedDates write FLocalizedDates default false;
    property  EncodeProgressStep: word read FEncodeProgressStep write FEncodeProgressStep;
    property  SendProgressStep: word read FSendProgressStep write FSendProgressStep;
    property  OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property  OnQuit: TNotifyEvent read FOnDisconnect write FOnDisconnect;
    property  OnError: TOnError read FOnError write FOnError;
    property  OnBeforeSend: TNotifyEvent read FOnBeforeSend write FOnBeforeSend;
    property  OnAfterSend: TNotifyEvent read FOnAfterSend write FOnAfterSend;
    property  OnEncodeStart: TOnCodeStartEvent read FOnEncodeStart write FOnEncodeStart;
    property  OnEncodeProgress: TOnCodeProgressEvent read FOnEncodeProgress write FOnEncodeProgress;
    property  OnEncodeEnd: TNotifyEvent read FOnEncodeEnd write FOnEncodeEnd;
    property  OnSendProgress: TOnSendProgressEvent read FOnSendProgress write FOnSendProgress;
    property  OnLookup: TSocketNotifyEvent read FOnLookup write FOnLookup;
    property  OnConnecting: TSocketNotifyEvent read FOnConnecting write FOnConnecting;
    property  OnSendTextToSocket: TToFromSocketEvent read FOnSendTextToSocket write FOnSendTextToSocket;
    property  OnReceiveTextFromSocket: TToFromSocketEvent read FOnReceiveTextFromSocket write FOnReceiveTextFromSocket;
    property  TimeOut: longword read FTimeOut write FTimeOut;
  end;


implementation

uses Forms, SakMIME;

const crlf = #13#10;

{ ***************** TSakSMTP ***************** }

constructor TSakSMTP.Create( AOwner: TComponent);
begin
  inherited create( AOwner);
  FConnected := false;
  FPort := '25';
  FEncodeProgressStep := 10;
  FSendProgressStep := 10;
  SocketOkToRead := False;
  SocketOkToWrite := False;
  FTimeOut := 60000;  // a minute
  if not ( csDesigning in ComponentState) then
  begin
    FSocket := TClientSocket.create( AOwner);
    FSocket.ClientType := ctBlocking;
    FSocket.OnLookup := FDoLookup;
    FSocket.OnConnecting := FDoConnecting;
    FSocket.OnConnect := FDoConnect;
    FSocket.OnDisconnect := FDoDisconnect;
    FSocket.OnError := FDoError;
  end;
end;

procedure TSakSMTP.Connect;
begin
  FSocket.Port := StrToIntDef( FPort, 25);
  if sak_IsIPAddress(FHost) then
  begin
    FSocket.Address := FHost;        // Roger
    FSocket.Host := '';              // Roger
  end else
  begin
    FSocket.Host := FHost;          // Sergio
    FSocket.Address := '';          // Sergio
  end;

  FSMTPError := false;
  try
    FSocket.Open;
  except
    FSMTPError := True;
    exit;
  end;

  repeat
    Application.ProcessMessages;
  until FConnected;

  FReceiveTextFromSocket;

  if not FSMTPError then
    FSMTPError := (FReplyCode <> '220');

  if FSMTPError then
  begin
    FDoErr( eeConnect);
    exit;
  end;

  FSendTextToSocket( 'HELO ' + FSocket.Socket.LocalHost + crlf);
  FReceiveTextFromSocket;
  if not FSMTPError then
    FSMTPError := FReplyCode <> '250';
  if FSMTPError then
    FDoErr( eeConnect);
  FCanceled := False;
end;

procedure TSakSMTP.FDoConnect( Sender: TObject; Socket: TCustomWinSocket);
begin
  FConnected := true;
  if assigned( FOnConnect) then FOnConnect( Sender);
end;

procedure TSakSMTP.Quit;
begin
  if FConnected then
  begin
    try
       if FCanceled then
         exit;
       FSendTextToSocket( 'QUIT' +crlf);
       FReceiveTextFromSocket;
       if not FSMTPError then
         FSMTPError := FReplyCode <> '221';
       if FSMTPError then
          FDoErr( eeDisconnect);
      finally
       FSocket.close;
       FConnected := false;
    end
  end;
end;


function TSakSMTP.SendMessage( var aMsg: TSakMsg): boolean;
var
  MsgTOs, MsgCCs, MsgBCCs: TStringList;
  FromAux: string;
  StrListMsg: TStringList;
begin
  result := false;

  if not FConnected then
  begin
    raise Exception.create( sak_esNotConnected);
  end;
  if aMsg.From = '' then
  begin
    raise Exception.create( sak_esNotOrigin);
  end;
  if aMsg.SendTo = '' then
  begin
    raise Exception.create( sak_esNotDestination);
  end;

  aMsg.Date := sak_GetInternetDate( Now);

  StrListMsg := FPrepareText( aMsg);
  if FCanceled then
  begin
    StrListMsg.Free;
    exit;
  end;

  DoOnBeforeSend;

  FromAux := sak_ExtractAddress( aMsg.From, False);

  MsgTOs  := sak_CleanUpAddresses( aMsg.SendTo);
  MsgCCs  := sak_CleanUpAddresses( aMsg.CC);
  MsgBCCs := sak_CleanUpAddresses( aMsg.BCC);

  try
    if FSendMail( FromAux, MsgTOs, StrListMsg) < 1 then
       FDoErr( eeGeneral);
    if FSendMail( FromAux, MsgCCs, StrListMsg) < 1 then
       FDoErr( eeGeneral);
    if FSendMail( FromAux, MsgBCCs, StrListMsg) < 1 then
       FDoErr( eeGeneral);

    if FSendProgress < 100 then FDoSendProgress( 100);
    result := true;
    DoOnAfterSend;
  finally
    StrListMsg.Free;
    MsgTOs.Free;
    MsgCCs.Free;
    MsgBCCs.Free;
  end;
end;

function TSakSMTP.FSendMail( const From: string; AddressList, data: TStringList): integer;
var
  i: integer;
  step: word;
begin
  result := 1;

  if AddressList.Count = 0 then exit;
  FSendTextToSocket( 'MAIL FROM:' + '<' + From + '>' + crlf);
  FReceiveTextFromSocket;
  if not FSMTPError then
    FSMTPError := FReplyCode <> '250';
  if FSMTPError then
  begin
    result := -1;
    exit;
  end;

  for i := 0 to AddressList.Count-1 do
  begin
    FSendTextToSocket( 'RCPT TO:' + '<' + AddressList[ i] + '>' + crlf);

    FReceiveTextFromSocket;
    if not FSMTPError then
      FSMTPError := FReplyCode <> '250';
    if FSMTPError then
    begin
      result := -2;
      exit;
    end;
  end;

  FSendTextToSocket( 'DATA' +crlf);
  FReceiveTextFromSocket;
  if not FSMTPError then
    FSMTPError := (FReplyCode <> '354'); // and (FReplyCode <> '250');
  if FSMTPError then
  begin
    result := -3;
    exit;
  end;

  step := FSendProgressStep;

  for i := 0 to data.Count-1 do
  begin
    try
      FSendTextToSocket( data[ i] + crlf);
     except
      FSMTPError := true;
      result := -6;
      exit;
    end;
    FSendProgress := round( 100*(i+1)/data.Count);
    if ( FSendProgress >= step) then
    begin
      FDoSendProgress( FSendProgress);
      inc( step, FSendProgressStep);
    end;
    Application.ProcessMessages;
    if FCanceled then
    begin
      result := 0;
      exit;
    end;
  end;
  FSendTextToSocket( crlf + '.' + crlf);     // end of msg
  FReceiveTextFromSocket;
  if not FSMTPError then
    FSMTPError := FReplyCode <> '250';
  if FSMTPError then
  begin
    result := -4;
    exit;
  end;

  // In order for the server to accept another e-mail sent by SendMessage
  // without disconnecting and connecting again, RSET must be sent
  // in order for the server buffers to be cleared so that MAIL FROM:
  // will not return an error "503 Sender already specified".
  //
  //     Andy Charalambous - June 19, 1999.
  //
  FSendTextToSocket( 'RSET' + crlf);
  FReceiveTextFromSocket;
  if not FSMTPError then
    FSMTPError := FReplyCode <> '250';
  if FSMTPError then
  begin
    result := -5;
    exit;
  end;

  FDoSendProgress( 100);
end;

function TSakSMTP.FPrepareText( var aMsg: TSakMsg): TStringList;
var
  i: integer;
  boundary, UsrName, CTF: string;
  body, Headers: TStringList;
  AttFile: TAttachedFile;
  TextCoded: TMemoryStream;
  b64Encode: TBase64EncodingStream;
  c: char;
begin
  result := nil;
  Headers := TStringList.Create;
  Body := TStringList.Create;

  Body.Text := aMsg.Text.Text;

  UsrName := AMsg.UserName;

  Headers.Add('Message-Id: ' + sak_MakeUniqueId( FSocket.Socket.LocalHost));
  if aMsg.InReplyTo <> '' then
  begin
    Headers.Add('In-Reply-To: ' + aMsg.InReplyTo);
  end;

  Headers.Add('Date: ' + aMsg.Date);
  Headers.Add('X-Priority: ' + IntToStr(Integer(aMsg.Priority) + 1));

  if UsrName <> '' then
  begin
    if (pos( '@', aMsg.From) = 0) then
    begin
      Headers.Add('From: ' + '"' + UsrName + '" <' +
                   aMsg.From + '@' + Host + '>');
    end else
    begin
      Headers.Add('From: ' + '"' + UsrName + '" <' +
                   aMsg.From + '>');
    end;
  end else
  begin
    Headers.Add('From: ' + aMsg.From);
  end;

  if aMsg.ReplyTo <> '' then
  begin
    Headers.Add('Reply-To: ' + aMsg.ReplyTo);
  end;
  Headers.Add('X-Mailer: ' + Application.Title);
  Headers.Add('To: ' + aMsg.SendTo);
  if aMsg.CC <> '' then
  begin
    Headers.Add('CC: ' + aMsg.CC);
  end;
  Headers.Add('MIME-Version: 1.0');

  CTF := '8Bit';
  if aMsg.TextEncoding = te8Bit then
  begin
    i := 0;
    while i < Body.Count do
    begin
      if pos( '.', Body[i]) = 1 then
        Body[i] := '.' + Body[i];      // add transparency
      i := i + 1;
    end;
  end else
  begin   // TextEncoding = teBase64
    // encode the subject
    TextCoded := TMemoryStream.Create;
    b64Encode := TBase64EncodingStream.Create( TextCoded);
    b64Encode.Write( pointer( aMsg.Subject)^, length( aMsg.Subject));
    b64Encode.Free;  // first, to flush the remaining bytes
    aMsg.Subject := '';
    TextCoded.Position := 0;
    for i:= 1 to TextCoded.Size do
    begin
      TextCoded.Read( c, 1);
      aMsg.Subject := aMsg.Subject + c;
    end;
    aMsg.Subject := '=?' + aMsg.CharSet + '?B?' + aMsg.Subject + '?=';
    TextCoded.Free;

    // encode the body
    TextCoded := TMemoryStream.Create;
    b64Encode := TBase64EncodingStream.Create( TextCoded);
    b64Encode.Write( pointer( Body.Text)^, length( Body.Text));
    b64Encode.Free;  // first, to flush the remaining bytes
    Body.Clear;
    TextCoded.Position := 0;
    Body.LoadFromStream( TextCoded);
    TextCoded.Free;
    CTF := 'base64';
  end;

  Headers.Add('Subject: ' + aMsg.Subject);

  if aMsg.attachedFiles.count = 0 then
  begin
    Headers.Add( 'Content-Type: Text/Plain; charset=' + aMsg.CharSet);
    Headers.Add( 'Content-Transfer-Encoding: ' + CTF);
  end else
  begin
    boundary := sak_GenerateBoundary;
    Headers.Add( 'Content-Type: multipart/mixed; boundary="' + boundary + '"');
    boundary := '--' + boundary;
    Body.Insert( 0, boundary);
    Body.Insert( 1, 'Content-Type: Text/Plain; charset=' + aMsg.CharSet);
    Body.Insert( 2, 'Content-Transfer-Encoding: ' + CTF);
    Body.Insert( 3, '');
    for i := 0 to aMsg.attachedFiles.count-1 do
    begin
      AttFile := aMsg.AttachedFiles[ i];
      Body.Add( boundary);
      Body.Add( 'Content-Type: ' + AttFile.MIMEType +
                '; name="' + AttFile.FileName + '"');
      Body.Add( 'Content-Transfer-Encoding: base64');
      Body.Add( 'Content-Disposition: inline; FileName="' +
                aMsg.AttachedFiles[ i].FileName + '"');
      Body.Add( '');
      Base64Encode( AttFile);

      Application.ProcessMessages;
      if FCanceled then
      begin
        Headers.Clear; Headers.Free;
        Body.Clear; Body.Free;
        exit;
      end;

      Body.AddStrings( AttFile.BodyEncoded);
    end;
    Body.Add( '');
    Body.Add( boundary + '--');
    Body.Add( '');
  end;

  Headers.AddStrings( aMsg.ExtraHeaders);

  result := TStringList.Create;
  result.AddStrings( Headers);
  result.Add( '');
  result.AddStrings( Body);
  Headers.Clear; Headers.Free;
  Body.Clear; Body.Free;
end;


procedure TSakSMTP.Base64Encode( var AttachedFile: TAttachedFile);
const
  BytesToRead = 1024;
var
  b: array[0..1024] of byte;
  step: word;
  BytesRead: integer;
  TextCoded: TFileStream;
  TextBin: TFileStream;
  b64Encode: TBase64EncodingStream;
  fn: string;
begin
  TextBin := TFileStream.Create( AttachedFile.UNCFileName, fmOpenRead or fmShareDenyNone);
  fn := sak_util.sak_GetTempFileName;
  TextCoded := TFileStream.Create( fn, fmCreate or fmOpenReadWrite or fmShareExclusive);

  FDoEncodeStart( AttachedFile.FileName, TextBin.Size);

  b64Encode := TBase64EncodingStream.Create( TextCoded);

  step := FEncodeProgressStep;
  repeat
    Application.ProcessMessages;
    if FCanceled then
    begin
      TextBin.Free;
      b64Encode.Free;
      TextCoded.Free;
      DeleteFile( fn);
      exit;
    end;

    BytesRead := TextBin.Read( b, BytesToRead);
    b64Encode.Write( b, BytesRead);

    if TextBin.Size > 0 then
      FEncodeProgress := round( 100*TextBin.Position/TextBin.Size)
    else
      FEncodeProgress := 100;

    if ( FEncodeProgress >= step) then
    begin
      FDoEncodeProgress( FEncodeProgress);
      inc( step, FEncodeProgressStep);
    end;
  until (BytesRead < BytesToRead);

  if FEncodeProgress < 100 then FDoEncodeProgress( 100);

  b64Encode.Free;  // first, to flush the remaining bytes
  TextCoded.Free;
  TextBin.Free;

  AttachedFile.BodyEncoded.LoadFromFile( fn);
  DeleteFile( fn);

  FDoEncodeEnd;
end;


procedure TSakSMTP.FDoDisconnect( Sender: TObject; Socket: TCustomWinSocket);
begin
  FConnected := false;
  if assigned( FOnDisconnect) then
    FOnDisconnect( Sender);
end;


function TSakSMTP.FReceiveTextFromSocket: string;
var
  s: string;
  i, x : integer;
  buff: array[1..1024] of char;
begin
  repeat
    Application.ProcessMessages;

    x := FSocket.Socket.ReceiveBuf( buff, 1024);

    s := copy( buff, 1, x);
    i := pos( crlf, s);
    while (i > 0) and (length( s) > i+2) do
    begin
      s := copy( s, i+2, length(s)-i-1);
      i := pos( crlf, s);
    end;
    FReplyCode := trim( copy( s, 1, 3));
    FReplyString := trim( copy( s, 4, 64));
    result := s;
    Application.ProcessMessages;
    if length( s) < 4 then s := '----';
  until s[4] = ' ';
  // because the replys that are like '250-OK' are not final,
  // replys like '250 OK' are finals, note the fourth char
  if assigned( FOnReceiveTextFromSocket) then
  begin
    FOnReceiveTextFromSocket( self, s);
  end;
end;

procedure TSakSMTP.FSendTextToSocket( const txt: string);
begin
  Application.ProcessMessages;
  FSocket.Socket.SendBuf( pointer(txt)^, length( txt));

  if assigned( FOnSendTextToSocket) then
  begin
    FOnSendTextToSocket( self, txt);
  end;
end;

procedure TSakSMTP.DoOnBeforeSend;
begin
  if assigned( FOnBeforeSend) then
    FOnBeforeSend( self);
end;

procedure TSakSMTP.DoOnAfterSend;
begin
  if assigned( FOnAfterSend) then
    FOnAfterSend( self);
end;

procedure TSakSMTP.FDoErr( ErrorEvent: TErrorEvent);
var
  x: integer;
begin
  x := 0;
  FDoError( self, FSocket.Socket, ErrorEvent, x);
end;

procedure TSakSMTP.FDoError( Sender: TObject; Socket: TCustomWinSocket;
                             ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  FSMTPError := true;
  FSocket.close;
  FConnected := false;
  if assigned( FOnError) then
    FOnError( Sender, StrToInt( FReplyCode), FReplyString);
end;

procedure TSakSMTP.FDoEncodeStart( const FileName: string; Size: longint);
begin
  if assigned( FOnEncodeStart) then
    FOnEncodeStart( self, FileName, Size);
end;

procedure TSakSMTP.FDoEncodeProgress( const Percent: word);
begin
  if assigned( FOnEncodeProgress) then
    FOnEncodeProgress( self, Percent);
end;

procedure TSakSMTP.FDoEncodeEnd;
begin
  if assigned( FOnEncodeEnd) then
    FOnEncodeEnd( self);
end;

procedure TSakSMTP.FDoSendProgress( const Percent: word);
begin
  if assigned( FOnSendProgress) then
    FOnSendProgress( self, Percent);
end;

procedure TSakSMTP.FDoLookup( Sender: TObject; Socket: TCustomWinSocket);
begin
  if assigned( FOnLookup) then
    FOnLookup( Sender, Socket);
end;

procedure TSakSMTP.FDoConnecting( Sender: TObject; Socket: TCustomWinSocket);
begin
  if assigned( FOnConnecting) then
    FOnConnecting( Sender, Socket);
end;


end.
