Ситуация - есть у нас один большой клиент. Можно сказать ключевой. И есть у него неприятная черта - его почтовый сервер на DNSBL прямо-таки молится. 
В общем стоит попасть в блэклист баракуды и начинается коллапс с недоходящей до них почтой(ибо баллами они не пользуются, а блокируют безоговорочно). Т.к. в нескольких случаях ситуация возникала в пятницу под вечер, то наши сотрудники следуя традиции ("само исправится" - ведь даже менеджеры, свободно общающиеся на английском с клиентами, оказываются неспособны прочитать банальное уведомление о блокировке) сообщали о проблеме только в понедельник. А т.к. удаление из списка процесс не быстрый, то пол дня без возможности связаться с клиентом. Момент крайне неприятный.
Собственно для того чтобы оперативно отслеживать данную ситуацию и решил написать скриптик(в бою пока не был, но на IP из серверных логов потестировал). Надеюсь будет полезен не только мне.
' VB Script Document
Option Explicit
' http://www.barracudacentral.org/rbl/how-to-use
' http://ru.wikipedia.org/wiki/DNSBL
' если IP есть в блоклисте, то будет резолвиться хостнейм вида IP_наоборот.black.list.hostname
' например, для 192.149.23.63 на баракуде нужно проверять 63.23.149.192.b.barracudacentral.org
' резолвиться будет в адрес 127.0.0.x (обычно, но не обязательно)
' X - в зависимости от причины попадания в список(хотя официального документа на этот счёт видимо нет)
' http://www.spamhaus.org/faq/answers.lasso?section=DNSBL%20Usage#202 - расшифровка X для SPAMHOUSE
Dim RegPath, Write2Reg
RegPath = "HKLM\Software\VBS Scripts Settings\DNSBL_Monitoring" ' Храним тут
Write2Reg = true ' false - отключает запись в реестр(а вдруг будет нужно?)
' Параметры отправки почты
Dim smtp_host, smtp_auth, smtp_port, smtp_user, smtp_pass, from_email, to_email
smtp_host = "mail.mydomen.com"
smtp_auth = 0 ' если 1(т.е. с авторизацией), то пароль нужен обязательно
smtp_port = 25
smtp_user = "myusername"
smtp_pass = "mypassword"
from_email = "dnsbl.monitoring@ru.mydomen.com"
to_email = "my.name@ru.mydomen.com"
Dim DNSBL, Hosts, TestHost
TestHost = "8.8.8.8" ' "неумерающий" хост для проверки доступности интернета, например публичный ДНС гугла
Set DNSBL = CreateObject("Scripting.Dictionary") 'список блэклистов
DNSBL.Add "b.barracudacentral.org", "Вражина №1"
DNSBL.Add "sbl.spamhaus.org", "SBL Spamhaus"
DNSBL.Add "xbl.spamhaus.org", "XBL Spamhaus"
DNSBL.Add "pbl.spamhaus.org", "PBL Spamhaus"
'DNSBL.Add "zen.spamhaus.org", "ZEN Spamhaus"
' OFF потому что объединяет ответ не только с SBL, XBL, PBL, но и с cbl.abuseat.org
' к тому-же если IP числится только в cbl.abuseat.org(а не в SBL, XBL or PBL),
' то сайт выдаёт "LISTED", а по лукапу выходит NOTLISTED
' подробности - http://www.spamhaus.org/faq/answers.lasso?section=DNSBL%20Usage#252
DNSBL.Add "cbl.abuseat.org", "cbl.abuseat.org"
DNSBL.Add "bl.spamcop.net", "bl.spamcop.net"
DNSBL.Add "dnsbl.sorbs.net", "dnsbl.sorbs.net"
DNSBL.Add "web.dnsbl.sorbs.net", "web.dnsbl.sorbs.net"
DNSBL.Add "bl.tiopan.com", "bl.tiopan.com"
Set Hosts = CreateObject("Scripting.Dictionary") 'список проверяемых IP-адресов
Hosts.Add "94.100.177.6", "pop3.mail.ru"
Hosts.Add "74.125.39.109", "pop.gmail.com"
Hosts.Add "87.250.250.124", "imap.yandex.ru"
Hosts.Add "86.35.249.224", "Blocked IP2"
Hosts.Add "194.250.63.103", "Blocked IP"
'##############################################################################
'###### все настройки выше ######
'##############################################################################
Dim TotalTimer
TotalTimer = Timer
' объекты:
Dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")
Dim Key ' для возврата значений ключа реестра
Dim arrDNSBL, arrHosts
arrDNSBL = DNSBL.Keys
arrHosts = Hosts.Keys
Dim BBody, Need2Report
BBody = "<HTML> <meta http-equiv=""Content-Type"" content=""text/html; charset=windows-1251"" /> <b>DNSBL_Monitoring</b><br>начало работы скрипта: " & Now & "<hr>" ' "начинаем" тело
Need2Report = false ' если появятся новые данные по блокировкам, станет true
Dim i, j
For i = LBound(arrDNSBL) To UBound(arrDNSBL) 'пинганём список...
DNSBL.Item(arrDNSBL(i)) = vbNullstring ' очистка перед заполнением
For j = LBound(arrHosts) To UBound(arrHosts) 'пинганём список...
'читаем соотв. ключ в реестре и проверяем что IP ещё не там
' ##############################################################################
if Ping(TestHost) then ' инет есть, можно проверять BL
Key = DoTheKey(RegPath, arrDNSBL(i), false, vbNullstring)
'wscript.echo "Key = " & Key
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
if StrComp(Key, vbNullstring, vbTextCompare) <> 0 then ' если ключ непустой - проверяем есть ли в нём IP, иначе переход на проверку хоста
if InStr(1, Key, arrHosts(j), vbTextCompare) > 0 then 'если IP уже блокировался
if not IsInBL(arrDNSBL(i), arrHosts(j)) then ' если более не в списке - уведомляем что IP удалён из BL
BBody = BBody & "IP-адрес " & arrHosts(j) & "(" & Hosts.Item(arrHosts(j)) & ") был удалён из DNSBL: " & arrDNSBL(i) & "<br>"
Need2Report = true
end if
else '<<2>> ранее IP в BL не числился
if IsInBL(arrDNSBL(i), arrHosts(j)) then ' попал в список - уведомляем
BBody = BBody & "IP-адрес " & arrHosts(j) & "(" & Hosts.Item(arrHosts(j)) & ") был занесён в DNSBL: " & arrDNSBL(i) & "<br>"
Need2Report = true
end if
end if ' IP в списке?
else '<1> если Key пустой => блоклист ранее не проверялся
if IsInBL(arrDNSBL(i), arrHosts(j)) then ' попал в список - уведомляем
BBody = BBody & "IP-адрес " & arrHosts(j) & "(" & Hosts.Item(arrHosts(j)) & ") был занесён в DNSBL: " & arrDNSBL(i) & "<br>"
Need2Report = true
end if
end if
' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
else ' или инета нет, или гугл накрылся :)
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
wscript.echo "Паночка померла :)"
' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
end if ' жив ли гугл?
Next 'j
Key = DoTheKey(RegPath, arrDNSBL(i), true, DNSBL.Item(arrDNSBL(i)))
Next 'i
BBody = BBody & "<hr>" & Now & " => Проверка завершена. Продолжительность проверки: " & Timer - TotalTimer & " сек."
BBody = BBody & "</HTML>"
if Need2Report then call SendMail("DNSBL Monitoring Report", BBody) ' если были подвижки в списках, надо уведомить
'###############################################################################
function IsInBL(DNSBL_name, HOST2Chk) 'Оцениваем результаты пинга
if Ping(RevIP(HOST2Chk) & "." & DNSBL_name) then 'если до сих пор в BL то...
' переформируем список заблокированных хостов для этого BL
IsInBL = true
if DNSBL.Item(DNSBL_name) = vbNullstring then
DNSBL.Item(DNSBL_name) = HOST2Chk
else
DNSBL.Item(DNSBL_name) = DNSBL.Item(DNSBL_name) & "|" & HOST2Chk
end if
else
IsInBL = false
end if
end function
'###############################################################################
Function Ping(Ip2Ping) 'пингуем хост
Dim Hosts(), strComputer, objWMIService, colPings, objStatus
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colPings = objWMIService.ExecQuery _
("Select * From Win32_PingStatus where Address = '" & Ip2Ping & "'")
For Each objStatus In colPings
If IsNull(objStatus.StatusCode) Or objStatus.StatusCode<>0 Then
'в принципе, уже не пингуется... но дополнительно проверим и IP(зарезолвился или нет)
If objStatus.ProtocolAddress = vbNullstring Then Ping = False
Else
if StrComp(TestHost, Ip2Ping, vbTextcompare) <> 0 then
WScript.Echo "ping host " & Ip2Ping & " .... LISTED"
wscript.echo "Return IP: " & objStatus.ProtocolAddress
end if
Ping = True
End If
Next
End Function
'###############################################################################
Function RevIP(IP) ' "переворачиваем" IP-адрес
Dim arrIPs, i
RevIP = vbNullString
arrIPs = Split(IP, ".", -1, vbTextCompare)
If UBound(arrIPs) > 3 Then wscript.echo "Неверный IP! " & IP : wscript.quit
For i = UBound(arrIPs) To LBound(arrIPs) step -1
If arrIPs(i) > 254 Then wscript.echo "Неверный IP! " & IP : wscript.quit
If i = 3 Then RevIP = arrIPs(i) Else RevIP = RevIP & "." & arrIPs(i)
Next
End Function
'###############################################################################
' чтение-создание ключей в реестре
' если Make = true, то записываем значение KeyValue в ключ
' если Make = false, то пытаемся считать ключ и при его отсутствии создаём с значением KeyValue
Function DoTheKey(RegPath, RegKey, Make, KeyValue)
If Make and not Write2Reg Then ' Есди писАть в реестр запрещено, то писАть в реестр нельзя
Exit Function
End If
If Make Then ' если задача записать, то:
WshShell.RegWrite RegPath & "\" & RegKey, KeyValue, "REG_SZ"
Else ' если только прочесть, то всё немного сложнее :)
On Error Resume Next ' половим ошибки при отсутствии ключа(вариант что прав на чтения не хватает не рассматривается)
DoTheKey = WshShell.RegRead(RegPath & "\" & RegKey)
If Err.Number <> 0 Then
wscript.echo "не найден ключ или раздел в реестре: " & RegPath & "\" & RegKey
Err.Clear ' Clear the error.
WshShell.RegWrite RegPath & "\" & RegKey, KeyValue, "REG_SZ" ' если ключа нет, то создаём его и заносим в него переданное значение(KeyValue)
If Err.Number = 0 Then
wscript.echo "в реестре создан ключ: [" & RegPath & "\" & RegKey & "] со значением [" & KeyValue & "]."
DoTheKey = WshShell.RegRead(RegPath & "\" & RegKey)
End If
Else
' wscript.echo "Значение ключа " & RegKey & " = [" & WshShell.RegRead(RegPath & "\" & RegKey) & "]"
DoTheKey = WshShell.RegRead(RegPath & "\" & RegKey)
End If
Err.Clear ' Clear the error.
On Error Goto 0
End If
End Function
'###############################################################################
Sub SendMail(Subject, Body)' отправка уведомления через CDO
Dim iMsg, iConf, Flds
Set iMsg=CreateObject("CDO.Message")
Set iConf=CreateObject("CDO.Configuration")
Set Flds=iConf.Fields
'http://msdn.microsoft.com/en-us/library/ms873037(EXCHG.65).aspx
'The mechanism to use to send messages.
' cdoSendUsingPort (2)
Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'The authentication mechanism to use when authenticating to a SMTP service over the network.
'This field is relevant only if the http://schemas.microsoft.com/cdo/configuration/sendusing field is set to cdoSendUsingPort.
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = smtp_auth
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtp_host
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = smtp_port
Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = smtp_user
Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = smtp_pass
Flds.Item("http://schemas.microsoft.com/cdo/configuration/languagecode") = "ru" '?
Flds.Update
iMsg.Configuration = iConf
iMsg.To = to_email
iMsg.From = from_email
iMsg.Subject = Subject
iMsg.BodyPart.Charset = "windows-1251"
iMsg.HtmlBody = Body
iMsg.Send
Set iMsg=Nothing
Set iConf=Nothing
Set Flds=Nothing
End SubПринцип работы простой: два словаря(блэклисты и IP офисов и сервера), проверяем присутствие IP в чёрном списке(или исчезновение оттуда) и уведомляем об этом на почту. Список текущих блокировок хранится в реестре(я сохраняю в HKLM, чтобы можно было в любой момент без выкрутасов посмотреть что там ). Если IP уже числится в реестре, то по нему повторных отчётов не шлётся. Ну и чтобы для проверки наличия интернета пингуем гугл.
При отсутсвии ветки/параметра в реестре они создаются автоматически, в процессе работы параметры из этой ветки могут перезаписываться - несмотря на п.6.5 отключать запись в реестр по умолчанию не стал(переменная Write2Reg - рудимент, присутствующий у меня везде где есть зработа с реестром 
). Во-первых, данная ветка по умолчанию отсутствует, во-вторых, без неё полноценно скрипт функционировать не будет.
Метод проверки есть в скрипте, на википедии, в FAQ спамхауса(ссылки в коментариях скрипта), поэтому дублировать не буду.
Единственное что не протестировал - ситуацию с удалением IP из DNSBL - своих IP в блоках не имею(ттт), а чужие разблокировать не буду(ибо скорее всего спамерские - из логов сервера брал) - если кто-то может протестировать, буду рад. Или буду ждать попадания наших IP в BL.
Список DNSBL можно посмотреть здесь(кстати, удобный инструмент для ручной проверки попадания в BL).
P.S. Остался правда один момент - команда вроде такой "nslookup -type=ANY 103.63.250.194.b.barracudacentral.org" даёт больше информации, и если в случае с баракудой пользы от ней немного(выдаёт только ссылку на проверку IP), то для спамхауза это не так. У спамхауза в возвращаемом адресе "закодирован" как минимум список в который IP попал - но это в теории. В практике в спамхаузом пока не срабатывает (для IP из PBL-списка), впрочем я так до конца не понял систему взаимодействия их BL. Отсюда вопрос: есть ли под VBScript класс позволяющий выполнять запросы к DNS-серверу? В MSDN пока наткнулся на DNS WMI Provider, но беглый осмотр навёл на мысль что он предназначен для управления MS DNS-сервером. Глубже пока не копал - текущего скрипта мне достаточно(подробности через nslookup узнаю)... В идеале обойтись без сторонних контролов