Option Explicit

' sshd_block.vbs - Blocks IP addresses generating invalid SSH logons
' Copyright 2009 Wellbury LLC - See LICENSE for license information
'
' Release 20090721 - Initial public release
' Release 20100120 - Added "invalid user" strings, blackhole rule creation
'   using "Advanced Firewall", tested against Windows 7 x64

' External executables required to be accessible from PATH:
'
' ROUTE.EXE          For black-hole routing banned IP addresses in Windows 2000 / XP / 2003
' NETSH.EXE          For black-hole firewall rule creation on Windows Vista / 2008 / 7 / 2008 R2
' EVENTCREATE.EXE    For writing to the event log (if enabled)
'
' For support, please contact Evan Anderson at Wellbury LLC: 
'   EAnderson@wellbury.com, (866) 569-9799, ext 801

' Main
Dim objShell, objWMIService, objEventSink, blackHoleIPAddress, regexpSanitizeEventLog, regexpSanitizeIP
Dim dictIPLastSeenTime, dictIPBadLogons, dictUnbanTime, dictBanImmediatelyUsers
Dim colOperatingSystem, intOSBuild, intBlackholeStyle

' =====================( Configuration )=====================

' Set to 0 to disable debugging output
Const DEBUGGING = 0

' Set to 0 to disable event log reporting of bans / unbans
Const USE_EVENTLOG = 1
Const EVENTLOG_SOURCE = "sshd_block"
Const EVENTLOG_TYPE_INFORMATION = "INFORMATION"
Const EVENTLOG_TYPE_ERROR = "ERROR"
Const EVENTLOG_ID_STARTED = 1
Const EVENTLOG_ID_ERROR_NO_BLACKHOLE_IP = 2
Const EVENTLOG_ID_ERROR_NO_EVENT_MESSAGE_FILE = 3
Const EVENTLOG_ID_BAN = 256
Const EVENTLOG_ID_UNBAN = 257

' Location of Event Message File in registry
Const REGISTRY_EVENT_MESSAGE_FILE = "HKLM\SYSTEM\CurrentControlSet\Services\Eventlog\Application\sshd\EventMessageFile"

' Expiration (in seconds) for IPs to be banned
Const BAN_DURATION = 300

' Number of failed logons in time window before IP will be banner
Const BAN_LIMIT = 5		' Attempts
Const BAN_TIMEOUT = 120	' in X seconds

' Usernames that attempted logons for result in immediate banning
Set dictBanImmediatelyUsers = CreateObject("Scripting.Dictionary")
dictBanImmediatelyUsers.Add "administrator", 1
dictBanImmediatelyUsers.Add "root", 1
dictBanImmediatelyUsers.Add "guest", 1

' ===================( End Configuration )===================

Const SSHD_BLOCK_VERSION = "20100120"
Const BLACKHOLE_ROUTE = 1		' Blackhole packets via routing table
Const BLACKHOLE_FIREWALL = 2	' Blackhole packets via firewall

' =====================( Stress Testing )====================

' Set to 1 to perform stress testing
Const TESTING = 0

' Number of "bogus" bans to load
Const TESTING_IP_ADDRESSES = 10000

' Minimum number of milliseconds between adding "bogus" IPs to the ban list during testing
Const TESTING_IP_MIN_LATENCY = 10

' Maximum number of milliseconds between adding "bogus" IPs to the ban list during testing
Const TESTING_IP_MAX_LATENCY = 50

If TESTING Then 
	Dim testLatency, cumulativeLatency, testLoop, maxBanned, bannedAddresses
	Randomize
End IF

' ===================( End Stress Testing )==================

Set dictIPLastSeenTime = CreateObject("Scripting.Dictionary")
Set dictIPBadLogons  = CreateObject("Scripting.Dictionary")
Set dictUnbanTime = CreateObject("Scripting.Dictionary")
Set objShell = CreateObject("WScript.Shell")

Set regexpSanitizeEventLog = new Regexp
regexpSanitizeEventLog.Global = True
regexpSanitizeEventLog.Pattern = "[^0-9a-zA-Z._ /:\-]"

