wsmtpserver.pas

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

      if Context = mcConnecting then
        begin
        // Check for DNS timeout
        if Delta >= cDNStimeout then
          PostMessage(Handle,wmClientLookupDone,0,cardinal(Self.Server.Client[i]))
        end
      else
        begin
        // Check for client timeout
        if (Timeout > 0) and (Delta > Timeout) then
          begin
          SendStatus(s221,'0.0',[ServerDomain,xTimeout]);
          CloseDelayed;
          end
        end
      end;
  end;


//******************************************************************//
//  Routine      SetActive                                          //
//                                                                  //
//  Description  Sets server active/inactive                        //
//******************************************************************//

procedure TWSMTPserver.SetActive(AActive : boolean);
  var
    i : integer;
  begin
  if AActive <> Active then
    try
      Active := AActive;
      CheckTimer.Enabled := AActive;
      if AActive then
        // Activate Server
        with Server do
          begin
          Addr               := Address;
          Port               := ServerPort;
          MultiThreaded      := MultiThread;
          Listen;
          end
      else
        begin
        // Deactivate server & connections
        for i := PRED(Server.ClientCount) downto 0 do
          with TWSMTPclient(Server.Client[i]) do
            if State <> wsClosed then
              begin
              OnSessionClosed := nil;
              SendStatus(s421,'0.0',[ServerDomain,xShutdown,sClosingChannel]);
              Close;
              end;
        Server.Close;
        end;
    except
      on E : Exception do RaiseException(E.Message);
      end;
  end;


//******************************************************************//
//  Routine      SetAddr                                            //
//                                                                  //
//  Description  Sets the listener address                          //
//******************************************************************//

procedure TWSMTPserver.SetAddr(AAddr : string);
  begin
  if Active then
    RaiseException(xNoAddrWhenActive)
  else
    Address := Trim(AAddr);
  end;


//******************************************************************//
//  Routine      SetPort                                            //
//                                                                  //
//  Description  Sets the listener port                             //
//******************************************************************//

procedure TWSMTPserver.SetPort(APort : string);
  begin
  if Active then
    RaiseException(xNoPortWhenActive)
  else
    ServerPort := Trim(APort);
  end;


//******************************************************************//
//  Routine      SetHost                                            //
//                                                                  //
//  Description  Sets the host name of the server.                  //
//******************************************************************//

procedure TWSMTPserver.SetHost(AHost : string);
  begin
  if Active then
    RaiseException(xNoHostWhenActive)
  else
    begin
    AHost := Trim(AHost);
    if (AHost <> '') and (AHost[Length(AHost)] <> '.') then
      AHost := AHost + '.';
    ServerDomain := AHost;
    end
  end;


//******************************************************************//
//  Routine      SetDomain                                          //
//                                                                  //
//  Description  Sets the base domain for the server (e.g. xyz.com) //
//******************************************************************//

procedure TWSMTPserver.SetDomain(ADomain : string);
  begin
  if Active then
    RaiseException(xNoDomWhenActive)
  else
    ServerDomain := Trim(ADomain);
  end;


//******************************************************************//
//  Routine      SetServerName                                      //
//                                                                  //
//  Description  Sets the service name                              //
//******************************************************************//

procedure TWSMTPserver.SetServerName(AName : string);
  begin
  if Active then
    RaiseException(xNoNameWhenActive)
  else
    ServerName := Trim(AName);
  end;


//******************************************************************//
//  Routine      SetMaxMsgSize                                      //
//                                                                  //
//  Description  Sets the maximum message size                      //
//******************************************************************//

procedure TWSMTPserver.SetMaxMsgSize(AMsgSize : integer);
  begin
  if AMsgSize <= 0 then
    MaxMsgSize := 0
  else
    MaxMsgSize := AMsgSize;
  end;


//******************************************************************//
//  Routine      ServerException                                    //
//                                                                  //
//  Description  Handles a TWSocketServer exception                 //
//******************************************************************//

procedure TWSMTPserver.ServerException(    Sender   : TObject;
                                           E        : Exception;
                                       var CanClose : Boolean);
  begin
  RaiseException(E.Message);
  end;


