MailGuard-a script for selectively blocking recepients

This section contains scripts that hMailServer has contributed with. hMailServer 5 is needed to use these.
Post Reply
prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-03 15:52

Hello all,
This is a script called "MailGuard" that I created for controlling internal email Ids from sending mail to other email Ids/domains.
This is an "Allow" based script and its my first attempt, so please do share your feedback and let me know if it helps you.
Apart from the script which has to be defined in EventHandlers.vbs, you should define your Allow rules in a file called Rules.csv.

Rules.csv file has the following fields-
RuleId, FromEmail, ToEmail -
RuleId is a counter.
FromEmail is the internal ID on which the filter is going to be applied.
ToEmail is the definition of the email/domain to which the allow rule is being set.

The script implements the rules like this -
1)If an internal email ID is not defined in rules.csv, then there are no restrictions for this email ID and it can send mail to all domains.
2)If an internal email ID *is* defined in rules.csv, then mails are allowed *only* to the email IDs mentioned in the rules.csv file and everything else is blocked.

Here's the scenario:
1. User CEO@goodDomain.com should send mail to everyone with no restrictions
2. User joe@goodDomain.com should send mail only to other users at goodDomain.com and all external domains must be blocked
3. User jill@goodDomain.com should send mail only to someone@badDomain.com and everyone at goodDomain.com

This is how you would set up rules.csv:
CEO@goodDomain.com should not be mentioned in rules.csv at all
Rules.csv
RuleId,FromEmail,ToEmail
1,joe@goodDomain.com,*@gooddomain.com
2,jill@gooddomain.com,*@gooddomain.com
3,jill@gooddomain.com,someone@baddomain.com


The script is given below-

Code: Select all

Sub OnAcceptMessage(oClient, oMessage)
On Error Resume Next
'Start of MailGuard settings
'Log - logging True=enabled False=Disabled
Dim Log: Log = False
'Be sure to set the path to where to save logs if enabled above!! IT MUST EXIST if logging enabled
Dim StrSave: StrSave = "C:\hmaillog"
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001
'Path to the rules.csv file
strPathtoRulesFile = "C:\vbscripts\"

Set objConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")
Set objRuleSet = CreateObject("ADODB.Recordset")

objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & strPathtoRulesFile & ";" & _
          "Extended Properties=""text;HDR=YES;FMT=Delimited"""

		  
'End of Settings

REM If the sender email id is not in the table -> allow to all domains *.*
REM If the sender email id is in the table -> block all UNLESS
REM 	-Recipient email id is defined (or)
REM  -Recipient email id domain wildcard is defined.


'if Log Then Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
'if Log Then Dim FSOStream: Set FSOStream = FSO.OpenTextFile(StrSave & "\" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "-MailGuard.log",8,True)
'if Log Then FSOStream.WriteLine Now & " MailGuard Starting"


Dim SendMail 
SendMail = true

Dim recipientDomain
Dim rejectReason

set obRecipients = oMessage.Recipients
'FSOStream.Writeline "Number of recipients:" & obRecipients.count 

'First check if the SenderEmail address is defined in the rule list. 
objRecordset.Open "SELECT count(*) as C FROM rules.csv where FromEmail=""" & oMessage.FromAddress & """", _
          objConnection, adOpenStatic, adLockOptimistic, adCmdText
		  
'FSOStream.WriteLine Now & objRecordSet.Fields("C") & " Rules found for : " & oMessage.FromAddress 
	
If cint(objRecordset.Fields(0)) > 0 then
	

	'The sender email Id has been defined in the rules. By default, ALL mails to ALL recipients will be blocked, unless all recipients to this message
	'have been defined in the ToEmail field as Allow rules
	SendMail=false
	'Now loop through each recipient to this email.
	
	for i = 0 to obRecipients.Count -1
		set obRecipient  = obRecipients.Item(i)
		'FSOStream.WriteLine Now & " Recipient: " & obRecipient.Address
	
		'Identify the recipient's domain
		recipientDomain = Mid(obRecipient.Address, InstrRev(obRecipient.Address,"@")+1, len(obRecipient.Address)-InstrRev(obRecipient.Address,"@"))
		'FSOStream.WriteLine Now & "Domain: " & recipientDomain
		
		'Check if the recipient address OR the recipient domain is mentioned in ToEmail for this FromEmail address
		sqlCmd = "SELECT count(*) FROM rules.csv where fromEmail=""" & oMessage.FromAddress & """ and (ToEmail=""" & obRecipient.Address & """ OR toEmail=""*@" & recipientDomain  & """)"
		'FSOStream.WriteLine Now & "SQL: " & sqlCmd
		objRuleSet.close
		objRuleSet.Open sqlCmd, objConnection, adOpenStatic, adLockOptimistic, adCmdText
		
		If cint(objRuleSet.Fields(0)) = 0 then
			'No allow rules available for the recipient and/or *@recipient domain, so set sendMail=false and terminate the loop
			SendMail = false
			rejectReason = oMessage.FromAddress & " cannot send mail to " & obRecipient.Address
			'Write to hMail event log
			EventLog.Write("MailGuard: The email with subject: " & oMessage.subject & " is BLOCKED because " & rejectReason)
		else
			SendMail = true
		end if
		'Terminate the loop immdly
		If sendMail=false then exit for
	Next
End If

objRuleSet.close
objRecordSet.close
objRuleSet = nothing
objRecordset = nothing
'FSOStream.close

If SendMail = false then
	Result.Message = rejectReason
	Result.Value = 2
End If

End Sub

