EventHandlers.vbs

'   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