This script remembers the recipients from any authenticated smtp user and add them to the global whitelist. Also all members of the lists are added.
Installation instruction:
1. Activate Scripting in hmailserver, should be in hm admin tool: settings->advanced->settings
2. Click on show scripts and open eventhandler.vbs
3a. in case you aren't using any vbs scripts at the moment
Paste the whole script into the the eventhandler.vbs file
3b. in case you are using vbs scripts
paste the global variables (every line at the top starting with public) at the top of your script file
activate and/or integrated the provided content of sub OnAcceptMessage in your OnAcceptMessage
(just paste the provided content in your sub should do the trick)
paste the subs and functions below the sub OnAcceptMessage at the end of your script
(starts with the line sub register_emailadress(oClient, oMessage))
4 do the settings
iplocalhost ist the ip of the localhost from where you can send mails without authentification
user and pw is the login data to hmailserver
dbg is boolean and instructs the script to log the actions or not
remember_wl_address is the amount of days the outgoing addresses are stored
emailaddressesfile is the file in which the addresses are stored, can be anywhere on your server, i put it in the events dir of hm
logspath is the path where the logs of hm are saved, make sure it ends with a backslash (\)
5a switch on smtp logs of hm
5b you are not happy about my solution and the function get_smtp_recipient, which reads the recipients out of the log file
generally changing sub register_emailadress should do it
change the code and take the recipients of the method message.recipients.
variable toarr must be an array of recipients
get_smtp_recipient returns a string of recipients separated by #, see line toarr = Split(get_smtp_recipient(oClient.IPAddress),"#")
6 save the file and close the editor
7 check syntax of the script in hm
8a syntax is correct -> reload the script in hm
8b syntax check fails -> check the error message an correct
9 check the event log and the emailaddressfile and see if it works according to your testing
(this script writes a separate logfile in the logspath)
As I extracted the code from a lot more scripts and didn't test it in a stand alone environment, we need a volunteer here ...
... westdam tested the stand alone version, see below.
Couldn't upload the code via file so here it is ...
Code: Select all
Public obApp
Public Const iplocalhost = "a.b.c.d"
Public Const user = "Administrator"
Public Const pw = "yourpw"
public const dbg = true
Public Const remember_wl_address = 180
Public Const emailaddressesfile = "C:\Program Files (x86)\hMailServer\Events\emailaddresses.txt"
Public Const logspath = "C:\Program Files (x86)\hMailServer\Logs\"
'Sub OnClientConnect(oClient)
'End Sub
'Sub OnDeliveryStart(oMessage)
'End Sub
'Sub OnDeliverMessage(oMessage)
'End Sub
'Sub OnBackupFailed(sReason)
'End Sub
'Sub OnBackupCompleted()
'End Sub
Sub OnAcceptMessage(oClient, oMessage)
Set obApp = CreateObject("hMailServer.Application")
Call obApp.Authenticate(user, pw)
If oCLient.username <> "" Or oClient.IPAddress = iplocalhost Then
write_log ("-->User has authenticated. User " & oCLient.username & ", Client " & oClient.IPAddress)
register_emailadress oClient, oMessage
End if
End Sub
sub register_emailadress(oClient, oMessage)
'uses functions: get_smtp_recipient, update_whitelist
'uses globals: emailaddressesfile, remember_wl_address
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fs , f
Set fs = CreateObject("scripting.filesystemobject")
Dim ln
Dim arr
Dim fnd(2000)
Dim fd
Dim content
Dim upd
upd = False
Dim mailto
Dim toarr
toarr = Split(lcase(get_smtp_recipient(oClient.IPAddress)),"#")
content = ""
For i = 0 To UBound(toarr)
fnd(i) = False
Next
If fs.FileExists(emailaddressesfile) Then
Set f = fs.OpenTextFile(emailaddressesfile, ForReading)
Do While Not f.AtEndOfStream
ln = f.ReadLine
If ln <> "" Then
arr = Split(ln,Chr(9))
fd = false
For j = 0 To UBound(toarr)
mailto = toarr(j)
If arr(0) = mailto Then
fd = True
fnd(j) = True
End If
Next
If fd = True then
write_log (" adding to line " & ln)
content = content & arr(0) & Chr(9) & arr(1) + 1 & Chr(9) & Date() & Chr(9) & CLng(Date()) & nl
ElseIf CLng(arr(3)) < CLng(Date()) - remember_wl_address Then
write_log (" deleting line " & ln)
upd = true
Else
content = content & ln & nl
End If
End if
Loop
f.Close
End If
For i = 0 To UBound(toarr)
If fnd(i) = False Then
content = content & toarr(i) & Chr(9) & 1 & Chr(9) & Date() & Chr(9) & CLng(Date()) & nl
write_log (" adding new line")
upd = true
End If
next
Set f = fs.OpenTextFile(emailaddressesfile, ForWriting, true)
f.Write(content)
write_log (" writing emailaddressesfile")
f.Close
If upd = True Then
update_whitelist
End If
End Sub
Sub update_whitelist()
'uses functions:
'uses globals: obapp, emailaddressesfile
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set fs = CreateObject("scripting.filesystemobject")
Dim i
Dim j
Dim k
Dim ln
Dim arr
Dim dom
Dim lstrcps
Dim rcp
Set whtlst = obapp.Settings.AntiSpam.WhiteListAddresses
Dim lstadrs
lstadrs = ""
Dim lstadrsarr
i = whtlst.Count - 1
Do While i >= 0
Set wlo = whtlst.Item(i)
If Mid(wlo.Description,1,5) = "zvbs_" Or Mid(wlo.Description,1,5) = "zlst_" Then
whtlst.DeleteByDBID(whtlst.Item(i).id)
End If
i = i - 1
loop
If fs.FileExists(emailaddressesfile) Then
Set f = fs.OpenTextFile(emailaddressesfile, ForReading)
Do While Not f.AtEndOfStream
ln = f.ReadLine
arr = Split(ln,Chr(9))
If UBound(arr) = 3 Then
Set nwl = whtlst.Add
nwl.LowerIPAddress = "0.0.0.0"
nwl.UpperIPAddress = "255.255.255.255"
nwl.emailaddress = arr(0)
nwl.description = "zvbs_" & arr(0)
nwl.Save
End if
Loop
write_log(" Updating whitelist successful.")
Else
write_log(" Updating whitelist error: no emailadress file found.")
End If
i = 0
Do While i <= obapp.Domains.Count - 1
Set dom = obapp.Domains.Item(i)
j = 0
'write_log(" " & dom.Name)
Do While j <= dom.DistributionLists.Count - 1
Set lstrcps = dom.DistributionLists.Item(j).recipients
k = 0
'write_log(" " & dom.DistributionLists.Item(j).address)
Do While k <= lstrcps.count - 1
Set rcp = lstrcps.item(k)
'write_log(" " & rcp.recipientaddress)
If Not InStr(1, lstadrs, rcp.recipientaddress) > 0 Then
lstadrs = lstadrs & rcp.recipientaddress & "#"
End If
k = k + 1
Loop
j = j + 1
Loop
i = i + 1
Loop
If Len(lstadrs) > 1 Then
lstadrs = Mid(lstadrs,1,Len(lstadrs) -1)
End if
lstadrsarr = Split(lstadrs,"#")
i = 0
Do While i <= UBound(lstadrsarr)
Set nwl = whtlst.Add
nwl.LowerIPAddress = "0.0.0.0"
nwl.UpperIPAddress = "255.255.255.255"
nwl.emailaddress = lstadrsarr(i)
nwl.description = "zlst_" & lstadrsarr(i)
nwl.Save
'write_log(" adding " & lstadrsarr(i))
i = i + 1
Loop
If UBound(lstadrsarr) > 0 then
write_log(" Updating whitelist successful. Adding list members. Nr " & UBound(lstadrsarr) + 1)
End if
End sub
Function get_smtp_recipient(ipaddr)
'uses functions: get_date
'uses globals: logspath
get_smtp_recipient = ""
Dim fs
Dim f
Set fs = CreateObject("scripting.filesystemobject")
Dim fn
Dim ln
Dim arr
Dim tmp
Dim erg
erg = ""
fn = logspath & "hmailserver_" & get_date & ".log"
If fs.FileExists(fn) Then
Set f = fs.opentextfile(fn)
Do While Not f.AtEndOfStream
ln = f.ReadLine
arr = Split(ln, Chr(9))
If UBound(arr) = 5 Then
tmp = ""
If arr(0) = """SMTPD""" And arr(4) = """" & ipaddr & """" And InStr(1, " " & arr(5), "RECEIVED: EHLO") > 0 Then
erg = ""
End If
If arr(0) = """SMTPD""" And arr(4) = """" & ipaddr & """" And InStr(1, " " & arr(5), "RECEIVED: HELO") > 0 Then
erg = ""
End If
If arr(0) = """SMTPD""" And arr(4) = """" & ipaddr & """" And InStr(1, " " & arr(5), "SENT: 220 mailserver1.integrated-networks.de ESMTP") > 0 Then
erg = ""
End If
If arr(0) = """SMTPD""" And arr(4) = """" & ipaddr & """" And InStr(1, arr(5), "RCPT") > 0 And InStr(1, arr(5), "<") > 0 And InStr(1, arr(5), ">") > 0 Then
tmp = Mid(arr(5), InStr(1, arr(5), "<") + 1)
tmp = Mid(tmp, 1, InStr(1, tmp, ">") - 1)
End If
If erg = "" And tmp <> "" Then
erg = tmp & "#"
elseIf tmp <> "" Then
If InStr(1," " & erg,tmp) <= 1 Then
erg = erg & tmp & "#"
End if
End If
End If
Loop
f.Close
End If
If erg <> "" Then
get_smtp_recipient = Mid(erg, 1, Len(erg) - 1)
End If
End Function
Sub write_log(txt)
'uses functions: get_date, nl
'uses globals: logspath
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fs
Dim f
Set fs = CreateObject("scripting.filesystemobject")
Dim fn
Dim tmp
fn = logspath & "hmailserver_event_" & get_date & ".log"
If dbg = True Then
Set f = fs.opentextfile(fn, ForAppending, true)
tmp = """" & FormatDateTime(Date + time,0) & """" & Chr(9) & """" & txt & """" & nl
f.Write(tmp)
f.close
End If
End Sub
Function get_date
Dim tmp
Dim erg
tmp = Year(Date)
erg = CStr(tmp)
If Month(Date) < 10 Then
tmp = "0" & Month(Date)
Else
tmp = Month(Date)
End If
erg = erg & "-" & tmp
If day(Date) < 10 Then
tmp = "0" & day(Date)
Else
tmp = day(Date)
End If
erg = erg & "-" & tmp
get_date = erg
End Function
Function nl
nl = Chr(13) & Chr(10)
End function