functions_hash1way.asp

快速、可设定管理权限等级的论坛程序

<%
Function getSalt(intLen)
' Function takes a given length x and generates a random hex value of x digits.
' Salt can be used to help protect passwords.  When a password is first stored in a
' database generate a salt value also.  Concatenate the salt value with the password, 
' and then encrypt it using the HashEncode function below.  Store both the salt value,
' and the encrypted value in the database.  When a password needs to be verified, take 
' the password concatenate the salt from the database.  Encode it using the HashEncode 
' function below.  If the result matches the the encrypted password stored in the
' database, then it is a match.  If not then the password is invalid.
'
'
' Note: Passwords become case sensitive when using this encryption.
' For more information on Password HASH Encoding, and SALT visit: http://local.15seconds.com/issue/000217.htm
'
' Call this function if you wish to generate a random hex value of any given length
'
' Written By: Mark G. Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact

	Dim strSalt
	Dim intIndex, intRand

	If Not IsNumeric(intLen) Then
		getSalt = "00000000"
		exit function
	ElseIf CInt(intLen) <> CDbl(intLen) Or CInt(intLen) < 1 Then
		getSalt = "00000000"
		exit function
	End If

	Randomize

	For intIndex = 1 to CInt(intLen)
		intRand = CInt(Rnd * 1000) Mod 16
		strSalt = strSalt & getDecHex(intRand)
	Next
	
	getSalt = strSalt

End Function


Function HashEncode(strSecret)
' Function takes an ASCII string less than 2^61 characters long and 
' one way hash encrypts it using 160 bit encryption into a 40 digit hex value.
' The encoded hex value cannot be decoded to the original string value.
'
' This is the only function that you need to call for encryption.
'
' Written By: Mark G. Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact
'
' The author makes no warranties as to the validity, and/or authenticity of this code.
' You may use any code found herein at your own risk.
' This code was written to follow as closely as possible the standards found in
' Federal Information Processing Standards Publication (FIPS PUB 180-1)
' http://csrc.nist.gov/fips/fip180-1.txt -- Secure Hash Standard SHA-1
'
' This code is for private use only, and the security and/or encryption of the resulting
' hexadecimal value is not warrented or gaurenteed in any way.
'
    Dim strEncode, strH(4)
    Dim intPos
    
    
    If len(strSecret) = 0 or len(strSecret) >= 2^61 then
		HashEncode = "0000000000000000000000000000000000000000"
		exit function
    end if
    
    
    'Initial Hex words are used for encoding Digest.  
    'These can be any valid 8-digit hex value (0 to F)
    strH(0) = "FB0C14C2"
    strH(1) = "9F00AB2E"
    strH(2) = "991FFA67"
    strH(3) = "76FA2C3F"
    strH(4) = "ADE426FA"
    
    For intPos = 1 to len(strSecret) step 56
		
		strEncode = Mid(strSecret, intPos, 56) 'get 56 character chunks
		strEncode = WordToBinary(strEncode) 'convert to binary
		strEncode = PadBinary(strEncode) 'make it 512 bites
		strEncode = BlockToHex(strEncode) 'convert to hex value
		
		'Encode the hex value using the previous runs digest
		'If it is the first run then use the initial values above
		strEncode = DigestHex(strEncode, strH(0), strH(1), strH(2), strH(3), strH(4))

		'Combine the old digest with the new digest
		strH(0) = HexAdd(left(strEncode, 8), strH(0))
		strH(1) = HexAdd(mid(strEncode, 9, 8), strH(1))
		strH(2) = HexAdd(mid(strEncode, 17, 8), strH(2))
		strH(3) = HexAdd(mid(strEncode, 25, 8), strH(3))
		strH(4) = HexAdd(right(strEncode, 8), strH(4))
		
    Next
    
    'This is the final Hex Digest
    HashEncode = strH(0) & strH(1) & strH(2) & strH(3) & strH(4)
    
End Function



Function HexToBinary(btHex)

' Function Converts a single hex value into it's binary equivalent
'
' Written By: Mark Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact
'

    Select Case btHex
    Case "0"
        HexToBinary = "0000"
    Case "1"
        HexToBinary = "0001"
    Case "2"
        HexToBinary = "0010"
    Case "3"
        HexToBinary = "0011"
    Case "4"
        HexToBinary = "0100"
    Case "5"
        HexToBinary = "0101"
    Case "6"
        HexToBinary = "0110"
    Case "7"
        HexToBinary = "0111"
    Case "8"
        HexToBinary = "1000"
    Case "9"
        HexToBinary = "1001"
    Case "A"
        HexToBinary = "1010"
    Case "B"
        HexToBinary = "1011"
    Case "C"
        HexToBinary = "1100"
    Case "D"
        HexToBinary = "1101"
    Case "E"
        HexToBinary = "1110"
    Case "F"
        HexToBinary = "1111"
    Case Else
        HexToBinary = "2222"
    End Select
End Function

Function BinaryToHex(strBinary)

