wsmtpserver.pas

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

  end;


//******************************************************************//
//  Routine      HandleRSET                                         //
//                                                                  //
//  Description  Handles RSET command                               //
//******************************************************************//

procedure TWSMTPserver.HandleRSET(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  with TWSMTPclient(Sender) do
    begin
    Context := mcCommand;
    MessageFrom := '';
    SetLength(MessageTo,0);
    SendStatus(s250,'0.0',[sReset]);
    end
  end;


//******************************************************************//
//  Routine      HandleHELO                                         //
//                                                                  //
//  Description  Handles HELO command                               //
//******************************************************************//

procedure TWSMTPserver.HandleHELO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  ESMTP := false;
  with TWSMTPclient(Sender) do
    begin
    ClientDomain := ExtractEmail(Parameters);
    Context := mcCommand;
    SendStatus(s250,'',[ServerDomain]);
    end
  end;


//******************************************************************//
//  Routine      HandleEHLO                                         //
//                                                                  //
//  Description  Handles EHLO command                               //
//******************************************************************//

procedure TWSMTPserver.HandleEHLO(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  var
    CommandList : string;
    i           : integer;
  begin
  ESMTP := true;
  with TWSMTPclient(Sender) do
    begin
    ClientDomain := ExtractEmail(Parameters);
    Context := mcCommand;

    CommandList := Format(s250c,[ServerDomain])+CRLF;
    // Now list all non-optional commands
    for i := Low(Commands) to High(Commands) do
      if (StrIComp(@Commands[i].Cmd[1],cMAIL)=0) and
         (StrIComp(@Commands[i].Cmd[1],cRCPT)=0) and
         (StrIComp(@Commands[i].Cmd[1],cDATA)=0) and
         (StrIComp(@Commands[i].Cmd[1],cRSET)=0) and
         (StrIComp(@Commands[i].Cmd[1],cNOOP)=0) and
         (StrIComp(@Commands[i].Cmd[1],cQUIT)=0) and
         Assigned(Commands[i].Handler) then
        CommandList := CommandList + Format(s250c,[Trim(Commands[i].Cmd)])+CRLF;
    if MaxMsgSize > 0 then
      CommandList := CommandList +
                   Format(s250c,['SIZE '+IntToStr(MaxMsgSize)])+CRLF;
    CommandList   := CommandList +
                     Format(s250c,['ENHANCEDSTATUSCODES'])+CRLF+
                     Format(s250 ,['PIPELINING'])+CRLF;
    SendStr(CommandList);
    end
  end;


//******************************************************************//
//  Routine      HandleMAIL                                         //
//                                                                  //
//  Description  Handles MAIL command                               //
//******************************************************************//

procedure TWSMTPserver.HandleMAIL(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  TWSMTPclient(Sender).StartMessage(wsmtpMail,Parameters);
  end;


//******************************************************************//
//  Routine      HandleRCPT                                         //
//                                                                  //
//  Description  Handles RCPT command                               //
//******************************************************************//

procedure TWSMTPserver.HandleRCPT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  var
    Recipient : TStringDynArray;
    Reason    : string;
    Action    : TWSMTPmailAction;
  begin
  // Line should consist of TO: <[address]>. Validate.
  with TWSMTPclient(Sender) do
    if StrLIComp(cTo,Parameters,Length(cTo)) = 0 then
      begin
      // Extract the To address..
      Parameters := Parameters + Length(cTo);
      SetLength(Recipient,1);
      Recipient[0] := ExtractEmail(Parameters);

      // New recipient specified?
      if ANSIindexText(Recipient[0],MessageTo) = -1 then
        begin
        // New recipient
        Reason := '';
        if Assigned(ActionHandler) then
          Action := ActionHandler(Self,ID,PeerAddr,ClientDomain,ClientRDNS,ClientMX,Transport,MessageFrom,Recipient,Reason,nil)
        else
          Action := wsmtpOK;

        // Handle action
        case Action of
          wsmtpBadAccount : SendStatus(s550,'1.1',[xBadAccount]);
          wsmtpBadDomain  : SendStatus(s550,'1.2',[xBadDomain]);
          wsmtpAccClosed  : SendStatus(s550,'1.6',[xAccClosed]);
          wsmtpProhibited : begin
                            if (Reason = '') then
                              Reason := xPolicy;
                            SendStatus(s553,'7.1',[Reason]);
                            end;
          else              begin
                            SetLength(MessageTo,SUCC(Length(MessageTo)));
                            MessageTo[High(MessageTo)] := Recipient[0];
                            SendStatus(s250,'1.5',['<'+Recipient[0]+'> '+cOK]);
                            end;
          end;
        end
      else
        // Accept duplicate recipient (but don't actually add it to the list again)
        SendStatus(s250,'1.0',['<'+Recipient[0]+'> '+cOK]);
      end
    else
      // Syntax error
      SendStatus(s501,'5.2',[xBadTOparam]);
  end;


//******************************************************************//
//  Routine      HandleDATA                                         //
//                                                                  //
//  Description  Handles DATA command                               //
//******************************************************************//

procedure TWSMTPserver.HandleDATA(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  with TWSMTPclient(Sender) do
    if Length(MessageTo) = 0 then
      // No recipients specified
      SendStatus(s503,'1.3',[xNoRecipients])
    else
      begin
      MessageID := Format('%1.1u%9.9x%8.8x',[YearOf(Now) mod 10,MillisecondOfTheYear(Now),ID]);
      Context   := mcData;
      SendStatus(s354,'0.0',[]);
      end;
  end;


//******************************************************************//
//  Routine      HandleSEND                                         //
//                                                                  //
//  Description  Handles SEND command                               //
//******************************************************************//

procedure TWSMTPserver.HandleSEND(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  TWSMTPclient(Sender).StartMessage(wsmtpSend,Parameters);
  end;


//******************************************************************//
//  Routine      HandleSAML                                         //
//                                                                  //
//  Description  Handles SAML command                               //
//******************************************************************//

procedure TWSMTPserver.HandleSAML(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  TWSMTPclient(Sender).StartMessage(wsmtpSendOrMail,Parameters);
  end;


//******************************************************************//
//  Routine      HandleSOML                                         //
//                                                                  //
//  Description  Handles SOML command                               //
//******************************************************************//

procedure TWSMTPserver.HandleSOML(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  TWSMTPclient(Sender).StartMessage(wsmtpSendAndMail,Parameters);
  end;


//******************************************************************//
//  Component    WSMTPclient                                        //
//******************************************************************//

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

constructor TWSMTPclient.Create(AOwner : TComponent);
  begin
  inherited;

  Context         := mcConnecting;
  ESMTP           := false;
  ClientDomain    := '';
  ClientRDNS      := '';
  ClientMX        := '';
  MessageFrom     := '';
  SetLength(MessageTo,0);

  with Buffer do
    begin
    Size := cBlockSize;
    GetMem(Str,Size);
    Len := 0;
    Str[Len] := NUL;
    end;

  DNS := nil;

  OnBgException   := TWSocketServer(AOwner).OnBgException;
  OnDataAvailable := nil;
  end;


destructor TWSMTPclient.Destroy;
  begin
  with Buffer do
    FreeMem(Str,Size);

  inherited;
  end;


//******************************************************************//
//  Routine      SendStr                                            //
//                                                                  //
//  Description  SendStr with a CONST parameter                     //
//******************************************************************//

function TWSMTPclient.SendStr(const Str : String) : integer;
  begin
  if Length(Str) > 0 then
    begin
    if Assigned(SMTPserver.TraceHandler) then
      SMTPserver.TraceHandler(SMTPserver,ID,false,PChar(Str));
    Result := Send(@Str[1], Length(Str))
    end
  else
    Result := 0;

  LastContact := Now;
  end;


//******************************************************************//
//  Routine      SendStatus                                         //
//                                                                  //
//  Description  Sets and transmits an SMTP status string           //
//******************************************************************//

procedure TWSMTPclient.SendStatus(const FormatStr    : string;
                                  const EnhancedStat : string;
                                        Args         : array of const);
  var
    OutputBuffer : string;
  begin
  try
    OutputBuffer := Format(FormatStr,Args)+CRLF;
    if ESMTP and (EnhancedStat <> '') and (FormatStr <> '') then
      OutputBuffer := Copy(OutputBuffer,1,4)+FormatStr[1]+'.'+EnhancedStat+Copy(OutputBuffer,4,Length(OutputBuffer));
    SendStr(OutputBuffer);
  except
    on E : Exception do
      begin
      RaiseException(Format(xClientStat,[ID,Copy(FormatStr,1,3),E.Message]));
      Abort;
      end;
    end;
  end;


//******************************************************************//
//  Routine      ClientDataRx                                       //
//                                                                  //
//  Description  Invoked when data is received from the client      //
//******************************************************************//

procedure TWSMTPclient.ClientDataRx(Sender : TObject;
                                    Error  : Word);
  function ReadInput : integer;
    var
      Rx : integer;
    begin