Dynamic Black/Whitelists in your script.

This section contains scripts that hMailServer has contributed with. hMailServer 5 is needed to use these.
User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 12:02

I added your "log writes" to my code and "(fluke off niagara)" to my database...

Code: Select all

2532	"2021-10-16 11:47:31.001"	"key count  : 1"
2532	"2021-10-16 11:47:31.001"	"match count: 1"
2532	"2021-10-16 11:47:31.001"	"i        : 0"
2532	"2021-10-16 11:47:31.001"	"key      : 345"
2532	"2021-10-16 11:47:31.001"	"submatch : fluke off niagara"
I only have one (1) record with "Blacklist/Subject" and active=1
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 12:27

Hmm...

Try shifting these around like this ...

Code: Select all

Call MyListStat(MyListDict, oMatch)
Call BlackList(oMessage, "//Blacklist/Subject = '" & oMatch.Value & "'", 5)
Call AccRejDB(msgID, oClient.Port, "OnAcceptMessage", "REJECTED", "BL-Subject", oClient.IPAddress, "Matching string: " & oMatch.Value)
Can you check if you "Nothing" oMatch in Function BlackList ?
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-16 13:32

SorenR wrote:
2021-10-16 12:02
I added your "log writes" to my code and "(fluke off niagara)" to my database...

Code: Select all

2532	"2021-10-16 11:47:31.001"	"key count  : 1"
2532	"2021-10-16 11:47:31.001"	"match count: 1"
2532	"2021-10-16 11:47:31.001"	"i        : 0"
2532	"2021-10-16 11:47:31.001"	"key      : 345"
2532	"2021-10-16 11:47:31.001"	"submatch : fluke off niagara"
I only have one (1) record with "Blacklist/Subject" and active=1
Why is oMatch - as its sent to MyListStat() - an array in MyListStat() when its a single match value in the filter that calls MyListStat?

In other words:

Code: Select all

		REM - Blacklist "Subject:"
		Set oMatch = Nothing
		Set oMatchCollection = Nothing
		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 & "'", 1)
				Call MyListStat(MyListDict, oMatch)
				' Call AccRejDB(msgID, oClient.Port, "OnAcceptMessage", "REJECTED", "BL-Subject", oClient.IPAddress, "Matching string: " & oMatch.Value)
				Exit Do
			Next
		End If
Why is "Call MyListStat(MyListDict, oMatch)" not "Call MyListStat(MyListDict, oMatch.Value)" *AND* why is there a for loop in MyListStat() for oMatch? For each means 1 only.

Not to mention, why is oMatch.SubMatches.Count so off? Shouldn't the count be 1 always? Especially since I added Set o.. = Nothing to the top of every filter. Could sending only the match value solve the issue?

I have little league baseball and a big honeydo list, so I can't test until tonight.

(also, I did move them around and even added more debugging)

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 14:53

palinka wrote:
2021-10-16 13:32
SorenR wrote:
2021-10-16 12:02
I added your "log writes" to my code and "(fluke off niagara)" to my database...

Code: Select all

2532	"2021-10-16 11:47:31.001"	"key count  : 1"
2532	"2021-10-16 11:47:31.001"	"match count: 1"
2532	"2021-10-16 11:47:31.001"	"i        : 0"
2532	"2021-10-16 11:47:31.001"	"key      : 345"
2532	"2021-10-16 11:47:31.001"	"submatch : fluke off niagara"
I only have one (1) record with "Blacklist/Subject" and active=1
Why is oMatch - as its sent to MyListStat() - an array in MyListStat() when its a single match value in the filter that calls MyListStat?

In other words:

Code: Select all

		REM - Blacklist "Subject:"
		Set oMatch = Nothing
		Set oMatchCollection = Nothing
		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 & "'", 1)
				Call MyListStat(MyListDict, oMatch)
				' Call AccRejDB(msgID, oClient.Port, "OnAcceptMessage", "REJECTED", "BL-Subject", oClient.IPAddress, "Matching string: " & oMatch.Value)
				Exit Do
			Next
		End If
Why is "Call MyListStat(MyListDict, oMatch)" not "Call MyListStat(MyListDict, oMatch.Value)" *AND* why is there a for loop in MyListStat() for oMatch? For each means 1 only.

Not to mention, why is oMatch.SubMatches.Count so off? Shouldn't the count be 1 always? Especially since I added Set o.. = Nothing to the top of every filter. Could sending only the match value solve the issue?

I have little league baseball and a big honeydo list, so I can't test until tonight.

(also, I did move them around and even added more debugging)
The fact that your key count and match count do NOT match tell me you have a problem BEFORE running MyListStat().

Also, you need to look at your database and verify content.
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 15:28

Hmm...

Somethin's fishy :roll:

Extensifying logging inside an "On Error" bubble ...
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 16:04

For some reason RegEx find more "submatches" than there is...

Code: Select all

5924	"2021-10-16 15:17:28.375"	"Function myListsRegEx(myListsDict, MyNode)"
5924	"2021-10-16 15:17:28.391"	"key count  : 21"
5924	"2021-10-16 15:17:28.391"	"match value: ^(.*\.shop)$|^(.*\.one)$|^(.*\.top)$|^(.*\.xyz)$|^(.*\.cam)$|^(.*\.icu)$|(127(?:\.[0-9]{1,3}){3})|^(localhost\.localdomain)$|^(lolle\.org)$|^(.*\.bar)$|^(.*\.club)$|^(.*\.today)$|^(.*\.guru)$|^(.*\.tk)$|^(.*\.ml)$|^(.*\.work)$|^(.*\.buzz)$|^(.*\.co)$|^(.*\.cyou)$|^(amazon\.co\.jp)$|^(.*\.rest)$"
5924	"2021-10-16 15:17:28.391"	""
5924	"2021-10-16 15:17:28.391"	"Function myListsStat(myListsDict, oMatch)"
5924	"2021-10-16 15:17:28.391"	"key count  : 21"
5924	"2021-10-16 15:17:28.391"	"match count: 22"
5924	"2021-10-16 15:17:28.391"	"match value: spinblind.co"
5924	"2021-10-16 15:17:28.391"	"  i        : 0"
5924	"2021-10-16 15:17:28.391"	"  key      : 10"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 1"
5924	"2021-10-16 15:17:28.391"	"  key      : 11"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 2"
5924	"2021-10-16 15:17:28.391"	"  key      : 13"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 3"
5924	"2021-10-16 15:17:28.391"	"  key      : 15"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 4"
5924	"2021-10-16 15:17:28.391"	"  key      : 16"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 5"
5924	"2021-10-16 15:17:28.391"	"  key      : 17"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 6"
5924	"2021-10-16 15:17:28.391"	"  key      : 155"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 7"
5924	"2021-10-16 15:17:28.391"	"  key      : 156"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 8"
5924	"2021-10-16 15:17:28.391"	"  key      : 157"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 9"
5924	"2021-10-16 15:17:28.391"	"  key      : 158"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 10"
5924	"2021-10-16 15:17:28.391"	"  key      : 281"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 11"
5924	"2021-10-16 15:17:28.391"	"  key      : 285"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.391"	"  i        : 12"
5924	"2021-10-16 15:17:28.391"	"  key      : 286"
5924	"2021-10-16 15:17:28.391"	"  submatch : "
5924	"2021-10-16 15:17:28.407"	"  i        : 13"
5924	"2021-10-16 15:17:28.407"	"  key      : 289"
5924	"2021-10-16 15:17:28.407"	"  submatch : "
5924	"2021-10-16 15:17:28.407"	"  i        : 14"
5924	"2021-10-16 15:17:28.407"	"  key      : 290"
5924	"2021-10-16 15:17:28.407"	"  submatch : "
5924	"2021-10-16 15:17:28.407"	"  i        : 15"
5924	"2021-10-16 15:17:28.407"	"  key      : 291"
5924	"2021-10-16 15:17:28.407"	"  submatch : "
5924	"2021-10-16 15:17:28.407"	"  i        : 16"
5924	"2021-10-16 15:17:28.407"	"  key      : 292"
5924	"2021-10-16 15:17:28.407"	"  submatch : "
5924	"2021-10-16 15:17:28.407"	"  i        : 17"
5924	"2021-10-16 15:17:28.407"	"  key      : 293"
5924	"2021-10-16 15:17:28.407"	"  submatch : spinblind.co"
Regex101 matches "spinblind.co" as Group 18 ==> i = 17 ...
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-16 16:25