If you would rather use a database table instead of a csv file, change the way the ObjConnection is opened. You would also have to change the way objRuleset.open is called (remove adcmd option)
Thanks and creds to the other posters from whom I picked up bits and pieces.

Regards
Prashanth

^DooM^
Site Admin
Posts: 13861
Joined: 2005-07-29 16:18
Location: UK

Re: MailGuard-a script for selectively blocking recepients

Post by ^DooM^ » 2012-04-03 17:40

I am sure this will come in very handy for a lot of people. Thanks for sharing.
If at first you don't succeed, bomb disposal probably isn't for you! ヅ

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-04 08:47

Thank you Doom. Can you help me edit my earlier post? I can't seem to find an edit button anywhere

Changes to the code pasted above:

Dim StrSave: StrSave = "C:\hmaillog"
strPathtoRulesFile = "C:\vbscripts\"

The formatting codes need to be removed.

Also, want to add that the mail will not be sent if any of the recipients are blocked. The sender is shown a message stating why the message could not be sent so that the blocked recipient(s) can be removed.

Thank you Martin, for this fantastic mail server.

^DooM^
Site Admin
Posts: 13861
Joined: 2005-07-29 16:18
Location: UK

Re: MailGuard-a script for selectively blocking recepients

Post by ^DooM^ » 2012-04-04 17:23

I fixed your post.

You cannot edit posts after a certain amount of time. Stops people going back and changing what they originally said.

Cheers!
If at first you don't succeed, bomb disposal probably isn't for you! ヅ

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-23 19:13

I have tried implementing this on the Beta version of HMailServer and had some difficulty. Are there known compatibility issues? To elaborate, after creating the rules file per your direction and editing both the credentials and location of said file, the script does not filter anything. I have even tried running with a blank file (minus header) and had the same problem. If you could provide some assistance I'd really appreciate it. Thanks!

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-23 20:00

Happy to help. I've deployed this script on three sites and had no issues but i don't think we used the beta version anywhere. We use the latest stable hmailserver v5.

To help me debug, can you post a copy of your csv file here? A blank csv means no filtering, so i didn't quite understand a part of your post.
Alternately, could you do a simple test and see if the OnAcceptMessage event is getting triggered at all? Just write some text info a file inside the event handler and see if the code is being reached.
Regards
Prashanth

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-23 23:17

Thanks Prashanth, I've attached the Rules file (not that I haven't tested it with 1 and 2, I've simply replaced 1 with 2.

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-24 08:50

Sorry, I can't see your attachment. Can you just paste your rules.csv into the message?

Also, just a check to be sure - have you enabled scripts in hmailserver?

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-24 15:29

Yes, scripts are enabled. Here's the csv:


RuleID,FromEmail,ToEmail
1,*@mydomain.net,*@mydomain.com
2,norm@mydomain.net,*@mydomain.com

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-24 15:46

Hi,
It looks alrite except for this:

RuleID,FromEmail,ToEmail
1,*@mydomain.net,*@mydomain.com
2,norm@mydomain.net,*@mydomain.com

Quoting from my original post:
The script implements the rules like this -
1)If an internal email ID is not defined in rules.csv, then there are no restrictions for this email ID and it can send mail to all domains.
2)If an internal email ID *is* defined in rules.csv, then mails are allowed *only* to the email IDs mentioned in the rules.csv file and everything else is blocked.

So.. *@mydomain.net in the FromEmail column is not supported. You would have to define each email ID in the mydomain.net domain and define *@mydomain.com against each entry like this:

3,User1@mydomain.net,*@mydomain.com
4,User2@mydomain.net,*@mydomain.com

...and so on. If I find some time this weekend, I'll alter the script to support *@domain in the FromEmail column too.

However your rule 2 is fine and should work. As per my script, norm@mydomain.net will ONLY be able to send mails to IDs belonging to the mydomain.com domain.

Please try to alter your rules.csv. If it doesnt work, I'll try installing the latest beta and check it out for you.

Regards
Prashanth

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-24 15:51

Also, can you remove everything else and just paste this inside your OnAcceptMessage event handler and see if the file is getting created - so that you can be sure that the event is getting fired properly.