Set regexpSanitizeIP = new Regexp
regexpSanitizeIP.Global = True
regexpSanitizeIP.Pattern = "[^0-9.]"

' Get OS build number
Set objWMIService = GetObject("winmgmts:{(security)}!root/cimv2")
Set colOperatingSystem = objWMIService.ExecQuery("SELECT BuildNumber FROM Win32_OperatingSystem")

For Each intOSBuild in colOperatingSystem
	' Windows OS versions with the "Advanced Firewall" functionality have build numbers greater than 4000
	If intOSBuild.BuildNumber < 4000 Then intBlackholeStyle = BLACKHOLE_ROUTE Else intBlackholeStyle = BLACKHOLE_FIREWALL
	If DEBUGGING Then WScript.Echo "intBlackHoleStyle = " & intBlackHoleStyle 
Next ' intOSBuild

' Only obtain a blackhole adapter address on versions of Windows where it is required
If intBlackholeStyle = BLACKHOLE_ROUTE Then
	blackHoleIPAddress = GetBlackholeIP()
	If IsNull(blackHoleIPAddress) Then
		LogEvent EVENTLOG_ID_ERROR_NO_BLACKHOLE_IP, EVENTLOG_TYPE_ERROR, "Fatal Error - Could not obtain an IP address for an interface with no default gateway specified."
		WScript.Quit
	End If
End If

If NOT CheckEventMessageFile() Then
	LogEvent EVENTLOG_ID_ERROR_NO_EVENT_MESSAGE_FILE, EVENTLOG_TYPE_ERROR, "Fatal Error - Event message file for sshd not present."
	WScript.Quit
End IF

' Create event sink to catch sshd events
Set objEventSink = WScript.CreateObject("WbemScripting.SWbemSink", "eventSink_")
objWMIService.ExecNotificationQueryAsync objEventSink, "SELECT * FROM __InstanceCreationEvent WHERE TargetInstance ISA 'Win32_NTLogEvent' AND TargetInstance.SourceName = 'sshd'"

LogEvent EVENTLOG_ID_STARTED, EVENTLOG_TYPE_INFORMATION, EVENTLOG_SOURCE & " (version " & SSHD_BLOCK_VERSION & ") started."

If TESTING Then
	If DEBUGGING Then WScript.Echo "Stress test loop"

	For testLoop = 1 to TESTING_IP_ADDRESSES 
		testLatency = Int(Rnd() * (TESTING_IP_MAX_LATENCY - TESTING_IP_MIN_LATENCY)) + TESTING_IP_MIN_LATENCY

		WScript.Sleep(testLatency)
		Ban(CStr(Int(Rnd * 256)) & "." & CStr(Int(Rnd * 256)) & "." & CStr(Int(Rnd * 256)) & "." & CStr(Int(Rnd * 256)))
		bannedAddresses = bannedAddresses + 1

		' Try to ExpireBans no more often than once every 1000ms
		cumulativeLatency = cumulativeLatency + testLatency
		If cumulativeLatency >= 1000 Then
			if bannedAddresses > maxBanned Then maxBanned = bannedAddresses
			cumulativeLatency = 0
			ExpireBans
		End If
	Next ' testLoop

	' Drain the queue
	While dictUnbanTime.Count > 0
		WScript.Sleep(1000)
		ExpireBans
	Wend

	WScript.Echo "Stress test completed. " & TESTING_IP_ADDRESSES & " tested with a maximum of " & maxBanned & " addresses banned at once."

	' Loop until killed
	While (True)
		WScript.Sleep(1000)
	Wend

Else

	If DEBUGGING Then WScript.Echo "Entering normal operation wait loop."

	' Loop sleeping for 1000ms, expiring bans
	While (True)
		WScript.Sleep(1000)
		ExpireBans
	Wend

End If


