Broken SHA-1 function for VB?

[Lycaon]

Is there a function in VB to calculate the SHA1 hash of a password? Well, I think that's what I'm looking for.  I'm looking for the has h function used to create the 20 byte hash sent to the server with packet 0x29.  I've found the c++ function based on the java function by iago, and am poking through it getting ready to translate it to VB...  But I figured I'd ask first.

[Eric]

If there's anything I've left out, you can find it here.

Code Select Expand


Private Declare Sub RtlMoveMemory Lib "Kernel32.dll" (ByRef Destination As Any, ByRef Source As Any, ByVal numBYTEs As Long)

Public Function CalcHashBuf(ByVal buf As String) As String
Dim pos As Long, sublen As Long
Dim hashbuf(&H10 + 5) As Long
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
   Dim t As String
   t = Mid$(buf, pos + 1, sublen) & String(&H40 - sublen, Chr$(0))
   Dim i As Long
   For i = 0 To 15
       hashbuf(5 + i) = GetDWORD(Mid$(t, i * 4 + 1, 4))
   Next i
   Call DataHash(hashbuf)
Next pos
CalcHashBuf = MakeDWORD(hashbuf(0)) & _
   MakeDWORD(hashbuf(1)) & _
   MakeDWORD(hashbuf(2)) & _
   MakeDWORD(hashbuf(3)) & _
   MakeDWORD(hashbuf(4))
End Function

Private Sub DataHash(ByRef param() As Long)
Dim buf(&H50) As Long
Dim a As Long, b As Long, C As Long, D As Long, E As Long, G As Long
Dim i As Long
Dim p 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
   G = buf(i - &H10) Xor buf(i - &H8) Xor buf(i - &HE) Xor buf(i - &H3)
   buf(i) = RoL(1, G)
Next
a = param(0)
b = param(1)
C = param(2)
D = param(3)
E = param(4)
For i = 0 To 79
   G = buf(i)
   G = Add(G, E)
   G = Add(G, RoL(a, 5))
   Select Case i
       Case Is < 20
           G = Add(G, ((b And C) Or ((Not b) And D)))
           G = Add(G, &H5A827999)
       Case Is < 40
           G = Add(G, (D Xor C Xor b))
           G = Add(G, &H6ED9EBA1)
       Case Is < 60
           G = Add(G, (C And b) Or (D And C) Or (D And b))
           G = Add(G, &H8F1BBCDC)
       Case Is < 80
           G = Add(G, (D Xor C Xor b))
           G = Add(G, &HCA62C1D6)
       Case Else
           Exit Sub
   End Select
   E = D
   D = C
   C = RoL(b, 30)
   b = a
   a = G
Next
param(0) = Add(param(0), a)
param(1) = Add(param(1), b)
param(2) = Add(param(2), C)
param(3) = Add(param(3), D)
param(4) = Add(param(4), E)
End Sub

Public Function MakeDWORD(Value As Long) As String
Dim strReturn As String * 4
RtlMoveMemory ByVal strReturn, Value, 4
MakeDWORD = strReturn
End Function

Public Function Add(ByVal number1 As Long, ByVal number2 As Long) As Long
Add = DToL(CDbl(number1) + CDbl(number2))
End Function

Public 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

Public 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

Public 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


Code Select Expand


Private Sub SendAccountAuth(ByVal BNCS_SocketHandle As Long, ByVal PacketID As Byte)
Dim PacketBuffer As New clsPacketBuffer
Dim clsHashing As New clsHashing

Dim OutBuf As String * 20 'DWORD[5]
Dim tmpOutBuf As String
Dim ClientToken As Long
Dim PWHashBuf(2) As String

ClientToken = GetTickCount()

With PacketBuffer
   .InsertDWORD ClientToken
   .InsertDWORD tmpHashBuf.SvrToken
   PWHashBuf(0) = clsFunctions.MakeDWORD(ClientToken)
   PWHashBuf(1) = clsFunctions.MakeDWORD(tmpHashBuf.SvrToken)
   tmpOutBuf = Join(PWHashBuf(), vbNullString)
   tmpOutBuf = (tmpOutBuf & AccountBuf.PWHash) 'Original password hashed in SetAccount()
   OutBuf = clsHashing.CalcHashBuf(tmpOutBuf)
   .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 1, 4))
   .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 5, 4))
   .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 9, 4))
   .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 13, 4))
   .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 17, 4))
   .InsertNTString AccountBuf.Username
   .BuildPacket BNCS, PacketID
   .SendBuffer BNCS_SocketHandle
End With
Erase PWHashBuf()
End Sub


btw: Thank Camel for the majority of the C to VB porting.

[Lycaon]

Thanks much to both you and Camel.