' Function Converts a 4 bit binary value into it's hex equivalent
'
' Written By: Mark Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact
'
    Select Case strBinary
    Case "0000"
        BinaryToHex = "0"
    Case "0001"
        BinaryToHex = "1"
    Case "0010"
        BinaryToHex = "2"
    Case "0011"
        BinaryToHex = "3"
    Case "0100"
        BinaryToHex = "4"
    Case "0101"
        BinaryToHex = "5"
    Case "0110"
        BinaryToHex = "6"
    Case "0111"
        BinaryToHex = "7"
    Case "1000"
        BinaryToHex = "8"
    Case "1001"
        BinaryToHex = "9"
    Case "1010"
        BinaryToHex = "A"
    Case "1011"
        BinaryToHex = "B"
    Case "1100"
        BinaryToHex = "C"
    Case "1101"
        BinaryToHex = "D"
    Case "1110"
        BinaryToHex = "E"
    Case "1111"
        BinaryToHex = "F"
    Case Else
        BinaryToHex = "Z"
    End Select
End Function

Function WordToBinary(strWord)
' Function Converts a 8 digit hex value into it's 32 bit binary equivalent
'
' Written By: Mark Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header kept intact
'
	Dim strTemp, strBinary 
	Dim intPos

	For intPos = 1 To Len(strWord)
	    strTemp = Mid(strWord, cint(intPos), 1)
	    strBinary = strBinary & IntToBinary(Asc(strTemp))
	Next

	WordToBinary = strBinary

End Function

Function HexToInt(strHex)
' Function Converts a hex word to its base 10(decimal) equivalent
'
' Written By: Mark Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact
'

	Dim intNew, intPos, intLen

	intNew = 0
	intLen = CDbl(len(strHex)) - 1
	
	For intPos = CDbl(intLen) to 0 step -1
	    Select Case Mid(strHex, CDbl(intPos) + 1, 1)       
	    Case "0"
			intNew = CDbl(intNew) + (0 * 16^CDbl(intLen - intPos))
	    Case "1"
	        intNew = CDbl(intNew) + (1 * 16^CDbl(intLen - intPos))
	    Case "2"
	        intNew = CDbl(intNew) + (2 * 16^CDbl(intLen - intPos))
	    Case "3"
	        intNew = CDbl(intNew) + (3 * 16^CDbl(intLen - intPos))
	    Case "4"
	        intNew = CDbl(intNew) + (4 * 16^CDbl(intLen - intPos))
	    Case "5"
	        intNew = CDbl(intNew) + (5 * 16^CDbl(intLen - intPos))
	    Case "6"
	        intNew = CDbl(intNew) + (6 * 16^CDbl(intLen - intPos))
	    Case "7"
	        intNew = CDbl(intNew) + (7 * 16^CDbl(intLen - intPos))
	    Case "8"
	        intNew = CDbl(intNew) + (8 * 16^CDbl(intLen - intPos))
	    Case "9"
	        intNew = CDbl(intNew) + (9 * 16^CDbl(intLen - intPos))
	    Case "A"
	        intNew = CDbl(intNew) + (10 * 16^CDbl(intLen - intPos))
	    Case "B"
	        intNew = CDbl(intNew) + (11 * 16^CDbl(intLen - intPos))
	    Case "C"
	        intNew = CDbl(intNew) + (12 * 16^CDbl(intLen - intPos))
	    Case "D"
	        intNew = CDbl(intNew) + (13 * 16^CDbl(intLen - intPos))
	    Case "E"
	        intNew = CDbl(intNew) + (14 * 16^CDbl(intLen - intPos))
	    Case "F"
	        intNew = CDbl(intNew) + (15 * 16^CDbl(intLen - intPos))
		End Select

	Next

	HexToInt = CDbl(intNew)
	
End Function

Function IntToBinary(intNum)

' Function Converts an integer number to it's binary equivalent
'
' Written By: Mark Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact
'
    Dim strBinary, strTemp
    Dim intNew, intTemp
    Dim dblNew
    
    intNew = intNum
    
    Do While intNew > 1
        dblNew = CDbl(intNew) / 2
        intNew = Round(CDbl(dblNew) - 0.1, 0)
        If CDbl(dblNew) = CDbl(intNew) Then
            strBinary = "0" & strBinary
        Else
            strBinary = "1" & strBinary
        End If

    Loop
    
    strBinary = intNew & strBinary
    
    intTemp = Len(strBinary) mod 8
    
    For intNew = intTemp To 7
        strBinary = "0" & strBinary
    Next
    
    IntToBinary = strBinary
    
End Function

Function PadBinary(strBinary)

' Function adds 0's to a binary string until it reaches 448 bits.
' The lenghth of the original string is incoded into the last 16 bits.
' The end result is a binary string 512 bits long
'
' Written By: Mark Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact
'

	Dim intPos, intLen
	Dim strTemp
	    
	intLen = Len(strBinary)
	    
	strBinary = strBinary & "1"
	    
	For intPos = Len(strBinary) To 447
	    strBinary = strBinary & "0"
	Next
	    
	strTemp = IntToBinary(intLen)
	    
	For intPos = Len(strTemp) To 63
	    strTemp = "0" & strTemp
	Next
	    
	strBinary = strBinary & strTemp
	    
	PadBinary = strBinary
	    
End Function

Function BlockToHex(strBinary)

' Function Converts a 32 bit binary string into it's 8 digit hex equivalent
'
' Written By: Mark Jager
' Written Date: 8/10/2000
'
' Free to distribute as long as code is not modified, and header is kept intact
'
	Dim intPos
	Dim strHex