main.pas

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

//******************************************************************//
// Project      SMTPserver                                          //
//                                                                  //
// Module       Main                                                //
//                                                                  //
// Description  Implements the Main demo application form.          //
//                                                                  //
// Copyright    This software is subject to the license at:         //
//              http://www.codecutters.org/software/license.html    //
//              with the additional conditions below:               //
//                                                                  //
//              (i)   This source code is "Open Source"             //
//              (ii)  This source code may be freely distributed &  //
//                    modified, but it's origin must not be         //
//                    misrepresented in any way. This means that    //
//                    this this header must remain intact, with     //
//                    altered portions clearly marked and commented //
//              (iii) This source code may be used in any project,  //
//                    including commercial software; a mention of   //
//                    ADVsystems and a link to the web site would   //
//                    be appreciated, but is not mandatory.         //
//              (iv)  As stated in the license terms, the author    //
//                    accepts no responsibility for damages or costs//
//                    arising from the use or misuse of this        //
//                    software; the software is supplied "as-is",   //
//                    and no claims are made to its merchantability //
//                    or fitness for a given purpose.               //
//******************************************************************//
// (C) ADV Systems 2003, All rights reserved.                       //
//******************************************************************//
// Version  Date    Author   Reason                                 //
// 1.00     290303  I.Baker  Initial version                        //
// 1.01     130403  I.Baker  Incorporated comments from Arno Garrels//
// 1.02     170403  I.Baker  Incorporated further comments          //
// 2.00     081003  I.Baker  Rewritten around new component         //
//******************************************************************//

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, WSMTPserver, StrUtils, DateUtils;

