wsmtpserver.pas

SMTPserver is a freeware application that shows how to use the ADVsystems TWSMTPserver Delphi compon

  s421                 = '421 %s %s, %s';
  s452                 = '452 Requested action not taken: %s';
  s500                 = '500 Invalid command: "%s"';
  s501                 = '501 %s';
  s502                 = '502 Command not implemented: "%s"';
  s503                 = '503 %s';
  s550                 = '550 %s';
  s552                 = '552 Message exceeds fixed maximum message size';
  s553                 = '553 %s';
  s554                 = '554 %s';


type
  TWSMTPclient         = class(TWSocketClient)
                         private
                           ID           : cardinal;
                           LastContact  : TDateTime;
                           SMTPserver   : TWSMTPserver;
                           Context      : TWSMTPmsgContext;
                           ESMTP        : boolean;
                           ClientDomain : string;
                           ClientRDNS   : string;
                           ClientMX     : string;
                           Buffer       : record
                                          Str  : PChar;
                                          Len  : integer;
                                          Size : integer;
                                          end;
                           DNS          : TDNSquery;
                           Transport    : TWSMTPmailAction;
                           MessageID    : string;
                           MessageFrom  : string;
                           MessageTo    : TStringDynArray;
                           procedure      ClientDataRx(Sender : TObject; Error : Word);
                           procedure      ProcessCommand(Str : PChar);
                           procedure      WndProc(var MsgRec: TMessage); override;
                           procedure      LookupComplete(Sender : TObject; Error : Word);
                           procedure      StartMessage(const Mechanism : TWSMTPmailAction; Parameters : PChar);
                         public
                           function       SendStr(const Str : String) : integer; reintroduce;
                           procedure      SendStatus(const FormatStr : string; const EnhancedStat : string; Args : array of const);
                           constructor    Create(AOwner : TComponent); override;
                           destructor     Destroy; override;
                         end;

threadvar
  Counter              : cardinal;

//******************************************************************//
//  Routine      Utility routines                                   //
//******************************************************************//

function SMTPtime : string;
  // Returns current time in accepted SMTP format

  function TimeZone : string;
    const
      Sign   : array[false..true] of char = ('-','+');
    var
      TZone  : TTimeZoneInformation;
      CZone  : integer;
      Min    : integer;
      Zone   : string;
      i      : integer;
    begin
    CZone := GetTimeZoneInformation(TZone);
    if CZone = TIME_ZONE_ID_DAYLIGHT then Zone := string(TZone.DaylightName)
                                     else Zone := string(TZone.StandardName);
    i := 1;
    while (i <= Length(Zone)) and (ORD(Zone[i]) > ORD(' ')) do Inc(i);
    SetLength(Zone,PRED(i));
    if CZone = TIME_ZONE_ID_DAYLIGHT then
      begin
      Zone := Zone+' DST';
      Min := -TZone.DaylightBias;
      end
    else
      Min := -TZone.StandardBias;
    if Zone = 'GMT DST' then Zone := 'BST';

    Result := Format('%s%2.2u00 %s',[Sign[Min>=0],ABS(Min div 60),Zone]);
    end;

  begin
  Result := FormatDateTime('ddd d mmm yyyy hh:mm:ss ',Now)+TimeZone;
  end;


procedure SkipWhitespace(var Ptr : PChar);
  // Skips whitespace at the start of a PChar
  begin
  while (Ptr^ <> NUL) and (Ptr^ <= ' ') do
    Inc(Ptr);
  end;


function ExtractEmail(var Str : PChar) : string;
  // Extracts an RFC-821 address, removes angle-brackets
  var
    Ptr : PChar;
    i,j : integer;
  begin
  // Advance to first useful character
  while (Str^ <= ' ') or (Str^ in ['<',NUL]) do
    Inc(Str);
  // Ignore whitespace
  SkipWhitespace(Str);
  // Now locate end of string
  Ptr := Str + 1;
  if Str^ <> NUL then
    while (Ptr^ > ' ') and (Ptr^ <> '>') do
      Inc(Ptr);
  // Set Result; remove any relay requests while we're at it..
  SetString(Result,Str,Ptr-Str);
  for i := 1 to Length(Result) do
    if Result[i] in [cAT,'!'] then
      Result[i] := cAT;
  i := Pos(Result,cAT);
  if i > 0 then
    begin
    j := SUCC(i);
    while (j <= Length(Result)) and (Result[j] <> cAT) do
      Inc(j);
    if j <= Length(Result) then
      SetLength(Result,PRED(j));
    end;

  // Move pointer to end of this parameter
  if Ptr^ = NUL then
    Str := Ptr
  else
    Str := Ptr+1;
  end;