Dim FSOStream
Set FSOStream = FSO.OpenTextFile("c:\" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "-MailGuard.log",8,True)
FSOStream.WriteLine Now & " MailGuard Starting"

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-24 17:25

Thanks for helping out with this, when placing that code under OnAcceptMessage I receive the following error while checking syntax:

Script Error: Source: Microsoft VBScript runtime error - Error: 800A01A8 - Description: Object required: 'FSO' - line: 6 Column: 0 - Code: (Null)

The entire file looks like:

Code: Select all

'   Sub OnClientConnect(oClient)
'   End Sub

'   Sub OnAcceptMessage(oClient, oMessage)
Dim FSOStream
Set FSOStream = FSO.OpenTextFile("c:\" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "-MailGuard.log",8,True)
FSOStream.WriteLine Now & " MailGuard Starting"
'   End Sub

'   Sub OnDeliveryStart(oMessage)
'   End Sub

'   Sub OnDeliverMessage(oMessage)
'   End Sub

'   Sub OnBackupFailed(sReason)
'   End Sub

'   Sub OnBackupCompleted()
'   End Sub

'   Sub OnError(iSeverity, iCode, sSource, sDescription)
'   End Sub

'   Sub OnDeliveryFailed(oMessage, sRecipient, sErrorMessage)
'   End Sub

'   Sub OnExternalAccountDownload(oMessage, sRemoteUID)
'   End Sub

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-24 19:23

Looks like you need to remove the ’ (remark) in front of the OnAcceptMessage and the subsequent End Sub

Let me know if that's the issue.

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-24 20:03

:oops: Whoops, that was certainly the problem in this case. It doesn't appear to be generating that file, though.

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-24 20:54

To clarify, that wasn't the issue with the EventHandlers file containing your script. Is there anything else I could try running to confirm that OnReceive is triggering appropriately? It's worth noting that an OnBackup script I have was working just fine.

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-24 22:46

Quick update, I was able to get this script working after remaking the EventHandler file and rebooting the server. There may have been a conflict with another script but everything appears to be playing well. Thanks for the quick responses :D

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-25 04:34

Great! HTH and I'll update the script to include wildcards in the FromEmail column too.
Regards
Prashanth

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-25 15:48

That would be fantastic, I'm currently looking into a way to restrict incoming mail based on the same rules. If a user is permitted to contact an otuside e-mail address, that e-mail address should be allowed to deliver mail to the original sender, but I'll need to restrict non-whitelisted domains from sending mail to my users.

Thanks again!

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2012-04-25 19:21

Restricting inbound? Should be doable but what would the action be if a mail does arrive from a non white listed address ? Delete and inform the sender?

SCC_Norm
New user
New user
Posts: 11
Joined: 2012-04-23 18:50

Re: MailGuard-a script for selectively blocking recepients

Post by SCC_Norm » 2012-04-25 23:23

That would be ideal, yes.

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2013-09-24 14:18

Updated Script!

Changes:
1. Migrated from CSV to MySQL server
2. Block all *unless* defined in the rules
3. Link sender email address and client IP to prevent spoofing

Happy to help with any queries. There's a very usable .Net front end too to manage this. Please ping me if interested.

Code: Select all

'MailGuard Version 3.0 - MySQL Based (MGRulesTable)

'Todo: Install mysql ODBC driver (any 32 bit version) and create a system DSN called "MailGuard". 
'Configure the DSN with a user which can select from MGRulesTable,MGViolationsTable and hm_accounts - all found in the hmailserver database maildb

'MGRulesTable SQL is given below: (Remove the leading ' characters on each line.

'CREATE TABLE `mgrulestable` (
'  `RuleId` int(255) NOT NULL AUTO_INCREMENT,
'  `FromEmail` varchar(255) NOT NULL,
'  `ToEmail` varchar(255) NOT NULL,
'  `Remarks` varchar(200) DEFAULT '',
'  `LastModified` timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP,
'  `Enabled` char(1) DEFAULT 'y' COMMENT 'y/n - Is this rule enabled or not',
'  PRIMARY KEY (`RuleId`),
'  UNIQUE KEY `c` (`FromEmail`,`ToEmail`),
'  KEY `a` (`FromEmail`),
'  KEY `b` (`ToEmail`)
') ENGINE=InnoDB AUTO_INCREMENT=111 DEFAULT CHARSET=utf8;


'MGViolationsTable SQL is given below: (Remove the leading ' characters on each line.
'CREATE TABLE `mgviolationstable` (
'  `Sno` int(255) NOT NULL AUTO_INCREMENT,
'  `FromEmail` varchar(255) NOT NULL,
'  `FromIP` varchar(18) DEFAULT NULL,
'  `ToEmail` varchar(255) NOT NULL DEFAULT '',
'  `Message` varchar(200) DEFAULT '',
'  `EventTime` timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP,
'  PRIMARY KEY (`Sno`)
') ENGINE=InnoDB AUTO_INCREMENT=119 DEFAULT CHARSET=utf8;


'A column needs to be added to hm_accounts - SQL given below:
'  Alter table hm_accounts add column   `accountallowedips` varchar(150) NOT NULL DEFAULT '';


'MailGuard logic starts here.
'-----------------------------------
Sub OnAcceptMessage(oClient, oMessage)

On Error Resume Next

'Start of MailGuard settings

'Log - logging True=enabled False=Disabled
Dim Log: Log = True
'Be sure to set the path to where to save logs if enabled above!! IT MUST EXIST if logging 
'is enabled, do not add a \ at the end!
Dim StrSave: StrSave = "c:\mailguard"
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FSOStream: Set FSOStream = FSO.OpenTextFile(StrSave & "\" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "-MailGuard.log",8,True)
Dim violationSQL

if Log Then FSOStream.WriteLine Now & vbTab & "MailGuard Starting"

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001

Set objConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")
Set objRuleSet = CreateObject("ADODB.Recordset")


'Here is the connection. Create a SYSTEM DSN called MailGuard
objConnection.Open "DSN=MailGuard"
If Err <> 0 then
	Result.Message = "The DSN to connect to the MailGuard DB is not configured. Please contact IT admin!"
	Result.value = 2
	objRuleSet.close
	objRecordSet.close
	objRuleSet = nothing
	objRecordset = nothing
	If Log then FSOStream.close
	Exit Sub
End If
		  
'End of Settings

'Section 1 - Checking if oClient.IPAddress is present in the accountallowedips column in table hm_accounts for the accountaddress oMessage.FromAddress value
objRecordset.Open "SELECT accountallowedips as C FROM hm_accounts where Lcase(accountaddress)=""" & LCase(oMessage.FromAddress) & """", objConnection, adOpenStatic, adLockOptimistic, adCmdText


'If value is blank - exit saying allowed ips have to be defined
'If value is not *, check if oClient.IPAddress is contained in the returned value
if Log Then FSOStream.WriteLine Now & vbTab & objRecordSet.Fields("C") & " is the `accountallowedips` value for " & LCase(oMessage.FromAddress) & " and the sender IP is " & oClient.IPAddress
If Err <> 0 then
	Result.Message = Err.Number
	Result.value = 2
	objRuleSet.close
	objRecordSet.close
	objRuleSet = nothing
	objRecordset = nothing
	If Log then FSOStream.close
	Exit Sub
End If

If objRecordSet.Fields("C") = "" Then
	violationSQL="Insert into mgviolationstable (FromEmail,FromIP,Message) Values('" & oMessage.FromAddress & "','" & oClient.IPAddress & "','No AllowedIPs configured.')"
	FSOStream.writeline violationSQL
	
	objConnection.Execute violationSQL
	
	Result.Message = "Allowed IPs have not been defined for your email address. Please contact the IT admin!"
	Result.value = 2
	objRuleSet.close
	objRecordSet.close
	objRuleSet = nothing
	objRecordset = nothing
	If Log then FSOStream.close
	Exit Sub
else

		
	'If not * check if the origin IP is contained within the allowed IPs list
	if objRecordSet.Fields("C") <> "*" Then
		
		If InStr(objRecordSet.Fields("C"),oClient.IPAddress)= 0 then
			EventLog.Write("Security Issue! " & vbTab & Now & vbTab & LCase(oMessage.FromAddress) & " tried to connect from " & oClient.IPAddress & " while AllowedIps are " & objRecordSet.Fields("C"))
			violationSQL="Insert into mgviolationstable (FromEmail,FromIP,Message) Values('" & oMessage.FromAddress & "','" & oClient.IPAddress & "','IP not allowed!')"
			objConnection.Execute violationSQL

			Result.Message = "You cannot send mail from this computer. Please contact the IT admin."
			Result.value = 2
			objRuleSet.close
			objRecordSet.close
			objRuleSet = nothing
			objRecordset = nothing
			If Log then FSOStream.close
			Exit Sub
		End If
	End If
End If
objRecordSet.close

'Section 2: Anonymizing the sender IP
 
	Dim oHeaders
	set oHeaders = oMessage.Headers
	' Iterate over the headers looking for Received:
	Dim i
	For i = (oHeaders.Count-1) To 0 Step -1

		Dim oHeader
		Set oHeader = oHeaders.Item(i)

		If Log Then FSOStream.WriteLine oHeader.Name & vbtab & "=" & vbtab & oHeader.Value

		'Check if this is a header which we should modify.
		If LCase(oHeader.Name) = "received" Then
			' Log the header value in case we need it later on
			'EventLog.Write("Pre-anonymisation: " + oHeader.Value)
			'Do the replacement
			oHeader.Value = "from mail client by a friendly server; " & now
			Exit For
		End If
	Next
	oMessage.save

	

'Section 3 - Recipient checks	
	
' If the sender email id is not in the table -> BLOCK completely 
' If the sender email id is in the table -> Block all UNLESS
' 	-Recipient email id is defined (or)
'   -Recipient email id domain wildcard is defined.




Dim SendMail 
SendMail = true

Dim recipientDomain
Dim rejectReason

set obRecipients = oMessage.Recipients
If Log Then FSOStream.Writeline now & vbTab & "Number of recipients:" & obRecipients.count 

'First check if the SenderEmail address is defined in the rule list. 
objRecordset.Open "SELECT count(*) as C FROM MGRulesTable where Enabled=""y"" and Lcase(FromEmail)=""" & LCase(oMessage.FromAddress) & """", objConnection, adOpenStatic, adLockOptimistic, adCmdText
		  
if Log Then FSOStream.WriteLine Now & vbTab & objRecordSet.Fields("C") & " Rules found for : " & LCase(oMessage.FromAddress) 

If cint(objRecordset.Fields(0)) > 0 then

	'The sender email Id has been defined in the rules. By default, ALL mails to ALL recipients will be blocked, unless all recipients to this message
	'have been defined in the ToEmail field as Allow rules
	SendMail=false

	'Now loop through each recipient to this email.
	for i = 0 to obRecipients.Count -1
		set obRecipient  = obRecipients.Item(i)
		'if Log Then FSOStream.WriteLine Now & vbTab & "Recipient: " & obRecipient.Address
	
		'Identify the recipient's domain
		recipientDomain = LCase(Mid(obRecipient.Address, InstrRev(obRecipient.Address,"@")+1, len(obRecipient.Address)-InstrRev(obRecipient.Address,"@")))
		if Log Then FSOStream.WriteLine Now & vbTab & "Domain: " & recipientDomain
		
		'Check if the recipient address OR the recipient domain is mentioned in ToEmail for this FromEmail address
		sqlCmd = "SELECT count(*) FROM MGRulesTable where Enabled=""y"" and LCase(fromEmail)=""" & Lcase(oMessage.FromAddress) & """ and (LCase(ToEmail)=""" & LCase(obRecipient.Address) & """ OR LCase(toEmail)=""*@" & recipientDomain  & """ OR LCase(toEmail)=""*@*"")"
		'If Log then FSOStream.WriteLine Now & vbTab & "SQL: " & sqlCmd
		objRuleSet.close
		objRuleSet.Open sqlCmd, objConnection, adOpenStatic, adLockOptimistic, adCmdText

		if Log Then FSOStream.WriteLine Now & vbTab & "Pass rules found: " & objRuleSet.Fields(0)

		If cint(objRuleSet.Fields(0)) = 0 then
			'No allow rules available for the recipient and/or *@recipient domain, so set sendMail=false and terminate the loop
			SendMail = false
			rejectReason = oMessage.FromAddress & " cannot send mail to " & obRecipient.Address
			'Write to hMail event log and violations table
			EventLog.Write("MailGuard: The email with subject: " & oMessage.subject & " is BLOCKED because " & rejectReason)
			
			violationSQL="Insert into mgviolationstable (FromEmail,FromIP,ToEmail,Message) Values('" & oMessage.FromAddress & "','" & oClient.IPAddress & "','" & obRecipient.Address & "','" & rejectReason & "')"
			objConnection.Execute violationSQL

		else
			SendMail = true
		end if

		'Terminate the loop immdly
		If sendMail=false then exit for
	Next

Else
		'No rules were found for this . Block immediately
		rejectReason="Your email ID has not been properly configured on MailGuard. Please contact IT admin (Zero enabled rules)"
		violationSQL="Insert into mgviolationstable (FromEmail,FromIP,Message) Values('" & oMessage.FromAddress & "','" & oClient.IPAddress & "','Address not configured on MG')"
		FSOStream.WriteLine violationSQL
		objConnection.Execute violationSQL
		SendMail=false
End If

objRuleSet.close
objRecordSet.close
objRuleSet = nothing
objRecordset = nothing
If Log then FSOStream.close

If SendMail = false then
	Result.Message = rejectReason
	Result.Value = 2
End If

End Sub


'   Sub OnDeliveryStart(oMessage)
'   End Sub

'   Sub OnDeliverMessage(oMessage)
'   End Sub

'   Sub OnBackupFailed(sReason)
'   End Sub

'   Sub OnBackupCompleted()
'   End Sub

'   Sub OnError(iSeverity, iCode, sSource, sDescription)
'   End Sub

'   Sub OnDeliveryFailed(oMessage, sRecipient, sErrorMessage)
'   End Sub

'   Sub OnExternalAccountDownload(oMessage, sRemoteUID)
'   End Sub

Attachments
MailGuardManager.png

thomsen
New user
New user
Posts: 12
Joined: 2013-11-26 12:44

Re: MailGuard-a script for selectively blocking recepients

Post by thomsen » 2013-11-27 16:29

prashanthRaju wrote:Updated Script!

Changes:
1. Migrated from CSV to MySQL server
2. Block all *unless* defined in the rules
3. Link sender email address and client IP to prevent spoofing

Happy to help with any queries. There's a very usable .Net front end too to manage this. Please ping me if interested.
Hello. Where i can download the MailGuard Control Center?

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2019-03-10 14:50

Hello friends,

I'm pleased to share an updated version of my script - MailGuard along with the control center and helper apps. MailGuard is a versatile script that prevents users from sending external mails to unknown or unauthorized parties. This is a very important requirement in many businesses and my own business has been using MG for over 7 years. This is a complete rewrite of the original script which was necessary due to some unknown random errors that prevented the script from accessing the DSN to the database. Here are the instructions:
MailGuard v6 Instructions
-----------------------------

MailGuard is a script extension for the awesome free hmailserver email server for Windows.
It comprises of
1. A script (EventHandlers.vbs),
2. A control center (MailGuard.exe) which can be used to create outbound rules and
3. A helper app (MGChecker.exe) that is left running on the server to query the rules and return a result to the script (1.)

Communication between the script (1) and MGChecker (3) happens through pipes.

While this might seem to be a convoluted approach - after all, I could just query the database from the script. This indeed was the original approach and after several years of hearing our users complain about DSN errors (for unexplainable random reasons, the DSN set up for connecting to the database in the script would not be 'found' and the script would fail), I decided MailGuard needed an overhaul. There is an additional dependecy on an external program now, but I've found it to be very stable and have therefore decided to make it available for anyone who might be interested.

To do:

1. Edit MGChecker.exe.config and edit the connection string to the MySQL database. It can be found here:
<value>server=localhost;user=root;pwd=tree;database=hmail;</value>

2. Run MailGuard.exe - this is the control center to help you define rules. On the first run, supply the server creds and it will create the tables it needs.

3. Copy MGChecker to the server that runs hmailserver and set it up to run in the background - basically, schedule it to run on system logon, and check if its running every x minutes. If for some inexplicable reason it isn't running, start it again.

4. Go through the EventHandlers script and modify a couple of variables (log path and a return email address)

Good luck!

Prashanth


Here's the script:

Code: Select all

'MG Version 6
'This version uses Pipes to communicate with an external program - MGChecker.exe
'MG now sends emails after removing blocked recipients, modifies CC and TO headers
'also sends reject email to the sender explaining why the message was rejected
'Create folder c:\MGLog\ or change the MGLogPath variable
'Change the MailGuardID variable - this is the address from which MailGuard will appear to send a mail back to the sender on failure
'Prashanth (cyberprash at gmail)/10th March 2019
'Thanks to the examples provided by various contributors on the hmail forums

Option Explicit

' Global Settings
Dim MGLogPath,FailedDeliveryLogPath
MGLogPath = "c:\MGLog\log.txt"
Private Const LogLevel = 1 '0- Nothing, 1-Only Errors, 2-Everything
'End of global settings.

	
Sub OnAcceptMessage(oClient, oMessage)

On Error Resume Next

if oClient.UserName <> "" THEN 'Run only for authenticated users sending outbound email

	Dim fso1,InputString,ResultString
	Dim MailGuardID
	MailGuardID = "MailGuard <mailguard@YourDomain.com>"
	
	If LogLevel>0 THEN WriteLog MgLogPath, now & "-MG Starting"

	'Section 1: Anonymizing the sender IP
	oMessage.HeaderValue("Received") = "from a friendly server; " & now

	If LogLevel>0 THEN  WriteLog now & "-Finished anonymizing"

	'Section 2: Checking recipients
	Dim Recipients 
	Recipients = ""

	For i = 0 To oMessage.Recipients.Count-1
		   Recipients = Recipients & oMessage.Recipients(i).OriginalAddress & ","
	Next

	Recipients = truncate_one(Recipients) 'Remove the trailing comma if it exists
		  
	InputString = oClient.ipaddress & ":" & oMessage.fromAddress & ":" & Recipients
	ResultString = ""
	Err.Clear

	If LogLevel>0 THEN WriteLog MGlogPath, now & "-" & InputString

	set fso1 = CreateObject ("Scripting.FileSystemObject")
	fso1.CreateTextFile("\\.\pipe\MGPipe", True).Write(InputString)

	If Err.Number <> 0 Then
		If LogLevel>1 THEN WriteLog MGLogPath, now & Err.Message
		'ResultString="-MailGuard not running. Please inform IT immediately."
		ResultString = Err.Message
		Err.Clear
	End If

	If ResultString="" Then
		'Wait 0.5 seconds for the service to do its work
		Dim dteWait
		dteWait = DateAdd("s", 0.5, Now())
		Do Until (Now() > dteWait)
		Loop
		
		'Open the 2nd Pipe and get the results
		ResultString = fso1.OpenTextFile("\\.\pipe\MGPipeOut",1).readLine
		
		If Err.Number <> 0 Then
			If LogLevel>1 THEN WriteLog MGLogPath, now & "-Error in creating/reading from Pipe 2"
			Err.Clear
			ResultString="Z" 'Locally generated ResultString, handle it
		End If
	End If
	
	fso1.close
	Set fso1 = nothing

	if ResultString<>"" Then 
		'Section 3: Handling the exception
			If LogLevel>1 THEN  WriteLog now & "-Received result:" & ResultString
			Dim nl
			nl = Chr(13) & Chr(10)
			'Return codes: 
			'1. X - not defined in MG Rules
			'2. IP - Sending IP not defined ub MGAllowedIPsTable
			'3. List of addresses that are not allowed as per rules
			'4. Blank - everything OK
			'5 - Z - MailGuard not running
		Select case ResultString
			case "Z"
				Result.Message = "MailGuard is not running on the server! Please contact IT immediately"
				Result.Value = 2
			Case "X"
				SendMessage MailGuardID,oMessage.FromAddress,"Could not send: " & oMessage.Subject,"Your email could not be sent as your email address is not configured in MailGuard." & nl & "Please contact IT support."
				Result.Message = ResultString
				Result.Value = 2
				
			Case "IP"
				SendMessage MailGuardID,oMessage.FromAddress,"Could not send: " & oMessage.Subject,"Your email could not be sent as your IP address (" & oClient.ipaddress & ") is not configured in MailGuard. " & nl & "Please reply to this email to have it configured."
				Result.Message = ResultString
				Result.Value = 2
				
			Case Else 'A list of banned addresses has been received from
					
				Dim FinalRecipients
				FinalRecipients=""
				Dim i,x
				
				Dim ToHeader,CCHeader
				Dim emailAddress,fullAddress
				Dim newToHeader,newCCHeader

				ToHeader = oMessage.TO
				CCHeader = oMessage.CC
				newToHeader=""
				newCCHeader=""
				
				'Loop through the recipients and see if they are contained in the returned list of disallowed IDs. Create the list of FinalRecipients who will be added back later
				For i = 0 To oMessage.Recipients.Count-1
					If instr(1,LCase(ResultString),LCase(oMessage.Recipients(i).OriginalAddress),1)=0 Then 'If the recipient is not in the list of disallowed IDs
						FinalRecipients = FinalRecipients & oMessage.Recipients(i).OriginalAddress & ","
					End If
				Next
				'Loop through the To and CC headers to find any disallowed Ids. We are re-creating the TO and CC headers after removing the disallowed IDs entirely (name and email ID)
				for each fullAddress in split(ToHeader,",")
					'Get the email address portion from "Name <EmailID>"
					emailAddress = MID(fullAddress,InstrRev(fullAddress,"<")+1,Len(fullAddress)-InstrRev(fullAddress,"<")-1)
					If instr(1,LCase(ResultString),LCase(emailAddress))=0 Then 'If the disallowed ID list does not contain the ID from the ToList
						newToHeader = newToHeader & fullAddress & ", "
					End If
				Next 
				'Loop thru the CC header
				for each fullAddress in split(CCHeader,",")
				'Get the email address portion from "Name <EmailID>"
					emailAddress = MID(fullAddress,InstrRev(fullAddress,"<")+1,Len(fullAddress)-InstrRev(fullAddress,"<")-1)
					If instr(1,LCase(ResultString),LCase(emailAddress))=0 Then 'If the disallowed ID list does not contain the ID from the ToList
						newCCHeader = newCCHeader & fullAddress & ", "
					End If
				Next 
				'Remove any trailing commas
				newToHeader=truncate_one(newToHeader)
				newCCHeader=truncate_one(newCCHeader)
				
				'Clear all recipients from the message
				oMessage.ClearRecipients()
				
				'Add back the final recipients
				for each x in split(FinalRecipients,",")
					if Trim(x)<>"" then
						EventLog.Write("Now Adding: " & x)	  
						oMessage.addRecipient x,x
					End if
				next
				
				'Add back the modified CC and TO headers
				oMessage.HeaderValue("To") = newToHeader
				oMessage.HeaderValue("CC") = newCCHeader
				
				'Save the message
				oMessage.Save
				
				'Send the reject email stating that the mail was blocked for some recipients
		
				Dim RejectMessage 
				
				RejectMessage  = "Your mail was not sent to the following recipients: " & ResultString  & " as you are not allowed to send mails to them. " & nl & "Please send a reply to this message if you need these IDs to be unblocked."
				SendMessage MailGuardID,oMessage.FromAddress,"MailGuard blocked - " & oMessage.Subject, RejectMessage
				
				'Result.Message = "You cannot send mails to the following IDs as they are blocked by MailGuard: " & ResultString
				Result.Value = 0
		End Select
		
	Else 'blank, everything ok
		If LogLevel>0 THEN WriteLog MGLogPath, now & "-MGResult:Ok"
		Result.Value = 0
	End If

Else
	Result.Message = "You need to be authenticated to send email through this system."
	Result.value = 2
End If 'Run only for authenticated outbound email
End Sub

Function truncate_one(s)
  If Right(s, 1) = "," Then 
    truncate_one = Left(s, Len(s) - 1) 
  Else 
    truncate_one = s
  End If
End Function

Function ErrorHandler(msg)
	If Err.Number <> 0 Then
		WriteLog now & msg
		Err.Clear
	End If
End Function

Function WriteLog(filename,StrTxt)
      Dim fso2
      Set fso2 = CreateObject("Scripting.FileSystemObject")
      fso2.OpenTextFile(filename, 8, True).WriteLine(StrTxt)
	  Set fso2 = Nothing
End Function

Attachments
MailGuard.7z
(240.47 KiB) Downloaded 31 times

prashanthRaju
New user
New user
Posts: 17
Joined: 2012-04-03 15:32

Re: MailGuard-a script for selectively blocking recepients

Post by prashanthRaju » 2019-03-11 05:28

Sorry, missed adding a Sub in the EventHandlers.vbs file. If anybody'd like to go through / verify the source code of MGChecker.exe (VB.net) - I've attached it to this message. The code for the control center - MailGuard.exe is also available, but I'll need to do a little bit of work to strip out some routines that are relevant only to my organization. Please ask if it is needed.

Here's the whole complete script again:

Code: Select all

'MG Version 6
'This version uses Pipes to communicate with an external program - MGChecker.exe
'MG now sends emails after removing blocked recipients, modifies CC and TO headers
'also sends reject email to the sender explaining why the message was rejected
'Create folder c:\MGLog\ or change the MGLogPath variable
'Change the MailGuardID variable - this is the address from which MailGuard will appear to send a mail back to the sender on failure
'Prashanth (cyberprash at gmail)/10th March 2019
'Thanks to the examples provided by various contributors on the hmail forums

Option Explicit

' Global Settings
Dim MGLogPath,FailedDeliveryLogPath
MGLogPath = "c:\MGLog\log.txt"
Private Const LogLevel = 1 '0- Nothing, 1-Only Errors, 2-Everything
'End of global settings.

	
Sub OnAcceptMessage(oClient, oMessage)

On Error Resume Next

if oClient.UserName <> "" THEN 'Run only for authenticated users sending outbound email

	Dim fso1,InputString,ResultString
	Dim MailGuardID
	MailGuardID = "MailGuard <mailguard@YourDomain.com>"
	
	If LogLevel>0 THEN WriteLog MgLogPath, now & "-MG Starting"

	'Section 1: Anonymizing the sender IP
	oMessage.HeaderValue("Received") = "from a friendly server; " & now

	If LogLevel>0 THEN  WriteLog now & "-Finished anonymizing"

	'Section 2: Checking recipients
	Dim Recipients 
	Recipients = ""

	For i = 0 To oMessage.Recipients.Count-1
		   Recipients = Recipients & oMessage.Recipients(i).OriginalAddress & ","
	Next

	Recipients = truncate_one(Recipients) 'Remove the trailing comma if it exists
		  
	InputString = oClient.ipaddress & ":" & oMessage.fromAddress & ":" & Recipients
	ResultString = ""
	Err.Clear

	If LogLevel>0 THEN WriteLog MGlogPath, now & "-" & InputString

	set fso1 = CreateObject ("Scripting.FileSystemObject")
	fso1.CreateTextFile("\\.\pipe\MGPipe", True).Write(InputString)

	If Err.Number <> 0 Then
		If LogLevel>1 THEN WriteLog MGLogPath, now & Err.Message
		'ResultString="-MailGuard not running. Please inform IT immediately."
		ResultString = Err.Message
		Err.Clear
	End If

	If ResultString="" Then
		'Wait 0.5 seconds for the service to do its work
		Dim dteWait
		dteWait = DateAdd("s", 0.5, Now())
		Do Until (Now() > dteWait)
		Loop
		
		'Open the 2nd Pipe and get the results
		ResultString = fso1.OpenTextFile("\\.\pipe\MGPipeOut",1).readLine
		
		If Err.Number <> 0 Then
			If LogLevel>1 THEN WriteLog MGLogPath, now & "-Error in creating/reading from Pipe 2"
			Err.Clear
			ResultString="Z" 'Locally generated ResultString, handle it
		End If
	End If
	
	fso1.close
	Set fso1 = nothing

	if ResultString<>"" Then 
		'Section 3: Handling the exception
			If LogLevel>1 THEN  WriteLog now & "-Received result:" & ResultString
			Dim nl
			nl = Chr(13) & Chr(10)
			'Return codes: 
			'1. X - not defined in MG Rules
			'2. IP - Sending IP not defined ub MGAllowedIPsTable
			'3. List of addresses that are not allowed as per rules
			'4. Blank - everything OK
			'5 - Z - MailGuard not running
		Select case ResultString
			case "Z"
				Result.Message = "MailGuard is not running on the server! Please contact IT immediately"
				Result.Value = 2
			Case "X"
				SendMessage MailGuardID,oMessage.FromAddress,"Could not send: " & oMessage.Subject,"Your email could not be sent as your email address is not configured in MailGuard." & nl & "Please contact IT support."
				Result.Message = ResultString
				Result.Value = 2
				
			Case "IP"
				SendMessage MailGuardID,oMessage.FromAddress,"Could not send: " & oMessage.Subject,"Your email could not be sent as your IP address (" & oClient.ipaddress & ") is not configured in MailGuard. " & nl & "Please reply to this email to have it configured."
				Result.Message = ResultString
				Result.Value = 2
				
			Case Else 'A list of banned addresses has been received from
					
				Dim FinalRecipients
				FinalRecipients=""
				Dim i,x
				
				Dim ToHeader,CCHeader
				Dim emailAddress,fullAddress
				Dim newToHeader,newCCHeader

				ToHeader = oMessage.TO
				CCHeader = oMessage.CC
				newToHeader=""
				newCCHeader=""
				
				'Loop through the recipients and see if they are contained in the returned list of disallowed IDs. Create the list of FinalRecipients who will be added back later
				For i = 0 To oMessage.Recipients.Count-1
					If instr(1,LCase(ResultString),LCase(oMessage.Recipients(i).OriginalAddress),1)=0 Then 'If the recipient is not in the list of disallowed IDs
						FinalRecipients = FinalRecipients & oMessage.Recipients(i).OriginalAddress & ","
					End If
				Next
				'Loop through the To and CC headers to find any disallowed Ids. We are re-creating the TO and CC headers after removing the disallowed IDs entirely (name and email ID)
				for each fullAddress in split(ToHeader,",")
					'Get the email address portion from "Name <EmailID>"
					emailAddress = MID(fullAddress,InstrRev(fullAddress,"<")+1,Len(fullAddress)-InstrRev(fullAddress,"<")-1)
					If instr(1,LCase(ResultString),LCase(emailAddress))=0 Then 'If the disallowed ID list does not contain the ID from the ToList
						newToHeader = newToHeader & fullAddress & ", "
					End If
				Next 
				'Loop thru the CC header
				for each fullAddress in split(CCHeader,",")
				'Get the email address portion from "Name <EmailID>"
					emailAddress = MID(fullAddress,InstrRev(fullAddress,"<")+1,Len(fullAddress)-InstrRev(fullAddress,"<")-1)
					If instr(1,LCase(ResultString),LCase(emailAddress))=0 Then 'If the disallowed ID list does not contain the ID from the ToList
						newCCHeader = newCCHeader & fullAddress & ", "
					End If
				Next 
				'Remove any trailing commas
				newToHeader=truncate_one(newToHeader)
				newCCHeader=truncate_one(newCCHeader)
				
				'Clear all recipients from the message
				oMessage.ClearRecipients()
				
				'Add back the final recipients
				for each x in split(FinalRecipients,",")
					if Trim(x)<>"" then
						EventLog.Write("Now Adding: " & x)	  
						oMessage.addRecipient x,x
					End if
				next
				
				'Add back the modified CC and TO headers
				oMessage.HeaderValue("To") = newToHeader
				oMessage.HeaderValue("CC") = newCCHeader
				
				'Save the message
				oMessage.Save
				
				'Send the reject email stating that the mail was blocked for some recipients
		
				Dim RejectMessage 
				
				RejectMessage  = "Your mail was not sent to the following recipients: " & ResultString  & " as you are not allowed to send mails to them. " & nl & "Please send a reply to this message if you need these IDs to be unblocked."
				SendMessage MailGuardID,oMessage.FromAddress,"MailGuard blocked - " & oMessage.Subject, RejectMessage
				
				'Result.Message = "You cannot send mails to the following IDs as they are blocked by MailGuard: " & ResultString
				Result.Value = 0
		End Select
		
	Else 'blank, everything ok
		If LogLevel>0 THEN WriteLog MGLogPath, now & "-MGResult:Ok"
		Result.Value = 0
	End If

Else
	Result.Message = "You need to be authenticated to send email through this system."
	Result.value = 2
End If 'Run only for authenticated outbound email
End Sub

Function truncate_one(s)
  If Right(s, 1) = "," Then 
    truncate_one = Left(s, Len(s) - 1) 
  Else 
    truncate_one = s
  End If
End Function

Function ErrorHandler(msg)
	If Err.Number <> 0 Then
		WriteLog now & msg
		Err.Clear
	End If
End Function

Function WriteLog(filename,StrTxt)
      Dim fso2
      Set fso2 = CreateObject("Scripting.FileSystemObject")
      fso2.OpenTextFile(filename, 8, True).WriteLine(StrTxt)
	  Set fso2 = Nothing
End Function

Function SendMessage(sender,recipient,subject,body)
	dim oMessage
	Set oMessage=CreateObject("hMailServer.Message")
	oMessage.From=sender
	oMessage.FromAddress=sender
	oMessage.AddRecipient recipient, recipient
	oMessage.Subject = subject
	oMessage.Body = body
	oMessage.Save 
	oMessage = nothing
End Function


Attachments
MGChecker.7z
Source code (vb.net) for MGChecker - the background utility that communicates with the script
(133.47 KiB) Downloaded 36 times

Post Reply