Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ' Sub OnClientConnect(oClient)
- ' End Sub
- ' Sub OnAcceptMessage(oClient, oMessage)
- ' 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
- Public obApp
- Public Const iplocalhost = "127.0.0.1"
- Public excluded_domains
- excluded_domains = array("gmail.com","hotmail.com","yahoo.com","yahoo.fr")
- Public Const user = "private"
- Public Const pw = "private"
- public const dbg = true
- Public Const remember_wl_address = 60
- Public Const emailaddressesfile = "D:\hMailServer\Events\auto-whitelist.txt"
- Public Const logspath = "D:\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
- Dim erg
- Dim tmp
- upd = False
- Dim mailto
- Dim toarr
- Dim Domain_to
- Dim in_excluded
- Set obRecipients = oMessage.Recipients
- erg = ""
- For i = 0 to obRecipients.Count - 1
- Set obRecipient = obRecipients.Item(i)
- tmp = obRecipient.Address
- Domain_to = Split(lcase(tmp),"@")
- in_excluded = False
- On Error Resume Next
- ' test to see if the domain and email are local. if local exclude it from whitelisting
- Dim obDomain
- Set obDomain = obApp.Domains.ItemByName(Domain_to(1))
- if Err = 0 then
- Set obAccount = obDomain.Accounts.ItemByAddress(tmp)
- if Err = 0 then
- in_excluded = true
- end if
- end if
- ' Loop through all excluded domains and test if the recipient domain is in the excluded domains list
- If not in_excluded Then
- For each str in excluded_domains
- If Domain_to(1) = str Then
- in_excluded = True
- Exit For
- End If
- Next
- End If
- If not in_excluded Then
- erg = erg & tmp & "#"
- End if
- tmp = ""
- Next
- If erg <> "" Then
- erg = Mid(erg, 1, Len(erg) - 1)
- toarr = Split(lcase(erg),"#")
- 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 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
- 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
- Sub OnClientConnect(oClient)
- Dim geoip
- Dim Country
- Result.Value = 0
- set geoip = CreateObject("GeoIPCOMEx.GeoIPEx")
- geoip.set_db_path("D:\hMailServer\Geoip\")
- geoip.find_by_addr(oClient.IPAddress)
- country = GeoIP.country_code
- If (country = "CN" ) Then ' Reject this country
- Result.Value = 1
- End if
- If (country = "NG" ) Then ' Reject this country
- Result.Value = 1
- End if
- If (country = "UA" ) Then ' Reject this country
- Result.Value = 1
- End if
- If (country = "RU" ) Then ' Reject this country
- Result.Value = 1
- End if
- If (country = "TR" ) Then ' Reject this country
- Result.Value = 1
- End if
- If (country = "PL" ) Then ' Reject this country
- Result.Value = 1
- End if
- If (country = "LT" ) Then ' Reject this country
- Result.Value = 1
- End if
- If (Result.Value = 1 ) Then ' Rejected
- EventLog.Write("Geo-IP rejected:"+Chr(34)+vbTab+oClient.IPAddress+vbTab+Chr(34)+geoip.country_code+" "+geoip.country_name)
- End if
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement