checkalldata.asp

通过使用Office的Access数据库与之关联

<%
Dim FireConn '此处声明变量不能少

Sub redOpenData(Num)
    Rem =========access数据库配置信息 开始 修改以下=========ACCESS
		
    Dim redDbPath,redConnStr
		
    If Num = 0 Then
	    redDbPath = "/Fire/songs.mdb"
    Else
	    redDbPath = "/Fire/songs.mdb"
    End If
		
	Rem =========access数据库配置信息 结束 修改以上数据=================ACCESS
		
	redConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(redDbPath)
	
	On Error Resume Next
	
	Set FireConn = Server.CreateObject("ADODB.Connection")
	FireConn.open redConnStr
	
	If Err Then
		Err.Clear
		Set FireConn = Nothing
		Response.Write "Fire DataBase Eoor Here " '数据库连接出错提示
		Response.End
	End If
End Sub

Public Sub AllFireHere()
    Dim FireStr,FireStrs,Count_fire
	Count_fire = 0
    
	Rem ==================此处可以改动 开始====================
	
	If IsObject(Application("Fire_Config")) = False Then 
	    Call RedGetFireConfig()
	End If
	
	If Application("Fire_Config")(3) = 1 Then
	    Call RedCheckIpAdress()
	End If
	
	FireStrs = Application("Fire_Config")(0)
	
	Rem ==================此处可以改动 结束====================
	
	If RedCheckFireStr(Request.QueryString,FireStrs) = False Or RedCheckFireStr(Request.Form,FireStrs) = False Or RedCheckFireStr(Request.Cookies,FireStrs) = False Then
	    
		Call RedFireStart() 'log记录
		Response.End()
	End If
End Sub

Sub RedGetFireConfig()
    If IsObject(FireConn) = False Then
	    Call redOpenData(0)
	End IF
	
	Dim Rs_Sub,tempArr(7)
	Set Rs_Sub = FireConn.Execute("Select Conf_FireStr,Conf_Log,Conf_Domain,Conf_KillIp,Conf_ErrorType,Conf_ErrorUrl,Conf_AlertInfo,Conf_LockInfo From [Tb_FireConfig]")
	
	If Not Rs_Sub.Eof Then
	    Dim i
		For i = 0 To Ubound(tempArr)
		    tempArr(i) = Rs_Sub(i)
		Next
		
		Rs_Sub.Close : Set Rs_Sub = Nothing
	Else
	    Response.Write("数据库Fire配置信息获取失败！")
		Response.End()
	End If
	
	Application.Lock
	    Set Application("Fire_Config") = Nothing
		Application("Fire_Config") = tempArr
	Application.unlock
End Sub

Sub RedCheckIpAdress()
    If IsObject(FireConn) = False Then
	    Call redOpenData(0)
	End If
	
	Dim subIp,Rs_Sub,Songs
	subIp = Trim(RedGetIP())
	Songs = False
	
	Set Rs_Sub = FireConn.Execute("Select Kill_Id From [Tb_KillIp] Where Kill_IP = '" & subIp & "' And Kill_Check = 1")
	
	If Not Rs_Sub.Eof Then
	    Songs = True
		Rs_Sub.Close : Set Rs_Sub = Nothing
	End If
	
	If Songs Then
	    Call RedKillIp_ShowInfo()
		FireConn.Execute("Update [Tb_KillIp] Set Kill_Count = Kill_Count + 1 Where Kill_IP = '" & subIp & "'")
		Response.End() '此处频闭ip
	End If
End Sub

Sub RedScript(scriptStr)
    Response.Write("<script language=""javascript"">" & scriptStr & "</script>")
End Sub

Sub RedKillIp_ShowInfo()
    Select Case Cint(Application("Fire_Config")(4))
	    Case 1
		    Call RedScript("alert('" & Application("Fire_Config")(7) & "');window.close();")
		Case 2
		    Call RedScript("location.href='" & Application("Fire_Config")(5) & "';")
		Case 3
		    Call RedScript("alert('" & Application("Fire_Config")(7) & "');location.href='" & Application("Fire_Config")(5) & "';")
		Case Else
		    Call RedScript("window.close();")
	End Select
End Sub

Sub LogAlertInfo()
    Select Case Cint(Application("Fire_Config")(4))
	    Case 1
		    Call RedScript("alert('" & Application("Fire_Config")(6) & "');window.close();")
		Case 2
		    Call RedScript("location.href='" & Application("Fire_Config")(5) & "';")
		Case 3
		    Call RedScript("alert('" & Application("Fire_Config")(6) & "');location.href='" & Application("Fire_Config")(5) & "';")
		Case Else
		    Call RedScript("window.close();")
	End Select
End Sub

Function RedCheckFireStr(strng,FireStrs)
    If CheckEmpty(strng) Then
	    RedCheckFireStr = True
		Exit Function
	End If
	
	FireStrs = ReSpecialStr(FireStrs)
	
	Dim i_fire,FireStr,TempNum
	FireStr = Split(LCase(FireStrs),",")
	TempNum = Ubound(FireStr)
	
	
	For i_fire = 0 To TempNum
	    If Instr(Lcase(strng),FireStr(i_fire)) > 0 Then
		    RedCheckFireStr = False
			Exit Function
	    End If
	Next
	
	RedCheckFireStr = True
End Function

Function CheckEmpty(fstrng)
    If IsNull(fstrng) Or IsEmpty(fstrng) Or fstrng = "" Then
	    CheckEmpty = True
	Else
	    CheckEmpty = False
	End If
End Function

Function RegExpTest(patrn, strng) 
    If CheckEmpty(strng) Then
	    RegExpTest = False
		Exit Function
	End If
	
	Dim regEx, retVal 
    Set regEx = New RegExp 
    regEx.Pattern = patrn 
    regEx.IgnoreCase = True 
    retVal = regEx.Test(strng) 
	
    RegExpTest = retVal 
	
	Set regEx = Nothing
End Function 

Function RedIsIpAdress(fIp)
    If CheckEmpty(fIp) Then
	    RedIsIpAdress = "0.0.0.0"
		Exit Function
	End If
	
	If RegExpTest("^\d{1,4}(\.\d{1,4}){3}$",fIp) Then
	    RedIsIpAdress =  fIp
	Else
	    RedIsIpAdress = "0.0.0.0"
	End If
End Function

Private Function RedGetIP()
    Dim strIPAddr
	If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
		strIPAddr = Request.ServerVariables("REMOTE_ADDR")
	ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
		strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
	ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
		strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
	Else
		strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
	End If
	
	RedGetIP = RedIsIpAdress(Trim(Mid(strIPAddr, 1, 30)))
End Function

Function FireFomatSpecialString(strng)
	strng = LCase(strng)
	
	strng = Replace(strng,Chr(34),"&#34;") ' "
	strng = Replace(strng,Chr(37),"&#37;") ' %
	strng = Replace(strng,Chr(38),"&#38;") ' &
	strng = Replace(strng,Chr(39),"&#39;") ' '
	strng = Replace(strng,Chr(40),"&#40") ' (
	strng = Replace(strng,Chr(41),"&#41") ' )
	strng = Replace(strng,Chr(42),"&#42") ' *
	strng = Replace(strng,Chr(43),"&#43") ' +
	strng = Replace(strng,Chr(44),"&#44") ' ,
	strng = Replace(strng,Chr(45),"&#45") '-
	strng = Replace(strng,Chr(60),"&#60") ' <
	strng = Replace(strng,Chr(62),"&#62") ' >
	strng = Replace(strng," ","&nbsp;") ' space
	
	strng = Replace(strng,"javascript","#Java Script#") 
	strng = Replace(strng,"execute","#execute#") 
	strng = Replace(strng,"eval","#eval#") 
	
	FireFomatSpecialString = strng
