Tweet
This is the lastest version of the code for the smtpserver. I
have added checking of base64 encode attachments and fixed a
number of bugs in the filtering and bhl system. I have also add
domain rejection as well.
I have also picked a problems with the latest spam html emails.
Email is a line based protocol and normally the lines are about
80 characters long/ The programs that generate these html spam
create lines up to 300 characters long. The system was truncating
these long lines so the system checks for long lines and breaks
then into a number of records.
'==============================================================================
' SMTP Server Program Handler Version 1.10(SMTPD)
' Copyright (c) 2005 by Martin Draper
'
' This library is free developer software; you can use it and/or
' modify it under the terms of the Phoenix Project Developer
' License. All commerical use and rights are strictly reserved.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
'
'
'-------------------------------------------------------------------------------------
' Changes 30/9/2005 Blocking added for Server at the Helo Command and Sender
' blocking add at the Mail command
' Content filtering of the subject and body added
' Automatic Blackhole system implemented.
'
' 01/9/2005 Add a function to determineand record the EmailType from the
' Content Header in the email if there is one. It defaults to
' text/plain.
'
' EmailSize is now determined and recorded.
'
' Maximum email size control added. If the max size is set and
' The email exceeds that size then email is junked.
'
' Internal mail support. In businesses much of the email is internal
' from one staff member to another. If these emails did not have a
' realm attached "@yourserver.com" these emails could never leave the
' server and cannot be access from outside. NO SPAM ! Purely internal
' mail opens the way for sensitive material to be transfered more
' securely.
'
' 02/10/2005 System Loging added
'
' 02/02/2006 SqlFreeMemory to reduce the memory useage
'
' 05/02/2006 Diagnostic level addedd
'
' 12/02/2006 The Email Date is changed to a pure mysql date so the age of email can
' be checked.
' Null and "\" added to filtering.
'
' 13/2/2006 The email data in now stried line by line in the emails table
'
' 19/02/2006 A field for encoding format added
'
' 30/3/2006 The SequenceNo added to log files
'
' 02/06/2005 Changes to error handling. You just can't exit out of the sequence
' you have to give an error message back to the send and get them to
' quit or they jusy keep send data which clogs the system
'
' 05/06/2006 System crashed due to rubbish in the log. The Sequence failed in the
' data transmissiona and the system logged the juck as errors. They
' contained "'" and "," which are now being removed from the log entries
'
' 13/2/2006 The have been problems with failure when the emails get to large.
' Basically storing the mail in blob has not worked and data is being
' lost
'
' 18/6/2006 Long strings of html are being truncated the data is checked for length
' then the data is split into blocks
'
' 22/6/2006 Base64 Scanning added
'-------------------------------------------------------------------------------------
' Notes 30/9/2005 If you are using Sqlite instead of the Mysql you have to take out
' the "Use EmailServer" query as Sqlite Only supports one database.
'
' 02/9/2005 The server will consist of 4 parts
' The SMTPD (This program which will receive incoming mail)
' The SMTP-REMOTE which forwards mail to external servers
' The POP3-Proxy which gets mail from external servers
' The POP3D which forwards mail to the user.
'
' The will also be an SMTP Client and Pop3 Client for Applications
'
'-------------------------------------------------------------------------------------
'
#COMPILE EXE
#DIM ALL
'==============================================================================
' Multi threading do's and don'ts
'
' Thread-efficient programs are efficiently parallelized programs.
' The use of global data is thread-unsafe. It should be maintained per thread or
' encapsulated, so that its access can be serialized. A thread may read an error
' code corresponding to an error caused by another thread.
' So variables with a thread should be local.
'
' No data should be kept over successive calls, because different threads may
' successively call the function.
' The function must be completed with the thread.
'
' In multi-threaded programs, all functions called by multiple threads must be thread-safe.
' It is a good programming practice to always use and write reentrant and thread-safe functions.
'
'------------------------------------------------------------------------------
' Include Files
'
#RESOURCE "SmtpServ.pbr"
%USEMACROS = 1
#INCLUDE "Win32API.inc"
#INCLUDE "WS2_32.inc"
#INCLUDE "\aims5\lib\MySqlDB.inc"
#INCLUDE "dns3.inc"
'------------------------------------------------------------------------------
' Equates and global variables
'
%TCP_ACCEPT = %WM_USER + 4093 ' Any value larger than %WM_USER + 500
%TCP_SMTP = %WM_USER + 4094 ' Any value larger than %WM_USER + 500
%TCP_MAIL = %WM_USER + 4095 ' Any value larger than %WM_USER + 500
'
GLOBAL hList AS LONG
GLOBAL nServer AS LONG
GLOBAL hSmtp AS LONG 'DWORD
GLOBAL MailserverName AS STRING
GLOBAL Filter() AS STRING
GLOBAL FilterRecords AS LONG
GLOBAL SenderLevel AS INTEGER
GLOBAL ServerLevel AS INTEGER
GLOBAL MaxEmailSize AS LONG
'
GLOBAL DiagLevel AS INTEGER
'-------------------------------------------------------------------------
' BASE64 Decoding
' Original VBDOS Version by G. Balla, 1996 (Public Domain)
' PB/DOS Conversion by Marc van den Dikkenberg, 1999
' Modified for PBCC by Martin Draper 2000
'
'--------------------------------------------------------------------------
GLOBAL icChopMask AS INTEGER ' Constant 8-bit mask (Faster than using string constants)
GLOBAL icBitShift AS INTEGER ' Constant shift mask (Faster than using string constants)
GLOBAL icStartMask AS INTEGER ' Initial mask value (Faster than using string constants)
GLOBAL iRollOver AS INTEGER ' Decoded Roll over value
GLOBAL iHighMask AS INTEGER ' Mask high bits of each char
GLOBAL iShift AS INTEGER ' Multiplier shift value
GLOBAL iLowShift AS INTEGER ' Mask low bits of each char
GLOBAL szAlphabet AS STRING ' Decode/Encode Lookup Table
GLOBAL szTemp AS STRING ' Working string
'
'----------------------------------------------------------------------------------------------
' Name: INITDECODE64
' Type: Sub procedure
' Description: Initializes local shared variables for DECODE64$
' Required because many encoded files cannot be decoded in a single string
'
' Used: Before decoding a BASE64 file. (DECODE64$)
' Arguements: None
' Returns: Nothing
'
' Errors: None
'
' Global Variables used:
' szAlphabet Encode/Decode Table lookup
'
' icChopMask Constant value in variable to speed process
' icBitShift Constant value in variable to speed process
' icStartMask Constant value in variable to speed process
'
' iShift Multiplier shift value
' iLowShift Mask Low bits of each char
' iRollOver Decoded Roll over value from prev char in string
' iHighMask Mask high bits of each char
'----------------------------------------------------------------------------------------------
SUB InitDecode64
' Initialize 2nd encoding pass lookup dictionary
szAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
' Initialize Constants
icChopMask = 255
icBitShift = 4
icStartMask = &H10
' Initialize Masks
iShift = icBitShift
iLowShift = 0
iRollOver = 0
iHighMask = -1
'
END SUB
'
'----------------------------------------------------------------------------------------------
' Name: DECODE64$
' Type: String function
' Description: decodes a string from BASE64 to binary format
'
' Arguements: Source string to decode (szEncoded)
' Last string in file to decode flag (iEndOfText)
' Returns: Un-Encoded binary string.
'
' Errors: Generates an Error via ERROR statement.
' Error code: 253 = No string to decode
' -----------------------------------------------
' NOTES: Must call INITDECODE64 before sending 1st string of an encoded file.
'
' A DOEVENTS occurs near the end of the FOR/NEXT loop
' -----------------------------------------------
' Global variables: szAlphabet ' Decode/Encode lookup table
' szTemp ' Working string
'
' iRollOver ' Decode/Encode rollover value
' iHighMask ' High bit mask
' iShift ' Multiplier value
'
'
' Local variables: iChar ' Ascii Char value from Encoded string
' iPtr ' Lookup table pointer
' iCounter ' FOR/NEXT counter
'
'----------------------------------------------------------------------------------------------
FUNCTION DECODE64$ (szEncoded AS STRING, iEndOfText AS INTEGER)
'
' Create variables
DIM iPtr AS INTEGER
DIM iChar AS INTEGER
DIM iCounter AS INTEGER
'
' Check if empty decoded string.
' If Empty, return NUL and Generate error 254
'
IF LEN(szEncoded) = 0 THEN
DECODE64$ = ""
ERROR 253
EXIT FUNCTION
END IF
' Initialize working string
szTemp = ""
' Begin Decoding
FOR iCounter = 1 TO LEN(szEncoded)
' Get next alphabet
iChar = ASC(MID$(szEncoded, iCounter, 1))
' Get Decoded value
iPtr = INSTR(szAlphabet, CHR$(iChar)) - 1
' Check if character is valid
IF iPtr >= 0 THEN
' Char is valid, process it
IF iShift = icBitShift THEN
' 1st char in block of 4, keep high part of character
iRollOver = (iPtr * iShift) AND icChopMask
' Reset masks for next character
iHighMask = &H30
iLowShift = icStartMask
iShift = icStartMask
ELSE
' Start saving decoded character
szTemp = szTemp + CHR$(iRollOver OR ((iPtr AND iHighMask) / iLowShift))
' Calculate next mask and shift values
iRollOver = (iPtr * iShift) AND icChopMask
iShift = iShift * icBitShift
iHighMask = (iHighMask \ icBitShift) OR &H30
iLowShift = iLowShift / icBitShift
IF iShift > 256 THEN
iShift = icBitShift
iLowShift = 0
END IF
END IF
END IF
NEXT
' Concat last character if required
IF (iShift > icBitShift AND iShift < 256) THEN
' Character remaining in iRollOver
IF iEndOfText THEN
' Last string to decode in file
szTemp = szTemp + CHR$(iRollOver)
END IF
END IF
' Exit wth decoded string
DECODE64$ = szTemp
'
END FUNCTION
'-----------------------------------------------------------------------------
' Retrieve the current time and date in E-mail header format
'
FUNCTION MailDate () AS STRING
LOCAL szFormat AS ASCIIZ * 40
LOCAL szTemp AS ASCIIZ * 40
LOCAL sResult AS STRING
LOCAL t AS SYSTEMTIME
LOCAL sUCTOffset AS STRING
LOCAL tzi AS TIME_ZONE_INFORMATION
GetLocalTime t
szFormat = "ddd',' dd MMM yyyy"
GetDateFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, SIZEOF(szTemp)
sResult = szTemp
szFormat = "HH':'mm':'ss"
GetTimeFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, SIZEOF(szTemp)
SELECT CASE GetTimeZoneInformation(tzi)
CASE %TIME_ZONE_ID_DAYLIGHT
sUCTOffset = IIF$((tzi.bias + tzi.DaylightBias) <= 0, "+", "-") _
+ FORMAT$((tzi.bias + tzi.DaylightBias) \ 60, "00") _
+ FORMAT$((tzi.bias + tzi.DaylightBias) MOD 60, "00")
CASE %TIME_ZONE_ID_STANDARD
sUCTOffset = IIF$((tzi.bias + tzi.StandardBias) <= 0, "+", "-") _
+ FORMAT$((tzi.bias + tzi.StandardBias) \ 60, "00") _
+ FORMAT$((tzi.bias + tzi.StandardBias) MOD 60, "00")
CASE ELSE
sUCTOffset = "-0000"
END SELECT
FUNCTION = sResult + " " + szTemp + " " + sUCTOffset
END FUNCTION
'------------------------------------------------------------------------------
' Event logging
'
SUB LogEvent (BYVAL Buffer AS STRING)
LOCAL idx AS LONG
Buffer = DATE$ +" "+ TIME$ + " - " + Buffer
idx = SendMessage(hList, %LB_ADDSTRING, 0, STRPTR(Buffer))
SendMessage hList, %LB_SETCURSEL, idx, 0
END SUB
SUB SmtpLog(Event AS STRING,Action AS STRING, SequenceNo AS LONG,UserID AS STRING)
'
' record and event in the smtp log
'
REPLACE "'" WITH "" IN Event
REPLACE "'" WITH "" IN Action
REPLACE "," WITH "" IN Event
REPLACE "," WITH "" IN Action
'
SqlQuery "Insert into SmtpLog (LogID,LogDate,Event,Action,SequenceNo,Username) " + _
" values ( '',Now(),'"+Event+"','"+Action+"','"+TRIM$(STR$(SequenceNo))+"','"+UserID+"')"
'
END SUB
FUNCTION LoadFilter AS INTEGER
'
LOCAL Index AS LONG
'
' Get the number of filters
'
SqlQuery "Select Count(FilterString) from Filter"
GetRecord
FilterRecords = VAL(Field(1))
SqlFreeMemory
'
REDIM Filter(FilterRecords)
'
' load the records in to the array
'
SqlQuery "Select FilterString from Filter"
FOR Index = 1 TO RowCount
GetRecord
Filter(Index) = UCASE$(TRIM$(Field(1)))
NEXT I
'
SqlFreeMemory
'
'SmtpLog "Filter Loaded " + str$(RowCount) + " Records" , Filter(1) + "->" + Filter(Rowcount-1),0,"System"
END FUNCTION
FUNCTION InitListen(hDlg AS DWORD) AS INTEGER
'
LOCAL sBuffer AS STRING
'
' open the socket for smtp
'
nServer = FREEFILE
TCP OPEN SERVER "smtp" AS nServer
'
IF ERR THEN
sBuffer = "Unable to listen to smtp"
FUNCTION = 0
ELSE
'
' Notify will specify which notifications your code will process, use the TCP NOTIFY statement:
' It tells Winsock that it should send the %TCP_ACCEPT message to the window specified by nServer.
'
TCP NOTIFY nServer, ACCEPT TO hDlg AS %TCP_ACCEPT
sBuffer = "Connected to smtp"
FUNCTION = 1
END IF
LogEvent sBuffer
'
END FUNCTION
FUNCTION AcceptConnection(hDlg AS DWORD) AS INTEGER
'
' Create a socket to the client
'
hSmtp = FREEFILE
TCP ACCEPT nServer AS hSmtp
'
' send the server connect message
'
TCP SEND hSmtp, "220 "+MailserverName+" ESMTP System v3.1.2" + $CRLF
'
' The Helo is next
'
TCP NOTIFY hSmtp, RECV TO hDlg AS %TCP_SMTP
LogEvent "connection accepted"
'
FUNCTION = 1
'
END FUNCTION
FUNCTION SmtpTHread(hSmtp AS DWORD) AS INTEGER
'
' hello from the client
' RFC 1123 requires that the parameter be a valid principal host domain name for the client host.
' However, some clients don't have names. I recommend that they use bracketed IP addresses:
'
' The server's response text begins with the server's name. The server must be careful not to
' use another host's name here: if a sendmail client on that host connects and sees its own name,
' it will refuse to ``talk to itself.
'
' Some servers do not accept MAIL requests before HELO. Clients use HELO as the first request
' in every session. (Exception: see EHLO.) This is a waste of time. I recommend that server
' implementors let clients skip HELO, to support a future transition to a world without HELO.
'
' Beware that many servers reject all HELO requests after the first, so clients cannot rely
' on HELO as a way to clear the envelope. For example, sendmail returns a 503 code.
'
' A few servers reject messages from clients whose HELO parameters do not match the results
' of PTR lookups on their IP addresses. This behavior is a disaster in practice; surveys in
' 1998 found that more than 10% of all clients by volume use invalid HELO parameters.
' Compuserve reportedly uses unqualified names:
'
' RFC 1123 Requirements for Internet Hosts - Application and Support
' prohibits HELO-based rejections
'
' HELO testmx.unixwiz.net
' 554 <testmx.unixwiz.net> Helo command rejected: Access denied
'
LOCAL Buffer AS STRING
LOCAL MailServer AS STRING
LOCAL MailHost AS STRING
LOCAL MailFrom AS STRING
LOCAL MailTo AS STRING
'
LOCAL EmailSubject AS STRING
LOCAL EmailDate AS STRING
LOCAL EmailData AS STRING
LOCAL Destination AS STRING
LOCAL DestinationDomain AS STRING
LOCAL DestinationID AS LONG
LOCAL Source AS STRING
LOCAL SourceDomain AS STRING
LOCAL EmailSize AS LONG
LOCAL EmailType AS STRING
LOCAL MessageID AS STRING
LOCAL Retries AS INTEGER
LOCAL SequenceNo AS LONG
LOCAL FileHandle AS LONG
LOCAL TotalSize AS LONG
LOCAL Encoding AS STRING
LOCAL FilterIndex AS LONG
LOCAL Reason AS STRING
'
LOCAL Index AS LONG
LOCAL Reject AS INTEGER
LOCAL BHLID AS LONG
LOCAL FieldStart AS INTEGER
LOCAL FieldEnd AS INTEGER
LOCAL QuotaSize AS LONG
LOCAL QuotaCount AS LONG
LOCAL Username AS STRING
'
LOCAL Recipients() AS STRING
LOCAL NoRecipients AS INTEGER
LOCAL LoopTrap AS INTEGER
'
LOCAL DataAccepted AS INTEGER
'
REDIM Field(32),Recipients(100)
NoRecipients = 0
Retries = 0
Reject = 0
Reason = ""
'
IF SqlConnect = 0 THEN
SmtpLog "Unable to Connect to Database Server ", "Connection Terminated",SequenceNo,Username
LogEvent "Unable to Connect to Database Server "
EXIT FUNCTION
END IF
'
SqlQuery "Use pbmail"
SmtpLog "Connected to Database Server ", "Processing Started",SequenceNo ,Username
'
' load the content filter table
'
LoadFilter
'
'
' get the next sequence number for the email
'
5 FileHandle = FREEFILE
OPEN "sequence" FOR INPUT AS FileHandle
INPUT #FileHandle , SequenceNo
CLOSE FileHandle
'
SequenceNo = SequenceNo + 1
'
FileHandle = FREEFILE
OPEN "sequence" FOR OUTPUT AS FileHandle
PRINT #FileHandle , SequenceNo
CLOSE FileHandle
' '
' helo
'
10 TCP LINE hSmtp, buffer
'
IF ERR > 0 THEN
SmtpLog "Session Failed from "+MailFrom, "Connection Dropped",SequenceNo,Username
LogEvent "Session Failed from "+MailFrom
GOTO 999
END IF
'
'
'
' Looping trap
'
IF Buffer = "" THEN
loopTrap = LoopTrap + 1
IF LoopTrap > 20 THEN
SmtpLog "Connection Looped Out " + MailServer, "Connection Terminated",SequenceNo,Username
GOTO 999
END IF
SLEEP 1000
GOTO 10
ELSE
LoopTrap = 0
END IF
'
SmtpLog "Data Received " + MailServer, Buffer,SequenceNo,Username
'
' start helo
'
IF LEFT$(UCASE$(Buffer),4) = "HELO" THEN
MailServer = TRIM$(MID$(Buffer,5,LEN(buffer)-4))
TCP SEND hSmtp, "250 HELO " + MailserverName + "."+buffer+ $CRLF
LogEvent "HELO connection accepted from " + MailServer
IF DiagLevel = 1 OR DiagLevel = 2 THEN LogEvent "connection accepted from " + MailServer
END IF
'
' spammers will send email from the address of the server.
' this will block this email
'
'IF Mailserver = "202.94.66.101" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".pl" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".hu" _
' OR INSTR(LCASE$(MailServer),"bounce") > 0 THEN
' SmtpLog "HELO Rejected from " + MailServer, "Spam Deteced",SequenceNo,Username
' GOTO 999
'END IF
'
'Mailhost = MX_Query(Mailserver, "ns1.hypermax.net.au")
'SmtpLog "Dns check " + MailServer,">"+ MailHost + "< found",SequenceNo,Username
'
' Black hole blocking
'
'Field(1) = ""
'SqlQuery " Select BHLID from BHL where Domain = '"+MailServer+"' and DomainStatus = 'Active'"
'GetRecord
'SqlFreeMemory
'IF VAL(Field(1)) > 0 THEN
' TCP SEND hSmtp, "554 " + MailserverName + "Helo command rejected: Access denied" + $CRLF
' SmtpLog "HELO Rejected from " + MailServer, "Connection Terminated",SequenceNo,Username
' LogEvent "HELO Rejected from " + MailServer
' GOTO 999
'ELSE
'END IF
'GOTO 10
'
' start elho
'
IF LEFT$(UCASE$(Buffer),4) = "EHLO" THEN
MailServer = TRIM$(MID$(Buffer,5,LEN(buffer)-4))
TCP SEND hSmtp, "250 HELO " + MailserverName + "."+buffer+ $CRLF
LogEvent "EHLO connection accepted from " + MailServer
IF DiagLevel = 1 OR DiagLevel = 2 THEN LogEvent "connection accepted from " + MailServer
END IF
'
' spammers will send email from the address of the server.
' this will block this email
'
'IF Mailserver = "202.94.66.101" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".pl" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".hu" _
' OR instr(LCASE$(MailServer),"bounce") > 0 THEN
' SmtpLog "HELO Rejected from " + MailServer, "Spam Deteced",SequenceNo,Username
' GOTO 999
'END IF
'
'Mailhost = MX_Query(Mailserver, "ns1.hypermax.net.au")
'SmtpLog "Dns check " + MailServer,">"+ MailHost + "< found",SequenceNo,Username
'
' Black hole blocking
'
'SqlQuery " Select BHLID from BHL where Domain = '"+MailServer+"' and DomainStatus = 'Active'"
'GetRecord
'SqlFreeMemory
'IF VAL(Field(1)) > 0 THEN
' TCP SEND hSmtp, "554 " + MailserverName + "Helo command rejected: Access denied" + $CRLF
' SmtpLog "EHLO Rejected from " + MailServer, "Connection Terminated",SequenceNo,Username
' LogEvent "EHELO Rejected from " + MailServer
' GOTO 999
'ELSE
'
'
' TCP NOTIFY hSmtp, RECV SEND CLOSE TO hDlg AS %TCP_MAIL
'
' MAIL FROM in the smtp this give you the email address of the client sending the email
' This command tells the SMTP-receiver that a new mail transaction is starting and to
' reset all its state tables and buffers, including any recipients or mail data. It
' gives the reverse-path which can be used to report errors. If accepted, the
' receiver-SMTP returns a 250 OK reply.
'
' The <reverse-path> can contain more than just a mailbox. The <reverse-path> is a
' reverse source routing list of hosts and source mailbox. The first host in the
' <reverse-path> should be the host sending this command.
'
20 IF LEFT$(Buffer,4) = "MAIL" THEN
MailFrom = MID$(Buffer,INSTR(Buffer,"<")+1,LEN(buffer)-INSTR(Buffer,"<")-1)
Source = ""
'
' get domain of the sender
'
FieldStart = INSTR(MailFrom,"@")
IF FieldStart > 0 THEN
SourceDomain = RIGHT$(MailFrom,LEN(MailFrom)-FieldStart)
ELSE
SourceDomain = ""
END IF
'
' domain rejection
'
Field(1) = ""
SqlQuery " Select DomainID from Domains where instr('"+MailServer+"',Domain) > 0 " + _
" or instr('"+MailFrom+"',Domain) > 0 "
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
TCP SEND hSmtp, "550 " + MailFrom + "Mail command rejected: Access denied" + $CRLF
SmtpLog "MAIL " +MailFrom + " Rejected by Domain", "Connection Terminated",SequenceNo,Username
LogEvent "MAIL " +MailFrom + " Rejected by Domain"
GOTO 10
END IF
'
' Check the Black hole list
'
Field(1) = ""
SqlQuery " Select BHLID from BHL where Domain = '"+MailFrom+"' and DomainStatus = 'Active'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
TCP SEND hSmtp, "550 " + MailFrom + "Mail command rejected: Access denied" + $CRLF
SmtpLog "MailFrom: " +MailFrom + " Rejected by BHL -" + STR$(BHLID), "Connection Terminated",SequenceNo,Username
LogEvent "MailFrom: " +MailFrom + " Rejected by BHL -" + STR$(BHLID)
GOTO 10
END IF
'
' determine the Source
'
Field(1) = ""
SqlQuery " Select LocalID from MailBoxes where LocalAddress = '"+MailFrom+"'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
Source = "Local"
ELSE
Source = "Forward"
END IF
'
TCP SEND hSmtp, "250 " + MailFrom + " OK" + $CRLF
SmtpLog "Process Mail From " +MailFrom,"MAIL Command Accepted",SequenceNo ,Username
LogEvent "Process Mail From " +MailFrom
GOTO 10
END IF
'
' This command gives a forward-path identifying one recipient.
' If accepted, the receiver-SMTP returns a 250 OK reply, and
' stores the forward-path. If the recipient is unknown the
' receiver-SMTP returns a 550 Failure reply. This second step of
' the procedure can be repeated any number of times.
'
' The <forward-path> can contain more than just a mailbox. The
' <forward-path> is a source routing list of hosts and the
' destination mailbox. The first host in the <forward-path>
' should be the host receiving this command.
' RCPT To:<steve@unixwiz.net>
' 554 <linux.unixwiz.net> Helo command rejected: Get lost - you're lying about who you are
'
' The list is comprised of the email addresses of the recipients seperated by commas or semicolons.
' The email addresses found in BCC are not copied into the header of the email message.
' If the mail server has conformed strictly to the SMTP specifications it may limit the
' total number recipients to 100. Strict conformance to this number is not mandatory
' so your mail server may permit more than 100 recipients.
'
30 IF LEFT$(Buffer,4) = "RCPT" THEN
Mailto = MID$(Buffer,INSTR(Buffer,"<")+1,LEN(buffer)-INSTR(Buffer,"<")-1)
'
' Get the domain of recipient
'
FieldStart = INSTR(MailTo,"@")
IF FieldStart > 0 THEN
DestinationDomain = RIGHT$(MailTo,LEN(MailTo)-FieldStart)
ELSE
DestinationDomain = ""
END IF
'
' dns check
'
IF SourceDomain <> "" THEN
Mailhost = MX_Query(SourceDomain, "203.87.88.1")
SmtpLog "Mailhost", Mailhost ,SequenceNo,Username
END IF
'
' check routing for internal mail
'
IF DestinationDomain = "" THEN
TCP SEND hSmtp, "550 Invalid Destination " + $CRLF
SmtpLog "RCPT " +MailTo+ " Invalid Destination ", "Connection Terminated",SequenceNo,Username
LogEvent "RCPT " +MailTo+ " Invalid Destination "
GOTO 10
END IF
'
' determine the destination
'
Field(1) = ""
SqlQuery " Select LocalID,EmailQuotaSize,EmailQuotaCount,Username from MailBoxes where LocalAddress = '"+MailTo+"'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
Destination = "Local"
QuotaSize = VAL(Field(2))
QuotaCount = VAL(Field(3))
Username = Field(4)
'
' check the quotas for the mailbox
'
IF QuotaSize > 0 OR QuotaCount > 0 THEN
SqlQuery " Select Count(QueueID), Sum(EmailSize) from Queue where EmailTo = '"+MailTo+"'"
GetRecord
SqlFreeMemory
IF (QuotaCount > 0 AND VAL(Field(1)) > QuotaCount) OR _
(QuotaSize > 0 AND VAL(Field(2)) > QuotaSize) THEN
TCP SEND hSmtp, "550 MailBox Full " + $CRLF
SmtpLog "MailTo: " +MailTo+ " MailBox Full ", "Connection Terminated",SequenceNo,Username
LogEvent "MailTo: " +MailTo+ " MailBox Full "
GOTO 10
END IF
END IF
ELSE
Destination = "Forward"
'
' Is the destination a local domain
'
Field(1) = ""
IF DestinationDomain <> "" THEN
SqlQuery " Select DomainID from Domains where Domain = '"+DestinationDomain+"'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN DestinationID = VAL(Field(1))
END IF
'
END IF
'
' relay check
'
IF Destination = "Forward" AND Source = "Forward" THEN
IF DestinationID = 0 THEN
TCP SEND hSmtp, "550 Relaying not permitted " + $CRLF
SmtpLog "MailTo: " +MailTo+ " Relay Attempt Blocked ", "Connection Terminated",SequenceNo,Username
LogEvent "MailTo: " +MailTo+ " Relay Attempt Blocked "
GOTO 10
ELSE
TCP SEND hSmtp, "550 MailBox Unknown " + $CRLF
SmtpLog "MailTo: " +MailTo+ " Mail Box Unknown ","Connection terminated",SequenceNo,Username
LogEvent "MailTo: " +MailTo+ " Mail Box Unknown "
GOTO 10
END IF
ELSE
TCP SEND hSmtp, "250 " + MailTo + " OK" + $CRLF
NoRecipients = NoRecipients + 1
Recipients(NoRecipients) = MailTo
SmtpLog "MailTo: " +MailTo, "RCPT Command Accepted",SequenceNo,Username
LogEvent "MailTo: " +MailTo
END IF
GOTO 10
END IF
'
' If accepted, the receiver-SMTP returns a 354 Intermediate reply
' and considers all succeeding lines to be the message text.
' When the end of text is received and stored the SMTP-receiver
' sends a 250 OK reply.
'
IF LEFT$(Buffer,4) = "DATA" THEN
'
DataAccepted = 0
'
' put a header on the email
'
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ "Received: from " +MailServer+ "; " + MailDate + $CRLF+"')
'
'
' Set the Type of the email
'
EmailType = "text/plain"
'
TCP SEND hSmtp, "354 send the mail data, end with ." + $CRLF
' LogEvent "Start Data"
'
' loop until the end of the data is received
'
50 TCP LINE hSmtp, buffer
'
' error trap
'
IF ERR > 0 THEN
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "',' Connection Failed "+ $CRLF+"')
SmtpLog "Forced End Data from "+MailFrom, "ERR " + STR$(ERR) + " Occured",SequenceNo,Username
LogEvent "Forced End Data from "+MailFrom
GOTO 60
END IF
'
' end of the data received
'
IF buffer = "." THEN GOTO 60
'
' Looping trap
'
IF Buffer = "" THEN
LoopTrap = LoopTrap + 1
ELSE
LoopTrap = 0
END IF
'
IF LoopTrap > 30 THEN
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','Data Failed"+ $CRLF+"')
SmtpLog "Forced End Data from "+MailFrom, "DATA Looped Out",SequenceNo,Username
LogEvent "Forced End Data from "+MailFrom
GOTO 60
END IF
'
'
' http encoding to avert problems with html
'
511 IF INSTR(buffer, CHR$(0)) > 0 THEN
REPLACE CHR$(0) WITH "�" IN Buffer
GOTO 511
END IF
51 IF INSTR(buffer, CHR$(34)) > 0 THEN
REPLACE CHR$(34) WITH """ IN Buffer
GOTO 51
END IF
53 IF INSTR(buffer, "'") > 0 THEN
REPLACE "'" WITH "'" IN Buffer
GOTO 53
END IF
55 IF INSTR(buffer,",") > 0 THEN
REPLACE "," WITH "," IN Buffer
GOTO 55
END IF
'
56 IF INSTR(buffer,"\") > 0 THEN
REPLACE "\" WITH "\" IN Buffer
GOTO 56
END IF
'
' determine the content type
'
IF INSTR(UCASE$(Buffer),"CONTENT-TYPE:") > 0 THEN
FieldEnd = INSTR(Buffer,";")
IF FieldEnd = 0 THEN
FieldEnd = LEN(Buffer)
EmailType = MID$(Buffer,14,FieldEnd-13)
ELSE
EmailType = MID$(Buffer,14,FieldEnd-14)
END IF
END IF
'
' subject line
'
IF INSTR(UCASE$(Buffer),"SUBJECT:") > 0 THEN
EmailSubject = MID$(Buffer,INSTR(Buffer,":")+2,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Encoding Format
'
IF INSTR(UCASE$(Buffer),"ENCODING:") > 0 THEN
Encoding = RIGHT$(Buffer,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Email date
'
IF INSTR(UCASE$(Buffer),"DATE:") > 0 THEN
EmailDate = RIGHT$(Buffer,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Message-Id:
'
IF INSTR(UCASE$(Buffer),"MESSAGE-ID:") > 0 THEN
MessageID = MID$(Buffer,INSTR(Buffer,":")+2,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Content filter the subject. If a reject word is found then exit
' no filtering on local email
'
IF Source = "Local" THEN GOTO 59
'
FOR FilterIndex = 1 TO FilterRecords
IF UCASE$(TRIM$(Encoding)) <> "BASE64" AND _
INSTR(UCASE$(Buffer),Filter(FilterIndex)) > 0 THEN
Reason = Filter(FilterIndex)
SmtpLog "Filter Detected ", Filter(FilterIndex),SequenceNo,"System"
Reject = Reject + 1
GOTO 59
END IF
IF UCASE$(TRIM$(Encoding)) = "BASE64" AND _
INSTR(UCASE$(Decode64$(Buffer,-1)),Filter(FilterIndex)) > 0 THEN
Reason = Filter(FilterIndex)
SmtpLog "Base64 Filter Detected ", Filter(FilterIndex),SequenceNo,"System"
Reject = Reject + 1
GOTO 59
END IF
NEXT FilterIndex
'
' save the email line by line instead of by block
' an number of emails have poorly formated html which appears as huge strings which
' are getting truncated so these strings are being chopped into smaller sections so
' data is not lost.
'
59 IF LEN(Buffer) < 250 THEN
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ Buffer + $CRLF+"')
ELSE
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ LEFT$(Buffer,250)+"')
Buffer = RIGHT$(Buffer, LEN(Buffer) - 250)
GOTO 59
END IF
'
TotalSize = TotalSize + LEN(Buffer)
EmailSize = EmailSize + LEN(Buffer)
'
'59 EmailData = EmailData + buffer + $CRLF
GOTO 50
'
' attach the receive header
'
'60 EmailData = "Received: from " +MailServer+ "; " + MailDate + $CRLF + EmailData
'
' Get the size of the email
'
' EmailSize = LEN(EmailData)
'
' send end of data
'
60 SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ $CRLF+"')
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ Buffer + $CRLF+"')
TCP SEND hSmtp, "250 OK" + $CRLF
SmtpLog "End Data from "+MailFrom, "DATA Command Accepted",SequenceNo,Username
LogEvent "End Data from "+MailFrom
'
'
'
'
' Once the email data is received then save it then next
' duplicate message filter
'
100 SqlQuery " Select count(QueueID) from Queue where MessageID = '"+MessageID+"'"
GetRecord
SqlFreeMemory
'
IF VAL(Field(1)) > 0 AND MessageID <> "" THEN
SmtpLog "Message exist in the Queue " +MessageID, "Message Rejected",SequenceNo,Username
LogEvent "Message exist in the Queue " +MessageID
GOTO 999
END IF
'
SqlQuery " Select count(QueueID) from Rejects where MessageID = '"+MessageID+"'"
GetRecord
SqlFreeMemory
'
IF VAL(Field(1)) > 0 AND MessageID <> "" THEN
SmtpLog "Message exist in the Rejects " +MessageID, "Message Rejected",SequenceNo,Username
LogEvent "Message exist in the Rejects " +MessageID
GOTO 999
END IF
'
'
'
'
' Handling for Multiple Recipients
' The mail is basically the same for all the people in the Recipient list
' So entries into the queue process via a loop selecting the new Recipients
' each time. Recipients()
'
'
' If the email is to be rejected don't record the email just black whole the email
'
FOR Index = 1 TO NoRecipients
MailTo = Recipients(Index)
'
IF Reject = 0 THEN
IF (MaxEmailSize > 0 AND EmailSize < MaxEmailSize) OR Source = "Local" THEN
SqlQuery "Insert into Queue values ( '','"+MailServer+"','"+MailFrom+"','"+MailTo+"','"+_
EmailSubject +"',Now(),'','Received','"+Destination+"','" + _
STR$(EmailSize) + "','" + EmailType + "','"+MessageID+"','"+ _
STR$(Retries)+"','"+TRIM$(STR$(SequenceNo))+"','"+Encoding+"')"
SmtpLog " Mail from "+MailServer+"."+MailFrom, "Accepted for "+MailTo,SequenceNo,Username
LogEvent " Mail from "+MailServer+"."+MailFrom + "Accepted for "+MailTo
ELSE
SqlQuery "Insert into Rejects values ( '','"+MailServer+"','"+MailFrom+"','"+MailTo+"','"+_
EmailSubject +"',Now(),'SequenceNo','MaxEmailSize','"+Destination+"','" + _
STR$(EmailSize) + "','" + EmailType + "','"+MessageID+"','"+ _
STR$(Retries)+"','"+TRIM$(STR$(SequenceNo))+"','"+Encoding+"')"
SmtpLog " Mail from "+MailFrom+" exceeds MaxMailSize", "Email junked",SequenceNo,Username
LogEvent " Mail from "+MailFrom+" exceeds MaxMailSize Rejected"
END IF
EmailData = ""
SqlFreeMemory
ELSE
SqlQuery "Insert into Rejects values ( '','"+MailServer+"','"+MailFrom+"','"+MailTo+"','"+_
EmailSubject +"',Now(),'"+Reason+"','Rejected','"+Destination+"','" + _
STR$(EmailSize) + "','" + EmailType + "','"+MessageID+"','"+ _
STR$(Retries)+"','"+TRIM$(STR$(SequenceNo))+"','"+Encoding+"')"
SmtpLog " Mail from "+MailFrom+" Failed Filtering", "Rejected",SequenceNo,Username
LogEvent " Mail from "+MailFrom+" Failed Filtering and Rejected"
END IF
'
NEXT Index
'
IF Reject = 0 THEN GOTO 10
'
' Black hole reject System
' Check senderlevel for blackhole if exceeded
' if it is not in the list add to the list to be watched
' if the sender is in the blackhole list then increamnet the rejects
' if the rejects are greater than the bhl senderlevel then blackhole the sender
'
' if server is not in the list add the server to be watched
' if it is in th list increment the rejects
' if the rejects are greater than the server level then blackhole the server
'
' Basically spammers come certain senders on certain server. If the system gets
' some many emails that are rejected by the system then that sender will be blocked
' but they will change their address. So if they move to another address it will start
' again and will be blocked again if they move more than some many times and get
' blocked then the server is blocked
'
'
' is the send in the list
IF Reject = 0 THEN
Sqlquery " Select BHLID from BHL where Domain = '"+MailFrom+"'"
GetRecord
SqlFreeMemory
BHLID = VAL(TRIM$(Field(1)))
IF BHLID > 0 THEN
' sender in the list increment the rejects
Sqlquery " Update BHL set Rejects = Rejects + 1 where BHLID = "+STR$(BHLID)
' check the sender level
Sqlquery " Select Rejects from BHL where BHLID = "+STR$(BHLID)
GetRecord
SqlFreeMemory
' is the sender level exceeded black hole the sender
IF VAL(TRIM$(Field(1))) > SenderLevel THEN
Sqlquery " Update BHL set DomainStatus = 'Active' where BHLID = "+STR$(BHLID)
'
'
' is the server in the blachole list
Field(1) = ""
Sqlquery " Select BHLID from BHL where Domain = '"+MailServer+"'
GetRecord
SqlFreeMemory
BHLID = VAL(TRIM$(Field(1)))
IF BHLID > 0 THEN
' server is on the list increment the server rejects
Sqlquery " Update BHL set Rejects = Rejects + 1 where BHLID = "+STR$(BHLID)
' check the server level
Sqlquery " Select Rejects from BHL where BHLID = "+STR$(BHLID)
GetRecord
SqlFreeMemory
' is the sender level exceeded black hole the server
IF VAL(TRIM$(Field(1))) > ServerLevel THEN
Sqlquery " Update BHL set DomainStatus = 'Active' where BHLID = "+STR$(BHLID)
END IF
'
'
ELSE
' add the server to the list
Sqlquery " Insert into BHL values( '','" +MailServer +"',1,'Watching')
END IF
END IF
'
' the sender is no in the list so addit
'
ELSE
Sqlquery " Insert into BHL values( '','" +MailFrom +"',1,'Watching')
END IF
'
END IF
END IF
'
' This is the quit command to complete the email
' This command specifies that the receiver must send an OK
' reply, and then close the transmission channel.
'
' The receiver should not close the transmission channel until
' it receives and replies to a QUIT command (even if there was
' an error). The sender should not close the transmission
' channel until it send a QUIT command and receives the reply
' (even if there was an error response to a previous command).
'
' If the connection is closed prematurely the receiver should
' act as if a RSET command had been received (canceling any
' pending transaction, but not undoing any previously
' completed transaction), the sender should act as if the
' command or transaction in progress had received a temporary
' error (4xx).
90 IF LEFT$(UCASE$(Buffer),4) = "QUIT" THEN
'TCP SEND hSmtp, "221 "+$CRLF
GOTO 999
END IF
'
' This command specifies that the current mail transaction is
' to be aborted. Any stored sender, recipients, and mail data
' must be discarded, and all buffers and state tables cleared.
' The receiver must send an OK reply.
'
' The rset command can be sent between messages so a new connection
' does not have to be made again. So the current email is complete
' then the process begins again.
'
IF LEFT$(UCASE$(Buffer),4) = "RSET" THEN
TCP SEND hSmtp, "250 OK" + $CRLF
SmtpLog "RSET from "+MailFrom, "RSET Command Accepted",SequenceNo,Username
LogEvent "RSET"
GOTO 10
END IF
'
' unsupported commands
'
IF LEFT$(UCASE$(Buffer),4) = "VRFY" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "VRFY from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "VRFY from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "EXPN" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "EXPN from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "EXPN from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "SOML" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "SOML from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "SOML from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "SEND" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "SEND from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "SEND from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "TURN" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "TURN from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "TURN from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "HELP" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "HELP from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "HELP from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
GOTO 10
'
999 SmtpLog "Session Closed " + MailServer," Connection terminated",SequenceNo,Username
LogEvent "Session Closed " + MailServer +" Connection terminated"
SqlClose
'
END FUNCTION
'------------------------------------------------------------------------------
' Callback function for the main dialog window
'
FUNCTION DlgProc (BYVAL hDlg AS DWORD, _
BYVAL wMsg AS LONG, _
BYVAL wParam AS LONG, _
BYVAL lParam AS LONG) EXPORT AS LONG
'
STATIC nServer AS LONG
'
SELECT CASE wMsg
'
' To create a TCP server, your program must first open a socket using the TCP OPEN SERVER statement.
' Then, when a client contacts your server, this socket will receive the notification.
' To specify which notifications your code will process, use the TCP NOTIFY statement:
'
CASE %WM_INITDIALOG
hList = GetDlgItem(hDlg, 101)
'
' open the socket for smtp
'
nServer = FREEFILE
TCP OPEN SERVER "smtp" AS nServer TIMEOUT 50000
IF ERR THEN
logevent "Unable to listen to smtp"
FUNCTION = 0
ELSE
'
' Notify will specify which notifications your code will process, use the TCP NOTIFY statement:
' It tells Winsock that it should send the %TCP_ACCEPT message to the window specified by nServer.
'
TCP NOTIFY nServer, ACCEPT TO hDlg AS %TCP_ACCEPT
logevent "Connected to smtp"
FUNCTION = 1
END IF
'
' The lParam& parameter to your callback will tell you what type of notification was sent:
'
CASE %TCP_ACCEPT
SELECT CASE LOWRD(lParam)
'
CASE %FD_ACCEPT
hSmtp = FREEFILE
TCP ACCEPT nServer AS hSmtp ' Create a socket to the client
TCP SEND hSmtp, "220 "+MailserverName+" ESMTP System v3.1.2" + $CRLF ' send the server connect message
SmtpThread hSmtp
CLOSE hSmtp
END SELECT
'
FUNCTION = 1
'
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE 102
EndDialog hDlg, 0
FUNCTION = 1
END SELECT
'
CASE %WM_DESTROY
TCP CLOSE nServer
LogEvent "Disconnected from Pop3"
'
CASE %WM_SYSCOMMAND
IF (wParam AND &H0FFF0) = %SC_CLOSE THEN
SendMessage hDlg, %WM_COMMAND, 102, 0
FUNCTION = 1
END IF
END SELECT
END FUNCTION
'
'------------------------------------------------------------------------------
' Main Application entry point...
'
FUNCTION WINMAIN (BYVAL hInstance AS LONG, _
BYVAL hPrevInstance AS LONG, _
BYVAL lpCmdLine AS ASCIIZ PTR, _
BYVAL iCmdShow AS LONG) AS LONG
MailserverName = "mail.abconcepts.com.au"
'
' get the server config
'
CHDIR "c:\pbmail"
GetMysqlConfig
'
DiagLevel = 2
'
' initate this program as a windows service
'
InitDecode64
'
' set the automatic blackhole levels
'
SenderLevel = 5
ServerLevel = 5
MaxEmailSize = 5000000
'
DialogBox hInstance, BYVAL 100&, %HWND_DESKTOP, CODEPTR(DlgProc)
END FUNCTION
------------------
have added checking of base64 encode attachments and fixed a
number of bugs in the filtering and bhl system. I have also add
domain rejection as well.
I have also picked a problems with the latest spam html emails.
Email is a line based protocol and normally the lines are about
80 characters long/ The programs that generate these html spam
create lines up to 300 characters long. The system was truncating
these long lines so the system checks for long lines and breaks
then into a number of records.
'==============================================================================
' SMTP Server Program Handler Version 1.10(SMTPD)
' Copyright (c) 2005 by Martin Draper
'
' This library is free developer software; you can use it and/or
' modify it under the terms of the Phoenix Project Developer
' License. All commerical use and rights are strictly reserved.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
'
'
'-------------------------------------------------------------------------------------
' Changes 30/9/2005 Blocking added for Server at the Helo Command and Sender
' blocking add at the Mail command
' Content filtering of the subject and body added
' Automatic Blackhole system implemented.
'
' 01/9/2005 Add a function to determineand record the EmailType from the
' Content Header in the email if there is one. It defaults to
' text/plain.
'
' EmailSize is now determined and recorded.
'
' Maximum email size control added. If the max size is set and
' The email exceeds that size then email is junked.
'
' Internal mail support. In businesses much of the email is internal
' from one staff member to another. If these emails did not have a
' realm attached "@yourserver.com" these emails could never leave the
' server and cannot be access from outside. NO SPAM ! Purely internal
' mail opens the way for sensitive material to be transfered more
' securely.
'
' 02/10/2005 System Loging added
'
' 02/02/2006 SqlFreeMemory to reduce the memory useage
'
' 05/02/2006 Diagnostic level addedd
'
' 12/02/2006 The Email Date is changed to a pure mysql date so the age of email can
' be checked.
' Null and "\" added to filtering.
'
' 13/2/2006 The email data in now stried line by line in the emails table
'
' 19/02/2006 A field for encoding format added
'
' 30/3/2006 The SequenceNo added to log files
'
' 02/06/2005 Changes to error handling. You just can't exit out of the sequence
' you have to give an error message back to the send and get them to
' quit or they jusy keep send data which clogs the system
'
' 05/06/2006 System crashed due to rubbish in the log. The Sequence failed in the
' data transmissiona and the system logged the juck as errors. They
' contained "'" and "," which are now being removed from the log entries
'
' 13/2/2006 The have been problems with failure when the emails get to large.
' Basically storing the mail in blob has not worked and data is being
' lost
'
' 18/6/2006 Long strings of html are being truncated the data is checked for length
' then the data is split into blocks
'
' 22/6/2006 Base64 Scanning added
'-------------------------------------------------------------------------------------
' Notes 30/9/2005 If you are using Sqlite instead of the Mysql you have to take out
' the "Use EmailServer" query as Sqlite Only supports one database.
'
' 02/9/2005 The server will consist of 4 parts
' The SMTPD (This program which will receive incoming mail)
' The SMTP-REMOTE which forwards mail to external servers
' The POP3-Proxy which gets mail from external servers
' The POP3D which forwards mail to the user.
'
' The will also be an SMTP Client and Pop3 Client for Applications
'
'-------------------------------------------------------------------------------------
'
#COMPILE EXE
#DIM ALL
'==============================================================================
' Multi threading do's and don'ts
'
' Thread-efficient programs are efficiently parallelized programs.
' The use of global data is thread-unsafe. It should be maintained per thread or
' encapsulated, so that its access can be serialized. A thread may read an error
' code corresponding to an error caused by another thread.
' So variables with a thread should be local.
'
' No data should be kept over successive calls, because different threads may
' successively call the function.
' The function must be completed with the thread.
'
' In multi-threaded programs, all functions called by multiple threads must be thread-safe.
' It is a good programming practice to always use and write reentrant and thread-safe functions.
'
'------------------------------------------------------------------------------
' Include Files
'
#RESOURCE "SmtpServ.pbr"
%USEMACROS = 1
#INCLUDE "Win32API.inc"
#INCLUDE "WS2_32.inc"
#INCLUDE "\aims5\lib\MySqlDB.inc"
#INCLUDE "dns3.inc"
'------------------------------------------------------------------------------
' Equates and global variables
'
%TCP_ACCEPT = %WM_USER + 4093 ' Any value larger than %WM_USER + 500
%TCP_SMTP = %WM_USER + 4094 ' Any value larger than %WM_USER + 500
%TCP_MAIL = %WM_USER + 4095 ' Any value larger than %WM_USER + 500
'
GLOBAL hList AS LONG
GLOBAL nServer AS LONG
GLOBAL hSmtp AS LONG 'DWORD
GLOBAL MailserverName AS STRING
GLOBAL Filter() AS STRING
GLOBAL FilterRecords AS LONG
GLOBAL SenderLevel AS INTEGER
GLOBAL ServerLevel AS INTEGER
GLOBAL MaxEmailSize AS LONG
'
GLOBAL DiagLevel AS INTEGER
'-------------------------------------------------------------------------
' BASE64 Decoding
' Original VBDOS Version by G. Balla, 1996 (Public Domain)
' PB/DOS Conversion by Marc van den Dikkenberg, 1999
' Modified for PBCC by Martin Draper 2000
'
'--------------------------------------------------------------------------
GLOBAL icChopMask AS INTEGER ' Constant 8-bit mask (Faster than using string constants)
GLOBAL icBitShift AS INTEGER ' Constant shift mask (Faster than using string constants)
GLOBAL icStartMask AS INTEGER ' Initial mask value (Faster than using string constants)
GLOBAL iRollOver AS INTEGER ' Decoded Roll over value
GLOBAL iHighMask AS INTEGER ' Mask high bits of each char
GLOBAL iShift AS INTEGER ' Multiplier shift value
GLOBAL iLowShift AS INTEGER ' Mask low bits of each char
GLOBAL szAlphabet AS STRING ' Decode/Encode Lookup Table
GLOBAL szTemp AS STRING ' Working string
'
'----------------------------------------------------------------------------------------------
' Name: INITDECODE64
' Type: Sub procedure
' Description: Initializes local shared variables for DECODE64$
' Required because many encoded files cannot be decoded in a single string
'
' Used: Before decoding a BASE64 file. (DECODE64$)
' Arguements: None
' Returns: Nothing
'
' Errors: None
'
' Global Variables used:
' szAlphabet Encode/Decode Table lookup
'
' icChopMask Constant value in variable to speed process
' icBitShift Constant value in variable to speed process
' icStartMask Constant value in variable to speed process
'
' iShift Multiplier shift value
' iLowShift Mask Low bits of each char
' iRollOver Decoded Roll over value from prev char in string
' iHighMask Mask high bits of each char
'----------------------------------------------------------------------------------------------
SUB InitDecode64
' Initialize 2nd encoding pass lookup dictionary
szAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
' Initialize Constants
icChopMask = 255
icBitShift = 4
icStartMask = &H10
' Initialize Masks
iShift = icBitShift
iLowShift = 0
iRollOver = 0
iHighMask = -1
'
END SUB
'
'----------------------------------------------------------------------------------------------
' Name: DECODE64$
' Type: String function
' Description: decodes a string from BASE64 to binary format
'
' Arguements: Source string to decode (szEncoded)
' Last string in file to decode flag (iEndOfText)
' Returns: Un-Encoded binary string.
'
' Errors: Generates an Error via ERROR statement.
' Error code: 253 = No string to decode
' -----------------------------------------------
' NOTES: Must call INITDECODE64 before sending 1st string of an encoded file.
'
' A DOEVENTS occurs near the end of the FOR/NEXT loop
' -----------------------------------------------
' Global variables: szAlphabet ' Decode/Encode lookup table
' szTemp ' Working string
'
' iRollOver ' Decode/Encode rollover value
' iHighMask ' High bit mask
' iShift ' Multiplier value
'
'
' Local variables: iChar ' Ascii Char value from Encoded string
' iPtr ' Lookup table pointer
' iCounter ' FOR/NEXT counter
'
'----------------------------------------------------------------------------------------------
FUNCTION DECODE64$ (szEncoded AS STRING, iEndOfText AS INTEGER)
'
' Create variables
DIM iPtr AS INTEGER
DIM iChar AS INTEGER
DIM iCounter AS INTEGER
'
' Check if empty decoded string.
' If Empty, return NUL and Generate error 254
'
IF LEN(szEncoded) = 0 THEN
DECODE64$ = ""
ERROR 253
EXIT FUNCTION
END IF
' Initialize working string
szTemp = ""
' Begin Decoding
FOR iCounter = 1 TO LEN(szEncoded)
' Get next alphabet
iChar = ASC(MID$(szEncoded, iCounter, 1))
' Get Decoded value
iPtr = INSTR(szAlphabet, CHR$(iChar)) - 1
' Check if character is valid
IF iPtr >= 0 THEN
' Char is valid, process it
IF iShift = icBitShift THEN
' 1st char in block of 4, keep high part of character
iRollOver = (iPtr * iShift) AND icChopMask
' Reset masks for next character
iHighMask = &H30
iLowShift = icStartMask
iShift = icStartMask
ELSE
' Start saving decoded character
szTemp = szTemp + CHR$(iRollOver OR ((iPtr AND iHighMask) / iLowShift))
' Calculate next mask and shift values
iRollOver = (iPtr * iShift) AND icChopMask
iShift = iShift * icBitShift
iHighMask = (iHighMask \ icBitShift) OR &H30
iLowShift = iLowShift / icBitShift
IF iShift > 256 THEN
iShift = icBitShift
iLowShift = 0
END IF
END IF
END IF
NEXT
' Concat last character if required
IF (iShift > icBitShift AND iShift < 256) THEN
' Character remaining in iRollOver
IF iEndOfText THEN
' Last string to decode in file
szTemp = szTemp + CHR$(iRollOver)
END IF
END IF
' Exit wth decoded string
DECODE64$ = szTemp
'
END FUNCTION
'-----------------------------------------------------------------------------
' Retrieve the current time and date in E-mail header format
'
FUNCTION MailDate () AS STRING
LOCAL szFormat AS ASCIIZ * 40
LOCAL szTemp AS ASCIIZ * 40
LOCAL sResult AS STRING
LOCAL t AS SYSTEMTIME
LOCAL sUCTOffset AS STRING
LOCAL tzi AS TIME_ZONE_INFORMATION
GetLocalTime t
szFormat = "ddd',' dd MMM yyyy"
GetDateFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, SIZEOF(szTemp)
sResult = szTemp
szFormat = "HH':'mm':'ss"
GetTimeFormat %LOCALE_USER_DEFAULT, 0, t, szFormat, szTemp, SIZEOF(szTemp)
SELECT CASE GetTimeZoneInformation(tzi)
CASE %TIME_ZONE_ID_DAYLIGHT
sUCTOffset = IIF$((tzi.bias + tzi.DaylightBias) <= 0, "+", "-") _
+ FORMAT$((tzi.bias + tzi.DaylightBias) \ 60, "00") _
+ FORMAT$((tzi.bias + tzi.DaylightBias) MOD 60, "00")
CASE %TIME_ZONE_ID_STANDARD
sUCTOffset = IIF$((tzi.bias + tzi.StandardBias) <= 0, "+", "-") _
+ FORMAT$((tzi.bias + tzi.StandardBias) \ 60, "00") _
+ FORMAT$((tzi.bias + tzi.StandardBias) MOD 60, "00")
CASE ELSE
sUCTOffset = "-0000"
END SELECT
FUNCTION = sResult + " " + szTemp + " " + sUCTOffset
END FUNCTION
'------------------------------------------------------------------------------
' Event logging
'
SUB LogEvent (BYVAL Buffer AS STRING)
LOCAL idx AS LONG
Buffer = DATE$ +" "+ TIME$ + " - " + Buffer
idx = SendMessage(hList, %LB_ADDSTRING, 0, STRPTR(Buffer))
SendMessage hList, %LB_SETCURSEL, idx, 0
END SUB
SUB SmtpLog(Event AS STRING,Action AS STRING, SequenceNo AS LONG,UserID AS STRING)
'
' record and event in the smtp log
'
REPLACE "'" WITH "" IN Event
REPLACE "'" WITH "" IN Action
REPLACE "," WITH "" IN Event
REPLACE "," WITH "" IN Action
'
SqlQuery "Insert into SmtpLog (LogID,LogDate,Event,Action,SequenceNo,Username) " + _
" values ( '',Now(),'"+Event+"','"+Action+"','"+TRIM$(STR$(SequenceNo))+"','"+UserID+"')"
'
END SUB
FUNCTION LoadFilter AS INTEGER
'
LOCAL Index AS LONG
'
' Get the number of filters
'
SqlQuery "Select Count(FilterString) from Filter"
GetRecord
FilterRecords = VAL(Field(1))
SqlFreeMemory
'
REDIM Filter(FilterRecords)
'
' load the records in to the array
'
SqlQuery "Select FilterString from Filter"
FOR Index = 1 TO RowCount
GetRecord
Filter(Index) = UCASE$(TRIM$(Field(1)))
NEXT I
'
SqlFreeMemory
'
'SmtpLog "Filter Loaded " + str$(RowCount) + " Records" , Filter(1) + "->" + Filter(Rowcount-1),0,"System"
END FUNCTION
FUNCTION InitListen(hDlg AS DWORD) AS INTEGER
'
LOCAL sBuffer AS STRING
'
' open the socket for smtp
'
nServer = FREEFILE
TCP OPEN SERVER "smtp" AS nServer
'
IF ERR THEN
sBuffer = "Unable to listen to smtp"
FUNCTION = 0
ELSE
'
' Notify will specify which notifications your code will process, use the TCP NOTIFY statement:
' It tells Winsock that it should send the %TCP_ACCEPT message to the window specified by nServer.
'
TCP NOTIFY nServer, ACCEPT TO hDlg AS %TCP_ACCEPT
sBuffer = "Connected to smtp"
FUNCTION = 1
END IF
LogEvent sBuffer
'
END FUNCTION
FUNCTION AcceptConnection(hDlg AS DWORD) AS INTEGER
'
' Create a socket to the client
'
hSmtp = FREEFILE
TCP ACCEPT nServer AS hSmtp
'
' send the server connect message
'
TCP SEND hSmtp, "220 "+MailserverName+" ESMTP System v3.1.2" + $CRLF
'
' The Helo is next
'
TCP NOTIFY hSmtp, RECV TO hDlg AS %TCP_SMTP
LogEvent "connection accepted"
'
FUNCTION = 1
'
END FUNCTION
FUNCTION SmtpTHread(hSmtp AS DWORD) AS INTEGER
'
' hello from the client
' RFC 1123 requires that the parameter be a valid principal host domain name for the client host.
' However, some clients don't have names. I recommend that they use bracketed IP addresses:
'
' The server's response text begins with the server's name. The server must be careful not to
' use another host's name here: if a sendmail client on that host connects and sees its own name,
' it will refuse to ``talk to itself.
'
' Some servers do not accept MAIL requests before HELO. Clients use HELO as the first request
' in every session. (Exception: see EHLO.) This is a waste of time. I recommend that server
' implementors let clients skip HELO, to support a future transition to a world without HELO.
'
' Beware that many servers reject all HELO requests after the first, so clients cannot rely
' on HELO as a way to clear the envelope. For example, sendmail returns a 503 code.
'
' A few servers reject messages from clients whose HELO parameters do not match the results
' of PTR lookups on their IP addresses. This behavior is a disaster in practice; surveys in
' 1998 found that more than 10% of all clients by volume use invalid HELO parameters.
' Compuserve reportedly uses unqualified names:
'
' RFC 1123 Requirements for Internet Hosts - Application and Support
' prohibits HELO-based rejections
'
' HELO testmx.unixwiz.net
' 554 <testmx.unixwiz.net> Helo command rejected: Access denied
'
LOCAL Buffer AS STRING
LOCAL MailServer AS STRING
LOCAL MailHost AS STRING
LOCAL MailFrom AS STRING
LOCAL MailTo AS STRING
'
LOCAL EmailSubject AS STRING
LOCAL EmailDate AS STRING
LOCAL EmailData AS STRING
LOCAL Destination AS STRING
LOCAL DestinationDomain AS STRING
LOCAL DestinationID AS LONG
LOCAL Source AS STRING
LOCAL SourceDomain AS STRING
LOCAL EmailSize AS LONG
LOCAL EmailType AS STRING
LOCAL MessageID AS STRING
LOCAL Retries AS INTEGER
LOCAL SequenceNo AS LONG
LOCAL FileHandle AS LONG
LOCAL TotalSize AS LONG
LOCAL Encoding AS STRING
LOCAL FilterIndex AS LONG
LOCAL Reason AS STRING
'
LOCAL Index AS LONG
LOCAL Reject AS INTEGER
LOCAL BHLID AS LONG
LOCAL FieldStart AS INTEGER
LOCAL FieldEnd AS INTEGER
LOCAL QuotaSize AS LONG
LOCAL QuotaCount AS LONG
LOCAL Username AS STRING
'
LOCAL Recipients() AS STRING
LOCAL NoRecipients AS INTEGER
LOCAL LoopTrap AS INTEGER
'
LOCAL DataAccepted AS INTEGER
'
REDIM Field(32),Recipients(100)
NoRecipients = 0
Retries = 0
Reject = 0
Reason = ""
'
IF SqlConnect = 0 THEN
SmtpLog "Unable to Connect to Database Server ", "Connection Terminated",SequenceNo,Username
LogEvent "Unable to Connect to Database Server "
EXIT FUNCTION
END IF
'
SqlQuery "Use pbmail"
SmtpLog "Connected to Database Server ", "Processing Started",SequenceNo ,Username
'
' load the content filter table
'
LoadFilter
'
'
' get the next sequence number for the email
'
5 FileHandle = FREEFILE
OPEN "sequence" FOR INPUT AS FileHandle
INPUT #FileHandle , SequenceNo
CLOSE FileHandle
'
SequenceNo = SequenceNo + 1
'
FileHandle = FREEFILE
OPEN "sequence" FOR OUTPUT AS FileHandle
PRINT #FileHandle , SequenceNo
CLOSE FileHandle
' '
' helo
'
10 TCP LINE hSmtp, buffer
'
IF ERR > 0 THEN
SmtpLog "Session Failed from "+MailFrom, "Connection Dropped",SequenceNo,Username
LogEvent "Session Failed from "+MailFrom
GOTO 999
END IF
'
'
'
' Looping trap
'
IF Buffer = "" THEN
loopTrap = LoopTrap + 1
IF LoopTrap > 20 THEN
SmtpLog "Connection Looped Out " + MailServer, "Connection Terminated",SequenceNo,Username
GOTO 999
END IF
SLEEP 1000
GOTO 10
ELSE
LoopTrap = 0
END IF
'
SmtpLog "Data Received " + MailServer, Buffer,SequenceNo,Username
'
' start helo
'
IF LEFT$(UCASE$(Buffer),4) = "HELO" THEN
MailServer = TRIM$(MID$(Buffer,5,LEN(buffer)-4))
TCP SEND hSmtp, "250 HELO " + MailserverName + "."+buffer+ $CRLF
LogEvent "HELO connection accepted from " + MailServer
IF DiagLevel = 1 OR DiagLevel = 2 THEN LogEvent "connection accepted from " + MailServer
END IF
'
' spammers will send email from the address of the server.
' this will block this email
'
'IF Mailserver = "202.94.66.101" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".pl" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".hu" _
' OR INSTR(LCASE$(MailServer),"bounce") > 0 THEN
' SmtpLog "HELO Rejected from " + MailServer, "Spam Deteced",SequenceNo,Username
' GOTO 999
'END IF
'
'Mailhost = MX_Query(Mailserver, "ns1.hypermax.net.au")
'SmtpLog "Dns check " + MailServer,">"+ MailHost + "< found",SequenceNo,Username
'
' Black hole blocking
'
'Field(1) = ""
'SqlQuery " Select BHLID from BHL where Domain = '"+MailServer+"' and DomainStatus = 'Active'"
'GetRecord
'SqlFreeMemory
'IF VAL(Field(1)) > 0 THEN
' TCP SEND hSmtp, "554 " + MailserverName + "Helo command rejected: Access denied" + $CRLF
' SmtpLog "HELO Rejected from " + MailServer, "Connection Terminated",SequenceNo,Username
' LogEvent "HELO Rejected from " + MailServer
' GOTO 999
'ELSE
'END IF
'GOTO 10
'
' start elho
'
IF LEFT$(UCASE$(Buffer),4) = "EHLO" THEN
MailServer = TRIM$(MID$(Buffer,5,LEN(buffer)-4))
TCP SEND hSmtp, "250 HELO " + MailserverName + "."+buffer+ $CRLF
LogEvent "EHLO connection accepted from " + MailServer
IF DiagLevel = 1 OR DiagLevel = 2 THEN LogEvent "connection accepted from " + MailServer
END IF
'
' spammers will send email from the address of the server.
' this will block this email
'
'IF Mailserver = "202.94.66.101" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".pl" _
' OR LCASE$(RIGHT$(MailServer,3)) = ".hu" _
' OR instr(LCASE$(MailServer),"bounce") > 0 THEN
' SmtpLog "HELO Rejected from " + MailServer, "Spam Deteced",SequenceNo,Username
' GOTO 999
'END IF
'
'Mailhost = MX_Query(Mailserver, "ns1.hypermax.net.au")
'SmtpLog "Dns check " + MailServer,">"+ MailHost + "< found",SequenceNo,Username
'
' Black hole blocking
'
'SqlQuery " Select BHLID from BHL where Domain = '"+MailServer+"' and DomainStatus = 'Active'"
'GetRecord
'SqlFreeMemory
'IF VAL(Field(1)) > 0 THEN
' TCP SEND hSmtp, "554 " + MailserverName + "Helo command rejected: Access denied" + $CRLF
' SmtpLog "EHLO Rejected from " + MailServer, "Connection Terminated",SequenceNo,Username
' LogEvent "EHELO Rejected from " + MailServer
' GOTO 999
'ELSE
'
'
' TCP NOTIFY hSmtp, RECV SEND CLOSE TO hDlg AS %TCP_MAIL
'
' MAIL FROM in the smtp this give you the email address of the client sending the email
' This command tells the SMTP-receiver that a new mail transaction is starting and to
' reset all its state tables and buffers, including any recipients or mail data. It
' gives the reverse-path which can be used to report errors. If accepted, the
' receiver-SMTP returns a 250 OK reply.
'
' The <reverse-path> can contain more than just a mailbox. The <reverse-path> is a
' reverse source routing list of hosts and source mailbox. The first host in the
' <reverse-path> should be the host sending this command.
'
20 IF LEFT$(Buffer,4) = "MAIL" THEN
MailFrom = MID$(Buffer,INSTR(Buffer,"<")+1,LEN(buffer)-INSTR(Buffer,"<")-1)
Source = ""
'
' get domain of the sender
'
FieldStart = INSTR(MailFrom,"@")
IF FieldStart > 0 THEN
SourceDomain = RIGHT$(MailFrom,LEN(MailFrom)-FieldStart)
ELSE
SourceDomain = ""
END IF
'
' domain rejection
'
Field(1) = ""
SqlQuery " Select DomainID from Domains where instr('"+MailServer+"',Domain) > 0 " + _
" or instr('"+MailFrom+"',Domain) > 0 "
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
TCP SEND hSmtp, "550 " + MailFrom + "Mail command rejected: Access denied" + $CRLF
SmtpLog "MAIL " +MailFrom + " Rejected by Domain", "Connection Terminated",SequenceNo,Username
LogEvent "MAIL " +MailFrom + " Rejected by Domain"
GOTO 10
END IF
'
' Check the Black hole list
'
Field(1) = ""
SqlQuery " Select BHLID from BHL where Domain = '"+MailFrom+"' and DomainStatus = 'Active'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
TCP SEND hSmtp, "550 " + MailFrom + "Mail command rejected: Access denied" + $CRLF
SmtpLog "MailFrom: " +MailFrom + " Rejected by BHL -" + STR$(BHLID), "Connection Terminated",SequenceNo,Username
LogEvent "MailFrom: " +MailFrom + " Rejected by BHL -" + STR$(BHLID)
GOTO 10
END IF
'
' determine the Source
'
Field(1) = ""
SqlQuery " Select LocalID from MailBoxes where LocalAddress = '"+MailFrom+"'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
Source = "Local"
ELSE
Source = "Forward"
END IF
'
TCP SEND hSmtp, "250 " + MailFrom + " OK" + $CRLF
SmtpLog "Process Mail From " +MailFrom,"MAIL Command Accepted",SequenceNo ,Username
LogEvent "Process Mail From " +MailFrom
GOTO 10
END IF
'
' This command gives a forward-path identifying one recipient.
' If accepted, the receiver-SMTP returns a 250 OK reply, and
' stores the forward-path. If the recipient is unknown the
' receiver-SMTP returns a 550 Failure reply. This second step of
' the procedure can be repeated any number of times.
'
' The <forward-path> can contain more than just a mailbox. The
' <forward-path> is a source routing list of hosts and the
' destination mailbox. The first host in the <forward-path>
' should be the host receiving this command.
' RCPT To:<steve@unixwiz.net>
' 554 <linux.unixwiz.net> Helo command rejected: Get lost - you're lying about who you are
'
' The list is comprised of the email addresses of the recipients seperated by commas or semicolons.
' The email addresses found in BCC are not copied into the header of the email message.
' If the mail server has conformed strictly to the SMTP specifications it may limit the
' total number recipients to 100. Strict conformance to this number is not mandatory
' so your mail server may permit more than 100 recipients.
'
30 IF LEFT$(Buffer,4) = "RCPT" THEN
Mailto = MID$(Buffer,INSTR(Buffer,"<")+1,LEN(buffer)-INSTR(Buffer,"<")-1)
'
' Get the domain of recipient
'
FieldStart = INSTR(MailTo,"@")
IF FieldStart > 0 THEN
DestinationDomain = RIGHT$(MailTo,LEN(MailTo)-FieldStart)
ELSE
DestinationDomain = ""
END IF
'
' dns check
'
IF SourceDomain <> "" THEN
Mailhost = MX_Query(SourceDomain, "203.87.88.1")
SmtpLog "Mailhost", Mailhost ,SequenceNo,Username
END IF
'
' check routing for internal mail
'
IF DestinationDomain = "" THEN
TCP SEND hSmtp, "550 Invalid Destination " + $CRLF
SmtpLog "RCPT " +MailTo+ " Invalid Destination ", "Connection Terminated",SequenceNo,Username
LogEvent "RCPT " +MailTo+ " Invalid Destination "
GOTO 10
END IF
'
' determine the destination
'
Field(1) = ""
SqlQuery " Select LocalID,EmailQuotaSize,EmailQuotaCount,Username from MailBoxes where LocalAddress = '"+MailTo+"'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN
Destination = "Local"
QuotaSize = VAL(Field(2))
QuotaCount = VAL(Field(3))
Username = Field(4)
'
' check the quotas for the mailbox
'
IF QuotaSize > 0 OR QuotaCount > 0 THEN
SqlQuery " Select Count(QueueID), Sum(EmailSize) from Queue where EmailTo = '"+MailTo+"'"
GetRecord
SqlFreeMemory
IF (QuotaCount > 0 AND VAL(Field(1)) > QuotaCount) OR _
(QuotaSize > 0 AND VAL(Field(2)) > QuotaSize) THEN
TCP SEND hSmtp, "550 MailBox Full " + $CRLF
SmtpLog "MailTo: " +MailTo+ " MailBox Full ", "Connection Terminated",SequenceNo,Username
LogEvent "MailTo: " +MailTo+ " MailBox Full "
GOTO 10
END IF
END IF
ELSE
Destination = "Forward"
'
' Is the destination a local domain
'
Field(1) = ""
IF DestinationDomain <> "" THEN
SqlQuery " Select DomainID from Domains where Domain = '"+DestinationDomain+"'"
GetRecord
SqlFreeMemory
IF VAL(Field(1)) > 0 THEN DestinationID = VAL(Field(1))
END IF
'
END IF
'
' relay check
'
IF Destination = "Forward" AND Source = "Forward" THEN
IF DestinationID = 0 THEN
TCP SEND hSmtp, "550 Relaying not permitted " + $CRLF
SmtpLog "MailTo: " +MailTo+ " Relay Attempt Blocked ", "Connection Terminated",SequenceNo,Username
LogEvent "MailTo: " +MailTo+ " Relay Attempt Blocked "
GOTO 10
ELSE
TCP SEND hSmtp, "550 MailBox Unknown " + $CRLF
SmtpLog "MailTo: " +MailTo+ " Mail Box Unknown ","Connection terminated",SequenceNo,Username
LogEvent "MailTo: " +MailTo+ " Mail Box Unknown "
GOTO 10
END IF
ELSE
TCP SEND hSmtp, "250 " + MailTo + " OK" + $CRLF
NoRecipients = NoRecipients + 1
Recipients(NoRecipients) = MailTo
SmtpLog "MailTo: " +MailTo, "RCPT Command Accepted",SequenceNo,Username
LogEvent "MailTo: " +MailTo
END IF
GOTO 10
END IF
'
' If accepted, the receiver-SMTP returns a 354 Intermediate reply
' and considers all succeeding lines to be the message text.
' When the end of text is received and stored the SMTP-receiver
' sends a 250 OK reply.
'
IF LEFT$(Buffer,4) = "DATA" THEN
'
DataAccepted = 0
'
' put a header on the email
'
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ "Received: from " +MailServer+ "; " + MailDate + $CRLF+"')
'
'
' Set the Type of the email
'
EmailType = "text/plain"
'
TCP SEND hSmtp, "354 send the mail data, end with ." + $CRLF
' LogEvent "Start Data"
'
' loop until the end of the data is received
'
50 TCP LINE hSmtp, buffer
'
' error trap
'
IF ERR > 0 THEN
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "',' Connection Failed "+ $CRLF+"')
SmtpLog "Forced End Data from "+MailFrom, "ERR " + STR$(ERR) + " Occured",SequenceNo,Username
LogEvent "Forced End Data from "+MailFrom
GOTO 60
END IF
'
' end of the data received
'
IF buffer = "." THEN GOTO 60
'
' Looping trap
'
IF Buffer = "" THEN
LoopTrap = LoopTrap + 1
ELSE
LoopTrap = 0
END IF
'
IF LoopTrap > 30 THEN
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','Data Failed"+ $CRLF+"')
SmtpLog "Forced End Data from "+MailFrom, "DATA Looped Out",SequenceNo,Username
LogEvent "Forced End Data from "+MailFrom
GOTO 60
END IF
'
'
' http encoding to avert problems with html
'
511 IF INSTR(buffer, CHR$(0)) > 0 THEN
REPLACE CHR$(0) WITH "�" IN Buffer
GOTO 511
END IF
51 IF INSTR(buffer, CHR$(34)) > 0 THEN
REPLACE CHR$(34) WITH """ IN Buffer
GOTO 51
END IF
53 IF INSTR(buffer, "'") > 0 THEN
REPLACE "'" WITH "'" IN Buffer
GOTO 53
END IF
55 IF INSTR(buffer,",") > 0 THEN
REPLACE "," WITH "," IN Buffer
GOTO 55
END IF
'
56 IF INSTR(buffer,"\") > 0 THEN
REPLACE "\" WITH "\" IN Buffer
GOTO 56
END IF
'
' determine the content type
'
IF INSTR(UCASE$(Buffer),"CONTENT-TYPE:") > 0 THEN
FieldEnd = INSTR(Buffer,";")
IF FieldEnd = 0 THEN
FieldEnd = LEN(Buffer)
EmailType = MID$(Buffer,14,FieldEnd-13)
ELSE
EmailType = MID$(Buffer,14,FieldEnd-14)
END IF
END IF
'
' subject line
'
IF INSTR(UCASE$(Buffer),"SUBJECT:") > 0 THEN
EmailSubject = MID$(Buffer,INSTR(Buffer,":")+2,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Encoding Format
'
IF INSTR(UCASE$(Buffer),"ENCODING:") > 0 THEN
Encoding = RIGHT$(Buffer,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Email date
'
IF INSTR(UCASE$(Buffer),"DATE:") > 0 THEN
EmailDate = RIGHT$(Buffer,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Message-Id:
'
IF INSTR(UCASE$(Buffer),"MESSAGE-ID:") > 0 THEN
MessageID = MID$(Buffer,INSTR(Buffer,":")+2,LEN(Buffer)-INSTR(Buffer,":")-1)
END IF
'
' Content filter the subject. If a reject word is found then exit
' no filtering on local email
'
IF Source = "Local" THEN GOTO 59
'
FOR FilterIndex = 1 TO FilterRecords
IF UCASE$(TRIM$(Encoding)) <> "BASE64" AND _
INSTR(UCASE$(Buffer),Filter(FilterIndex)) > 0 THEN
Reason = Filter(FilterIndex)
SmtpLog "Filter Detected ", Filter(FilterIndex),SequenceNo,"System"
Reject = Reject + 1
GOTO 59
END IF
IF UCASE$(TRIM$(Encoding)) = "BASE64" AND _
INSTR(UCASE$(Decode64$(Buffer,-1)),Filter(FilterIndex)) > 0 THEN
Reason = Filter(FilterIndex)
SmtpLog "Base64 Filter Detected ", Filter(FilterIndex),SequenceNo,"System"
Reject = Reject + 1
GOTO 59
END IF
NEXT FilterIndex
'
' save the email line by line instead of by block
' an number of emails have poorly formated html which appears as huge strings which
' are getting truncated so these strings are being chopped into smaller sections so
' data is not lost.
'
59 IF LEN(Buffer) < 250 THEN
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ Buffer + $CRLF+"')
ELSE
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ LEFT$(Buffer,250)+"')
Buffer = RIGHT$(Buffer, LEN(Buffer) - 250)
GOTO 59
END IF
'
TotalSize = TotalSize + LEN(Buffer)
EmailSize = EmailSize + LEN(Buffer)
'
'59 EmailData = EmailData + buffer + $CRLF
GOTO 50
'
' attach the receive header
'
'60 EmailData = "Received: from " +MailServer+ "; " + MailDate + $CRLF + EmailData
'
' Get the size of the email
'
' EmailSize = LEN(EmailData)
'
' send end of data
'
60 SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ $CRLF+"')
SqlQuery "Insert into emails values ('','" + TRIM$(STR$(SequenceNo)) + "','"+ Buffer + $CRLF+"')
TCP SEND hSmtp, "250 OK" + $CRLF
SmtpLog "End Data from "+MailFrom, "DATA Command Accepted",SequenceNo,Username
LogEvent "End Data from "+MailFrom
'
'
'
'
' Once the email data is received then save it then next
' duplicate message filter
'
100 SqlQuery " Select count(QueueID) from Queue where MessageID = '"+MessageID+"'"
GetRecord
SqlFreeMemory
'
IF VAL(Field(1)) > 0 AND MessageID <> "" THEN
SmtpLog "Message exist in the Queue " +MessageID, "Message Rejected",SequenceNo,Username
LogEvent "Message exist in the Queue " +MessageID
GOTO 999
END IF
'
SqlQuery " Select count(QueueID) from Rejects where MessageID = '"+MessageID+"'"
GetRecord
SqlFreeMemory
'
IF VAL(Field(1)) > 0 AND MessageID <> "" THEN
SmtpLog "Message exist in the Rejects " +MessageID, "Message Rejected",SequenceNo,Username
LogEvent "Message exist in the Rejects " +MessageID
GOTO 999
END IF
'
'
'
'
' Handling for Multiple Recipients
' The mail is basically the same for all the people in the Recipient list
' So entries into the queue process via a loop selecting the new Recipients
' each time. Recipients()
'
'
' If the email is to be rejected don't record the email just black whole the email
'
FOR Index = 1 TO NoRecipients
MailTo = Recipients(Index)
'
IF Reject = 0 THEN
IF (MaxEmailSize > 0 AND EmailSize < MaxEmailSize) OR Source = "Local" THEN
SqlQuery "Insert into Queue values ( '','"+MailServer+"','"+MailFrom+"','"+MailTo+"','"+_
EmailSubject +"',Now(),'','Received','"+Destination+"','" + _
STR$(EmailSize) + "','" + EmailType + "','"+MessageID+"','"+ _
STR$(Retries)+"','"+TRIM$(STR$(SequenceNo))+"','"+Encoding+"')"
SmtpLog " Mail from "+MailServer+"."+MailFrom, "Accepted for "+MailTo,SequenceNo,Username
LogEvent " Mail from "+MailServer+"."+MailFrom + "Accepted for "+MailTo
ELSE
SqlQuery "Insert into Rejects values ( '','"+MailServer+"','"+MailFrom+"','"+MailTo+"','"+_
EmailSubject +"',Now(),'SequenceNo','MaxEmailSize','"+Destination+"','" + _
STR$(EmailSize) + "','" + EmailType + "','"+MessageID+"','"+ _
STR$(Retries)+"','"+TRIM$(STR$(SequenceNo))+"','"+Encoding+"')"
SmtpLog " Mail from "+MailFrom+" exceeds MaxMailSize", "Email junked",SequenceNo,Username
LogEvent " Mail from "+MailFrom+" exceeds MaxMailSize Rejected"
END IF
EmailData = ""
SqlFreeMemory
ELSE
SqlQuery "Insert into Rejects values ( '','"+MailServer+"','"+MailFrom+"','"+MailTo+"','"+_
EmailSubject +"',Now(),'"+Reason+"','Rejected','"+Destination+"','" + _
STR$(EmailSize) + "','" + EmailType + "','"+MessageID+"','"+ _
STR$(Retries)+"','"+TRIM$(STR$(SequenceNo))+"','"+Encoding+"')"
SmtpLog " Mail from "+MailFrom+" Failed Filtering", "Rejected",SequenceNo,Username
LogEvent " Mail from "+MailFrom+" Failed Filtering and Rejected"
END IF
'
NEXT Index
'
IF Reject = 0 THEN GOTO 10
'
' Black hole reject System
' Check senderlevel for blackhole if exceeded
' if it is not in the list add to the list to be watched
' if the sender is in the blackhole list then increamnet the rejects
' if the rejects are greater than the bhl senderlevel then blackhole the sender
'
' if server is not in the list add the server to be watched
' if it is in th list increment the rejects
' if the rejects are greater than the server level then blackhole the server
'
' Basically spammers come certain senders on certain server. If the system gets
' some many emails that are rejected by the system then that sender will be blocked
' but they will change their address. So if they move to another address it will start
' again and will be blocked again if they move more than some many times and get
' blocked then the server is blocked
'
'
' is the send in the list
IF Reject = 0 THEN
Sqlquery " Select BHLID from BHL where Domain = '"+MailFrom+"'"
GetRecord
SqlFreeMemory
BHLID = VAL(TRIM$(Field(1)))
IF BHLID > 0 THEN
' sender in the list increment the rejects
Sqlquery " Update BHL set Rejects = Rejects + 1 where BHLID = "+STR$(BHLID)
' check the sender level
Sqlquery " Select Rejects from BHL where BHLID = "+STR$(BHLID)
GetRecord
SqlFreeMemory
' is the sender level exceeded black hole the sender
IF VAL(TRIM$(Field(1))) > SenderLevel THEN
Sqlquery " Update BHL set DomainStatus = 'Active' where BHLID = "+STR$(BHLID)
'
'
' is the server in the blachole list
Field(1) = ""
Sqlquery " Select BHLID from BHL where Domain = '"+MailServer+"'
GetRecord
SqlFreeMemory
BHLID = VAL(TRIM$(Field(1)))
IF BHLID > 0 THEN
' server is on the list increment the server rejects
Sqlquery " Update BHL set Rejects = Rejects + 1 where BHLID = "+STR$(BHLID)
' check the server level
Sqlquery " Select Rejects from BHL where BHLID = "+STR$(BHLID)
GetRecord
SqlFreeMemory
' is the sender level exceeded black hole the server
IF VAL(TRIM$(Field(1))) > ServerLevel THEN
Sqlquery " Update BHL set DomainStatus = 'Active' where BHLID = "+STR$(BHLID)
END IF
'
'
ELSE
' add the server to the list
Sqlquery " Insert into BHL values( '','" +MailServer +"',1,'Watching')
END IF
END IF
'
' the sender is no in the list so addit
'
ELSE
Sqlquery " Insert into BHL values( '','" +MailFrom +"',1,'Watching')
END IF
'
END IF
END IF
'
' This is the quit command to complete the email
' This command specifies that the receiver must send an OK
' reply, and then close the transmission channel.
'
' The receiver should not close the transmission channel until
' it receives and replies to a QUIT command (even if there was
' an error). The sender should not close the transmission
' channel until it send a QUIT command and receives the reply
' (even if there was an error response to a previous command).
'
' If the connection is closed prematurely the receiver should
' act as if a RSET command had been received (canceling any
' pending transaction, but not undoing any previously
' completed transaction), the sender should act as if the
' command or transaction in progress had received a temporary
' error (4xx).
90 IF LEFT$(UCASE$(Buffer),4) = "QUIT" THEN
'TCP SEND hSmtp, "221 "+$CRLF
GOTO 999
END IF
'
' This command specifies that the current mail transaction is
' to be aborted. Any stored sender, recipients, and mail data
' must be discarded, and all buffers and state tables cleared.
' The receiver must send an OK reply.
'
' The rset command can be sent between messages so a new connection
' does not have to be made again. So the current email is complete
' then the process begins again.
'
IF LEFT$(UCASE$(Buffer),4) = "RSET" THEN
TCP SEND hSmtp, "250 OK" + $CRLF
SmtpLog "RSET from "+MailFrom, "RSET Command Accepted",SequenceNo,Username
LogEvent "RSET"
GOTO 10
END IF
'
' unsupported commands
'
IF LEFT$(UCASE$(Buffer),4) = "VRFY" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "VRFY from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "VRFY from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "EXPN" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "EXPN from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "EXPN from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "SOML" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "SOML from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "SOML from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "SEND" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "SEND from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "SEND from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "TURN" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "TURN from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "TURN from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
IF LEFT$(UCASE$(Buffer),4) = "HELP" THEN
TCP SEND hSmtp, "501 OK" + $CRLF
SmtpLog "HELP from " + MailServer,"Connection terminated",SequenceNo,Username
LogEvent "HELP from " + MailServer +" Connection terminated"
GOTO 999
END IF
'
GOTO 10
'
999 SmtpLog "Session Closed " + MailServer," Connection terminated",SequenceNo,Username
LogEvent "Session Closed " + MailServer +" Connection terminated"
SqlClose
'
END FUNCTION
'------------------------------------------------------------------------------
' Callback function for the main dialog window
'
FUNCTION DlgProc (BYVAL hDlg AS DWORD, _
BYVAL wMsg AS LONG, _
BYVAL wParam AS LONG, _
BYVAL lParam AS LONG) EXPORT AS LONG
'
STATIC nServer AS LONG
'
SELECT CASE wMsg
'
' To create a TCP server, your program must first open a socket using the TCP OPEN SERVER statement.
' Then, when a client contacts your server, this socket will receive the notification.
' To specify which notifications your code will process, use the TCP NOTIFY statement:
'
CASE %WM_INITDIALOG
hList = GetDlgItem(hDlg, 101)
'
' open the socket for smtp
'
nServer = FREEFILE
TCP OPEN SERVER "smtp" AS nServer TIMEOUT 50000
IF ERR THEN
logevent "Unable to listen to smtp"
FUNCTION = 0
ELSE
'
' Notify will specify which notifications your code will process, use the TCP NOTIFY statement:
' It tells Winsock that it should send the %TCP_ACCEPT message to the window specified by nServer.
'
TCP NOTIFY nServer, ACCEPT TO hDlg AS %TCP_ACCEPT
logevent "Connected to smtp"
FUNCTION = 1
END IF
'
' The lParam& parameter to your callback will tell you what type of notification was sent:
'
CASE %TCP_ACCEPT
SELECT CASE LOWRD(lParam)
'
CASE %FD_ACCEPT
hSmtp = FREEFILE
TCP ACCEPT nServer AS hSmtp ' Create a socket to the client
TCP SEND hSmtp, "220 "+MailserverName+" ESMTP System v3.1.2" + $CRLF ' send the server connect message
SmtpThread hSmtp
CLOSE hSmtp
END SELECT
'
FUNCTION = 1
'
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE 102
EndDialog hDlg, 0
FUNCTION = 1
END SELECT
'
CASE %WM_DESTROY
TCP CLOSE nServer
LogEvent "Disconnected from Pop3"
'
CASE %WM_SYSCOMMAND
IF (wParam AND &H0FFF0) = %SC_CLOSE THEN
SendMessage hDlg, %WM_COMMAND, 102, 0
FUNCTION = 1
END IF
END SELECT
END FUNCTION
'
'------------------------------------------------------------------------------
' Main Application entry point...
'
FUNCTION WINMAIN (BYVAL hInstance AS LONG, _
BYVAL hPrevInstance AS LONG, _
BYVAL lpCmdLine AS ASCIIZ PTR, _
BYVAL iCmdShow AS LONG) AS LONG
MailserverName = "mail.abconcepts.com.au"
'
' get the server config
'
CHDIR "c:\pbmail"
GetMysqlConfig
'
DiagLevel = 2
'
' initate this program as a windows service
'
InitDecode64
'
' set the automatic blackhole levels
'
SenderLevel = 5
ServerLevel = 5
MaxEmailSize = 5000000
'
DialogBox hInstance, BYVAL 100&, %HWND_DESKTOP, CODEPTR(DlgProc)
END FUNCTION
------------------
Comment