'***************************************************************************
' FTPBan.vbs version 2
'
' Greatly reduces brute-force password cracking attempts
'
' Created by Martin Reed
' September 24, 2007
'
' Adapted from the script by David Landy (david@milldata.co.uk)
' August 02, 2007
'
' Adapted from the script by Chrissy LeMaire (clemaire@gmail.com)
' http://blog.netnerds.net/2006/07/ban-administrator-ftp-login-attemps
'
' To run this as a service:
' http://blogs.mscorlib.com/Home/tabid/111/EntryID/42/Default.aspx
'
' A list of Windows Security Log Codes is available at:
' http://www.ultimatewindowssecurity.com/encyclopedia.aspx
'
' A list of IIS Status Codes is available at:
' http://support.microsoft.com/kb/318380
'
' NO WARRANTIES, etc.
'
' This script has only been tested on Windows Server 2003.
'
'**************************************
'
' "What it does"
' 1. Sets an Async Event Sink to notify the script of successful/failed logins.
'
' 2. Loads all previous banned clients from IPSecurity.
' a) Any entries made manually while the script is already running will be
' loaded and banned at the next event.
'
' 3. Parses the IIS log(s) for the username and client ip address.
' a) The log is filtered to only read records that occurred after the script
' started and/or since the last event call.
'
' 4. If the username is blacklisted, the client will be banned.
' a) If 'whitelist' is set to true, all usernames will be blacklisted except
' those specified in 'blacklist'.
'
' 5. If the username passes and 'allowedFailures' is turned on, the client will
' either receive an instant ban, or be banned after the specified number of
' failures.
'
' 6. *Optional* If 'fakeRoute' is set, all bans will also reroute clients
' to a fake/unused ip address on your network. This reroute is temporary and
' will be reset after a system reboot or after disabling/enabling your
' network connection.
'
'**************************************
'
' "Features"
' 1. Specify the number of attempts a client is allowed to make before being banned.
' Use 0 for an instant ban.
' Use any negative number to turn this feature off.
Const allowedFailures = 5
'
' 2. Specify a blacklist of usernames that will give an instant ban on failed attempts.
' Use Array() to turn this feature off.
Dim blacklist
blacklist = Array("Administrator")
'
' 3. Use 'blacklist' as a whitelist
' Warning: If 'blacklist' is turned off, and whitelist is set to true, then
' every user will be banned!
Const whitelist = false
'
' 4. Use a temporary ban that will reroute clients to a fake/unused ip address on
' your network. All reroutes will be reset when you reboot your server, or
' disable/enable your network connection. If set, this must be an address on the
' same substructure as your sever (XXX.XXX.XXX.*).
' Use Null to turn this feature off, set the ip as a string otherwise.
Const fakeRoute = "192.168.1.0"
'
'****************************************************************************

' WScript shell to use throughout the script
Dim wshell
Set wshell = wscript.CreateObject("WScript.Shell")

' Start filtering the IIS log records
Dim logFilterStart
logFilterStart = convertGMT(Now())

' Initialize the failed attempt array
Dim failedClient
failedClient = Array()

' Initialize the banned client array
Dim bannedClient
bannedClient = Array()

' Catch all successful or failed logins
Dim objWMIService
Dim eventSink
Dim strSQL

Set objWMIService = GetObject("winmgmts:{(security)}!root/cimv2")
Set eventSink = wscript.CreateObject("WbemScripting.SWbemSink", "EVSINK_")
strSQL = "Select * from __InstanceCreationEvent where TargetInstance isa 'Win32_NTLogEvent' and "
strSQL = strSQL & "TargetInstance.SourceName = 'Security' and ("
strSQL = strSQL & "(TargetInstance.EventCode >= 528 and TargetInstance.EventCode <= 537) or "
strSQL = strSQL & "TargetInstance.EventCode = 539)"
'strSQL = strSQL & "TargetInstance.SourceName = 'MSFTPSVC' and TargetInstance.EventCode = 100"
objWMIService.ExecNotificationQueryAsync eventSink, strSQL

' Keep it going forever
Do While true
wscript.Sleep(1000)
Loop


Sub EVSINK_OnObjectReady(objObject, objAsyncContext)

Dim logFilterStop
logFilterStop = convertGMT(Now())

Dim objFTPSVC
Dim objFSO
Dim objLog
Dim objFTPIPSec

Set objFTPSVC = GetObject("IIS://localhost/MSFTPSVC")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLog = CreateObject("MSWC.IISLog")
Set objFTPIPSec = objFTPSVC.IPSecurity