Sub Ban(IP)
	' Ban an IP address and set the time for the ban expiration
	Dim strRunCommand
	Dim intRemoveBanTime

	' Ban an IP address (either by black-hole routing it or adding a firewall rule)
	If (TESTING <> 1) Then 
		If intBlackholeStyle = BLACKHOLE_ROUTE Then strRunCommand = "route add " & IP & " mask 255.255.255.255 " & blackHoleIPAddress 
		If intBlackholeStyle = BLACKHOLE_FIREWALL Then strRunCommand = "netsh advfirewall firewall add rule name=""Blackhole " & IP & """ dir=in protocol=any action=block remoteip=" & IP 

		If DEBUGGING Then WScript.Echo "Executing " & strRunCommand
		objShell.Run strRunCommand
	End If

	' Calculate time to remove ban and add to dictUnbanTime
	intRemoveBanTime = (Date + Time) + (BAN_DURATION / (24 * 60 * 60))

	If NOT dictUnbanTime.Exists(intRemoveBanTime) Then
		Set dictUnbanTime.Item(intRemoveBanTime) = CreateObject("Scripting.Dictionary")
	End If
	If NOT dictUnbanTime.Item(intRemoveBanTime).Exists(IP) Then dictUnbanTime.Item(intRemoveBanTime).Add IP, 1

	LogEvent EVENTLOG_ID_BAN, EVENTLOG_TYPE_INFORMATION, "Banned " & IP & " until " & intRemoveBanTime
End Sub

Sub Unban(IP)
	' Unban an IP address
	Dim strRunCommand

	If (TESTING <> 1) Then 
		If intBlackholeStyle = BLACKHOLE_ROUTE Then strRunCommand = "route delete " & IP & " mask 255.255.255.255 " & blackHoleIPAddress  
		If intBlackholeStyle = BLACKHOLE_FIREWALL Then strRunCommand = "netsh advfirewall firewall delete rule name=""Blackhole " & IP & """"

		If DEBUGGING Then WScript.Echo "Executing " & strRunCommand
		objShell.Run strRunCommand
	End If

	LogEvent EVENTLOG_ID_UNBAN, EVENTLOG_TYPE_INFORMATION, "Unbanned " & IP
End Sub

Sub LogFailedLogonAttempt(IP)
	' Log failed logon attempts and, if necessary, ban the IP address

	' Have we already seen this IP address before?
	If dictIPLastSeenTime.Exists(IP) Then

		' Be sure that prior attempts, if they are older than BAN_TIMEOUT, don't count it against the IP
		If (dictIPLastSeenTime.Item(IP) + (BAN_TIMEOUT / (24 * 60 * 60))) <= (Date + Time) Then
			If dictIPBadLogons.Exists(IP) Then dictIPBadLogons.Remove(IP)
		End If

		dictIPLastSeenTime.Item(IP) = (Date + Time)
	Else
		dictIPLastSeenTime.Add IP, (Date + Time)
	End If

	' Does this IP address already have a history of bad logons?
	If dictIPBadLogons.Exists(IP) Then
		dictIPBadLogons.Item(IP) = dictIPBadLogons.Item(IP) + 1
	Else
		dictIPBadLogons.Add IP, 1
	End If

	If DEBUGGING Then WScript.Echo "Logging bad attempt from " & IP & ", attempt # " & dictIPBadLogons.Item(IP)

	' Should we ban this IP address?
	If dictIPBadLogons.Item(IP) = BAN_LIMIT Then Ban(IP)
End Sub

Sub ExpireBans()
	Dim unbanTime, ipAddress

	For Each unbanTime in dictUnbanTime.Keys

		If unbanTime <= (Date + Time) Then 
			For Each ipAddress in dictUnbanTime.Item(unbanTime)
				Unban(ipAddress)
				If TESTING Then bannedAddresses = bannedAddresses - 1
			Next ' ipAddress

			dictUnbanTime.Remove unbanTime
		End If
	Next 'ipAddress
End Sub

' Should an invalid logon from specified user result in an immediate ban?
Function BanImmediate(user)
	Dim userToBan

	For Each userToBan in dictBanImmediatelyUsers.Keys
		If UCase(user) = UCase(userToBan) Then 
			BanImmediate = True
			Exit Function
		End If
	Next 'userToBan

	BanImmediate = False