function ComputerName : string;
  // Returns the Windows host name
  var
    NameLen  : cardinal;
    Computer : PChar;
  begin
  try
    NameLen  := SUCC(MAX_COMPUTERNAME_LENGTH);
    Computer := AllocMem(NameLen);
    try
      GetComputerName(Computer,NameLen);
      Result := string(Computer);
    finally
      FreeMem(Computer,NameLen);
      end;
  except
    Result := 'localhost';
    end
  end;


//******************************************************************//
//  Component    WSMTPserver                                        //
//******************************************************************//

//******************************************************************//
//  Routine      Constructor                                        //
//******************************************************************//

constructor TWSMTPserver.Create(AOwner : TComponent);
  var
    i       : integer;
  begin
  inherited;

  Address        := '0.0.0.0';
  ServerPort     := 'smtp';
  MultiThread    := false;
  MaxUsers       := 0;
  DNSaddr        := '';
  SetTimeout(cClientTimeout);

  TraceHandler   := nil;
  ExtHandler     := nil;
  ActionHandler  := nil;

  // Set default domain
  ServerDomain := '';
  i := 0;
  while (i < LocalIPlist.Count) and (ServerDomain = '') do
    begin
    ServerDomain := WSocketResolveIP(LocalIPlist[i]);
    Inc(i);
    end;

  // Set host name
  ServerHost   := LowerCase(ComputerName)+'.';
  if ServerDomain = '' then
    // No entry found. Set default domain
    ServerDomain := 'local'
  else
    begin
    // Remove leading host name
    i := Pos('.',ServerDomain);
    if i > 0 then
      ServerHost := Copy(ServerDomain,1,PRED(i))+'.';
    ServerDomain := Copy(ServerDomain,SUCC(i),Length(ServerDomain));
    end;

  ServerName   := ClassName;

  // Create SocketServer
  Server  := TWsocketServer.Create(nil);
  with Server do
    begin
    OnBgException      := ServerException;
    Banner             := '';
    BannerTooBusy      := '';
    ClientClass        := TWSMTPclient;
    OnClientConnect    := ClientConnect;
    OnClientDisconnect := ClientDisconnect;
    end;

  // Define client check timer
  CheckTimer := TTimer.Create(Self);
  CheckTimer.Interval := cTimerInterval;
  CheckTimer.OnTimer  := CheckClientStatus;
  CheckTimer.Enabled  := false;

  // Add commands
  SetLength(Commands,0);
  AddCommand(cMAIL,HandleMAIL);
  AddCommand(cRCPT,HandleRCPT,mcMessage);
  AddCommand(cDATA,HandleDATA,mcMessage);
  AddCommand(cHELO,HandleHELO,mcConnected);
  AddCommand(cEHLO,HandleEHLO,mcConnected);
  AddCommand(cQUIT,HandleQUIT);
  AddCommand(cRSET,HandleRSET);
  AddCommand(cSEND,HandleSEND);
  AddCommand(cSOML,HandleSOML);
  AddCommand(cSAML,HandleSAML);
  AddCommand(cNOOP,HandleNOOP);
  AddCommand(cTURN,nil);
  AddCommand(cVRFY,nil);
  AddCommand(cEXPN,nil);
  AddCommand(cETRN,nil);
  AddCommand(cHELP,nil);
  end;


//******************************************************************//
//  Routine      Destructor                                         //
//******************************************************************//

destructor TWSMTPserver.Destroy;
  begin
  if Active then
    SetActive(false);

  Server.Free;
  Server := nil;

  inherited;
  end;


//******************************************************************//
//  Routine      RaiseException                                     //
//                                                                  //
//  Description  Raises an exception                                //
//******************************************************************//

procedure TWSMTPserver.RaiseException(const Message : string);
  begin
  if Assigned(ExtHandler) then
    ExtHandler(Self,EWSMTPserver.Create(Message))
  else
    raise EWSMTPserver.Create(Message);
  end;


//******************************************************************//
//  Routine      SetTimeout                                         //
//                                                                  //
//  Description  Sets the client timeout                            //
//******************************************************************//

procedure TWSMTPserver.SetTimeout(ATimeout : integer);
  begin
  if ATimeout <= 0 then
    Timeout := ATimeout
  else
    Timeout := ATimeout;
  end;


//******************************************************************//
//  Routine      CheckClientStatus                                  //
//                                                                  //
//  Description  Runs through attached clients, looking for timeout //
//******************************************************************//

procedure TWSMTPserver.CheckClientStatus(Sender : TObject);
  var
    i     : integer;
    Time  : TDateTime;
    Delta : integer;
  begin
  Time := Now;

  for i := PRED(Server.ClientCount) downto 0 do
    with TWSMTPclient(Server.Client[i]) do
      begin
      Delta := SecondsBetween(Time,LastContact);