' Reload all banned clients from IPSecurity, incase some were entered/removed manually
' while this script was already running
Erase bannedClient
bannedClient = Array()

For Each element In objFTPIPSec.IPDeny
banClient Left(element, InStr(element, ",") - 1), false
Next

' Iterate through each FTP site.
For Each objSITE In objFTPSVC
If LCase(objSITE.class) = "iisftpserver" Then

Dim ftpLogFilePath
Dim objFolder
Dim objFiles

ftpLogFilePath = wshell.ExpandEnvironmentStrings(objSITE.LogFileDirectory) & "\msftpsvc" & objSITE.Name
Set objFolder = objFSO.GetFolder(ftpLogFilePath)
Set objFiles = objFolder.Files

' Get the last file name
Dim strLogFile
For Each element In objFiles
strLogFile = element
Next

' Open the IIS log and filter previous events
objLog.OpenLogFile strLogFile, 1, "MSFTPSVC", 1, 0
objLog.ReadFilter logFilterStart, logFilterStop

' Use the IIS log file parser provided by msft
Do While Not objLog.AtEndOfLog

' Read the log record
objLog.ReadLogRecord

Dim clientIP
clientIP = objLog.ClientIP

' The client has not been banned
If search1(bannedClient, clientIP) = -1 Then

Select Case objLog.ProtocolStatus
Case 331 ' User name okay, need password.

Dim username
Dim blacklistBan
Dim whitelistBan

username = objLog.URIStem
blacklistBan = (whitelist = true And search1(blacklist, username) = -1)
whitelistBan = (whitelist = false And search1(blacklist, username) <> -1)

' The username is blacklisted (or not whitelisted)
If blacklistBan Or whitelistBan Then
banClient clientIP, true
End If

Case 530 ' Not logged in.
' Use instant ban, or allow n-many failures
If allowedFailures > -1 Then
failureCheck clientIP
End If
End Select
End If
Loop

' Close the IIS log
objLog.CloseLogFiles 1
End If
Next

' Set the new list of banned clients
objFTPIPSec.GrantByDefault = true ' Otherwise this script is pointless
objFTPIPSec.IPDeny = bannedClient
objFTPSVC.IPSecurity = objFTPIPSec
objFTPSVC.SetInfo

logFilterStart = logFilterStop
End Sub


Sub banClient(clientIP, routeBan)

' Delete the client from the failed attempt list
Dim findFailedCient
findFailedCient = search2(failedClient, clientIP, 0)

If findFailedCient <> -1 Then
pop failedClient, findFailedCient
End If

' Add the new client to be banned
push bannedClient, clientIP

' Reroute the client
If routeBan = true And Not IsNull(fakeRoute) Then
wshell.Run "route add " & clientIP & " mask 255.255.255.255 " & fakeRoute, 1, true
End If
End Sub


Sub failureCheck(clientIP)

Dim findFailedCient
findFailedCient = search2(failedClient, clientIP, 0)

' The client has failure attempts already, but is not yet banned
If findFailedCient <> -1 Then

' Increment the failure count
Dim failureCount
failureCount = failedClient(findFailedCient)(1) + 1
failedClient(findFailedCient)(1) = failureCount

' No more attempts are left
If failureCount > allowedFailures Then
banClient clientIP, true
End If

' The client is either banned already, or this is their first failed attempt
Else

' Allow the first failed attempt
If allowedFailures > 0 Then
push failedClient, Array(clientIP, 1)

' Instant ban on first failed attempt
Else
banClient clientIP, true
End If
End If
End Sub


Sub push(a, s)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = s
End Sub


Sub pop(a, i)
Dim j
For j = i To UBound(a) - 1
a(j) = a(j + 1)
Next
ReDim Preserve a(UBound(a) - 1)
End Sub


Function search1(a, s)
Dim i
For i = 0 To UBound(a)
If Not IsArray(a(i)) Then
If LCase(a(i)) = LCase(s) Then
search1 = i
Exit Function
End If
End If
Next
search1 = -1
End Function


Function search2(a, s, j)
Dim i
For i = 0 To UBound(a)
If IsArray(a(i)) Then
If Not IsArray(a(i)(j)) Then
If LCase(a(i)(j)) = LCase(s) Then
search2 = i
Exit Function
End If
End If
End If
Next
search2 = -1
End Function


Function convertGMT(t)
Dim offsetMin
offsetMin = wshell.RegRead("HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
convertGMT = dateadd("n", offsetMin, t)
End Function