Here's a bit of what I have. As you can see, the point of the thing is you can operate on the database anywhere you want doing anything you want. Its not limited to Sub OnAcceptMessage or the items I use. I have others too. Basically, you want to reject on specific HELO or PTR? You can put that in Sub OnHELO, or anywhere after. I've been thinking lately to move everything to OnDeliverMessage because I noticed sometimes whitelist entries don't get picked up and I believe that's because there is no spam score available (not returned from spamassassin yet). I haven't tried it yet.
Code: Select all
Option Explicit
'******************************************************************************************************************************
'********** Settings **********
'******************************************************************************************************************************
' COM authentication
Private Const ADMIN = "Administrator"
Private Const hMSPASSWORD = "supersecretpassword"
Private Const DBTABLE = "hm_black_white_list"
Private MyListDict : Set MyListDict = CreateObject("Scripting.Dictionary")
'******************************************************************************************************************************
'********** Functions **********
'******************************************************************************************************************************
Function Lookup(strRegEx, strMatch) : Lookup = False
With CreateObject("VBScript.RegExp")
.Pattern = strRegEx
.Global = False
.MultiLine = True
.IgnoreCase = True
If .Test(strMatch) Then Lookup = True
End With
End Function
Function oLookup(strRegEx, strMatch, bGlobal)
If strRegEx = "" Then strRegEx = StrReverse(strMatch)
With CreateObject("VBScript.RegExp")
.Pattern = strRegEx
.Global = bGlobal
.MultiLine = True
.IgnoreCase = True
Set oLookup = .Execute(strMatch)
End With
End Function
Function LockFile(strPath)
Const Append = 8
Const Unicode = -1
Dim i
On Error Resume Next
With CreateObject("Scripting.FileSystemObject")
For i = 0 To 30
Err.Clear
Set LockFile = .OpenTextFile(strPath, Append, True, Unicode)
If (Not Err.Number = 70) Then Exit For
Wait(1)
Next
End With
If (Err.Number = 70) Then
EventLog.Write( "ERROR: EventHandlers.vbs" )
EventLog.Write( "File " & strPath & " is locked and timeout was exceeded." )
Err.Clear
ElseIf (Err.Number <> 0) Then
EventLog.Write( "ERROR: EventHandlers.vbs : Function LockFile" )
EventLog.Write( "Error : " & Err.Number )
EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
EventLog.Write( "Source : " & Err.Source )
EventLog.Write( "Description : " & Err.Description )
Err.Clear
End If
On Error Goto 0
End Function
Function AutoBan(sIPAddress, sReason, iDuration, sType) : AutoBan = False
'
' sType can be one of the following;
' "yyyy" Year, "m" Month, "d" Day, "h" Hour, "n" Minute, "s" Second
'
Dim oApp : Set oApp = CreateObject("hMailServer.Application")
Call oApp.Authenticate(ADMIN, hMSPASSWORD)
With LockFile(TEMPDIR & "\autoban.lck")
On Error Resume Next
Dim oSecurityRange : Set oSecurityRange = oApp.Settings.SecurityRanges.ItemByName("(" & sReason & ") " & sIPAddress)
If Err.Number = 9 Then
With oApp.Settings.SecurityRanges.Add
.Name = "(" & sReason & ") " & sIPAddress
.LowerIP = sIPAddress
.UpperIP = sIPAddress
.Priority = 20
.Expires = True
.ExpiresTime = DateAdd(sType, iDuration, Now())
.Save
End With
AutoBan = True
End If
On Error Goto 0
.Close
End With
Set oApp = Nothing
End Function
Function Disconnect(sIPAddress)
With CreateObject("WScript.Shell")
.Run """C:\hMailServer\Events\Disconnect.exe"" " & sIPAddress & "", 0, True
REM EventLog.Write("Disconnect.exe " & sIPAddress & "")
End With
End Function
Function PTRLookup(strIP)
Dim strLookup, strPTR
With CreateObject("DNSLibrary.DNSResolver")
strLookup = .PTR(strIP)
End With
If strLookup = Empty Then strPTR = "No.PTR.Record" Else strPTR = strLookup End If
PTRLookup = strPTR
End Function
'******************************************************************************************************************************
'********** Dynamic Black/White lists **********
'******************************************************************************************************************************
Function MyListRegEx(MyListDict, MyNode) : MyListRegEx = ""
Dim i, a, strData, nodeRegex
Dim oRecord, oDB : Set oDB = CreateObject("ADODB.Connection")
oDB.Open "Driver={MariaDB ODBC 3.1 Driver}; Server=localhost; Database=hmailserver; User=hmailserver; Password=supersecretpassword;"
If oDB.State <> 1 Then
EventLog.Write( "MyListRegEx - ERROR: Could not connect to database" )
MyListRegEx = "VOID"
Exit Function
End If
MyListDict.RemoveAll
a = Split(MyNode, "/")
Set oRecord = oDB.Execute("SELECT * FROM " & DBTABLE & " WHERE active = 1 AND trunk = '" & a(2) & "' AND branch = '" & a(3) & "' ORDER BY id DESC;")
Do Until oRecord.EOF
If (Trim(oRecord("node")) <> "") Then
strData = strData & Trim(oRecord("node")) & "|"
myListDict.Add CStr(oRecord("id")), CStr(oRecord("node"))
End If
oRecord.MoveNext
Loop
If (Trim(strData) <> "") Then
MyListRegEx = Left(strData,Len(strData)-1)
Else
EventLog.Write("ERROR: MyListRegEx: No database entry for //" & a(2) & "/" & a(3))
MyListRegEx = "VOID"
End If
Set oRecord = Nothing
oDB.Close
Set oDB = Nothing
End Function
Function MyListStat(MyListDict, oMatchValue)
Dim strSQL, oDB, objKey
Set oDB = CreateObject("ADODB.Connection")
oDB.Open "Driver={MariaDB ODBC 3.1 Driver}; Server=localhost; Database=hmailserver; User=hmailserver; Password=supersecretpassword;"
If oDB.State <> 1 Then
EventLog.Write( "myListRegEx - ERROR: Could not connect to database" )
myListRegEx = "VOID"
Exit Function
End If
For Each objKey In myListDict
If Lookup(CStr(myListDict(objKey)), oMatchValue) Then
strSQL = "UPDATE " & DBTABLE & " SET tracked = NOW(), hits = (hits + 1) WHERE id = " & CStr(objKey) & ";"
Call oDB.Execute(strSQL)
Exit For
End If
Next
Set oDB = Nothing
End Function
Sub BlackList(oMessage, strMatch, iScore)
Dim i, Done : Done = False
If CInt(oMessage.HeaderValue("X-hMailServer-Reason-Score")) > 0 Then
i = CInt(oMessage.HeaderValue("X-hMailServer-Reason-Score"))
Else
oMessage.HeaderValue("X-hMailServer-Spam") = "YES"
i = 0
End If
oMessage.HeaderValue("X-hMailServer-Blacklist") = "YES"
oMessage.HeaderValue("X-hMailServer-Reason-0") = "BlackListed - (Score: " & iScore & ")"
oMessage.HeaderValue("X-hMailServer-Reason-Score") = iScore + i
i = 1
Do Until Done
If (oMessage.HeaderValue("X-hMailServer-BlackList-" & i) = "") Then
oMessage.HeaderValue("X-hMailServer-BlackList-" & i) = strMatch
Exit Do
Else
i = i + 1
End If
Loop
oMessage.Save
End Sub
Sub WhiteList(oMessage, strMatch)
Dim i
If (oMessage.HeaderValue("X-hMailServer-Reason-Score") > 0) Then
oMessage.HeaderValue("X-hMailServer-WhiteList") = strMatch
If oMessage.HeaderValue("X-hMailServer-Spam") <> "" Then oMessage.Headers.ItemByName("X-hMailServer-Spam").Delete
For i = 0 To 10
If (oMessage.HeaderValue("X-hMailServer-Reason-" & i) <> "") Then oMessage.Headers.ItemByName("X-hMailServer-Reason-" & i).Delete
Next
oMessage.HeaderValue("X-hMailServer-Reason-Score") = 0
oMessage.Save
End If
End Sub
Sub RansomWare(oMessage)
Dim i
If (oMessage.HeaderValue("X-hMailServer-Spam") = "YES") Then
i = CInt(oMessage.HeaderValue("X-hMailServer-Reason-Score"))
Else
oMessage.HeaderValue("X-hMailServer-Spam") = "YES"
i = 0
End If
oMessage.HeaderValue("X-hMailServer-Reason-0") = "RansomWare - (Score: 5)"
oMessage.HeaderValue("X-hMailServer-Reason-Score") = 5 + i
oMessage.Subject = ":!: RansomWare :!: " & oMessage.Subject
oMessage.Save
End Sub
'******************************************************************************************************************************
'********** hMailServer Triggers **********
'******************************************************************************************************************************
Sub OnAcceptMessage(oClient, oMessage)
Dim i, a, n, j
Dim strRegEx, Match, Matches
Dim PTR_Record
Dim oMatch, oMatchCollection
Dim strMsgBody
REM - Exclude authenticated users test
If (oClient.Username <> "") Then Exit Sub
REM - Convert message body to text string
If oMessage.Body = Empty Then
strMsgBody = RemoveHTML(oMessage.HTMLBody)
Else
strMsgBody = oMessage.Body
End If
REM - Grab PTR-Record
PTR_Record = PTRLookup(oClient.IPAddress)
REM - Reject "List-Unsubscribe:"
If oMessage.HeaderValue("List-Unsubscribe") <> "" Then
strRegEx = MyListRegEx(MyListDict, "//Reject/List-Unsubscribe")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), False)
For Each oMatch In oMatchCollection
Result.Value = 2
Result.Message = ". 08 Your access to this mail system has been rejected due to the sending MTA's poor reputation. If you believe that this failure is in error, please contact the intended recipient via alternate means."
Call Disconnect(oClient.IPAddress)
Call AutoBan(oClient.IPAddress, "Rejected List Unsubscribe - " & oClient.HELO, 1, "h")
Call MyListStat(MyListDict, oMatch.Value)
Exit Sub
Next
End If
End If
REM - Reject "X-Envelope-From:"
strRegEx = MyListRegEx(MyListDict, "//Reject/X-Envelope-From")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.FromAddress, False)
For Each oMatch In oMatchCollection
Result.Value = 2
Result.Message = ". 09 Your access to this mail system has been rejected due to the sending MTA's poor reputation. If you believe that this failure is in error, please contact the intended recipient via alternate means."
Call Disconnect(oClient.IPAddress)
Call AutoBan(oClient.IPAddress, "Rejected X-Envelope-From - " & oClient.HELO, 1, "h")
Call MyListStat(MyListDict, oMatch.Value)
Exit Sub
Next
End If
REM - Reject "From:"
strRegEx = MyListRegEx(MyListDict, "//Reject/From")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.From, False)
For Each oMatch In oMatchCollection
Result.Value = 2
Result.Message = ". 10 Your access to this mail system has been rejected due to the sending MTA's poor reputation. If you believe that this failure is in error, please contact the intended recipient via alternate means."
Call Disconnect(oClient.IPAddress)
Call AutoBan(oClient.IPAddress, "Rejected From Address - " & oClient.HELO, 1, "h")
Call MyListStat(MyListDict, oMatch.Value)
Exit Sub
Next
End If
REM - Reject "Body:"
strRegEx = MyListRegEx(MyListDict, "//Reject/Bodytxt")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, strMsgBody, False)
For Each oMatch In oMatchCollection
Result.Value = 2
Result.Message = ". 12 Your access to this mail system has been rejected due to the sending MTA's poor reputation. If you believe that this failure is in error, please contact the intended recipient via alternate means."
Call Disconnect(oClient.IPAddress)
Call AutoBan(oClient.IPAddress, "Rejected From Address - " & oClient.HELO, 1, "h")
Call MyListStat(MyListDict, oMatch.Value)
Exit Sub
Next
End If
REM - RansomWare - Body text/URL check
strRegEx = MyListRegEx(MyListDict, "//Ransomware/Bodytxt")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, strMsgBody, False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call RansomWare(oMessage)
Next
End If
REM - Extortion - Body text/URL check
strRegEx = MyListRegEx(MyListDict, "//Extortion/Bodytxt")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, strMsgBody, False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call RansomWare(oMessage)
Next
End If
REM - Extortion - SpamAssassin X-Spam-Status
strRegEx = MyListRegEx(MyListDict, "//Extortion/X-Spam-Status")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.HeaderValue("X-Spam-Status"), False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call RansomWare(oMessage)
Next
End If
REM - Additional SPAM processing
Dim Done : Done = False
If CInt(oMessage.HeaderValue("X-hMailServer-Reason-Score")) > 6 Then Done = True
Do Until Done
REM - Blacklist "Subject:"
strRegEx = MyListRegEx(MyListDict, "//Blacklist/Subject")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.Subject, False)
For Each oMatch In oMatchCollection
EventLog.Write("Blacklist/Subject called on match: " & oMatch.Value)
Call BlackList(oMessage, "//Blacklist/Subject = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
REM - Blacklist "IPRange:"
strRegEx = MyListRegEx(MyListDict, "//Blacklist/IPRange")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oClient.IPAddress, False)
For Each oMatch In oMatchCollection
Call BlackList(oMessage, "//Blacklist/IPRange = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
REM - Blacklist "X-Envelope-From:"
strRegEx = MyListRegEx(MyListDict, "//Blacklist/X-Envelope-From")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.FromAddress, False)
For Each oMatch In oMatchCollection
Call BlackList(oMessage, "//Blacklist/X-Envelope-From = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
REM - Blacklist "From:"
strRegEx = MyListRegEx(MyListDict, "//Blacklist/From")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.From, False)
For Each oMatch In oMatchCollection
Call BlackList(oMessage, "//Blacklist/From = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
REM - Blacklist Body (Plain Text)
strRegEx = MyListRegEx(MyListDict, "//Blacklist/Bodytxt")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, strMsgBody, False)
For Each oMatch In oMatchCollection
Call BlackList(oMessage, "//Blacklist/Body = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
REM - Blacklist URL-Redirects on SURBL blacklist hits
strRegEx = MyListRegEx(MyListDict, "//Blacklist/URL-Redirect")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, strMsgBody, False)
For Each oMatch In oMatchCollection
If IsInSurbl(oMatch.Value) Then
Call BlackList(oMessage, "//Blacklist/URL-Redirect (multi.surbl.org) = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
End If
If IsInSpamHausDBL(oMatch.Value) Then
Call BlackList(oMessage, "//Blacklist/URL-Redirect (dbl.spamhaus.org) = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
End If
Next
End If
REM - Blacklist PTR
strRegEx = MyListRegEx(MyListDict, "//Blacklist/PTR")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, PTR_Record, False)
For Each oMatch In oMatchCollection
Call BlackList(oMessage, "//Blacklist/PTR = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
REM - Blacklist HELO
strRegEx = MyListRegEx(MyListDict, "//Blacklist/HELO")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oClient.HELO, False)
For Each oMatch In oMatchCollection
Call BlackList(oMessage, "//Blacklist/HELO = '" & oMatch.Value & "'", 5)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
REM - BLACKHOLE "X-Envelope-From:"
strRegEx = MyListRegEx(MyListDict, "//Blackhole/X-Envelope-From")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.FromAddress, False)
For Each oMatch In oMatchCollection
Call BlackList(oMessage, "//Blackhole/X-Envelope-From = '" & oMatch.Value & "'", 25)
Call MyListStat(MyListDict, oMatch.Value)
' Exit Do
Next
End If
Done = True
Loop
REM - Whitelisting
If CInt(oMessage.HeaderValue("X-hMailServer-Reason-Score")) > 0 Then
REM - Whitelist "EHLO:"
strRegEx = MyListRegEx(MyListDict, "//Whitelist/HELO")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oClient.HELO, False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call WhiteList(oMessage, "//Whitelist/HELO = '" & oMatch.Value & "'")
Exit Sub
Next
End If
REM - Whitelist "PTR:"
strRegEx = MyListRegEx(MyListDict, "//Whitelist/PTR")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, PTR_Record, False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call WhiteList(oMessage, "//Whitelist/PTR = '" & oMatch.Value & "'")
Exit Sub
Next
End If
REM - Whitelist "X-Envelope-From:"
strRegEx = MyListRegEx(MyListDict, "//Whitelist/X-Envelope-From")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.FromAddress, False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call WhiteList(oMessage, "//Whitelist/X-Envelope-From = '" & oMatch.Value & "'")
Next
End If
REM - Whitelist "From:"
strRegEx = MyListRegEx(MyListDict, "//Whitelist/From")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.From, False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call WhiteList(oMessage, "//Whitelist/From = '" & oMatch.Value & "'")
Next
End If
REM - Whitelist "Subject:"
strRegEx = MyListRegEx(MyListDict, "//Whitelist/Subject")
If strRegEx <> "VOID" Then
Set oMatchCollection = oLookup(strRegEx, oMessage.Subject, False)
For Each oMatch In oMatchCollection
Call MyListStat(MyListDict, oMatch.Value)
Call WhiteList(oMessage, "//Whitelist/Subject = '" & oMatch.Value & "'")
Next
End If
End If
End Sub