wsmtpserver.pas

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

    with Buffer do
      begin
      Result := 0;
      repeat
        // Check buffer size
        if Len >= PRED(Size) then
          begin
          Inc(Size,cBlockSize);
          ReallocMem(Str,Size);
          end;
        // Receive data
        Rx := Receive(@Str[Len],PRED(Size)-Len);
        if Rx > 0 then
          begin
          Inc(Result,Rx);
          Inc(Len,Rx);
          end;
        until Rx <= 0;
      // Mark end of PChar & record interaction
      Str[Len] := NUL;
      end;
    // If data received, mark reception time
    if Result > 0 then
      LastContact := Now;
    end;

  procedure HandleCommand;
    var
      LineEnd : PChar;
    begin
    // Check for a command. Protocol says CRLF as terminator, but let's be nice to bad UNIX proggers..
    with Buffer do
      begin
      LineEnd := StrScan(Str,CR);
      if LineEnd = nil then
        LineEnd := StrScan(Str,LF);
      if Assigned(LineEnd) then
        begin
        // Command line received. Strip, process, and shuffle buffer
        LineEnd^ := NUL;
        ProcessCommand(Str);
        Inc(LineEnd);
        if (LineEnd^ in [CR,LF]) then Inc(LineEnd);
        StrCopy(Str,LineEnd);
        Len := StrLen(Str);
        // Check for more commands or message data..
        PostMessage(Handle,wmCheckInputBuffer,0,cardinal(Self));
        end
      end
    end;

  procedure HandleMessage(MsgEnd : PChar);
    var
      Reason   : string;
      NextChar : char;
    begin
    // End-of-Message detected
    with Buffer do
      begin
      if (SMTPserver.MaxMsgSize <= 0) or (Len <= SMTPserver.MaxMsgSize) then
        begin
        if Assigned(SMTPserver.ActionHandler) then
          begin
          // Temporarily overwrite the end-of-message character
          NextChar := MsgEnd^;
          MsgEnd^  := NUL;
          case SMTPserver.ActionHandler(Self,ID,PeerAddr,ClientDomain,ClientRDNS,ClientMX,Transport,MessageFrom,MessageTo,Reason,Str) of
            wsmtpProhibited  : begin
                               if Reason = '' then Reason := xPolicy;
                               SendStatus(s554,'7.1',[Reason]);
                               end;
            wsmtpMsgTooLarge : SendStatus(s452,'3.1',[xNoStorage]);
            wsmtpSysUnavail  : SendStatus(s554,'3.2',[xNoSysUnavail]); // System is not accepting messages (e.g. shutting-down, PM, etc.)
            wsmtpNetError    : SendStatus(s554,'4.0',[xNetError]);     // Network error
            wsmtpCongested   : SendStatus(s554,'4.5',[xCongested]);    // System is congested. Please try again later.
            wsmtpTooMany     : SendStatus(s554,'5.3',[xTooMany]);      // Too many recipients specified
            wsmtpBadMedia    : SendStatus(s554,'3.1',[xBadMedia]);     // Media not supported (e.g. we don't like Base-64 ;o)
            wsmtpListNotAuth : SendStatus(s554,'3.1',[xListNotAuth]);  // You are not authorised to send messages to this mailing list
            wsmtpListNotRec  : SendStatus(s554,'2.4',[xListNotRec]);   // Mailing list does not exist
            else               SendStatus(s250,'6.0',[Format(sQueued,[MessageID])]);
            end;
          // Repair buffer
          MsgEnd^  := NextChar;
          end
        else
          // Noone at home to receive the completed message
          SendStatus(s554,'3.5',[xNoSpool]);
        end
      else
        begin
        // Message too large
        if Assigned(SMTPserver.ActionHandler) then
          begin
          // Inform calling application
          Reason := '';
          SMTPserver.ActionHandler(Self,ID,PeerAddr,ClientDomain,ClientRDNS,ClientMX,wsmtpMsgTooLarge,MessageFrom,MessageTo,Reason,nil);
          end;
        SendStatus(s554,'2.3',[xMsgTooLarge]);
        end;

      // Now reset context and shuffle buffer
      StrCopy(Str,MsgEnd);
      Len := StrLen(Str);
      Context := mcCommand;
      if Len > 0 then
        // Handle PIPELINEd command
        PostMessage(Handle,wmCheckInputBuffer,0,cardinal(Self));
      end
    end;

  var
    MsgEnd  : PChar;
  begin
  if (Error = ERROR_SUCCESS) then
    begin
    if (Sender = nil) or (ReadInput > 0) then
      begin
      if Context = mcData then
        begin
        // Message data received. Start by checking for an end-of-message marker
        MsgEnd := SearchBuf(Buffer.Str,Buffer.Len,0,0,EOM);
        if Assigned(MsgEnd) then
          HandleMessage(MsgEnd+Length(EOM))
        end
      else
        HandleCommand;
      end
    end
  else
    // Data reception error. Close link
    Close;
  end;


//******************************************************************//
// Routine      WndProc                                             //
//                                                                  //
// Description  Handles custom message processing                   //
//******************************************************************//

