Broken SHA-1 Differences

[Barabajagal]

That's all I wanted to know. Thank you.

Edit: And now, I've got everything but War3 working without BNCSUtil:

Code Select Expand

Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Function PassHashSingle(ByVal Password As String) As String
    PassHashSingle = BrokenSHA1(Password)
End Function
Public Function PassHashDouble(ByVal Password As String, ByVal ClientToken As Long, ByVal ServerToken As Long) As String
Dim pHash As String * 20
    pHash = BrokenSHA1(Password)
    PassHashDouble = BrokenSHA1(MakeDWORD(ClientToken) & MakeDWORD(ServerToken) & BrokenSHA1(Password))
End Function
Public Function KeyHashAuth(ByVal CDKey As String, ByVal ClientToken As Long, ByVal ServerToken As Long, ByRef KeyProd As Long, ByRef KeyVal1 As Long, ByRef KeyVal2 As Long, ByRef KeyHash As String) As Byte
Dim KeyDecoder  As Long
Dim HashLength  As Long
Dim HashData    As String
Dim Ret         As Byte
    If DecodeKey(CDKey, KeyProd, KeyVal1, KeyVal2) Then
        HashData = MakeDWORD(ClientToken)
        HashData = HashData & MakeDWORD(ServerToken)
        HashData = HashData & MakeDWORD(KeyProd)
        HashData = HashData & MakeDWORD(KeyVal1)
        HashData = HashData & MakeDWORD(0)
        HashData = HashData & MakeDWORD(KeyVal2)
        KeyHash = BrokenSHA1(HashData)
        KeyHashAuth = 0
    Else
        Ret = bncsutil_HashKey(CDKey, ClientToken, ServerToken, KeyProd, KeyVal1, KeyVal2, KeyHash)
        If Ret = 0 Then
            KeyHashAuth = 0
        Else
            KeyHashAuth = Ret
        End If
    End If
End Function
Public Function KeyHashOld(ByVal CDKey As String, ByVal ClientToken As Long, ByVal ServerToken As Long, ByRef KeyProd As Long, ByRef KeyVal1 As Long, ByRef KeyVal2 As Long, ByRef KeyHash As String) As Byte
Dim KeyDecoder  As Long
Dim HashLength  As Long
Dim HashData    As String
Dim Ret         As Byte
    Ret = DecodeKey(CDKey, KeyProd, KeyVal1, KeyVal2)
    If Ret = 0 Then
        HashData = MakeDWORD(ClientToken)
        HashData = HashData & MakeDWORD(ServerToken)
        HashData = HashData & MakeDWORD(KeyProd)
        HashData = HashData & MakeDWORD(KeyVal1)
        HashData = HashData & MakeDWORD(KeyVal2)
        KeyHash = BrokenSHA1(HashData)
        KeyHashOld = 0
    Else
        Ret = bncsutil_HashKey(CDKey, ClientToken, ServerToken, KeyProd, KeyVal1, KeyVal2, KeyHash)
        If Ret = 0 Then
            HashData = MakeDWORD(ClientToken)
            HashData = HashData & MakeDWORD(ServerToken)
            HashData = HashData & MakeDWORD(KeyProd)
            HashData = HashData & MakeDWORD(KeyVal1)
            HashData = HashData & MakeDWORD(KeyVal2)
            KeyHash = BrokenSHA1(HashData)
            KeyHashOld = 0
        Else
            KeyHashOld = Ret
        End If
    End If
End Function
Private Function DecodeKey(ByVal CDKey As String, ByRef KeyProd As Long, ByRef KeyVal1 As Long, ByRef KeyVal2 As Long) As Boolean
    If Len(CDKey) = 13 Then
        CDKey = DecodeSTARKey(CDKey)
        KeyProd = Val("&H" & Left$(CDKey, 2))
        If KeyProd = &H1 Or KeyProd = &H2 Then
            KeyVal1 = Val(Mid$(CDKey, 3, 7))
            KeyVal2 = Val(Mid$(CDKey, 10, 3))
            DecodeKey = True
        Else
            DecodeKey = False
        End If
    ElseIf Len(CDKey) = 16 Then
        CDKey = DecodeD2DVKey(CDKey)
        KeyProd = Val("&H" & Left$(CDKey, 2))
        If KeyProd = &H4 Or KeyProd = &H6 Or KeyProd = &HA Then
            KeyVal1 = Val("&H" & Mid$(CDKey, 3, 6))
            KeyVal2 = Val("&H" & Mid$(CDKey, 9))
            DecodeKey = True
        Else
            DecodeKey = False
        End If
    ElseIf Len(CDKey) = 26 Then
        'Warcraft III not in vb6
        DecodeKey = False
    Else
        DecodeKey = False
    End If