End Function

' Fires each time new sshd events are generated
Sub eventSink_OnObjectReady(objEvent, objWbemAsyncContext)
	Dim arrEventMessage, arrInvalidLogonText
	Dim IP, user

	arrEventMessage = Split(objEvent.TargetInstance.Message, ":")

	If Left(LTrim(UCase(arrEventMessage(2))), 12) = "ILLEGAL USER" Then
		arrInvalidLogonText = Split(LTrim(arrEventMessage(2)), " ")
		user = arrInvalidLogonText(2)
		IP = arrInvalidLogonText(4)
	ElseIf Left(LTrim(UCase(arrEventMessage(2))), 12) = "INVALID USER" Then
		arrInvalidLogonText = Split(LTrim(arrEventMessage(2)), " ")
		user = arrInvalidLogonText(2)
		IP = arrInvalidLogonText(4)
	ElseIf Left(LTrim(UCase(arrEventMessage(2))), 32) = "FAILED PASSWORD FOR ILLEGAL USER" Then
		arrInvalidLogonText = Split(LTrim(arrEventMessage(2)), " ")
		user = arrInvalidLogonText(5)
		IP = arrInvalidLogonText(7)
	ElseIf Left(LTrim(UCase(arrEventMessage(2))), 32) = "FAILED PASSWORD FOR INVALID USER" Then
		arrInvalidLogonText = Split(LTrim(arrEventMessage(2)), " ")
		user = arrInvalidLogonText(5)
		IP = arrInvalidLogonText(7)
	ElseIf Left(LTrim(UCase(arrEventMessage(2))), 19) = "FAILED PASSWORD FOR" Then
		arrInvalidLogonText = Split(LTrim(arrEventMessage(2)), " ")
		user = arrInvalidLogonText(3)
		IP = arrInvalidLogonText(5)
	End If

	' Make sure only characters allowed in IP addresses are passed to external commands
	IP = regexpSanitizeIP.Replace(IP, "")

	' If the event didn't generate both a username and IP address then do nothing
	If (IP <> "") AND (user <> "") Then
		If BanImmediate(user) Then Ban(IP) Else LogFailedLogonAttempt(IP)
	End If
End Sub

Function GetBlackholeIP()
	' Sift through the NICs on the machine to locate a NIC's IP to use to blackhole offending hosts.
	' Look for a NIC with no default gateway set and an IP address assigned. Return NULL if we can't
	' find one.

	Dim objNICs, objNICConfig
	Set objNICs = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = TRUE")

	' Scan for a NIC with no default gateway set and IP not 0.0.0.0
	For Each objNICConfig in objNICs
		If IsNull(objNICConfig.DefaultIPGateway) and (objNICConfig.IPAddress(0) <> "0.0.0.0") Then 
			If DEBUGGING Then WScript.Echo "Decided on black-hole IP address " & objNICConfig.IPAddress(0) & ", interface " & objNICConfig.Description
			GetBlackholeIP = objNICConfig.IPAddress(0)
			Exit Function
		End If
	Next

	' Couldn't find anything, return NULL to let caller know we failed
	GetBlackHoleIP = NULL
End Function

Sub LogEvent(ID, EventType, Message)
	' Log an event to the Windows event log

	' Sanitize input string
	Message = regexpSanitizeEventLog.Replace(Message, "")

	If DEBUGGING Then WScript.Echo "Event Log - Event ID: " & ID & ", Type: " & EventType & " - " & Message
	If USE_EVENTLOG Then objShell.Exec "EVENTCREATE /L APPLICATION /SO " & EVENTLOG_SOURCE & " /ID " & ID & " /T " & EventType & " /D """ & Message & """"
End Sub

Function CheckEventMessageFile()
	Dim eventMessageFile
	On Error Resume Next ' Noooooooo!

	eventMessageFile = objShell.RegRead(REGISTRY_EVENT_MESSAGE_FILE)

	If Err.Number <> 0 Then CheckEventMessageFile = False Else CheckEventMessageFile = True

	On Error Goto 0
End Function