End Function

Function ReSpecialStr(strng)
	
	strng = Replace(strng,"&#34;",Chr(34)) ' "
	strng = Replace(strng,"&#39;",Chr(39)) ' '
	strng = Replace(strng,"&#40",Chr(40)) ' (
	strng = Replace(strng,"&#41",Chr(41)) ' )
	
	ReSpecialStr = strng
End Function

Sub RedFireStart()
    On Error Resume Next
	
	If IsObject(Application("Fire_Config")) = False Then 
	    Call RedGetFireConfig()
	End If
	
	If Application("Fire_Config")(1) = 1 Then
	    Call RedFireLog()
	End If
	
	If Application("Fire_Config")(3) = 1 Then
	    Call RedFireLogIp()
	End If
	
	Call LogAlertInfo()
End Sub

Sub RedFireLog()
    If IsObject(FireConn) = False Then
	    Call redOpenData(0)
	End If
	
	Dim fireArr(2)
	
	fireArr(0) = Request.ServerVariables("SCRIPT_NAME")
	
	If CheckEmpty(Request.QueryString) = False Then
	    fireArr(0) = fireArr(0) & "?" & Request.QueryString
	End If
	
	fireArr(1) = RedGetIP()
	
	fireArr(2) = ""
	
	If Request.ServerVariables("HTTP_USER_AGENT") <> "" Then
	    fireArr(2) = fireArr(2) & "HTTP_USER_AGENT : " & Request.ServerVariables("HTTP_USER_AGENT") & VbCrlf
	End If
	
	If Request.ServerVariables("HTTP_REFERER") <> "" Then
	    fireArr(2) = fireArr(2) & "HTTP_REFERER : " & Request.ServerVariables("HTTP_REFERER") & VbCrlf
	End If
	
	If Request.ServerVariables("SERVER_PORT") <> "" Then
	    fireArr(2) = fireArr(2) & "SERVER_PORT : " & Request.ServerVariables("SERVER_PORT") & VbCrlf
	End If
	
	If Request.ServerVariables("SERVER_PORT_SECURE") <> "" Then
	    fireArr(2) = fireArr(2) & "SERVER_PORT_SECURE : " & Request.ServerVariables("SERVER_PORT_SECURE") & VbCrlf
	End If
	
	Dim i
	For i = 0 To Ubound(fireArr)
	    fireArr(i) = Trim(FireFomatSpecialString(fireArr(i)))
	Next
	
	FireConn.Execute("Insert Into [Tb_FireLog] (Fire_QueryString,Fire_Ip,Fire_Other) Values ('" & fireArr(0) & "','" & fireArr(1) & "','" & fireArr(2) & "')")
End Sub

Sub RedFireLogIp()
    If IsObject(FireConn) = False Then
	    Call redOpenData(0)
	End If
	
	Dim subIp,Rs_Check,Songs
	subIp = Trim(RedGetIP())
	Songs = False
	
	Set Rs_Check = FireConn.Execute("Select Kill_Check From [Tb_KillIp] Where Kill_IP = '" & subIp & "'")
	
	If Not Rs_Check.Eof Then
		Songs = True
		
		If Rs_Check("Kill_Check") <> 1 Then
		    FireConn.Execute("Update [Tb_KillIp] Set Kill_Check = 1 , Kill_Time = '" & Now() & "' Where Kill_IP = '" & subIp & "'")
		End If
		
		Rs_Check.Close : Set Rs_Check = Nothing
	End If
	
	If Songs = False Then
	    FireConn.Execute("Insert Into [Tb_KillIp] (Kill_IP,Kill_Check,Kill_Time) Values ('" & subIp & "',1,'" & Now() & "') ")
	End If
End Sub

Rem ======================================以上防火墙配置结束==========================================




Rem ======================================此处调用放火墙==============================================

Call AllFireHere()
%>