End Function
Private Function bncsutil_HashKey(ByVal CDKey As String, ByVal ClientToken As Long, ByVal ServerToken As Long, ByRef KeyProd As Long, ByRef KeyVal1 As Long, ByRef KeyVal2 As Long, ByRef KeyHash As String) As Byte
Dim KeyDecoder  As Long
Dim HashLength  As Long
    kd_init
    KeyDecoder = kd_create(CDKey, Len(CDKey))
    If (KeyDecoder = -1) Then
        bncsutil_HashKey = 1
        kd_free KeyDecoder
        Exit Function
    End If
    HashLength = kd_calculateHash(KeyDecoder, ClientToken, ServerToken)
    If (HashLength = 0) Then
        bncsutil_HashKey = 2
        kd_free KeyDecoder
        Exit Function
    End If
    If (kd_isValid(KeyDecoder) = 0) Then
        bncsutil_HashKey = 3
        kd_free KeyDecoder
        Exit Function
    End If
    KeyHash = String$(HashLength, vbNullChar)
    kd_getHash KeyDecoder, KeyHash
    If Len(KeyHash) <> 20 Then
        bncsutil_HashKey = 4
        kd_free KeyDecoder
        Exit Function
    End If
    KeyProd = kd_product(KeyDecoder)
    KeyVal1 = kd_val1(KeyDecoder)
    KeyVal2 = kd_val2(KeyDecoder)
    kd_free KeyDecoder
End Function

'Broken SHA 1
Private Function BrokenSHA1(ByVal buf As String) As String
Dim Pos                 As Long
Dim sublen              As Long
Dim HashBuf(&H10 + 5)   As Long
Dim I                   As Long
Dim T                   As String
    HashBuf(0) = &H67452301
    HashBuf(1) = &HEFCDAB89
    HashBuf(2) = &H98BADCFE
    HashBuf(3) = &H10325476
    HashBuf(4) = &HC3D2E1F0
    For Pos = 0 To Len(buf) Step &H40
        sublen = Len(buf) - Pos
        If sublen > &H40 Then sublen = &H40
        T = Mid$(buf, Pos + 1, sublen) & String(&H40 - sublen, Chr$(0))
        For I = 0 To 15
            HashBuf(5 + I) = GetDWORD(Mid$(T, I * 4 + 1, 4))
        Next I
        BrokenHash HashBuf
    Next Pos
    BrokenSHA1 = MakeDWORD(HashBuf(0)) & MakeDWORD(HashBuf(1)) & MakeDWORD(HashBuf(2)) & MakeDWORD(HashBuf(3)) & MakeDWORD(HashBuf(4))
End Function
Private Sub BrokenHash(ByRef param() As Long)
Dim buf(&H50)   As Long
Dim A           As Long
Dim B           As Long
Dim C           As Long
Dim D           As Long
Dim E           As Long
Dim I           As Long
Dim P           As Long
Dim T           As Long
    P = UBound(param) - 5
    If P > &H40 Then P = &H40
    For I = 0 To P - 1
        buf(I) = param(I + 5)
    Next
    For I = &H10 To &H4F
        T = buf(I - &H3) Xor buf(I - &H8) Xor buf(I - &H10) Xor buf(I - &HE)
        buf(I) = RoL(1, T)
    Next
    A = param(0)
    B = param(1)
    C = param(2)
    D = param(3)
    E = param(4)
    For I = 0 To 79
        T = U32Add(buf(I), E)
        T = U32Add(T, RoL(A, 5))
        Select Case I
            Case Is < 20
                T = U32Add(T, ((B And C) Or ((Not B) And D)))
                T = U32Add(T, &H5A827999)
            Case Is < 40
                T = U32Add(T, (B Xor C Xor D))
                T = U32Add(T, &H6ED9EBA1)
            Case Is < 60
                T = U32Add(T, (B And C) Or (B And D) Or (C And D))
                T = U32Add(T, &H8F1BBCDC)
            Case Is < 80
                T = U32Add(T, (B Xor C Xor D))
                T = U32Add(T, &HCA62C1D6)
            Case Else
                Exit Sub
        End Select
        E = D
        D = C
        C = RoL(B, &H1E)
        B = A
        A = T
    Next
    param(0) = U32Add(param(0), A)
    param(1) = U32Add(param(1), B)
    param(2) = U32Add(param(2), C)
    param(3) = U32Add(param(3), D)
    param(4) = U32Add(param(4), E)