//******************************************************************//
//  Routine      AddCommand                                         //
//                                                                  //
//  Description  Add an SMTP command handler                        //
//******************************************************************//

procedure TWSMTPserver.AddCommand(Cmd     : string;
                                  Handler : TWSMTPcmdHandler;
                                  Context : TWSMTPmsgContext);
  var
    i : integer;
  begin
  // Add NUL terminator and attempt to locate existing entry
  Cmd := Cmd + #00;
  i := Low(Commands);
  while (i <= High(Commands)) and not(SameText(Cmd,Commands[i].Cmd)) do
    Inc(i);
  if i > High(Commands) then
    begin
    // Add new command
    SetLength(Commands,SUCC(Length(Commands)));
    Commands[i].Cmd := Cmd;
    end;
  // Set command parameters
  Commands[i].Context := Context;
  Commands[i].Handler := Handler;
  end;


//******************************************************************//
//  Routine      SendString                                         //
//                                                                  //
//  Description  Send a arbitrary string to a client                //
//******************************************************************//

procedure TWSMTPserver.SendString(Client : TObject; const Str : string);
  begin
  if Client is TWSMTPclient then
    begin
    with TWSMTPclient(Client) do
      if TWSocketServer(Owner).IsClient(Client) then
        SendStr(Str);
    end
  else
    RaiseException(Format(xInvalidObj,['SendString()']));
  end;


//******************************************************************//
//  Routine      ClientConnect                                      //
//                                                                  //
//  Description  Invoked when someone connects to the server        //
//******************************************************************//

procedure TWSMTPserver.ClientConnect(Sender : TObject;
                                     Client : TWSocketClient;
                                     Error  : Word);
  begin
  with TWSMTPclient(Client) do
    begin
    // Assign unique session ID
    if Counter = $FFFFFFFE then
      Counter := 1
    else
      Inc(Counter);
    ID := Counter;
    SMTPserver := Self;

    if (MaxUsers > 0) and (cardinal(Self.Server.ClientCount) >= MaxUsers) then
      begin
      // Reject connection
      SendStatus(s452,'3.2',['user limit reached']);
      Close;
      end
    else
      begin
      if DNSaddr = '' then
        // No DNS available - skip lookup
        PostMessage(Handle,wmClientLookupDone,0,cardinal(Client))
      else
        begin
        LastContact := Now;
        DNS := TDNSquery.Create(nil);
        DNS.Addr          := DNSaddr;
        DNS.OnRequestDone := LookupComplete;
        DNS.PTRLookup(Client.PeerAddr);
        end
      end
    end
  end;


//******************************************************************//
//  Routine      ClientConnect                                      //
//                                                                  //
//  Description  Invoked when someone connects to the server        //
//******************************************************************//

procedure TWSMTPserver.ClientDisconnect(Sender : TObject;
                                        Client : TWSocketClient;
                                        Error  : Word);
  var
    Scratch : string;
  begin
  if Active and Assigned(ActionHandler) then
    begin
    Scratch := '';
    with TWSMTPclient(Client) do
      ActionHandler(Self,ID,PeerAddr,ClientDomain,ClientRDNS,ClientMX,wsmtpDisconnect,'',nil,Scratch,nil);
    end;
  end;


//******************************************************************//
//  Routine      HandleNOOP                                         //
//                                                                  //
//  Description  Handles NOOP command                               //
//******************************************************************//

procedure TWSMTPserver.HandleNOOP(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  with TWSMTPclient(Sender) do
    SendStatus(s250,'0.0',[cOK]);
  end;


//******************************************************************//
//  Routine      HandleQUIT                                         //
//                                                                  //
//  Description  Handles QUIT command                               //
//******************************************************************//

procedure TWSMTPserver.HandleQUIT(Sender : TObject; const ClientID : cardinal; var ESMTP : boolean; Parameters : PChar);
  begin
  with TWSMTPclient(Sender) do
    begin
    SendStatus(s221,'0.0',[ServerDomain,sClosingChannel]);
    CloseDelayed;
    end