SorenR wrote:
2021-10-16 16:04
For some reason RegEx find more "submatches" than there is...
Right? That's my problem exactly. I'm surprised you haven't seen out of range errors like i have.

Maybe the solution is to construct every node to match beginning and end. That way there could not possibly additional matches? In shooting in the dark here...

(^.*(node).*$)

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 16:33

palinka wrote:
2021-10-16 16:25
SorenR wrote:
2021-10-16 16:04
For some reason RegEx find more "submatches" than there is...
Right? That's my problem exactly. I'm surprised you haven't seen out of range errors like i have.

Maybe the solution is to construct every node to match beginning and end. That way there could not possibly additional matches? In shooting in the dark here...

(^.*(node).*$)
I have probably run a few million emails through this on all sorts of levels and never had the dreaded "out of range" error. It is deffo in the design of the RegEx.

I've gone into combat mode trying to figure this shyte out... In the meantime ...

Code: Select all

        On Error Resume Next
        For i = 0 To oMatch.SubMatches.Count-1
            If Not IsEmpty(oMatch.SubMatches(i)) Then
                strSQL = "UPDATE " & DBTABLE & " SET tracked = NOW(), hits = (hits + 1) WHERE id = " & a(i) & ";"
                Call oDB.Execute(strSQL)
                Exit For
            End If
        Next
        On Error GoTo 0
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 16:45

If you have strRegEx = "(^(text)$)" you really have two (2) groups matching "text" thus you have two submatches in oMatchCollection :shock:
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 17:03

Hmm...

2 groups ... two submatches in oMatchCollection

strRegEx = "(127(?:\.[0-9]{1,3}){3})"
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-16 17:25

SorenR wrote:
2021-10-16 16:33
I've gone into combat mode trying to figure this shyte out...
Never go to war with vikings. :mrgreen:
SorenR wrote:
2021-10-16 17:03
Hmm...

2 groups ... two submatches in oMatchCollection

strRegEx = "(127(?:\.[0-9]{1,3}){3})"
I think i have it. First off all, everything works except sometimes on MyListStat(). Nothing wrong with the rest of the code.

Possible solution: in the filter, send only the match value to MyListStat(). Then reverse the operation. Match the node to the filter-found match value.

Baseball over. Now it's time for all you can eat sushi as the boy's reward for a good game. He picked the restaurant. Then honeydo list. I won't get to testing new code until tonight.

Edit - the alternative is to just get rid of MyListStat altogether. It's informative, but not operative.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-16 19:58

palinka wrote:
2021-10-16 17:25
SorenR wrote:
2021-10-16 16:33
I've gone into combat mode trying to figure this shyte out...
Never go to war with vikings. :mrgreen:
SorenR wrote:
2021-10-16 17:03
Hmm...

2 groups ... two submatches in oMatchCollection

strRegEx = "(127(?:\.[0-9]{1,3}){3})"
I think i have it. First off all, everything works except sometimes on MyListStat(). Nothing wrong with the rest of the code.

Possible solution: in the filter, send only the match value to MyListStat(). Then reverse the operation. Match the node to the filter-found match value.

Baseball over. Now it's time for all you can eat sushi as the boy's reward for a good game. He picked the restaurant. Then honeydo list. I won't get to testing new code until tonight.

Edit - the alternative is to just get rid of MyListStat altogether. It's informative, but not operative.
The ting is.... When MyListRegEx build strRegEx everything fits...

Dictionary - ID = record number, NODE = RegEx element.
myListRegex - Concatenated string of all RegEx element.

Up to this level the two lists correlate.

Problem occurs as RegEx interpret the groups. Some RegEx elements end up occupying than one group and this is where the lists become skewed.

Unfortunately VBScript RegEx do not support named groups otherwise it could make things easier.
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-16 22:33

I'm boning up on multi dimensional arrays.

User avatar
mattg
Moderator
Moderator
Posts: 22435
Joined: 2007-06-14 05:12
Location: 'The Outback' Australia

Re: Dynamic Black/Whitelists in your script.

Post by mattg » 2021-10-17 02:57

palinka wrote:
2021-10-16 22:33
I'm boning up on multi dimensional arrays.
Whatever you are into really...if that makes you happy?

Or is it only in Australia, where 'boning up' is a sexual reference, meaning where a bloke would get aroused.
Just 'cause I link to a page and say little else doesn't mean I am not being nice.
https://www.hmailserver.com/documentation

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-17 03:02

mattg wrote:
2021-10-17 02:57
palinka wrote:
2021-10-16 22:33
I'm boning up on multi dimensional arrays.
Whatever you are into really...if that makes you happy?

Or is it only in Australia, where 'boning up' is a sexual reference, meaning where a bloke would get aroused.
https://www.merriam-webster.com/dictionary/bone%20up

bone up verb
boned up; boning up; bones up

Definition of bone up
intransitive verb

1: to try to master necessary information quickly : CRAM
//bone up for the exam

2: to renew one's skill or refresh one's memory
//boned up on the speech just before giving it

In other news, arrays are hard and anyway its already part of soren's script. no need to reinvent the wheel.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-17 03:49

SorenR wrote:
2021-10-16 19:58
palinka wrote:
2021-10-16 17:25
SorenR wrote:
2021-10-16 16:33
I've gone into combat mode trying to figure this shyte out...
Never go to war with vikings. :mrgreen:
SorenR wrote:
2021-10-16 17:03
Hmm...

2 groups ... two submatches in oMatchCollection

strRegEx = "(127(?:\.[0-9]{1,3}){3})"
I think i have it. First off all, everything works except sometimes on MyListStat(). Nothing wrong with the rest of the code.

Possible solution: in the filter, send only the match value to MyListStat(). Then reverse the operation. Match the node to the filter-found match value.

Baseball over. Now it's time for all you can eat sushi as the boy's reward for a good game. He picked the restaurant. Then honeydo list. I won't get to testing new code until tonight.

Edit - the alternative is to just get rid of MyListStat altogether. It's informative, but not operative.
The ting is.... When MyListRegEx build strRegEx everything fits...

