SHARE
TWEET

EventHandlers.vbs

bagu May 15th, 2013 20 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. '   Sub OnClientConnect(oClient)
  2. '   End Sub
  3.  
  4. '   Sub OnAcceptMessage(oClient, oMessage)
  5. '   End Sub
  6.  
  7. '   Sub OnDeliveryStart(oMessage)
  8. '   End Sub
  9.  
  10. '   Sub OnDeliverMessage(oMessage)
  11. '   End Sub
  12.  
  13. '   Sub OnBackupFailed(sReason)
  14. '   End Sub
  15.  
  16. '   Sub OnBackupCompleted()
  17. '   End Sub
  18.  
  19. '   Sub OnError(iSeverity, iCode, sSource, sDescription)
  20. '   End Sub
  21.  
  22. '   Sub OnDeliveryFailed(oMessage, sRecipient, sErrorMessage)
  23. '   End Sub
  24.  
  25. '   Sub OnExternalAccountDownload(oMessage, sRemoteUID)
  26. '   End Sub
  27.  
  28. Public obApp
  29. Public Const iplocalhost = "127.0.0.1"
  30. Public excluded_domains
  31. excluded_domains = array("gmail.com","hotmail.com","yahoo.com","yahoo.fr")
  32. Public Const user = "private"
  33. Public Const pw = "private"
  34. public const dbg = true
  35.  
  36. Public Const remember_wl_address = 60
  37. Public Const emailaddressesfile = "D:\hMailServer\Events\auto-whitelist.txt"
  38. Public Const logspath = "D:\hMailServer\Logs\"
  39.  
  40. 'Sub OnClientConnect(oClient)
  41. 'End Sub
  42.  
  43. 'Sub OnDeliveryStart(oMessage)
  44. 'End Sub
  45.  
  46. 'Sub OnDeliverMessage(oMessage)
  47. 'End Sub
  48.  
  49. 'Sub OnBackupFailed(sReason)
  50. 'End Sub
  51.  
  52. 'Sub OnBackupCompleted()
  53. 'End Sub
  54.  
  55. Sub OnAcceptMessage(oClient, oMessage)
  56.    Set obApp = CreateObject("hMailServer.Application")
  57.    Call obApp.Authenticate(user, pw)
  58.    
  59.    If oCLient.username <> "" Or oClient.IPAddress = iplocalhost Then
  60.       write_log ("-->User has authenticated. User " & oCLient.username & ", Client " & oClient.IPAddress)
  61.       register_emailadress oClient, oMessage
  62.    End if
  63.    
  64. End Sub
  65.  
  66. sub register_emailadress(oClient, oMessage)
  67.    'uses functions: get_smtp_recipient, update_whitelist
  68.   'uses globals: emailaddressesfile, remember_wl_address
  69.   Const ForReading = 1, ForWriting = 2, ForAppending = 8
  70.    Dim fs , f
  71.    Set fs = CreateObject("scripting.filesystemobject")
  72.    Dim ln
  73.    Dim arr
  74.    Dim fnd(2000)
  75.    Dim fd
  76.    Dim content
  77.    Dim upd
  78.    Dim erg
  79.    Dim tmp
  80.    upd = False
  81.    
  82.    Dim mailto
  83.    Dim toarr
  84.    Dim Domain_to
  85.    Dim in_excluded
  86.    
  87.    Set obRecipients = oMessage.Recipients
  88.    erg = ""
  89.    For i = 0 to obRecipients.Count - 1
  90.    Set obRecipient = obRecipients.Item(i)
  91.    tmp = obRecipient.Address
  92.    Domain_to = Split(lcase(tmp),"@")
  93.  
  94. in_excluded = False
  95.  
  96. On Error Resume Next
  97.  
  98. ' test to see if the domain and email are local. if local exclude it from whitelisting
  99.   Dim obDomain
  100.    Set obDomain = obApp.Domains.ItemByName(Domain_to(1))
  101.  
  102. if Err = 0 then
  103.     Set obAccount = obDomain.Accounts.ItemByAddress(tmp)
  104.        if Err = 0 then
  105.       in_excluded = true
  106.    end if  
  107. end if
  108.  
  109. ' Loop through all excluded domains and test if the recipient domain is in the excluded domains list
  110. If not in_excluded Then
  111. For each str in excluded_domains
  112.    If Domain_to(1) = str Then
  113.       in_excluded = True
  114.       Exit For
  115.    End If
  116. Next
  117. End If
  118.  
  119.      If not in_excluded Then  
  120.      erg = erg & tmp & "#"    
  121.      End if
  122.  
  123.    tmp = ""
  124.    Next
  125. If erg <> "" Then
  126.    erg = Mid(erg, 1, Len(erg) - 1)
  127.    toarr = Split(lcase(erg),"#")
  128.  
  129.    content = ""
  130.    For i = 0 To UBound(toarr)
  131.       fnd(i) = False
  132.    Next
  133.    
  134.    If fs.FileExists(emailaddressesfile) Then
  135.       Set f = fs.OpenTextFile(emailaddressesfile, ForReading)
  136.       Do While Not f.AtEndOfStream
  137.          ln = f.ReadLine
  138.          If ln <> "" Then
  139.             arr = Split(ln,Chr(9))
  140.            
  141.             fd = false
  142.             For j = 0 To UBound(toarr)
  143.                mailto = toarr(j)
  144.                If arr(0) = mailto Then
  145.                   fd = True
  146.                   fnd(j) = True
  147.                End If
  148.             Next
  149.             If fd = True then
  150.                write_log ("  adding to line " & ln)
  151.                content = content & arr(0) & Chr(9) & arr(1) + 1 & Chr(9) & Date() & Chr(9) & CLng(Date()) & nl
  152.             ElseIf CLng(arr(3)) < CLng(Date()) - remember_wl_address Then
  153.                write_log ("  deleting line " & ln)
  154.                upd = true
  155.             Else
  156.                content = content & ln & nl
  157.             End If
  158.          End if
  159.       Loop
  160.       f.Close
  161.    End If
  162.    
  163.    For i = 0 To UBound(toarr)
  164.       If fnd(i) = False Then
  165.          content = content & toarr(i) & Chr(9) & 1 & Chr(9) & Date() & Chr(9) & CLng(Date()) & nl
  166.          write_log ("  adding new line")
  167.          upd = true
  168.       End If
  169.    next
  170.    
  171.    Set f = fs.OpenTextFile(emailaddressesfile, ForWriting, true)
  172.    f.Write(content)
  173.    write_log ("  writing emailaddressesfile")
  174.    f.Close
  175.    
  176.    If upd = True Then
  177.       update_whitelist
  178.    End If
  179. End If  
  180. End Sub
  181.  
  182. Sub update_whitelist()
  183.    'uses functions:
  184.   'uses globals: obapp, emailaddressesfile
  185.   Const ForReading = 1, ForWriting = 2, ForAppending = 8
  186.    Set fs = CreateObject("scripting.filesystemobject")
  187.    Dim i
  188.    Dim j
  189.    Dim k
  190.    Dim ln
  191.    Dim arr
  192.    Dim dom
  193.    Dim lstrcps
  194.    Dim rcp
  195.    Set whtlst = obapp.Settings.AntiSpam.WhiteListAddresses
  196.    Dim lstadrs
  197.    lstadrs = ""
  198.    Dim lstadrsarr
  199.    
  200.    i = whtlst.Count - 1
  201.    Do While i >= 0
  202.       Set wlo = whtlst.Item(i)
  203.       If Mid(wlo.Description,1,5) = "zvbs_" Or Mid(wlo.Description,1,5) = "zlst_" Then
  204.          whtlst.DeleteByDBID(whtlst.Item(i).id)
  205.       End If
  206.       i = i - 1
  207.    loop
  208.    
  209.    If fs.FileExists(emailaddressesfile) Then
  210.       Set f = fs.OpenTextFile(emailaddressesfile, ForReading)
  211.      
  212.       Do While Not f.AtEndOfStream
  213.          ln = f.ReadLine
  214.          arr = Split(ln,Chr(9))
  215.          
  216.          If UBound(arr) = 3 Then
  217.             Set nwl = whtlst.Add
  218.             nwl.LowerIPAddress = "0.0.0.0"
  219.             nwl.UpperIPAddress = "255.255.255.255"
  220.             nwl.emailaddress = arr(0)
  221.             nwl.description = "zvbs_" & arr(0)
  222.             nwl.Save
  223.          End if
  224.       Loop
  225.       write_log("  Updating whitelist successful.")
  226.    Else
  227.       write_log("  Updating whitelist error: no emailadress file found.")
  228.    End If
  229.    
  230.    i = 0
  231.    Do While i <= obapp.Domains.Count - 1
  232.       Set dom = obapp.Domains.Item(i)
  233.       j = 0
  234.       'write_log("    " & dom.Name)
  235.      Do While j <= dom.DistributionLists.Count - 1
  236.          Set lstrcps = dom.DistributionLists.Item(j).recipients
  237.          k = 0
  238.          'write_log("      " & dom.DistributionLists.Item(j).address)
  239.         Do While k <= lstrcps.count - 1
  240.             Set rcp = lstrcps.item(k)
  241.             'write_log("        " & rcp.recipientaddress)
  242.            If Not InStr(1, lstadrs, rcp.recipientaddress) > 0 Then
  243.                lstadrs = lstadrs & rcp.recipientaddress & "#"
  244.             End If
  245.             k = k + 1
  246.          Loop
  247.          j = j + 1
  248.       Loop
  249.       i = i + 1
  250.    Loop
  251.    
  252.    If Len(lstadrs) > 1 Then
  253.       lstadrs = Mid(lstadrs,1,Len(lstadrs) -1)
  254.    End if
  255.    lstadrsarr = Split(lstadrs,"#")
  256.    i = 0
  257.    Do While i <= UBound(lstadrsarr)
  258.       Set nwl = whtlst.Add
  259.       nwl.LowerIPAddress = "0.0.0.0"
  260.       nwl.UpperIPAddress = "255.255.255.255"
  261.       nwl.emailaddress = lstadrsarr(i)
  262.       nwl.description = "zlst_" & lstadrsarr(i)
  263.       nwl.Save
  264.       'write_log("  adding " & lstadrsarr(i))
  265.      i = i + 1
  266.    Loop
  267.    If UBound(lstadrsarr) > 0 then
  268.       write_log("  Updating whitelist successful. Adding list members. Nr " & UBound(lstadrsarr) + 1)
  269.    End if
  270. End sub
  271.  
  272.  
  273. Sub write_log(txt)
  274.    'uses functions: get_date, nl
  275.   'uses globals: logspath
  276.   Const ForReading = 1, ForWriting = 2, ForAppending = 8
  277.    Dim fs
  278.    Dim f
  279.    
  280.    Set fs = CreateObject("scripting.filesystemobject")
  281.    
  282.    Dim fn
  283.    Dim tmp
  284.     fn = logspath & "hmailserver_event_" & get_date & ".log"
  285.    If dbg = True Then
  286.       Set f = fs.opentextfile(fn, ForAppending, true)
  287.       tmp = """" & FormatDateTime(Date + time,0) & """" & Chr(9) & """" & txt & """" & nl
  288.       f.Write(tmp)
  289.       f.close
  290.    End If
  291. End Sub
  292.  
  293. Function get_date
  294.    Dim tmp
  295.    Dim erg
  296.    tmp = Year(Date)
  297.    erg = CStr(tmp)
  298.    
  299.    If Month(Date) < 10 Then
  300.       tmp = "0" & Month(Date)
  301.    Else
  302.       tmp = Month(Date)
  303.    End If
  304.    erg = erg & "-" & tmp
  305.    
  306.    If day(Date) < 10 Then
  307.       tmp = "0" & day(Date)
  308.    Else
  309.       tmp = day(Date)
  310.    End If
  311.    erg = erg & "-" & tmp
  312.    
  313.    get_date = erg
  314. End Function
  315.  
  316. Function nl
  317.    nl = Chr(13) & Chr(10)
  318. End function
  319.  
  320. Sub OnClientConnect(oClient)
  321.    Dim geoip
  322.    Dim Country
  323.    Result.Value = 0
  324.    set geoip = CreateObject("GeoIPCOMEx.GeoIPEx")
  325.    geoip.set_db_path("D:\hMailServer\Geoip\")
  326.    geoip.find_by_addr(oClient.IPAddress)
  327.    country = GeoIP.country_code
  328.  
  329.    If (country = "CN" ) Then  ' Reject this country
  330.      Result.Value = 1
  331.    End if
  332.    If (country = "NG" ) Then  ' Reject this country
  333.      Result.Value = 1
  334.    End if
  335.    If (country = "UA" ) Then  ' Reject this country
  336.      Result.Value = 1
  337.    End if
  338.    If (country = "RU" ) Then  ' Reject this country
  339.      Result.Value = 1
  340.    End if
  341.    If (country = "TR" ) Then  ' Reject this country
  342.      Result.Value = 1
  343.    End if
  344.    If (country = "PL" ) Then  ' Reject this country
  345.      Result.Value = 1
  346.    End if
  347.    If (country = "LT" ) Then  ' Reject this country
  348.      Result.Value = 1
  349.    End if
  350.  
  351.    If (Result.Value = 1 ) Then  ' Rejected
  352.      EventLog.Write("Geo-IP rejected:"+Chr(34)+vbTab+oClient.IPAddress+vbTab+Chr(34)+geoip.country_code+" "+geoip.country_name)
  353.    End if
  354. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top