End Sub
Private Function U32Add(ByVal number1 As Long, ByVal number2 As Long) As Long
    U32Add = DToL(CDbl(number1) + CDbl(number2))
End Function
Private Function RoL(ByVal Number As Long, ByVal Shift As Long) As Long
    Shift = Shift And &H1F
    RoL = LShift(Number, Shift) Or RShift(Number, 32 - Shift)
End Function
Private Function LShift(ByVal pnValue As Long, ByVal pnShift As Long) As Long
    If pnShift > 31 Then
        LShift = 0
    ElseIf pnShift < 0 Then
        LShift = 0
    ElseIf pnShift = 0 Then
        LShift = pnValue
    Else
        pnValue = pnValue And (2 ^ (32 - pnShift) - 1)
        LShift = DToL(CDbl(pnValue) * CDbl(DToL(2 ^ pnShift)))
    End If
End Function
Private Function RShift(ByVal pnValue As Long, ByVal pnShift As Long) As Long
    If pnShift > 31 Then
        RShift = 0
    ElseIf pnShift < 0 Then
        RShift = 0
    ElseIf pnShift = 0 Then
        RShift = pnValue
    Else
        If (pnValue And &H80000000) = &H80000000 Then
            RShift = (pnValue And &H7FFFFFFF)
            RShift = RShift \ (2 ^ pnShift)
            RShift = RShift Or (2 ^ (31 - pnShift))
        Else
            RShift = Int(CDbl(pnValue) / CDbl(2 ^ pnShift))
        End If
        If RShift = -1 Then Debug.Assert False
    End If
End Function
Private Function DToL(ByVal num As Double) As Long
    While num > &H7FFFFFFF
        num = num - 4294967296#
    Wend
    While num < &H80000000
        num = num + 4294967296#
    Wend
    DToL = CLng(num)
End Function

'CDKey Decoding
Private Function DecodeSTARKey(ByVal sKey As String) As String
Dim R               As Double
Dim N               As Double
Dim N2              As Double
Dim v               As Double
Dim V2              As Double
Dim KeyValue        As Double
Dim C1              As Byte
Dim C2              As Byte
Dim C               As Byte
Dim bValid          As Boolean
Dim I               As Integer
Dim aryKey(0 To 12) As String
    For I = 1 To 13
        aryKey(I - 1) = Mid$(sKey, I, 1)
    Next I
    v = 3
    For I = 0 To 11
        C = aryKey(I)
        N = Val(C)
        N2 = v * 2
        N = N Xor N2
        v = v + N
    Next I
    v = v Mod 10
    If Hex(v) = aryKey(12) Then
        bValid = True
    End If
    v = 194
    For I = 11 To 0 Step -1
        If v < 7 Then Exit For
        C = aryKey(I)
        N = CInt(v / 12)
        N2 = v Mod 12
        v = v - 17
        C2 = aryKey(N2)
        aryKey(I) = C2
        aryKey(N2) = C
    Next I
    V2 = &H13AC9741
    For I = 11 To 0 Step -1
        C = UCase$(aryKey(I))
        aryKey(I) = C
        If Asc(C) <= &H37 Then
            v = V2
            C2 = v And &HFF
            C2 = C2 And 7
            C2 = C2 Xor C
            v = RShift(CLng(v), 3)
            aryKey(I) = C2
            V2 = v
        ElseIf Asc(C) < 65 Then
            C2 = CByte(I)
            C2 = C2 And 1
            C2 = C2 Xor C
            aryKey(I) = C2
        End If
    Next I
    DecodeSTARKey = Join(aryKey, "")
    Erase aryKey()