Dictionary - ID = record number, NODE = RegEx element.
myListRegex - Concatenated string of all RegEx element.

Up to this level the two lists correlate.

Problem occurs as RegEx interpret the groups. Some RegEx elements end up occupying than one group and this is where the lists become skewed.

Unfortunately VBScript RegEx do not support named groups otherwise it could make things easier.
I got it. Like I said, do it in reverse. From the filter, send only the match value to function MyListStat(). Then use myListDict to test against the match value in order to find the correct key. Here's my test script, which works. I haven't implemented it into eventhandlers yet.

Code: Select all

Option Explicit

Private MyListDict : Set MyListDict = CreateObject("Scripting.Dictionary")
Private Const DBTABLE  = "hm_black_white_list"

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 myListRegEx(myListDict, MyNode)
    Dim i, a, strData
    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
        WScript.Echo( "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) & "';")
    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
        myListRegEx = "VOID"
    End If
    Set oRecord = Nothing
    oDB.Close
    Set oDB = Nothing
End Function

Function MyListStat(MyListDict, oMatchValue)
	Dim i, a, b, Match, Matches, strRegEx, strSQL, 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
		WScript.Echo( "myListRegEx - ERROR: Could not connect to database" )
		myListRegEx = "VOID"
		Exit Function
	End If

	a = myListDict.Keys
	b = myListDict.Items

	WScript.Echo("key count     : " & myListDict.Count)

	If myListDict.Count > 0 Then
		For i = 0 to myListDict.Count-1
			WScript.Echo a(i)
			WScript.Echo b(i)
			Set Matches = oLookup(b(i), oMatchValue, False)
			For Each Match In Matches
				strSQL = "UPDATE " & DBTABLE & " SET tracked = NOW(), hits = (hits + 1) WHERE id = " & a(i) & ";"
				Call oDB.Execute(strSQL)
				Exit For
			Next
		Next
	End If
	Set oDB = Nothing
End Function

Dim strRegEx, oMatch, oMatchCollection
Dim strStr : strStr = "mail-qk1-f180.google.com"

REM - Blacklist "HELO:"
strRegEx = MyListRegEx(MyListDict, "//Blacklist/HELO")
WScript.Echo("strRegEx: " & strRegEx)
If strRegEx <> "VOID" Then
	Set oMatchCollection = oLookup(strRegEx, strStr, False)
	For Each oMatch In oMatchCollection
		WScript.Echo("Blacklist/HELO called on match: " & oMatch.Value)
		Call MyListStat(MyListDict, oMatch.Value)
	Next
End If
Last edited by palinka on 2021-10-17 04:12, edited 1 time in total.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-17 04:10

Just implemented it in eventhandlers and no more errors. Everything works. Hits count increases properly now on test message from gmail.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-17 11:50

palinka wrote:
2021-10-17 04:10
Just implemented it in eventhandlers and no more errors. Everything works. Hits count increases properly now on test message from gmail.
Nice catch ;-)

Only thing that bugs me is that it takes a little more ressources on a busy server. That is one of my "things" ... Saving CPU cycles = Saving CO2 :mrgreen:

https://www.youtube.com/watch?v=eUsF8FKB25U
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-17 13:10

SorenR wrote:
2021-10-17 11:50
palinka wrote:
2021-10-17 04:10
Just implemented it in eventhandlers and no more errors. Everything works. Hits count increases properly now on test message from gmail.
Nice catch ;-)

Only thing that bugs me is that it takes a little more ressources on a busy server. That is one of my "things" ... Saving CPU cycles = Saving CO2 :mrgreen:

https://www.youtube.com/watch?v=eUsF8FKB25U
Then run the for loop in reverse because it's pulling the nodes in order of ID ascending by default and its more likely to catch newer ones than older because of the evolution of spam. Or order the sql to do the same. :mrgreen:

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-17 14:12

Code: Select all

Function myListStat(myListDict, oMatchValue)
    Dim i, a, b
    Dim strSQL, 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
        WScript.Echo( "myListRegEx - ERROR: Could not connect to database" )
        myListRegEx = "VOID"
        Exit Function
    End If
    a = myListDict.Keys
    b = myListDict.Items
    If myListDict.Count > 0 Then
        For i = 0 to myListDict.Count-1
            If Lookup(b(i), oMatchValue) Then
                strSQL = "UPDATE " & DBTABLE & " SET tracked = NOW(), hits = (hits + 1) WHERE id = " & a(i) & ";"
                Call oDB.Execute(strSQL)
                Exit For
            End If
        Next
    End If
    Set oDB = Nothing
End Function
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-17 14:20

SorenR wrote:
2021-10-17 14:12

Code: Select all

Function myListStat(myListDict, oMatchValue)
    Dim i, a, b
    Dim strSQL, 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
        WScript.Echo( "myListRegEx - ERROR: Could not connect to database" )
        myListRegEx = "VOID"
        Exit Function
    End If
    a = myListDict.Keys
    b = myListDict.Items
    If myListDict.Count > 0 Then
        For i = 0 to myListDict.Count-1
            If Lookup(b(i), oMatchValue) Then
                strSQL = "UPDATE " & DBTABLE & " SET tracked = NOW(), hits = (hits + 1) WHERE id = " & a(i) & ";"
                Call oDB.Execute(strSQL)
                Exit For
            End If
        Next
    End If
    Set oDB = Nothing
End Function
👍

I still think you'll get some extra mileage out of ordering the sql by id descending. :D

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-17 14:27

Code: Select all

