This mdSha3.bas module includes CryptoSHA3 function that can be used to calculate SHA-3 hash in all bit-sizes: SHA3-224, SHA3-256, SHA3-384 and SHA3-512.
The module also includes CryptoKeccak function which calculates the legacy Keccak hash as it was implemented before being accepted as SHA-3 officially and CryptoShake function for SHAKE-128, SHAKE-256 and SHAKE-512 which can produce hashes in arbitrary output length.
This module uses VT_I8 Variants for the 64-bit arithmetic in Keccak sponge permutation function so it's not the fastest hasher on the block, one might expect performance around the 1MB/s mark when compiled.
All the public functions could be used with other non-standard bit-sizes but do this on your own risk only.
Here is a sample usage of the hash function with some test vectors from here.
cheers,
</wqw>
The module also includes CryptoKeccak function which calculates the legacy Keccak hash as it was implemented before being accepted as SHA-3 officially and CryptoShake function for SHAKE-128, SHAKE-256 and SHAKE-512 which can produce hashes in arbitrary output length.
This module uses VT_I8 Variants for the 64-bit arithmetic in Keccak sponge permutation function so it's not the fastest hasher on the block, one might expect performance around the 1MB/s mark when compiled.
All the public functions could be used with other non-standard bit-sizes but do this on your own risk only.
Code:
'--- mdSha3.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 0)
#Const LargeAddressAware = (Win64 = 0 And VBA7 = 0 And VBA6 = 0 And VBA5 = 0)
#If Win64 Then
Private Const PTR_SIZE As Long = 8
#Else
Private Const PTR_SIZE As Long = 4
Private Const SIGN_BIT As Long = &H80000000
#End If
#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) As LongPtr
Private Declare PtrSafe Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
#End If
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
cElements As Long
lLbound As Long
End Type
Private Const LNG_ROUNDS As Long = 24
Private Const LNG_SPONGE_WORDS As Long = 25
Private LNG_POW2(0 To 63) As Variant
Private LNG_RND_C(0 To 23) As Variant
Private Type HashState
DigestSize As Long
Capacity As Long
Absorbed As Long
Words(0 To LNG_SPONGE_WORDS - 1) As Variant
Bytes() As Byte
PeekArray As SAFEARRAY1D
End Type
Private Function ROTL64(lX As Variant, ByVal lN As Long) As Variant
'--- ROTL64 = LShift(X, n) Or RShift(X, 64 - n)
Debug.Assert lN <> 0
ROTL64 = ((lX And (LNG_POW2(63 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(63 - lN)) <> 0) * LNG_POW2(63)) Or _
((lX And (LNG_POW2(63) Xor -1)) \ LNG_POW2(64 - lN) Or -(lX < 0) * LNG_POW2(lN - 1))
End Function
Private Sub Theta(uState As HashState)
Static C(0 To 4) As Variant
Dim lIdx As Long
Dim lJdx As Long
Dim vTemp As Variant
With uState
For lIdx = 0 To 4
C(lIdx) = .Words(lIdx) Xor .Words(lIdx + 5) Xor .Words(lIdx + 10) Xor .Words(lIdx + 15) Xor .Words(lIdx + 20)
Next
For lIdx = 0 To 4
vTemp = C((lIdx + 4) Mod 5) Xor ROTL64(C((lIdx + 1) Mod 5), 1)
For lJdx = 0 To 24 Step 5
.Words(lIdx + lJdx) = .Words(lIdx + lJdx) Xor vTemp
Next
Next
End With
End Sub
Private Sub Rho(uState As HashState)
With uState
' .Words(0) = ROTL64(.Words(0), 0)
.Words(1) = ROTL64(.Words(1), 1)
.Words(2) = ROTL64(.Words(2), 62)
.Words(3) = ROTL64(.Words(3), 28)
.Words(4) = ROTL64(.Words(4), 27)
.Words(5) = ROTL64(.Words(5), 36)
.Words(6) = ROTL64(.Words(6), 44)
.Words(7) = ROTL64(.Words(7), 6)
.Words(8) = ROTL64(.Words(8), 55)
.Words(9) = ROTL64(.Words(9), 20)
.Words(10) = ROTL64(.Words(10), 3)
.Words(11) = ROTL64(.Words(11), 10)
.Words(12) = ROTL64(.Words(12), 43)
.Words(13) = ROTL64(.Words(13), 25)
.Words(14) = ROTL64(.Words(14), 39)
.Words(15) = ROTL64(.Words(15), 41)
.Words(16) = ROTL64(.Words(16), 45)
.Words(17) = ROTL64(.Words(17), 15)
.Words(18) = ROTL64(.Words(18), 21)
.Words(19) = ROTL64(.Words(19), 8)
.Words(20) = ROTL64(.Words(20), 18)
.Words(21) = ROTL64(.Words(21), 2)
.Words(22) = ROTL64(.Words(22), 61)
.Words(23) = ROTL64(.Words(23), 56)
.Words(24) = ROTL64(.Words(24), 14)
End With
End Sub
Private Sub Pi(uState As HashState)
Dim aTemp() As Variant
With uState
aTemp = .Words
' .Words(0) = aTemp(0)
.Words(10) = aTemp(1)
.Words(20) = aTemp(2)
.Words(5) = aTemp(3)
.Words(15) = aTemp(4)
.Words(16) = aTemp(5)
.Words(1) = aTemp(6)
.Words(11) = aTemp(7)
.Words(21) = aTemp(8)
.Words(6) = aTemp(9)
.Words(7) = aTemp(10)
.Words(17) = aTemp(11)
.Words(2) = aTemp(12)
.Words(12) = aTemp(13)
.Words(22) = aTemp(14)
.Words(23) = aTemp(15)
.Words(8) = aTemp(16)
.Words(18) = aTemp(17)
.Words(3) = aTemp(18)
.Words(13) = aTemp(19)
.Words(14) = aTemp(20)
.Words(24) = aTemp(21)
.Words(9) = aTemp(22)
.Words(19) = aTemp(23)
.Words(4) = aTemp(24)
End With
End Sub
Private Sub Chi(uState As HashState)
Static C(0 To 4) As Variant
Dim lIdx As Long
Dim lJdx As Long
With uState
For lJdx = 0 To 24 Step 5
For lIdx = 0 To 4
C(lIdx) = .Words(lIdx + lJdx)
Next
For lIdx = 0 To 4
.Words(lIdx + lJdx) = .Words(lIdx + lJdx) Xor (Not C((lIdx + 1) Mod 5) And C((lIdx + 2) Mod 5))
Next
Next
End With
End Sub
Private Sub Iota(uState As HashState, ByVal lIdx As Long)
uState.Words(0) = uState.Words(0) Xor LNG_RND_C(lIdx)
End Sub
Private Sub Keccak(uState As HashState)
Dim lIdx As Long
For lIdx = 0 To LNG_ROUNDS - 1
Theta uState
Rho uState
Pi uState
Chi uState
Iota uState, lIdx
Next
End Sub
Private Sub Absorb(uState As HashState, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long)
Dim lIdx As Long
Dim lOffset As Long
If lSize < 0 Then
lSize = UBound(baBuffer) + 1
End If
With uState
lOffset = PeekByte(uState, .Absorbed)
For lIdx = lPos To lSize - lPos - 1
.Bytes(lOffset) = .Bytes(lOffset) Xor baBuffer(lIdx)
If .Absorbed = .Capacity - 1 Then
Keccak uState
.Absorbed = 0
Else
.Absorbed = .Absorbed + 1
End If
If lOffset = 7 Then
lOffset = PeekByte(uState, .Absorbed)
Else
lOffset = lOffset + 1
End If
Next
End With
End Sub
Private Sub Squeeze(uState As HashState, baOutput() As Byte, ByVal lOutSize As Long, ByVal lLFSR As Long)
Dim lIdx As Long
Dim lOffset As Long
Dim uEmpty As HashState
With uState
ReDim baOutput(0 To lOutSize - 1) As Byte
lOffset = PeekByte(uState, .Absorbed)
.Bytes(lOffset) = .Bytes(lOffset) Xor lLFSR
lOffset = PeekByte(uState, .Capacity - 1)
.Bytes(lOffset) = .Bytes(lOffset) Xor &H80
lOffset = PeekByte(uState, 0)
For lIdx = 0 To UBound(baOutput)
If lIdx Mod .Capacity = 0 Then
Keccak uState
End If
baOutput(lIdx) = .Bytes(lOffset)
If lOffset = 7 Then
lOffset = PeekByte(uState, lIdx + 1)
Else
lOffset = lOffset + 1
End If
Next
End With
uState = uEmpty
End Sub
Private Sub Init(uState As HashState, ByVal lBitSize As Long)
Dim lIdx As Long
Dim vElem As Variant
If LNG_POW2(0) = 0 Then
LNG_POW2(0) = CLongLong(1)
For lIdx = 1 To 63
LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
Next
lIdx = 0
For Each vElem In Split("1 8082 800000000000808A 8000000080008000 808B 80000001 8000000080008081 8000000000008009 8A 88 80008009 8000000A 8000808B 800000000000008B 8000000000008089 8000000000008003 8000000000008002 8000000000000080 800A 800000008000000A 8000000080008081 8000000000008080 80000001 8000000080008008")
LNG_RND_C(lIdx) = CLongLong("&H" & vElem)
lIdx = lIdx + 1
Next
End If
With uState
.DigestSize = (lBitSize + 7) \ 8
.Capacity = LNG_SPONGE_WORDS * 8 - 2 * .DigestSize
.Words(0) = CLongLong(0)
For lIdx = 1 To UBound(.Words)
.Words(lIdx) = .Words(0)
Next
If .PeekArray.cDims = 0 Then
With .PeekArray
.cDims = 1
.fFeatures = 1 ' FADF_AUTO
.cbElements = 1
.cLocks = 1
.cElements = 8
End With
Call CopyMemory(ByVal ArrPtr(.Bytes), VarPtr(.PeekArray), PTR_SIZE)
End If
End With
End Sub
Private Function CLongLong(vValue As Variant) As Variant
Const VT_I8 As Long = &H14
Call VariantChangeType(CLongLong, vValue, 0, VT_I8)
End Function
Private Function PeekByte(uState As HashState, ByVal lOffset As Long) As Long
#If LargeAddressAware Then
uState.PeekArray.pvData = (VarPtr(uState.Words(lOffset \ 8)) Xor SIGN_BIT) + 8 Xor SIGN_BIT
#Else
uState.PeekArray.pvData = VarPtr(uState.Words(lOffset \ 8)) + 8
#End If
PeekByte = lOffset Mod 8
End Function
Public Sub CryptoSHA3(ByVal lBitSize As Long, baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim uState As HashState
Init uState, lBitSize
Absorb uState, baInput, Pos, Size
Squeeze uState, baOutput, uState.DigestSize, &H6
End Sub
Public Sub CryptoKeccak(ByVal lBitSize As Long, baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim uState As HashState
Init uState, lBitSize
Absorb uState, baInput, Pos, Size
Squeeze uState, baOutput, uState.DigestSize, &H1
End Sub
Public Sub CryptoShake(ByVal lBitSize As Long, baOutput() As Byte, ByVal lOutSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim uState As HashState
Init uState, lBitSize
Absorb uState, baInput, Pos, Size
Squeeze uState, baOutput, lOutSize, &H1F
End SubCode:
Option Explicit
Private Sub Form_Load()
Dim baInput() As Byte
Dim baHash() As Byte
baInput = StrConv("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu", vbFromUnicode)
CryptoSHA3 224, baHash, baInput
Debug.Print ToHex(baHash)
'-> 543e6868e1666c1a643630df77367ae5a62a85070a51c14cbf665cbc
CryptoSHA3 256, baHash, baInput
Debug.Print ToHex(baHash)
'-> 916f6061fe879741ca6469b43971dfdb28b1a32dc36cb3254e812be27aad1d18
CryptoSHA3 384, baHash, baInput
Debug.Print ToHex(baHash)
'-> 79407d3b5916b59c3e30b09822974791c313fb9ecc849e406f23592d04f625dc8c709b98b43b3852b337216179aa7fc7
CryptoSHA3 512, baHash, baInput
Debug.Print ToHex(baHash)
'-> afebb2ef542e6579c50cad06d2e578f9f8dd6881d7dc824d26360feebf18a4fa73e3261122948efcfd492e74e82e2189ed0fb440d187f382270cb455f21dd185
CryptoShake 128, baHash, 32, baInput, Size:=0
Debug.Print ToHex(baHash)
'-> 7f9c2ba4e88f827d616045507605853ed73b8093f6efbc88eb1a6eacfa66ef26
CryptoShake 256, baHash, 64, baInput, Size:=0
Debug.Print ToHex(baHash)
'-> 46b9dd2b0ba88d13233b3feb743eeb243fcd52ea62b81b82b50c27646ed5762fd75dc4ddd8c0f200cb05019d67b592f6fc821c49479ab48640292eacb3b7c4be
End Sub
Public Function ToHex(baText() As Byte, Optional Delimiter As String) As String
Dim aText() As String
Dim lIdx As Long
If LenB(CStr(baText)) <> 0 Then
ReDim aText(0 To UBound(baText)) As String
For lIdx = 0 To UBound(baText)
aText(lIdx) = Right$("0" & Hex$(baText(lIdx)), 2)
Next
ToHex = LCase$(Join(aText, Delimiter))
End If
End Function
Public Function FromHex(sText As String) As Byte()
Dim baRetVal() As Byte
Dim lIdx As Long
On Error GoTo QH
'--- check for hexdump delimiter
If sText Like "*[!0-9A-Fa-f]*" Then
ReDim baRetVal(0 To Len(sText) \ 3) As Byte
For lIdx = 1 To Len(sText) Step 3
baRetVal(lIdx \ 3) = "&H" & Mid$(sText, lIdx, 2)
Next
ElseIf LenB(sText) <> 0 Then
ReDim baRetVal(0 To Len(sText) \ 2 - 1) As Byte
For lIdx = 1 To Len(sText) Step 2
baRetVal(lIdx \ 2) = "&H" & Mid$(sText, lIdx, 2)
Next
Else
baRetVal = vbNullString
End If
FromHex = baRetVal
QH:
End Function</wqw>