procedure TWSMTPclient.WndProc(var MsgRec: TMessage);
  var
    Scratch : string;
  begin
  with TWSMTPclient(MsgRec.LParam) do
  case MsgRec.Msg of
    wmCheckInputBuffer  : ClientDataRx(nil,ERROR_SUCCESS);
    wmClientLookupDone  : if Context = mcConnecting then
                            begin
                            // Setup connection
                            Context := mcConnected;
                            DNS.Free;
                            DNS := nil;
                            SendStatus(s220,'',[SMTPserver.ServerDomain,SMTPserver.ServerName,SMTPtime]);
                            OnDataAvailable := ClientDataRx;
                            // Inform "caller"
                            if Assigned(SMTPserver.ActionHandler) then
                              begin
                              Scratch := '';
                              SMTPserver.ActionHandler(Self,ID,PeerAddr,ClientDomain,ClientRDNS,ClientMX,wsmtpConnect,'',nil,Scratch,nil);
                              end;
                            end;
    else                    inherited;
    end
  end;


//******************************************************************//
// Routine      LookupComplete                                      //
//                                                                  //
// Description  RDNS lookup complete for client connection          //
//******************************************************************//

procedure TWSMTPclient.LookupComplete(Sender : TObject; Error : Word);
  var
    i,j : integer;
  begin
  with DNS do
    if Error = ERROR_SUCCESS then
      begin
      if QuestionType = DnsQueryPTR then
        begin
        if ResponseANCount = 0 then
          // No rDNS available.
          PostMessage(Handle,wmClientLookupDone,0,cardinal(Self))
        else
          begin
          ClientRDNS := Hostname[0];
          MXLookup(ClientRDNS);
          end
        end
      else
        // MX record located
        if ResponseANCount = 0 then
          begin
          // Failed. Remove front subdomain and try again
          i := Pos('.',QuestionName);
          if i = 0 then
            // MX does not exist
            PostMessage(Handle,wmClientLookupDone,0,cardinal(Self))
          else
            // Remove front portion and try again..
            MXlookup(Copy(QuestionName,SUCC(i),Length(QuestionName)));
          end
        else
          begin
          // Locate current primary server
          i := 0;
          for j := 1 to PRED(ResponseANCount) do
            if MXpreference[j] < MXpreference[i] then
              i := j;
          ClientMX := MXexchange[i];
          end
      end
    else
      begin
      // DNS lookup has failed.
      OnRequestDone := nil;
      PostMessage(Handle,wmClientLookupDone,0,cardinal(Self))
      end;
  end;


//******************************************************************//
//  Routine      ProcessCommand                                     //
//                                                                  //
//  Description  Processes an SMTP command                          //
//******************************************************************//

procedure TWSMTPclient.ProcessCommand(Str : PChar);
  var
    Cmd, Ptr : PChar;
    i        : integer;
  begin
  if Str^ <> NUL then
    begin
    if Assigned(SMTPserver.TraceHandler) then
      SMTPserver.TraceHandler(SMTPserver,ID,true,Str);

    // Trim any trailing whitespace
    Ptr := StrEnd(Str)-1;
    while (Ptr >= Str) and (Ptr^ <= ' ') do
      Dec(Ptr);
    PChar(Ptr+1)^ := NUL;

    // Advance pointers to command and any parameters
    Cmd := Str;
    while (Cmd^ <> NUL) and (Cmd^ <= ' ') do
      Inc(Cmd);
    Ptr := Cmd;
    while (Ptr^ <> NUL) and (Ptr^ > ' ') do
      Inc(Ptr);
    if Ptr <> NUL then
      begin
      // Parameter present - skip whitespace
      Ptr^ := NUL;
      Inc(Ptr);
      while (Ptr^ <> NUL) and (Ptr^ <= ' ') do
        Inc(Ptr);
      end;

    // Search command list
    with SMTPserver do
      begin
      i := Low(Commands);
      while (i <= High(Commands)) and (StrIComp(Cmd,@Commands[i].Cmd[1]) <> 0) do
        Inc(i);
      if i < Length(Commands) then
        begin
        // Command recognized. Is it in-context?
        if (Commands[i].Context = Context) or (StrIComp(Cmd,cQUIT) = 0) or (StrIComp(Cmd,cRSET) = 0) then
          begin
          // Call handler, if assigned
          if Assigned(Commands[i].Handler) then
            Commands[i].Handler(Self,ID,ESMTP,Ptr)
          else
            // No handler.. hence not implemented
            SendStatus(s502,'5.1',[Cmd]);
          end
        else
          begin
          // Command is out-of-sequence
          if Context = mcConnected then
            SendStatus(s503,'5.1',[xNoHello])
          else
            SendStatus(s503,'5.1',[xOutOfSequence]);
          end
        end
      else
        SendStatus(s500,'5.2',[Cmd]);
      end
    end
  end;


//******************************************************************//
//  Routine      StartMessage                                       //
//                                                                  //
//  Description  Checks a message line & sets mechanism             //
//******************************************************************//

procedure TWSMTPclient.StartMessage(const Mechanism  : TWSMTPmailAction;
                                          Parameters : PChar);
  var
    MsgSize : integer;
  begin
  // Line should consist of FROM: <[address]>. Validate.
  if StrLIComp(c