Function myListsStat(myListsDict, oMatchValue)
    Dim i, objKey
    Dim strSQL, oDB : Set oDB = CreateObject("ADODB.Connection")
    oDB.Open "DRIVER={" & DBDRVR & "};Server=" & DBSERVER & ";Port=" & DBPORT & ";Database=" & DBNAME & ";Uid=" & DBUID & ";Pwd=" & DBPW & ";FOUND_ROWS=1;"
    If oDB.State <> 1 Then
        EventLog.Write( "myListsRegEx - ERROR: Could not connect to database" )
        myListsRegEx = "VOID"
        Exit Function
    End If
    For Each objKey In myListsDict
        If Lookup(CStr(myListsDict(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
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-17 16:01

SorenR wrote:
2021-10-17 14:27

Code: Select all

Function myListsStat(myListsDict, oMatchValue)
    Dim i, objKey
    Dim strSQL, oDB : Set oDB = CreateObject("ADODB.Connection")
    oDB.Open "DRIVER={" & DBDRVR & "};Server=" & DBSERVER & ";Port=" & DBPORT & ";Database=" & DBNAME & ";Uid=" & DBUID & ";Pwd=" & DBPW & ";FOUND_ROWS=1;"
    If oDB.State <> 1 Then
        EventLog.Write( "myListsRegEx - ERROR: Could not connect to database" )
        myListsRegEx = "VOID"
        Exit Function
    End If
    For Each objKey In myListsDict
        If Lookup(CStr(myListsDict(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
Done. :D

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-18 00:50

PHP interface attached. Minor improvements since last version.
Attachments
dynbl.zip
(7.95 KiB) Downloaded 252 times

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-18 12:20

One more small change. Sorting now works as follows: active hits (greater than 0) in order of tracked (timestamp) descending.

Therefore, inactive appear at the end; hits>0 appear in timestamp desc order (so you will always see the last hit at the very top, then the next to last, etc), then finally hits=0.

I think this ordering is the most "dashboard" informative way to view them. If you want them ordered differently, search for the sql stmt in index.php that contains ORDER BY.

Of course, you can search for any particular node, or list them by trunk/branch grouping.
Attachments
dynbl.zip
(7.97 KiB) Downloaded 269 times

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-21 22:17

SorenR wrote:
2019-03-17 14:31
SUCCESS! It turns out those guys at Namecheap are awesome!

Domains are still listed in Whois BUT! mxtoolbox cannot find the suspended ones so it appear they have no DNS records. :mrgreen:
Hello,

Thank you for your email.

While the following domain names are registered with Namecheap, they are hosted with another company:

acceptmiss.icu
almonlycian.icu
fruitweed.icu
gratefulcode.icu
hurtsail.icu
huttap.icu
limitedjest.icu
nascapacify.icu
springbeg.icu
tolerantload.icu

That is why we cannot check the logs for the domains and confirm if they are involved in sending unsolicited bulk emails.

However, it seems the domain names are listed in Spamhaus DBL and SURBL. Since we consider them to be trusted organizations, we opened a case regarding the domain names. Please allow us about 48 hours for our further investigation.

Additionally, please be informed that the following domain names have been suspended:

bozoiritis.icu
choosemyth.icu
comeheptad.icu
fulltool.icu
grantithiel.icu
gutflecky.icu
journalfear.icu
judgmentrub.icu
jutelysias.icu
kiddokumasi.icu
penzaabbrev.icu
pivotkitted.icu
rundumper.icu
sampjellib.icu
scandalarmy.icu
shaleburton.icu
slaminn.icu
slotflu.icu
spaetucket.icu
wasteupcast.icu

Thank you for letting us know about the issue.

------------------------
Regards,
Xxxxxx Xx. (redacted by SorenR according to GDPR)
Legal & Abuse Department
Namecheap Team

Ticket Details
Ticket ID: JBB-179-XXXXX (redacted by SorenR according to GDPR)
Department: Domains -- Legal and Abuse
Type: Issue
Status: Awaiting Client Response
Priority: High

Helpdesk: https://support.namecheap.com/index.php?
I was reminded of this today (while fighting spam like a ninja), so I looked it up here on this thread. Did you automate these messages to namecheap?

Also, did you actually receive spam on these domains or were they simply caught up in your black/white list script? Seems like you'd have to offer proof of spamming like the eml as attachment.

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-10-21 23:19

Well....

I have not used that for a very long time but ...

Code: Select all

      strRegEx = GetXMLNode(XMLDATA, "//UCE/namesilo")
      Set oMatches = oLookup(strRegEx, Client_HELO, False)
      For Each oMatch In oMatches
          If (oClient.IPAddress = Client_IP) Then
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(" ", 16, " ") & vbTab & Client_HELO )
          Else
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & Client_HELO )
          End If
          Call ReportUCE(oMessage, "abuse@namesilo.com")
          xmlStats( "//UCE/namesilo/" & oMatch.Value )
      Next
      If oMatches.Count > 0 Then Exit Do
      '
      '   abuse@namecheap.com
      '
      strRegEx = GetXMLNode(XMLDATA, "//UCE/namecheap")
      Set oMatches = oLookup(strRegEx, Client_HELO, False)
      For Each oMatch In oMatches
          If (oClient.IPAddress = Client_IP) Then
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(" ", 16, " ") & vbTab & Client_HELO )
          Else
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & Client_HELO )
          End If
          Call ReportUCE(oMessage, "postmaster@acme.inc")
          If BanClassC(Client_IP) Then
              If (oClient.IPAddress = Client_IP) Then
                  EventLogX.Write( LPad("Ban Class C", 15, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(" ", 16, " ") & vbTab & Client_HELO )
              Else
                  EventLogX.Write( LPad("Ban Class C", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & Client_HELO )
              End If
              Call ReportUCE(oMessage, "postmaster@acme.inc")
          End If
          xmlStats( "//UCE/namecheap/" & oMatch.Value )
      Next

Code: Select all

Function ReportUCE(oMessage, strContact)
    '
    '   Forbrugerombudsmanden,         dansk@spamklage.dk
    '   Danish Consumer Ombudsman,       int@spamklage.dk
    '   Federal Trade Commission (FTC), spam@uce.gov
    '
    '   https://api.hackertarget.com/whois/?q=google.com
    '   find email i text: strRegEx = "([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+\.[a-zA-Z0-9_-]+)"
    '   find email i text: strRegEx = "([\w.]+)\@(\w+\.\w+)(\.\w+)?"
    '
    Dim UCE(3)
    UCE(0) = Array( "Whois Abuse Contact", strContact )
    UCE(1) = Array( "Danish Consumer Ombudsman", "wile.e.coyote@acme.inc" )
    UCE(2) = Array( "Federal Trade Commission (FTC)", "road.runner@acme.inc" )
    UCE(3) = Array( "Automated UCE/SPAM Defence", "spam@acme.inc" )

    '   UCE(0) = Array( "Whois Abuse Contact", strContact )
    '   UCE(1) = Array( "Danish Consumer Ombudsman", "int@spamklage.dk" )
    '   UCE(2) = Array( "Federal Trade Commission (FTC)", "spam@uce.gov" )
    '   UCE(3) = Array( "Automated UCE/SPAM Defence", "spam@acme.inc" )

    With CreateObject("hMailServer.Message")
        .AddRecipient  UCE(0)(0), UCE(0)(1)
        .AddRecipient  UCE(1)(0), UCE(1)(1)
        .AddRecipient  UCE(2)(0), UCE(2)(1)
        .AddRecipient  UCE(3)(0), UCE(3)(1)
        .FromAddress = UCE(3)(1)
        .HeaderValue("To")   = Chr(34) & UCE(0)(0) & Chr(34) & " <" & UCE(0)(1) & ">"
        .HeaderValue("Cc")   = Chr(34) & UCE(1)(0) & Chr(34) & " <" & UCE(1)(1) & ">, " & _
        Chr(34) & UCE(2)(0) & Chr(34) & " <" & UCE(2)(1) & ">"
        .HeaderValue("From") = Chr(34) & UCE(3)(0) & Chr(34) & " <" & UCE(3)(1) & ">"
        Select Case LCase(Right(oMessage.HeaderValue("X-Envelope-HELO"),4))
            Case ".icu"
            .Subject = "Automated UCE/SPAM Report! Sender = " & oMessage.From
            .Body    = "Attached please find SPAM mail in .eml format." & vbCrLf & vbCrLf & _
            "Originating server is identified as [" & oMessage.HeaderValue("X-Envelope-HELO") & "] on IP Address " & oMessage.HeaderValue("X-Envelope-IPAddress")  & vbCrLf & vbCrLf & _
            "Domain registrar, US based Namecheap Inc., is responsible for registering .ICU domains and have been instrumental in diabling" & vbCrLf & _
            "several hundred domains so far, but it never stops. The spammers have adoptet the " & Chr(34) & "SnowShoe SPAM" & Chr(34) & " principle sending from the same domain " & vbCrLf & _
            "up to 6 emails to each " & Chr(34) & "victim" & Chr(34) & " before moving on to the next domain. Domain names are made by merging two everyday words together " & vbCrLf & _
            "appended with the .ICU TLD." & vbCrLf & _
            "Whois information show the domain registrant as:" & vbCrLf & vbCrLf & _
            "Registrant Organization: WhoisGuard, Inc." & vbCrLf & _
            "Registrant State/Province: Panama" & vbCrLf & _
            "Registrant Country: PA" & vbCrLf & _
            "Registrant Email: Please query the RDDS service of the Registrar of Record identified in this output for information on how to contact the Registrant, Admin, or Tech contact of the queried domain name." & vbCrLf & _
            "Admin Email: Please query the RDDS service of the Registrar of Record identified in this output for information on how to contact the Registrant, Admin, or Tech contact of the queried domain name." & vbCrLf & _
            "Tech Email: Please query the RDDS service of the Registrar of Record identified in this output for information on how to contact the Registrant, Admin, or Tech contact of the queried domain name." & vbCrLf & vbCrLf & _
            "WhoisGuard Inc. is not interrested in disclosing information about the registrant." & vbCrLf & vbCrLf & _
            "*********************************************************************************************" & vbCrLf & _
            "*** This message will repeat itself for every UCE/SPAM mail received from an .ICU domain. ***" & vbCrLf & _
            "*********************************************************************************************"
            Case Else
            .Subject = "Returning unused UCE/SPAM!"
            .Body = "Thanks for trying, but we are NOT interested! The original sender is violating EU GDPR law."
        End Select
        .Attachments.Add(oMessage.Filename)
        .Save
    End With
End Function
I ended up logging all the domains and sending them a list every 2 weeks or so. We got to know each other quite well for a while. Then I just moved on to reject if HELO said .ICO or whatever other unwanted TLD.
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-22 03:32

SorenR wrote:
2021-10-21 23:19
Well....

I have not used that for a very long time but ...

Code: Select all

      strRegEx = GetXMLNode(XMLDATA, "//UCE/namesilo")
      Set oMatches = oLookup(strRegEx, Client_HELO, False)
      For Each oMatch In oMatches
          If (oClient.IPAddress = Client_IP) Then
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(" ", 16, " ") & vbTab & Client_HELO )
          Else
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & Client_HELO )
          End If
          Call ReportUCE(oMessage, "abuse@namesilo.com")
          xmlStats( "//UCE/namesilo/" & oMatch.Value )
      Next
      If oMatches.Count > 0 Then Exit Do
      '
      '   abuse@namecheap.com
      '
      strRegEx = GetXMLNode(XMLDATA, "//UCE/namecheap")
      Set oMatches = oLookup(strRegEx, Client_HELO, False)
      For Each oMatch In oMatches
          If (oClient.IPAddress = Client_IP) Then
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(" ", 16, " ") & vbTab & Client_HELO )
          Else
              EventLogX.Write( LPad("Returned UCE", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & Client_HELO )
          End If
          Call ReportUCE(oMessage, "postmaster@acme.inc")
          If BanClassC(Client_IP) Then
              If (oClient.IPAddress = Client_IP) Then
                  EventLogX.Write( LPad("Ban Class C", 15, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(" ", 16, " ") & vbTab & Client_HELO )
              Else
                  EventLogX.Write( LPad("Ban Class C", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(Client_IP, 16, " ") & vbTab & Client_HELO )
              End If
              Call ReportUCE(oMessage, "postmaster@acme.inc")
          End If
          xmlStats( "//UCE/namecheap/" & oMatch.Value )
      Next

Code: Select all

Function ReportUCE(oMessage, strContact)
    '
    '   Forbrugerombudsmanden,         dansk@spamklage.dk
    '   Danish Consumer Ombudsman,       int@spamklage.dk
    '   Federal Trade Commission (FTC), spam@uce.gov
    '
    '   https://api.hackertarget.com/whois/?q=google.com
    '   find email i text: strRegEx = "([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+\.[a-zA-Z0-9_-]+)"
    '   find email i text: strRegEx = "([\w.]+)\@(\w+\.\w+)(\.\w+)?"
    '
    Dim UCE(3)
    UCE(0) = Array( "Whois Abuse Contact", strContact )
    UCE(1) = Array( "Danish Consumer Ombudsman", "wile.e.coyote@acme.inc" )
    UCE(2) = Array( "Federal Trade Commission (FTC)", "road.runner@acme.inc" )
    UCE(3) = Array( "Automated UCE/SPAM Defence", "spam@acme.inc" )

    '   UCE(0) = Array( "Whois Abuse Contact", strContact )
    '   UCE(1) = Array( "Danish Consumer Ombudsman", "int@spamklage.dk" )
    '   UCE(2) = Array( "Federal Trade Commission (FTC)", "spam@uce.gov" )
    '   UCE(3) = Array( "Automated UCE/SPAM Defence", "spam@acme.inc" )

    With CreateObject("hMailServer.Message")
        .AddRecipient  UCE(0)(0), UCE(0)(1)
        .AddRecipient  UCE(1)(0), UCE(1)(1)
        .AddRecipient  UCE(2)(0), UCE(2)(1)
        .AddRecipient  UCE(3)(0), UCE(3)(1)
        .FromAddress = UCE(3)(1)
        .HeaderValue("To")   = Chr(34) & UCE(0)(0) & Chr(34) & " <" & UCE(0)(1) & ">"
        .HeaderValue("Cc")   = Chr(34) & UCE(1)(0) & Chr(34) & " <" & UCE(1)(1) & ">, " & _
        Chr(34) & UCE(2)(0) & Chr(34) & " <" & UCE(2)(1) & ">"
        .HeaderValue("From") = Chr(34) & UCE(3)(0) & Chr(34) & " <" & UCE(3)(1) & ">"
        Select Case LCase(Right(oMessage.HeaderValue("X-Envelope-HELO"),4))
            Case ".icu"
            .Subject = "Automated UCE/SPAM Report! Sender = " & oMessage.From
            .Body    = "Attached please find SPAM mail in .eml format." & vbCrLf & vbCrLf & _
            "Originating server is identified as [" & oMessage.HeaderValue("X-Envelope-HELO") & "] on IP Address " & oMessage.HeaderValue("X-Envelope-IPAddress")  & vbCrLf & vbCrLf & _
            "Domain registrar, US based Namecheap Inc., is responsible for registering .ICU domains and have been instrumental in diabling" & vbCrLf & _
            "several hundred domains so far, but it never stops. The spammers have adoptet the " & Chr(34) & "SnowShoe SPAM" & Chr(34) & " principle sending from the same domain " & vbCrLf & _
            "up to 6 emails to each " & Chr(34) & "victim" & Chr(34) & " before moving on to the next domain. Domain names are made by merging two everyday words together " & vbCrLf & _
            "appended with the .ICU TLD." & vbCrLf & _
            "Whois information show the domain registrant as:" & vbCrLf & vbCrLf & _
            "Registrant Organization: WhoisGuard, Inc." & vbCrLf & _
            "Registrant State/Province: Panama" & vbCrLf & _
            "Registrant Country: PA" & vbCrLf & _
            "Registrant Email: Please query the RDDS service of the Registrar of Record identified in this output for information on how to contact the Registrant, Admin, or Tech contact of the queried domain name." & vbCrLf & _
            "Admin Email: Please query the RDDS service of the Registrar of Record identified in this output for information on how to contact the Registrant, Admin, or Tech contact of the queried domain name." & vbCrLf & _
            "Tech Email: Please query the RDDS service of the Registrar of Record identified in this output for information on how to contact the Registrant, Admin, or Tech contact of the queried domain name." & vbCrLf & vbCrLf & _
            "WhoisGuard Inc. is not interrested in disclosing information about the registrant." & vbCrLf & vbCrLf & _
            "*********************************************************************************************" & vbCrLf & _
            "*** This message will repeat itself for every UCE/SPAM mail received from an .ICU domain. ***" & vbCrLf & _
            "*********************************************************************************************"
            Case Else
            .Subject = "Returning unused UCE/SPAM!"
            .Body = "Thanks for trying, but we are NOT interested! The original sender is violating EU GDPR law."
        End Select
        .Attachments.Add(oMessage.Filename)
        .Save
    End With
End Function
I ended up logging all the domains and sending them a list every 2 weeks or so. We got to know each other quite well for a while. Then I just moved on to reject if HELO said .ICO or whatever other unwanted TLD.
Cool! I wasn't aware that ONLY namecheap issues .icu tlds.

I get a lot of .com domain spam from domains registered by namecheap. I remembered this ^ vaguely so i looked it up. I only know they're namecheap domains because i looked them up manually.

I'm going to look for a whois api. :mrgreen:

Edit - found one: https://www.webmasterapi.com/whois

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-23 20:59

PHP interface: Changed drop down boxes to submit on selection. Browsing goes a little faster.
Attachments
dynbl.zip
(8.1 KiB) Downloaded 254 times

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-10-27 13:12

PHP interface: added autocomplete to trunk and branch form fields in the add record page. Just start typing and select the match you want, or keep typing to create a new entry.

I was thinking about how to implement drop down boxes or something for that, but there's always the possibility you want to add a new trunk or branch. Autocomplete works out well and saves precious seconds of typing.
Attachments
dynbl.zip
(9.38 KiB) Downloaded 242 times

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-11-02 12:10

An interesting topic came up on the spamassassin user list this morning. Spammy domains in Google url redirects were not getting picked up. It got me to thinking about the dynamic list we have here. :D

The example url (with spaces since its probably not safe):

Code: Select all

http s://www.goo gle.com/url?q=htt ps%3A%2F%2Fkissch icksrr.com%2F%3Futm_source%3DbDukb6xHEYDF2%26amp%3Butm_campaign%3DKirka2&amp;sa=D&amp;sntz=1&amp;usg=AFQjCNGkpnVKLl8I1IP9aQXtTha-jCnt3A
Trunk: Blacklist
Branch: URL-Redirect
Node:

Code: Select all

(?:\bhttps:\/\/www\.google\.com\/url\?q=https?\%3A\%2F\%2F)([a-zA-Z0-9-.]+)(?:\%2F[^\s]+\b)
https://regex101.com/r/YGNCqD/1

Then blacklist it if the target domain appears on surbl lists:

Code: Select all

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 MyListStat(MyListDict, oMatch.Value)
			Call BlackList(oMessage, "//Blacklist/URL-Redirect (multi.surbl.org) = '" & oMatch.Value & "'", 5)
		End If
		If IsInSpamHausDBL(oMatch.Value) Then
			Call MyListStat(MyListDict, oMatch.Value)
			Call BlackList(oMessage, "//Blacklist/URL-Redirect (dbl.spamhaus.org) = '" & oMatch.Value & "'", 5)
		End If
	Next
End If
There are lots of common redirectors out there that spammers may be taking advantage of. Twatter, fakebook, apple, lots...

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-11-02 12:45

PHP interface: fixed nagging issue where confirm page would show false negative for adding node due to garbled url-decoded node parameter. The one above node ^ for example, contains urlencoding which was double encoded when passed as a parameter to confirm.php. Decoding that jumble is impossible so I changed the parameter to ID, which avoids all that decoding mess. :D
Attachments
dynbl.zip
(9.41 KiB) Downloaded 251 times

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-11-02 12:52

palinka wrote:
2021-11-02 12:10
An interesting topic came up on the spamassassin user list this morning. Spammy domains in Google url redirects were not getting picked up. It got me to thinking about the dynamic list we have here. :D

The example url (with spaces since its probably not safe):

Code: Select all

http s://www.goo gle.com/url?q=htt ps%3A%2F%2Fkissch icksrr.com%2F%3Futm_source%3DbDukb6xHEYDF2%26amp%3Butm_campaign%3DKirka2&amp;sa=D&amp;sntz=1&amp;usg=AFQjCNGkpnVKLl8I1IP9aQXtTha-jCnt3A
That is a recent issue ???

I believe this issue was mentioned 14 years ago ;-)

https://users.spamassassin.apache.narki ... ector-spam

http://www.surbl.org/redirection-sites
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-11-02 12:58

SorenR wrote:
2021-11-02 12:52
palinka wrote:
2021-11-02 12:10
An interesting topic came up on the spamassassin user list this morning. Spammy domains in Google url redirects were not getting picked up. It got me to thinking about the dynamic list we have here. :D

The example url (with spaces since its probably not safe):

Code: Select all

http s://www.goo gle.com/url?q=htt ps%3A%2F%2Fkissch icksrr.com%2F%3Futm_source%3DbDukb6xHEYDF2%26amp%3Butm_campaign%3DKirka2&amp;sa=D&amp;sntz=1&amp;usg=AFQjCNGkpnVKLl8I1IP9aQXtTha-jCnt3A
That is a recent issue ???

I believe this issue was mentioned 14 years ago ;-)

https://users.spamassassin.apache.narki ... ector-spam

http://www.surbl.org/redirection-sites
¯\_(ツ)_/¯ Seems to be an issue still.

It's not even something I have run across specifically. I'm just being proactive. :mrgreen:

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2021-11-02 13:18

SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-11-02 16:03

Just because its 18 years old to somebody doesn't mean its not brand new and fresh to me. :mrgreen:

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-11-03 02:52

Here's a better regex. It should pick up almost any redirect.

Code: Select all

(?:\bhttps?:\/\/.+\?.+=https?\%3A\%2F\%2F)([a-zA-Z0-9-.]+)(?:\%2F[^\s]+\b)

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-11-04 12:03

PHP interface: fixed leftover stupidity from last change in confirm.php.
Attachments
dynbl.zip
(9.38 KiB) Downloaded 246 times

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2021-11-28 01:43

Updated php interface to be MUCH more mobile friendly. The wide table becomes cards on small screens, so you don't have to zoom or scroll horizontally anymore.

Also, I moved it to github.

https://github.com/palinkas-jo-reggelt/ ... r_DynRBLWL

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2022-01-12 14:19

Updated php interface:
* got rid of popup window for editing
* after editing, return to referring page (refreshed with edited content)
* housekeeping

https://github.com/palinkas-jo-reggelt/ ... r_DynRBLWL

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2022-03-10 14:08

Updated PHP interface:
* added autocomplete trunk and branch in edit.php
* bolded node text in mobile view for easier readability

https://github.com/palinkas-jo-reggelt/ ... r_DynRBLWL

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2022-03-11 14:52

MAy I request final code for Eventhandler.vbs

I read the complete thread but getting confused and loosing track of changes, getting lots of errors which I am unable to debug.

TIA :oops:

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2022-03-11 18:21

gotspatel wrote:
2022-03-11 14:52
MAy I request final code for Eventhandler.vbs

I read the complete thread but getting confused and loosing track of changes, getting lots of errors which I am unable to debug.

TIA :oops:
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


palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2022-04-09 12:23

Scripting dictionary object only uses key/value pairs, correct?

I want to add a third element: score - to be used with blacklist scoring. Basically, I want to weight the blackness of the blacklist in the database, not on individual scripting elements.

What's the best strategy for that? If you point me in the right direction, Obi Wan, I can probably work out the rest. :D

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-04-27 11:48

palinka wrote:
2022-03-11 18:21
gotspatel wrote:
2022-03-11 14:52
MAy I request final code for Eventhandler.vbs

I read the complete thread but getting confused and loosing track of changes, getting lots of errors which I am unable to debug.

TIA :oops:
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


Getting so many errors as below,

Code: Select all

"ERROR"	13264	"2023-04-27 15:11:21.404"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:11:36.500"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
Line: 1276 --> MyListDict.RemoveAll

Line: 3679 --> If (mySPFDict.Count > 0) Then

any help please


Some more logs below

Code: Select all

"ERROR"	424	"2023-04-27 13:41:51.277"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	13112	"2023-04-27 13:41:55.693"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	8772	"2023-04-27 13:42:01.834"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	12116	"2023-04-27 13:42:18.607"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	5324	"2023-04-27 14:03:06.847"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	2544	"2023-04-27 14:03:16.149"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	2544	"2023-04-27 14:03:21.591"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:03:39.107"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:04:41.707"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:05:29.533"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:05:47.897"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:06:46.153"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:07:11.353"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	2544	"2023-04-27 14:27:31.849"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	5560	"2023-04-27 14:27:37.735"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	13888	"2023-04-27 14:27:45.013"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:28:03.241"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:28:14.172"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:28:27.151"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:28:36.934"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:28:50.170"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:29:10.669"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:29:57.822"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:31:36.114"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:31:57.231"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:32:25.197"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:32:38.297"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:33:09.807"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:33:28.170"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:33:48.933"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:34:08.732"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:34:31.091"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:35:37.719"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:36:00.992"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:36:21.842"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:36:41.819"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:37:04.608"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:37:28.165"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:37:48.298"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:38:03.030"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:38:18.887"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:38:34.838"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:38:56.425"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:39:11.607"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:39:28.173"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:39:40.054"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:40:03.945"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:40:27.018"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:40:42.629"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:40:59.675"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:41:11.081"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:41:34.834"	"Script Error: Source: DnsClient - Error: 80131500 - Description: Query 63839 => 245.106.129.150.rep.mailspike.net IN A on 192.168.172.1:53 timed out or is a transient error. - Line: 974 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:42:03.617"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:44:09.206"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:44:18.406"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:44:28.318"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:45:16.740"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:45:36.279"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:45:55.290"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:46:18.976"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:46:31.499"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:46:50.686"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:47:03.191"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:47:21.615"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:47:43.366"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:48:05.050"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:48:27.064"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:48:37.653"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:48:52.930"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:49:17.471"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:49:31.899"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:50:01.490"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:51:04.139"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:51:14.506"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:51:30.163"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:52:39.398"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:52:59.300"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:53:18.474"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:53:46.174"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:54:06.174"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:54:28.497"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:54:45.704"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:55:27.072"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:55:51.283"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:56:16.036"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:56:24.932"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 14:56:52.904"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	5324	"2023-04-27 15:11:07.476"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	13888	"2023-04-27 15:11:13.555"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	13264	"2023-04-27 15:11:21.404"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:11:36.500"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:11:48.857"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:11:55.748"	"Script Error: Source: DnsClient - Error: 80131500 - Description: Query 37988 => 245.106.129.150.rep.mailspike.net IN A on 192.168.172.1:53 timed out or is a transient error. - Line: 974 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:12:03.204"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:12:20.747"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:12:47.515"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:13:07.934"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:13:27.477"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:13:47.281"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:14:09.340"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:14:31.548"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:14:54.302"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:15:20.661"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:15:43.846"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	12116	"2023-04-27 15:16:01.864"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	1620	"2023-04-27 15:16:11.465"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	1620	"2023-04-27 15:16:31.807"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	1620	"2023-04-27 15:16:43.183"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	11272	"2023-04-27 15:16:59.193"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	1620	"2023-04-27 15:17:18.653"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	1620	"2023-04-27 15:17:37.370"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	1620	"2023-04-27 15:17:56.027"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	5076	"2023-04-27 15:18:09.554"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	5076	"2023-04-27 15:18:27.908"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'mySPFDict' - Line: 3679 Column: 2 - Code: (null)"
"ERROR"	13888	"2023-04-27 15:19:35.727"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	13888	"2023-04-27 15:19:41.459"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"
"ERROR"	13888	"2023-04-27 15:19:43.851"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'MyListDict' - Line: 1276 Column: 1 - Code: (null)"

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2023-04-27 14:24

gotspatel wrote:
2023-04-27 11:48
palinka wrote:
2022-03-11 18:21

Code: Select all

Private MyListDict : Set MyListDict = CreateObject("Scripting.Dictionary")
You have this line at the top of your eventhandlers.vbs?

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-04-27 14:25

palinka wrote:
2023-04-27 14:24
gotspatel wrote:
2023-04-27 11:48
palinka wrote:
2022-03-11 18:21

Code: Select all

Private MyListDict : Set MyListDict = CreateObject("Scripting.Dictionary")
You have this line at the top of your eventhandlers.vbs?
yes and others as well

Private Const ADMIN = "Administrator"
Private Const hMSPASSWORD = "supersecretpassword"
Private Const DBTABLE = "hm_black_white_list"

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2023-04-27 14:28

gotspatel wrote:
2023-04-27 14:25
yes and others as well
Can you post the eventhandlers.vbs?

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-04-27 14:33

palinka wrote:
2023-04-27 14:28
gotspatel wrote:
2023-04-27 14:25
yes and others as well
Can you post the eventhandlers.vbs?
May I send by PM??

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2023-04-27 14:38

gotspatel wrote:
2023-04-27 14:33
palinka wrote:
2023-04-27 14:28
gotspatel wrote:
2023-04-27 14:25
yes and others as well
Can you post the eventhandlers.vbs?
May I send by PM??
Wouldn't you rather tap into the collective knowledge of the community?

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-04-27 14:45

palinka wrote:
2023-04-27 14:38
gotspatel wrote:
2023-04-27 14:33
palinka wrote:
2023-04-27 14:28


Can you post the eventhandlers.vbs?
May I send by PM??
Wouldn't you rather tap into the collective knowledge of the community?
sure i am to share, give me some time to remove some information. :P

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-04-27 15:09

DISCLAIMER: USE AT YOU OWN RISK, NO WARRANTIES some codes are removed and some are partial


@Palinka

here is the full eventhandler, it includes all I have learnt, modified and adapted and implemented from this community. Hope to get a solution for the errors to rectify them and move ahead.


Your message contains 183612 characters.
The maximum number of allowed characters is 60000.


:lol: got this error so now it is attached
event.7z
(31.58 KiB) Downloaded 38 times

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2023-04-27 15:23

gotspatel wrote:
2023-04-27 15:09
DISCLAIMER: USE AT YOU OWN RISK, NO WARRANTIES some codes are removed and some are partial


@Palinka

here is the full eventhandler, it includes all I have learnt, modified and adapted and implemented from this community. Hope to get a solution for the errors to rectify them and move ahead.


Your message contains 183612 characters.
The maximum number of allowed characters is 60000.


:lol: got this error so now it is attached

event.7z
This might be it:

Code: Select all

    '
    '   Whitelist HELO
    '
	Dim MyListDict
Line 2499. Re-dimming removes the object created at the beginning.

Code: Select all

'
'   Global dictionaries
'
Private MyListDict : Set MyListDict = CreateObject("Scripting.Dictionary")
I'm guessing same issue for the other object, but I haven't looked yet.

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-04-27 15:26

palinka wrote:
2023-04-27 15:23
gotspatel wrote:
2023-04-27 15:09
DISCLAIMER: USE AT YOU OWN RISK, NO WARRANTIES some codes are removed and some are partial


@Palinka

here is the full eventhandler, it includes all I have learnt, modified and adapted and implemented from this community. Hope to get a solution for the errors to rectify them and move ahead.


Your message contains 183612 characters.
The maximum number of allowed characters is 60000.


:lol: got this error so now it is attached

event.7z
This might be it:

Code: Select all

    '
    '   Whitelist HELO
    '
	Dim MyListDict
Line 2499. Re-dimming removes the object created at the beginning.

Code: Select all

'
'   Global dictionaries
'
Private MyListDict : Set MyListDict = CreateObject("Scripting.Dictionary")
I'm guessing same issue for the other object, but I haven't looked yet.
Noted with thanks. Will post back the result

Will check others also.

Best Regards

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2023-04-27 17:25

Noticed your UTC conversion ...

Code: Select all

Dim dateTime
Set dateTime = CreateObject("WbemScripting.SWbemDateTime")    
dateTime.SetVarDate (now())
EventLog.Write  "UTC Time: " & dateTime.GetVarDate (false)

'Set dateTime = CreateObject("WbemScripting.SWbemDateTime")
'dateTime.SetVarDate now(),false  REM Where now is the UTC date
'WScript.echo cdate(dateTime.GetVarDate (true))
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-04-30 05:37

I am finding one problem with the clients who are roaming outside our LAN (mobile and laptop [win and mac]) they are being blocked in sub onhelo how to prevent that.

can anyone please point out :oops:

Regards

User avatar
RvdH
Senior user
Senior user
Posts: 3231
Joined: 2008-06-27 14:42
Location: The Netherlands

Re: Dynamic Black/Whitelists in your script.

Post by RvdH » 2023-04-30 10:57

gotspatel wrote:
2023-04-30 05:37
I am finding one problem with the clients who are roaming outside our LAN (mobile and laptop [win and mac]) they are being blocked in sub onhelo how to prevent that.

can anyone please point out :oops:

Regards
Without you being more specific what actually gets blocked out i would say: ignore authenticated connections or only check helo for port 25
CIDR to RegEx: d-fault.nl/cidrtoregex
DNS Lookup: d-fault.nl/dnstools
DKIM Generator: d-fault.nl/dkimgenerator
DNSBL Lookup: d-fault.nl/dnsbllookup
GEOIP Lookup: d-fault.nl/geoiplookup

User avatar
SorenR
Senior user
Senior user
Posts: 6308
Joined: 2006-08-21 15:38
Location: Denmark

Re: Dynamic Black/Whitelists in your script.

Post by SorenR » 2023-04-30 13:47

gotspatel wrote:
2023-04-30 05:37
I am finding one problem with the clients who are roaming outside our LAN (mobile and laptop [win and mac]) they are being blocked in sub onhelo how to prevent that.

can anyone please point out :oops:

Regards
I have a whitelist of "HELO"s that I know 112% are mine ...

Code: Select all

    '
    '   Whitelist "HELO"
    '
    strRegEx = myListsRegEx(myListsDict, "//Whitelist/HELO")
    If strRegEx <> "VOID" Then
        Set oMatchCollection = oLookup(strRegEx, oClient.HELO, False)
        For Each oMatch In oMatchCollection
            Call myListsStat(myListsDict, oMatch.Value)
            Set oMatch = Nothing
            Set oMatchCollection = Nothing
            Exit Sub  ' <<== Skip the rest of Sub OnHELO()
        Next
    End If
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4455
Joined: 2017-09-12 17:57

Re: Dynamic Black/Whitelists in your script.

Post by palinka » 2023-04-30 14:00

RvdH wrote:
2023-04-30 10:57
gotspatel wrote:
2023-04-30 05:37
I am finding one problem with the clients who are roaming outside our LAN (mobile and laptop [win and mac]) they are being blocked in sub onhelo how to prevent that.

can anyone please point out :oops:

Regards
Without you being more specific what actually gets blocked out i would say: ignore authenticated connections or only check helo for port 25
Bingo!

gotspatel
Senior user
Senior user
Posts: 347
Joined: 2013-10-08 05:42
Location: INDIA

Re: Dynamic Black/Whitelists in your script.

Post by gotspatel » 2023-05-01 05:48

RvdH wrote:
2023-04-30 10:57
gotspatel wrote:
2023-04-30 05:37
I am finding one problem with the clients who are roaming outside our LAN (mobile and laptop [win and mac]) they are being blocked in sub onhelo how to prevent that.

can anyone please point out :oops:

Regards
Without you being more specific what actually gets blocked out i would say: ignore authenticated connections or only check helo for port 25
This is the code in sub onhelo

Code: Select all

	If Not Lookup(strRegEx, oClient.HELO) Then
        Result.Message = "5.3.0 [BAD HELO] 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."
        Result.Value = 2
        Call Disconnect(oClient.IPAddress, oClient.port)
        If AutoBan(oClient.IPAddress, "BAD HELO " & oClient.HELO, 7, "d") Then EventLog.Write( LPad("BAD HELO", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & LPad(" ", 3, " ") & vbTab & LPad(" ", 16, " ") & vbTab & oClient.HELO )
        EventLog.Write( LPad("REJECT", 15, " ") & vbTab & LPad(oClient.IPAddress, 16, " ") & vbTab & Result.Message )
        Call FWBan(oClient.IPAddress, "BAD HELO", oClient.HELO,"")
        Call Disconnect(oClient.IPAddress, oClient.port)
        'Set EventLogX = Nothing
        Exit Sub
    End If
Log

Code: Select all

6944	"2023-04-30 19:03:35.035"	"BAD HELO       	150.129.166.124 	 HELO:  iPhone"
6944	"2023-04-30 19:03:35.035"	"REJECT         	150.129.166.124 	5.3.0 [BAD HELO] 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."
6944	"2023-04-30 19:03:35.145"	"Disconnected IP :	150.129.166.124	465"


Post Reply