End Function
Private Function DecodeD2DVKey(ByVal key As String) As String
Dim R               As Double
Dim N               As Double
Dim N2              As Double
Dim v               As Double
Dim V2              As Double
Dim KeyValue        As Double
Dim C1              As Byte
Dim C2              As Byte
Dim C               As Byte
Dim bValid          As Boolean
Dim I               As Integer
Dim aryKey(0 To 15) As String
Const CodeValues    As String = "246789BCDEFGHJKMNPRTVWXZ"
    R = 1
    KeyValue = 0
    For I = 1 To 16
        aryKey(I - 1) = Mid$(key, I, 1)
    Next I
    For I = 0 To 15 Step 2
        C1 = InStr(1, CodeValues, aryKey(I)) - 1
        If C1 = -1 Then C1 = &HFF
        N = C1 * 3
        C2 = InStr(1, CodeValues, aryKey(I + 1)) - 1
        If C2 = -1 Then C2 = &HFF
        N = C2 + N * 8
        If N >= &H100 Then
            N = N - &H100
            KeyValue = KeyValue Or R
        End If
        N2 = N
        N2 = RShift(N2, 4)
        aryKey(I) = GetHexValue(N2)
        aryKey(I + 1) = GetHexValue(N)
        R = LShift(R, 1)
    Next I
    v = 3
    For I = 0 To 15
        C = GetNumValue(aryKey(I))
        N = Val(C)
        N2 = v * 2
        N = N Xor N2
        v = v + N
    Next I
    v = v And &HFF
    For I = 15 To 0 Step -1
        C = Asc(aryKey(I))
        If I > 8 Then
            N = I - 9
        Else
            N = &HF - (8 - I)
        End If
        N = N And &HF
        C2 = Asc(aryKey(N))
        aryKey(I) = Chr$(C2)
        aryKey(N) = Chr$(C)
    Next I
    V2 = &H13AC9741
    For I = 15 To 0 Step -1
        C = Asc(UCase(aryKey(I)))
        aryKey(I) = Chr$(C)
        If Val(C) <= &H37 Then
            v = V2
            C2 = v And &HF
            C2 = C2 And 7
            C2 = C2 Xor C
            v = RShift(v, 3)
            aryKey(I) = Chr$(C2)
            V2 = v
        ElseIf Val(C) < &H41 Then
            C2 = CByte(I)
            C2 = C2 And 1
            C2 = C2 Xor C
            aryKey(I) = Chr$(C2)
        End If
    Next I
    DecodeD2DVKey = Join(aryKey, "")
    Erase aryKey()
End Function

Private Function GetHexValue(ByVal Val As Long) As String
    Val = Val And &HF
    If Val < 10 Then
        GetHexValue = Chr$(Val + &H30)
    Else
        GetHexValue = Chr$(v + &H37)
    End If
End Function
Private Function GetNumValue(ByVal Val As String) As Long
On Error Resume Next
    Val = UCase(Val)
    If IsNumeric(Val) Then
        GetNumValue = Asc(Val) - &H30
    Else
        GetNumValue = Asc(Val) - &H37
    End If
End Function
Private Function MakeDWORD(FromLong As Long) As String
Dim strReturn As String * 4
    RtlMoveMemory ByVal strReturn, FromLong, 4
    MakeDWORD = strReturn
End Function
Private Function GetDWORD(ByVal FromStr As String) As Long
Dim rVal As Long
    RtlMoveMemory rVal, ByVal FromStr, 4
    GetDWORD = rVal
End Function


Decoding Warcraft 3 keys in vb6 seems to be pretty much impossible without those nifty 64 bit integers. I'll probably write a PB dll to deal with that (and NLS) eventually. Thank you to the people who have helped me with this so far.

[Sorc.Polgara]

Why the hell are you porting hashing functions to VB... sigh.

[Barabajagal]

Because I'm tired of using external DLLs. And I've actually almost got war3 working, too. yay -1& instead of 4294967295

[Warrior]

Why the hell are you porting hashing functions to VB... sigh.

Because he obviously fails to see the obvious advantages other programming languages offer over VB. And he has his precious certification.

[l2k-Shadow]

war3 CheckRevision in VB takes what like 20 seconds?

[MyndFyre]

Because he obviously fails to see the obvious advantages other programming languages offer over VB. And he has his precious certification.

VB6 has certifications?

[Hero]

I still love you Reality!

[Warrior]

Because he obviously fails to see the obvious advantages other programming languages offer over VB. And he has his precious certification.

VB6 has certifications?

Nothing official I'm sure, just a plaque sent by some no-name company so that he feels better of himself when he writes code..err poetry.

[Barabajagal]

Because he obviously fails to see the obvious advantages other programming languages offer over VB. And he has his precious certification.

VB6 has certifications?

Nothing official I'm sure, just a plaque sent by some no-name company so that he feels better of himself when he writes code..err poetry.

ExpertRating.com