main.pas

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

//******************************************************************//
//  Routine      LogAction                                          //
//                                                                  //
//  Description  Logs a client event, handles recipient verification//
//******************************************************************//

function TMainForm.LogAction(      Sender   : TObject;
                             const ClientID : cardinal;
                             const Address  : string;
                             const Domain   : string;
                             const Hostname : string;
                             const MailX    : string;
                             const Action   : TWSMTPmailAction;
                             const MailFrom : string;
                             const MailTo   : TStringDynArray;
                             var   Reason   : string;
                                   Content  : PChar) : TWSMTPmailAction;
  begin
  Result := wsmtpOK;
  case Action of
    wsmtpConnect     : Log.Lines.Add(Format('%s  %8.8x      Client connected from %s',[FormatDateTime('yyyymmdd hh:nn:ss',Now),ClientID,Address]));
    wsmtpDisconnect  : Log.Lines.Add(Format('%s  %8.8x      Connection terminated',[FormatDateTime('yyyymmdd hh:nn:ss',Now),ClientID,Address]));
    wsmtpMail,
    wsmtpSend,
    wsmtpSendOrMail,
    wsmtpSendAndMail : if Content = nil then
                         begin
                         // No content has been assigned. This means that a recipient must have been added to the bottom of the list.
                         // If we're being protocol-aware, we have to return a yes/no answer. We /could/ just decide once the whole
                         // message has appeared, but that's a bit nasty - the client at the other end is left guessing.

                         // In this particular case, we are going to be *really* nasty, and just randomly refuse a client. This is not
                         // recommended as a deployment option ;o)
                         case Random(10) of
                           0 :  begin
                                Result := wsmtpProhibited;
                                // This is a policy-driven refusal, e.g. "Go away, foul spammer"
                                Reason := 'Recipient refused - your mother was a hamster, and your father smelt of elderberries';
                                end;
                           1 :  begin
                                Result := wsmtpBadAccount;
                                Reason := 'noone here by that name - please check your spleling';
                                end;
                           2 :  begin
                                Result := wsmtpBadDomain;
                                Reason := 'That Internet domain isn''t handled by this server. And I don''t feel like relaying it';
                                end;
                           3 :  begin
                                Result := wsmtpAccClosed;
                                Reason := 'Sorry, that person has moved-on to pastures new. Technically, I could tell you his new address, but I''m not going to';
                                end;
                           else begin
                                Result := wsmtpOK;
                                Reason := 'Recipient accepted';
                                end;
                           end;
                         // Log response
                         Log.Lines.Add(Format('%s  %8.8x      <%s> %s',[FormatDateTime('yyyymmdd hh:nn:ss',Now),ClientID,MailTo[0],Reason]));
                         end
                       else
                         begin
                         // Something has been assigned to the content, which means we have work to do!
                         // If we didn't check the sender and recipients while each recipient was added, now's the time!
                         // Mail messages (i.e. anything that doesn't have to be delivered straight away) should be spooled,
                         // in case there's noone at the other end to receive them.

                         // Display message contents
                         Log.Lines.Add(Format('%s  %8.8x  Rx  ',[FormatDateTime('yyyymmdd hh:nn:ss',Now),ClientID])+
                                       ANSIreplaceStr(Content,#13#10,#13#10+StringOfChar(' ',33)));

                         // In this case, we're going to be cruel (again!) and subject the client to some random errors
                         case Random(30) of
                           0  : begin
                                Result := wsmtpProhibited;
                                // This is a policy-driven refusal, e.g. "Go away, foul spammer"
                                Reason := 'Message refused. Probably spam anyway';
                                end;
                           1  : Result := wsmtpMsgTooLarge;
                           2  : Result := wsmtpSysUnavail;
                           3  : Result := wsmtpNetError;
                           4  : Result := wsmtpCongested;
                           5  : Result := wsmtpTooMany;
                           6  : Result := wsmtpBadMedia;
                           7  : Result := wsmtpListNotAuth;
                           8  : Result := wsmtpListNotRec;
                           else Result := wsmtpOK;
                           end;
                         end;
    wsmtpMsgTooLarge : Log.Lines.Add(Format('%s  %8.8x      Message lost (exceeded maximum permitted size)',[FormatDateTime('yyyymmdd hh:nn:ss',Now),ClientID]));
    else              ; // Ignore
    end;
  end;


//******************************************************************//
//  Routine      FormCreate                                         //
//                                                                  //
//  Description  Creates Form and SMTP object                       //
//******************************************************************//

procedure TMainForm.FormCreate(Sender: TObject);
  begin
  Caption := Application.Title;
  Log.Clear;
  TraceLog.Clear;
  Log.Height := (ClientHeight-ButtonPanel.Height-Splitter.Height) div 2;

  SMTPserver := TDemoSMTPserver.Create(Self);
  with SMTPserver do
    begin
    // Add an exception handler
    OnException     := HandleException;

    // Add an Action handler
    OnClientAction  := LogAction;

    // Add additional commands without learning OOP
    AddCommand('YES',HandleUserCommand);
    AddCommand('YES?',HandleUserCommand);
    end;

  bToggle.Click;
  end;


//******************************************************************//
//  Routine      bToggleClick                                       //
//                                                                  //
//  Description  Handler for Toggle button                          //
//******************************************************************//

procedure TMainForm.bToggleClick(Sender: TObject);
  const
    State   : array[false..true] of string
            = ('has been shutdown','is active');
    Caption : array[false..true] of string
            = ('Start','Shutdown');
  begin
  SMTPserver.Enabled := not SMTPserver.Enabled;
  Log.Lines.Add(SMTPserver.Service+' '+State[SMTPserver.Enabled]);
  bToggle.Caption := Caption[SMTPserver.Enabled];
  end;


//******************************************************************//
//  Routine      Trace                                              //
//                                                                  //
//  Description  Provides an SMTP trace facility                    //
//******************************************************************//

procedure TMainForm.Trace(Sender : TObject; Client : cardinal; const Inbound : boolean; Text : PChar);
  const
    Direction : array[false..true] of string
              = ('  ->  ','  <-  ');
  var
    Line : string;
  begin
  Line := TrimRight(FormatDateTime('yyyymmdd hh:nn:ss  ',Now)+IntToHex(Client,8)+Direction[Inbound] + string(Text));

  // Check text for multiple lines..
  if Assigned(StrScan(Text,#13)) then
    Line := StringReplace(Line,#13#10,#13#10+StringOfChar(' ',8+1+8+2+8+6),[rfReplaceAll]);
  if not Application.Terminated then
    TraceLog.Lines.Add(Line);
  end;


//******************************************************************//
//  Routine      HandleUserCommand                                  //
//                                                                  //
//  Description  Demo of how to add an additional command without   //
//               doing this object-orientated stuff.                //
//******************************************************************//

procedure TMainForm.HandleUserCommand(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  TDemoSMTPserver(Sender).SendString(Sender,'250 You sound rather positive.'#13#10);
  end;


end.