type
  TDemoSMTPserver = class(TWSMTPserver)
                    private
                    protected
                      procedure   HandleNOOP(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar); override;
                      procedure   HandleHELP(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
                    public
                      constructor Create(AOwner : TComponent); override;
                    end;


  TMainForm       = class(TForm)
    ButtonPanel: TPanel;
                      Log        : TMemo;
                      bToggle    : TButton;
    Splitter: TSplitter;
    TraceLog: TMemo;
                      procedure    FormCreate(Sender: TObject);
                      procedure    bToggleClick(Sender: TObject);
                    private
                      SMTPserver : TDemoSMTPserver;
                      procedure    Trace(Sender : TObject; Client : cardinal; const Inbound : boolean; Text : PChar);
                      procedure    HandleUserCommand(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
                      procedure    HandleException(Sender : TObject; E : Exception);
                      function     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;
                    public
                    end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

//******************************************************************//
//  Routine      Constructor                                        //
//                                                                  //
//  Description  Although WSMTPserver can be used as-is, this is a  //
//               demonstration on how to derive your own component  //
//               to do exactly what you want. We'll override a      //
//               built-in command, and add our own command. We will //
//               also disable support for the optional SEND, SAML,  //
//               and SOML commands.                                 //
//******************************************************************//

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

  // Set our server parameters
  Service        := 'DemoServer';
  OnClientTrace  := MainForm.Trace;
  DNS            := '195.117.6.25'; // OpenRoot - use IPHLPAPI to grab the default from your box
  ClientTimeout  := 5 * 60;
  MaxMessageSize := 2048;

  // Add an additional command
  AddCommand('HELP',HandleHELP);

  // Disable the SEND commands by setting a NIL handler
  AddCommand('SEND',nil);
  AddCommand('SAML',nil);
  AddCommand('SOML',nil);
  end;


//******************************************************************//
//  Routine      HandleNOOP                                         //
//                                                                  //
//  Description  Demo of how to override a built-in command         //
//******************************************************************//

procedure TDemoSMTPserver.HandleNOOP(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  if ESMTP then
    SendString(Sender,'250 2.0.0 Ho hum. Didn''t I see you at last year''s MTA Ball?'#13#10)
  else
    SendString(Sender,'250 Ah, I see. The strong, silent type?'#13#10);
  end;


//******************************************************************//
//  Routine      HandleHELP                                         //
//                                                                  //
//  Description  Demo of how to add a new command. AddCommand()     //
//               runs in .Create; you can also do this in the main  //
//               body of the code (see the other example)           //
//******************************************************************//

procedure TDemoSMTPserver.HandleHELP(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  const
    cHelpText : array[0..15] of record
                                Cmd  : PChar;
                                Text : string;
                                end
              = ((Cmd: ''; Text: '      Supported commands and extensions:'#13#10#13#10+
                                 '           EHLO     HELO     MAIL     SEND     SOML'#13#10+
                                 '           SAML     RCPT     DATA     RCPT     VRFY'#13#10+
                                 '           EXPN     RSET     NOOP     QUIT         '#13#10+
                                 #13#10'For more information about a listed topic, use "HELP <topic>"'#13#10'Please report mail-related problems to Postmaster at this site.'),
                 (Cmd: 'HELP'; Text: 'Usage:  HELP [command]'#13#10#13#10'Without an argument, the HELP command lists all of the supported'#13#10'SMTP commands.  If a command is specified, then help about that'#13#10'specific command is given (but you figured it out yourself :-)'),
                 (Cmd: 'EHLO'; Text: 'Usage:  EHLO domain'#13#10#13#10'The extended HELO command is used to determine which SMTP'#13#10'extensions are supported by the receiver.  The EHLO command'#13#10'can be used in place of HELO when extended SMTP functions'#13#10'are desired.'),
                 (Cmd: 'HELO'; Text: 'Usage:  HELO domain'#13#10#13#10'HELO announces the domain name of the sending host.  This is'#13#10'required at the start of every SMTP session.  See also EHLO.'),
                 (Cmd: 'MAIL'; Text: 'Usage:  MAIL FROM:<sender>'#13#10#13#10'Instructs the server that <sender> wishes to send an e-mail.'),
                 (Cmd: 'SEND'; Text: 'Usage:  SEND FROM:<sender>'#13#10#13#10'Instructs the server that <sender> wishes to send a message to '#13#10'a given terminal.'),
                 (Cmd: 'SOML'; Text: 'Usage:  SOML FROM:<sender>'#13#10#13#10'Instructs the server that <sender> wishes to send a message to '#13#10'a given terminal, assuming that the user is currently connected,'#13#10'or that an e-mail should be sent if that is not the case.'),
                 (Cmd: 'SAML'; Text: 'Usage:  SAML FROM:<sender>'#13#10#13#10'Instructs the server that <sender> wishes to send a message to '#13#10'a given terminal, assuming that the user is currently connected,'#13#10'and that an e-mail should be sent to that user''s mailbox.'),
                 (Cmd: 'RCPT'; Text: 'Usage:  RCPT TO:<recipient>'#13#10#13#10'Tells the receiver to deliver the message to <recipient>.  May be'#13#10'repeated any number of times for multiple recipients.'),
                 (Cmd: 'DATA'; Text: 'Usage:  DATA'#13#10#13#10'The DATA command is used to transfer the message body.  Lines'#13#10'are read until a line consisting of a single "." is encountered.'),
                 (Cmd: 'RCPT'; Text: 'Usage:  RCPT TO:<recipient>'#13#10#13#10'Tells the receiver to deliver the message to <recipient>.  May be'#13#10'repeated any number of times for multiple recipients.'),
                 (Cmd: 'VRFY'; Text: 'Usage:  VRFY <address>'#13#10#13#10'Verify that a message sent to <address> will be delivered.  If the'#13#10'address does not refer to a local account, the message may still'#13#10'be accepted and forwarded.'),
                 (Cmd: 'EXPN'; Text: 'Usage:  EXPN <address>'#13#10#13#10'EXPN lists the actual recipients of a message sent to <address>.'),
                 (Cmd: 'RSET'; Text: 'Usage:  RSET'#13#10#13#10'RSET resets the state of the receiver.  An implicit RSET is per-'#13#10'formed after every DATA command.'),
                 (Cmd: 'NOOP'; Text: 'Usage:  NOOP'#13#10#13#10'Do nothing (NO OPeration).  This can be used to check if the'#13#10'receiver is still listening for commands.'),
                 (Cmd: 'QUIT'; Text: 'Usage:  QUIT'#13#10#13#10'QUIT tells the receiver to stop expecting transaction requests'#13#10'from the sender, and to close the connection.'));
  var
    i : integer;
  begin
  // Intercept HELP command and implement here.
  i := High(cHelpText);
  while (i > Low(cHelpText)) and (StrIcomp(cHelpText[i].Cmd,Parameters) <> 0) do
    Dec(i);
  SendString(Sender,ANSIreplaceText('214-'+cHelpText[i].Text,#13#10,#13#10'214-')+#13#10+'214  '+#13#10);
  end;


//******************************************************************//
//  Routine      HandleException                                    //
//                                                                  //
//  Description  Report server exception                            //
//******************************************************************//

procedure TMainForm.HandleException(Sender : TObject; E : Exception);
  begin
  Log.Lines.Add('ERROR: '+E.Message);
  end;