Results 1 to 3 of 3

Thread: [VB6/VBA] BLAKE2 and BLAKE3 hash functions and MAC

  1. #1

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    [VB6/VBA] BLAKE2 and BLAKE3 hash functions and MAC

    These mdBlake2b.bas and mdBlake2s.bas modules provide BLAKE2b and BLAKE2s hash functions implementation as a streaming interface (Init/Update/Finalize) and byte-array + string convenience helpers which return result in one go.

    To use BLAKE2b-MAC and BLAKE2s-MAC just provide non-empty Key parameter with any of the CryptoBlake2bInit, CryptoBlake2bByteArray and CryptoBlake2bText or CryptoBlake2sInit, CryptoBlake2sByteArray and CryptoBlake2sText functions.

    BLAKE2b default output is of 512 bits and uses 64-bit operations internally (akin to SHA-512) so it's not very performant under 32-bit compilers while BLAKE2s default output is 256 bits and uses 32-bit operations internally like SHA-256 does.

    Code:
    '--- mdBlake2b.bas
    Option Explicit
    DefObj A-Z
    
    #Const HasPtrSafe = (VBA7 <> 0)
    #Const HasOperators = (TWINBASIC <> 0)
    
    #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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
    Private Declare PtrSafe Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
    Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #End If
    
    Private Const LNG_BLOCKSZ               As Long = 128
    Private Const LNG_ROUNDS                As Long = 12
    
    Public Type CryptoBlake2bContext
    #If HasPtrSafe Then
        H0                  As LongLong
        H1                  As LongLong
        H2                  As LongLong
        H3                  As LongLong
        H4                  As LongLong
        H5                  As LongLong
        H6                  As LongLong
        H7                  As LongLong
    #Else
        H0                  As Variant
        H1                  As Variant
        H2                  As Variant
        H3                  As Variant
        H4                  As Variant
        H5                  As Variant
        H6                  As Variant
        H7                  As Variant
    #End If
        Partial(0 To LNG_BLOCKSZ - 1) As Byte
        NPartial            As Long
        NInput              As Currency
        OutSize             As Long
    End Type
    
    #If HasPtrSafe Then
    Private LNG_ZERO                    As LongLong
    Private LNG_IV(0 To 7)              As LongLong
    #Else
    Private LNG_ZERO                    As Variant
    Private LNG_IV(0 To 7)              As Variant
    #End If
    Private LNG_SIGMA(0 To 15, 0 To LNG_ROUNDS - 1)  As Long
    
    #If Not HasOperators Then
    #If HasPtrSafe Then
    Private LNG_POW2(0 To 63)           As LongLong
    Private LNG_SIGN_BIT                As LongLong ' 2 ^ 63
    #Else
    Private LNG_POW2(0 To 63)           As Variant
    Private LNG_SIGN_BIT                As Variant
    #End If
    
    #If HasPtrSafe Then
    Private Function RotR64(ByVal lX As LongLong, ByVal lN As Long) As LongLong
    #Else
    Private Function RotR64(lX As Variant, ByVal lN As Long) As Variant
    #End If
        '--- RotR64 = RShift64(X, n) Or LShift64(X, 64 - n)
        Debug.Assert lN <> 0
        RotR64 = ((lX And (-1 Xor LNG_SIGN_BIT)) \ LNG_POW2(lN) Or -(lX < 0) * LNG_POW2(63 - lN)) Or _
            ((lX And (LNG_POW2(lN - 1) - 1)) * LNG_POW2(64 - lN) Or -((lX And LNG_POW2(lN - 1)) <> 0) * LNG_SIGN_BIT)
    End Function
    
    #If HasPtrSafe Then
    Private Function UAdd64(ByVal lX As LongLong, ByVal lY As LongLong) As LongLong
    #Else
    Private Function UAdd64(lX As Variant, lY As Variant) As Variant
    #End If
        If (lX Xor lY) >= 0 Then
            UAdd64 = ((lX Xor LNG_SIGN_BIT) + lY) Xor LNG_SIGN_BIT
        Else
            UAdd64 = lX + lY
        End If
    End Function
    
    #If HasPtrSafe Then
    Private Sub pvQuarter64(lA As LongLong, lB As LongLong, lC As LongLong, lD As LongLong, ByVal lX As LongLong, ByVal lY As LongLong)
    #Else
    Private Sub pvQuarter64(lA As Variant, lB As Variant, lC As Variant, lD As Variant, ByVal lX As Variant, ByVal lY As Variant)
    #End If
        lA = UAdd64(UAdd64(lA, lB), lX)
        lD = RotR64(lD Xor lA, 32)
        lC = UAdd64(lC, lD)
        lB = RotR64(lB Xor lC, 24)
        lA = UAdd64(UAdd64(lA, lB), lY)
        lD = RotR64(lD Xor lA, 16)
        lC = UAdd64(lC, lD)
        lB = RotR64(lB Xor lC, 63)
    End Sub
    #Else
    [ IntegerOverflowChecks (False) ]
    Private Sub pvQuarter64(lA As LongLong, lB As LongLong, lC As LongLong, lD As LongLong, ByVal lX As LongLong, ByVal lY As LongLong)
        lA = lA + lB + lX
        lD = (lD Xor lA) >> 32 Or (lD Xor lA) << 32
        lC = lC + lD
        lB = (lB Xor lC) >> 24 or (lB Xor lC) << 40
        lA = lA + lB + lY
        lD = (lD Xor lA) >> 16 or (lD Xor lA) << 48
        lC = lC + lD
        lB = (lB Xor lC) >> 63 or (lB Xor lC) << 1
    End Sub
    #End If
    
    #If Not HasPtrSafe Then
    Private Function CLngLng(vValue As Variant) As Variant
        Const VT_I8 As Long = &H14
        Call VariantChangeType(CLngLng, vValue, 0, VT_I8)
    End Function
    #End If
    
    Private Sub pvCompress(uCtx As CryptoBlake2bContext, Optional ByVal IsLast As Boolean)
    #If HasPtrSafe Then
        Static B(0 To 15)   As LongLong
        Dim V0              As LongLong
        Dim V1              As LongLong
        Dim V2              As LongLong
        Dim V3              As LongLong
        Dim V4              As LongLong
        Dim V5              As LongLong
        Dim V6              As LongLong
        Dim V7              As LongLong
        Dim V8              As LongLong
        Dim V9              As LongLong
        Dim V10             As LongLong
        Dim V11             As LongLong
        Dim V12             As LongLong
        Dim V13             As LongLong
        Dim V14             As LongLong
        Dim V15             As LongLong
        Dim S0              As LongLong
    #Else
        Static B(0 To 15)   As Variant
        Dim V0              As Variant
        Dim V1              As Variant
        Dim V2              As Variant
        Dim V3              As Variant
        Dim V4              As Variant
        Dim V5              As Variant
        Dim V6              As Variant
        Dim V7              As Variant
        Dim V8              As Variant
        Dim V9              As Variant
        Dim V10             As Variant
        Dim V11             As Variant
        Dim V12             As Variant
        Dim V13             As Variant
        Dim V14             As Variant
        Dim V15             As Variant
        Dim S0              As Variant
    #End If
        Dim cTemp           As Currency
        Dim lIdx            As Long
    
        With uCtx
            If .NPartial < LNG_BLOCKSZ Then
                Call FillMemory(.Partial(.NPartial), LNG_BLOCKSZ - .NPartial, 0)
            End If
            #If HasPtrSafe Then
                Call CopyMemory(B(0), .Partial(0), LNG_BLOCKSZ)
            #Else
                For lIdx = 0 To UBound(B)
                    B(lIdx) = LNG_ZERO
                    Call CopyMemory(ByVal VarPtr(B(lIdx)) + 8, .Partial(8 * lIdx), 8)
                Next
            #End If
            V0 = .H0: V1 = .H1
            V2 = .H2: V3 = .H3
            V4 = .H4: V5 = .H5
            V6 = .H6: V7 = .H7
            V8 = LNG_IV(0): V9 = LNG_IV(1)
            V10 = LNG_IV(2): V11 = LNG_IV(3)
            V12 = LNG_IV(4): V13 = LNG_IV(5)
            V14 = LNG_IV(6): V15 = LNG_IV(7)
            .NInput = .NInput + .NPartial
            .NPartial = 0
            cTemp = .NInput / 10000@
            #If HasPtrSafe Then
                Call CopyMemory(S0, cTemp, 8)
            #Else
                S0 = LNG_ZERO
                Call CopyMemory(ByVal VarPtr(S0) + 8, cTemp, 8)
            #End If
            V12 = V12 Xor S0
            If IsLast Then
                V14 = Not V14
            End If
            For lIdx = 0 To LNG_ROUNDS - 1
                pvQuarter64 V0, V4, V8, V12, B(LNG_SIGMA(0, lIdx)), B(LNG_SIGMA(1, lIdx))
                pvQuarter64 V1, V5, V9, V13, B(LNG_SIGMA(2, lIdx)), B(LNG_SIGMA(3, lIdx))
                pvQuarter64 V2, V6, V10, V14, B(LNG_SIGMA(4, lIdx)), B(LNG_SIGMA(5, lIdx))
                pvQuarter64 V3, V7, V11, V15, B(LNG_SIGMA(6, lIdx)), B(LNG_SIGMA(7, lIdx))
                pvQuarter64 V0, V5, V10, V15, B(LNG_SIGMA(8, lIdx)), B(LNG_SIGMA(9, lIdx))
                pvQuarter64 V1, V6, V11, V12, B(LNG_SIGMA(10, lIdx)), B(LNG_SIGMA(11, lIdx))
                pvQuarter64 V2, V7, V8, V13, B(LNG_SIGMA(12, lIdx)), B(LNG_SIGMA(13, lIdx))
                pvQuarter64 V3, V4, V9, V14, B(LNG_SIGMA(14, lIdx)), B(LNG_SIGMA(15, lIdx))
            Next
            .H0 = .H0 Xor V0 Xor V8
            .H1 = .H1 Xor V1 Xor V9
            .H2 = .H2 Xor V2 Xor V10
            .H3 = .H3 Xor V3 Xor V11
            .H4 = .H4 Xor V4 Xor V12
            .H5 = .H5 Xor V5 Xor V13
            .H6 = .H6 Xor V6 Xor V14
            .H7 = .H7 Xor V7 Xor V15
        End With
    End Sub
    
    Public Sub CryptoBlake2bInit(uCtx As CryptoBlake2bContext, ByVal lBitSize As Long, Optional Key As Variant)
        Dim vElem           As Variant
        Dim lIdx            As Long
        Dim baKey()         As Byte
        Dim lKeySize        As Long
        
        If LNG_IV(0) = 0 Then
            LNG_ZERO = CLngLng(0)
            For Each vElem In Split("6A09E667F3BCC908 BB67AE8584CAA73B 3C6EF372FE94F82B A54FF53A5F1D36F1 510E527FADE682D1 9B05688C2B3E6C1F 1F83D9ABFB41BD6B 5BE0CD19137E2179")
                LNG_IV(lIdx) = CLngLng(CStr("&H" & vElem))
                lIdx = lIdx + 1
            Next
            lIdx = 0
            For Each vElem In Split("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 " & _
                                    "14 10 4 8 9 15 13 6 1 12 0 2 11 7 5 3 " & _
                                    "11 8 12 0 5 2 15 13 10 14 3 6 7 1 9 4 " & _
                                    "7 9 3 1 13 12 11 14 2 6 5 10 4 0 15 8 " & _
                                    "9 0 5 7 2 4 10 15 14 1 11 12 6 8 3 13 " & _
                                    "2 12 6 10 0 11 8 3 4 13 7 5 15 14 1 9 " & _
                                    "12 5 1 15 14 13 4 10 0 7 6 3 9 2 8 11 " & _
                                    "13 11 7 14 12 1 3 9 5 0 15 4 8 6 2 10 " & _
                                    "6 15 14 9 11 3 0 8 12 2 13 7 1 4 10 5 " & _
                                    "10 2 8 4 7 6 1 5 15 11 9 14 3 12 13 0")
                LNG_SIGMA(lIdx And 15, lIdx \ 16) = vElem
                lIdx = lIdx + 1
            Next
            '--- copy rows 10 & 11 from rows 0 & 1
            Call CopyMemory(LNG_SIGMA(0, 10), LNG_SIGMA(0, 0), 2 * 64)
            #If Not HasOperators Then
                LNG_POW2(0) = CLngLng(1)
                For lIdx = 1 To 63
                    LNG_POW2(lIdx) = CVar(LNG_POW2(lIdx - 1)) * 2
                Next
                LNG_SIGN_BIT = LNG_POW2(63)
            #End If
        End If
        If lBitSize <= 0 Or lBitSize > 512 Or (lBitSize And 7) <> 0 Then
            Err.Raise vbObjectError, , "Invalid bit-size for BLAKE2b (" & lBitSize & ")"
        End If
        If Not IsMissing(Key) Then
            If IsArray(Key) Then
                baKey = Key
            Else
                baKey = ToUtf8Array(CStr(Key))
            End If
            lKeySize = UBound(baKey) + 1
        End If
        If lKeySize > 64 Then
            Err.Raise vbObjectError, , "Key for BLAKE2b-MAC must be up to 64 bytes (" & lKeySize & ")"
        End If
        With uCtx
            #If HasPtrSafe Then
                Call CopyMemory(.H0, LNG_IV(0), 8 * 8)
            #Else
                Call CopyMemory(.H0, LNG_IV(0), 8 * 16)
            #End If
            .OutSize = lBitSize \ 8
            .H0 = .H0 Xor &H1010000 Xor (lKeySize * &H100) Xor .OutSize
            .NPartial = 0
            .NInput = 0
            If lKeySize > 0 Then
                Call CopyMemory(.Partial(0), baKey(0), lKeySize)
                Call FillMemory(.Partial(lKeySize), LNG_BLOCKSZ - lKeySize, 0)
                .NPartial = LNG_BLOCKSZ
            End If
        End With
    End Sub
    
    Public Sub CryptoBlake2bUpdate(uCtx As CryptoBlake2bContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
        Dim lIdx            As Long
        
        With uCtx
            If Size < 0 Then
                Size = UBound(baInput) + 1 - Pos
            End If
            If .NPartial > 0 And .NPartial < LNG_BLOCKSZ And Size > 0 Then
                lIdx = LNG_BLOCKSZ - .NPartial
                If lIdx > Size Then
                    lIdx = Size
                End If
                Call CopyMemory(.Partial(.NPartial), baInput(Pos), lIdx)
                .NPartial = .NPartial + lIdx
                Pos = Pos + lIdx
                Size = Size - lIdx
            End If
            Do While Size > 0
                If .NPartial <> 0 Then
                    '--- do nothing
                ElseIf Size >= LNG_BLOCKSZ Then
                    Call CopyMemory(.Partial(0), baInput(Pos), LNG_BLOCKSZ)
                    .NPartial = LNG_BLOCKSZ
                    Pos = Pos + LNG_BLOCKSZ
                    Size = Size - LNG_BLOCKSZ
                Else
                    Call CopyMemory(.Partial(0), baInput(Pos), Size)
                    .NPartial = Size
                    Exit Do
                End If
                pvCompress uCtx
            Loop
        End With
    End Sub
    
    Public Sub CryptoBlake2bFinalize(uCtx As CryptoBlake2bContext, baOutput() As Byte)
        With uCtx
            pvCompress uCtx, IsLast:=True
            ReDim baOutput(0 To .OutSize - 1) As Byte
            #If HasPtrSafe Then
                Call CopyMemory(baOutput(0), .H0, .OutSize)
            #Else
                Call CopyMemory(.Partial(0), ByVal VarPtr(.H0) + 8, 8)
                Call CopyMemory(.Partial(8), ByVal VarPtr(.H1) + 8, 8)
                Call CopyMemory(.Partial(16), ByVal VarPtr(.H2) + 8, 8)
                Call CopyMemory(.Partial(24), ByVal VarPtr(.H3) + 8, 8)
                If .OutSize > 32 Then
                    Call CopyMemory(.Partial(32), ByVal VarPtr(.H4) + 8, 8)
                    Call CopyMemory(.Partial(40), ByVal VarPtr(.H5) + 8, 8)
                    Call CopyMemory(.Partial(48), ByVal VarPtr(.H6) + 8, 8)
                    Call CopyMemory(.Partial(56), ByVal VarPtr(.H7) + 8, 8)
                End If
                Call CopyMemory(baOutput(0), .Partial(0), .OutSize)
            #End If
        End With
        Call FillMemory(uCtx, LenB(uCtx), 0)
    End Sub
    
    Public Function CryptoBlake2bByteArray(ByVal lBitSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Key As Variant) As Byte()
        Dim uCtx            As CryptoBlake2bContext
        
        CryptoBlake2bInit uCtx, lBitSize, Key:=Key
        CryptoBlake2bUpdate uCtx, baInput, Pos, Size
        CryptoBlake2bFinalize uCtx, CryptoBlake2bByteArray
    End Function
    
    Private Function ToUtf8Array(sText As String) As Byte()
        Const CP_UTF8       As Long = 65001
        Dim baRetVal()      As Byte
        Dim lSize           As Long
        
        lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
        If lSize > 0 Then
            ReDim baRetVal(0 To lSize - 1) As Byte
            Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
        Else
            baRetVal = vbNullString
        End If
        ToUtf8Array = baRetVal
    End Function
    
    Private Function ToHex(baData() As Byte) As String
        Dim lIdx            As Long
        Dim sByte           As String
        
        ToHex = String$(UBound(baData) * 2 + 2, 48)
        For lIdx = 0 To UBound(baData)
            sByte = LCase$(Hex$(baData(lIdx)))
            If Len(sByte) = 1 Then
                Mid$(ToHex, lIdx * 2 + 2, 1) = sByte
            Else
                Mid$(ToHex, lIdx * 2 + 1, 2) = sByte
            End If
        Next
    End Function
    
    Public Function CryptoBlake2bText(ByVal lBitSize As Long, sText As String, Optional Key As Variant) As String
        CryptoBlake2bText = ToHex(CryptoBlake2bByteArray(lBitSize, ToUtf8Array(sText), Key:=Key))
    End Function
    cheers,
    </wqw>

  2. #2

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6/VBA] BLAKE2 and BLAKE3 hash functions and MAC

    (continued)

    Code:
    '--- mdBlake2s.bas
    Option Explicit
    DefObj A-Z
    
    #Const HasPtrSafe = (VBA7 <> 0)
    #Const HasOperators = (TWINBASIC <> 0)
    
    #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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #End If
    
    Private Const LNG_BLOCKSZ               As Long = 64
    Private Const LNG_ROUNDS                As Long = 10
    
    Public Type CryptoBlake2sContext
        H0                  As Long
        H1                  As Long
        H2                  As Long
        H3                  As Long
        H4                  As Long
        H5                  As Long
        H6                  As Long
        H7                  As Long
        Partial(0 To LNG_BLOCKSZ - 1) As Byte
        NPartial            As Long
        NInput              As Currency
        OutSize             As Long
    End Type
    
    Private LNG_IV(0 To 7)              As Long
    Private LNG_SIGMA(0 To 15, 0 To LNG_ROUNDS - 1)  As Long
    
    #If Not HasOperators Then
    Private LNG_POW2(0 To 31)           As Long
    
    Private Function RotR32(ByVal lX As Long, ByVal lN As Long) As Long
        '--- RotR32 = RShift32(X, n) Or LShift32(X, 32 - n)
        Debug.Assert lN <> 0
        RotR32 = ((lX And &H7FFFFFFF) \ LNG_POW2(lN) - (lX < 0) * LNG_POW2(31 - lN)) Or _
            ((lX And (LNG_POW2(lN - 1) - 1)) * LNG_POW2(32 - lN) Or -((lX And LNG_POW2(lN - 1)) <> 0) * &H80000000)
    End Function
    
    Private Function UAdd32(ByVal lX As Long, ByVal lY As Long) As Long
        If (lX Xor lY) >= 0 Then
            UAdd32 = ((lX Xor &H80000000) + lY) Xor &H80000000
        Else
            UAdd32 = lX + lY
        End If
    End Function
    
    Private Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
        lA = UAdd32(UAdd32(lA, lB), lX)
        lD = RotR32(lD Xor lA, 16)
        lC = UAdd32(lC, lD)
        lB = RotR32(lB Xor lC, 12)
        lA = UAdd32(UAdd32(lA, lB), lY)
        lD = RotR32(lD Xor lA, 8)
        lC = UAdd32(lC, lD)
        lB = RotR32(lB Xor lC, 7)
    End Sub
    #Else
    [ IntegerOverflowChecks (False) ]
    Private Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
        lA = lA + lB + lX
        lD = (lD Xor lA) >> 16 Or (lD Xor lA) << 16
        lC = lC + lD
        lB = (lB Xor lC) >> 12 or (lB Xor lC) << 20
        lA = lA + lB + lY
        lD = (lD Xor lA) >> 8 or (lD Xor lA) << 24
        lC = lC + lD
        lB = (lB Xor lC) >> 7 or (lB Xor lC) << 25
    End Sub
    #End If
    
    Private Sub pvCompress(uCtx As CryptoBlake2sContext, Optional ByVal IsLast As Boolean)
        Static B(0 To 15)   As Long
        Static S(0 To 1)    As Long
        Dim V0              As Long
        Dim V1              As Long
        Dim V2              As Long
        Dim V3              As Long
        Dim V4              As Long
        Dim V5              As Long
        Dim V6              As Long
        Dim V7              As Long
        Dim V8              As Long
        Dim V9              As Long
        Dim V10             As Long
        Dim V11             As Long
        Dim V12             As Long
        Dim V13             As Long
        Dim V14             As Long
        Dim V15             As Long
        Dim cTemp           As Currency
        Dim lIdx            As Long
    
        With uCtx
            If .NPartial < LNG_BLOCKSZ Then
                Call FillMemory(.Partial(.NPartial), LNG_BLOCKSZ - .NPartial, 0)
            End If
            Call CopyMemory(B(0), .Partial(0), LNG_BLOCKSZ)
            V0 = .H0: V1 = .H1
            V2 = .H2: V3 = .H3
            V4 = .H4: V5 = .H5
            V6 = .H6: V7 = .H7
            V8 = LNG_IV(0): V9 = LNG_IV(1)
            V10 = LNG_IV(2): V11 = LNG_IV(3)
            V12 = LNG_IV(4): V13 = LNG_IV(5)
            V14 = LNG_IV(6): V15 = LNG_IV(7)
            .NInput = .NInput + .NPartial
            .NPartial = 0
            cTemp = .NInput / 10000@
            Call CopyMemory(S(0), cTemp, 8)
            V12 = V12 Xor S(0)
            V13 = V13 Xor S(1)
            If IsLast Then
                V14 = Not V14
            End If
            For lIdx = 0 To LNG_ROUNDS - 1
                pvQuarter32 V0, V4, V8, V12, B(LNG_SIGMA(0, lIdx)), B(LNG_SIGMA(1, lIdx))
                pvQuarter32 V1, V5, V9, V13, B(LNG_SIGMA(2, lIdx)), B(LNG_SIGMA(3, lIdx))
                pvQuarter32 V2, V6, V10, V14, B(LNG_SIGMA(4, lIdx)), B(LNG_SIGMA(5, lIdx))
                pvQuarter32 V3, V7, V11, V15, B(LNG_SIGMA(6, lIdx)), B(LNG_SIGMA(7, lIdx))
                pvQuarter32 V0, V5, V10, V15, B(LNG_SIGMA(8, lIdx)), B(LNG_SIGMA(9, lIdx))
                pvQuarter32 V1, V6, V11, V12, B(LNG_SIGMA(10, lIdx)), B(LNG_SIGMA(11, lIdx))
                pvQuarter32 V2, V7, V8, V13, B(LNG_SIGMA(12, lIdx)), B(LNG_SIGMA(13, lIdx))
                pvQuarter32 V3, V4, V9, V14, B(LNG_SIGMA(14, lIdx)), B(LNG_SIGMA(15, lIdx))
            Next
            .H0 = .H0 Xor V0 Xor V8
            .H1 = .H1 Xor V1 Xor V9
            .H2 = .H2 Xor V2 Xor V10
            .H3 = .H3 Xor V3 Xor V11
            .H4 = .H4 Xor V4 Xor V12
            .H5 = .H5 Xor V5 Xor V13
            .H6 = .H6 Xor V6 Xor V14
            .H7 = .H7 Xor V7 Xor V15
        End With
    End Sub
    
    Public Sub CryptoBlake2sInit(uCtx As CryptoBlake2sContext, ByVal lBitSize As Long, Optional Key As Variant)
        Dim vElem           As Variant
        Dim lIdx            As Long
        Dim baKey()         As Byte
        Dim lKeySize        As Long
        
        If LNG_IV(0) = 0 Then
            For Each vElem In Split("6A09E667 BB67AE85 3C6EF372 A54FF53A 510E527F 9B05688C 1F83D9AB 5BE0CD19")
                LNG_IV(lIdx) = "&H" & vElem
                lIdx = lIdx + 1
            Next
            lIdx = 0
            For Each vElem In Split("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 " & _
                                    "14 10 4 8 9 15 13 6 1 12 0 2 11 7 5 3 " & _
                                    "11 8 12 0 5 2 15 13 10 14 3 6 7 1 9 4 " & _
                                    "7 9 3 1 13 12 11 14 2 6 5 10 4 0 15 8 " & _
                                    "9 0 5 7 2 4 10 15 14 1 11 12 6 8 3 13 " & _
                                    "2 12 6 10 0 11 8 3 4 13 7 5 15 14 1 9 " & _
                                    "12 5 1 15 14 13 4 10 0 7 6 3 9 2 8 11 " & _
                                    "13 11 7 14 12 1 3 9 5 0 15 4 8 6 2 10 " & _
                                    "6 15 14 9 11 3 0 8 12 2 13 7 1 4 10 5 " & _
                                    "10 2 8 4 7 6 1 5 15 11 9 14 3 12 13 0")
                LNG_SIGMA(lIdx And 15, lIdx \ 16) = vElem
                lIdx = lIdx + 1
            Next
            #If Not HasOperators Then
                LNG_POW2(0) = 1
                For lIdx = 1 To 30
                    LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
                Next
                LNG_POW2(31) = &H80000000
            #End If
        End If
        If lBitSize <= 0 Or lBitSize > 256 Or (lBitSize And 7) <> 0 Then
            Err.Raise vbObjectError, , "Invalid bit-size for BLAKE2s (" & lBitSize & ")"
        End If
        If Not IsMissing(Key) Then
            If IsArray(Key) Then
                baKey = Key
            Else
                baKey = ToUtf8Array(CStr(Key))
            End If
            lKeySize = UBound(baKey) + 1
        End If
        If lKeySize > 32 Then
            Err.Raise vbObjectError, , "Key for BLAKE2s-MAC must be up to 32 bytes (" & lKeySize & ")"
        End If
        With uCtx
            Call CopyMemory(.H0, LNG_IV(0), 8 * 4)
            .OutSize = lBitSize \ 8
            .H0 = .H0 Xor &H1010000 Xor (lKeySize * &H100) Xor .OutSize
            .NPartial = 0
            .NInput = 0
            If lKeySize > 0 Then
                Call CopyMemory(.Partial(0), baKey(0), lKeySize)
                Call FillMemory(.Partial(lKeySize), LNG_BLOCKSZ - lKeySize, 0)
                .NPartial = LNG_BLOCKSZ
            End If
        End With
    End Sub
    
    Public Sub CryptoBlake2sUpdate(uCtx As CryptoBlake2sContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
        Dim lIdx            As Long
        
        With uCtx
            If Size < 0 Then
                Size = UBound(baInput) + 1 - Pos
            End If
            If .NPartial > 0 And .NPartial < LNG_BLOCKSZ And Size > 0 Then
                lIdx = LNG_BLOCKSZ - .NPartial
                If lIdx > Size Then
                    lIdx = Size
                End If
                Call CopyMemory(.Partial(.NPartial), baInput(Pos), lIdx)
                .NPartial = .NPartial + lIdx
                Pos = Pos + lIdx
                Size = Size - lIdx
            End If
            Do While Size > 0
                If .NPartial <> 0 Then
                    '--- do nothng
                ElseIf Size >= LNG_BLOCKSZ Then
                    Call CopyMemory(.Partial(0), baInput(Pos), LNG_BLOCKSZ)
                    .NPartial = LNG_BLOCKSZ
                    Pos = Pos + LNG_BLOCKSZ
                    Size = Size - LNG_BLOCKSZ
                Else
                    Call CopyMemory(.Partial(0), baInput(Pos), Size)
                    .NPartial = Size
                    Exit Do
                End If
                pvCompress uCtx
            Loop
        End With
    End Sub
    
    Public Sub CryptoBlake2sFinalize(uCtx As CryptoBlake2sContext, baOutput() As Byte)
        With uCtx
            pvCompress uCtx, IsLast:=True
            ReDim baOutput(0 To .OutSize - 1) As Byte
            Call CopyMemory(baOutput(0), .H0, .OutSize)
        End With
        Call FillMemory(uCtx, LenB(uCtx), 0)
    End Sub
    
    Public Function CryptoBlake2sByteArray(ByVal lBitSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Key As Variant) As Byte()
        Dim uCtx            As CryptoBlake2sContext
        
        CryptoBlake2sInit uCtx, lBitSize, Key:=Key
        CryptoBlake2sUpdate uCtx, baInput, Pos, Size
        CryptoBlake2sFinalize uCtx, CryptoBlake2sByteArray
    End Function
    
    Private Function ToUtf8Array(sText As String) As Byte()
        Const CP_UTF8       As Long = 65001
        Dim baRetVal()      As Byte
        Dim lSize           As Long
        
        lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
        If lSize > 0 Then
            ReDim baRetVal(0 To lSize - 1) As Byte
            Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
        Else
            baRetVal = vbNullString
        End If
        ToUtf8Array = baRetVal
    End Function
    
    Private Function ToHex(baData() As Byte) As String
        Dim lIdx            As Long
        Dim sByte           As String
        
        ToHex = String$(UBound(baData) * 2 + 2, 48)
        For lIdx = 0 To UBound(baData)
            sByte = LCase$(Hex$(baData(lIdx)))
            If Len(sByte) = 1 Then
                Mid$(ToHex, lIdx * 2 + 2, 1) = sByte
            Else
                Mid$(ToHex, lIdx * 2 + 1, 2) = sByte
            End If
        Next
    End Function
    
    Public Function CryptoBlake2sText(ByVal lBitSize As Long, sText As String, Optional Key As Variant) As String
        CryptoBlake2sText = ToHex(CryptoBlake2sByteArray(lBitSize, ToUtf8Array(sText), Key:=Key))
    End Function
    cheers,
    </wqw>

  3. #3

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6/VBA] BLAKE2 and BLAKE3 hash functions and MAC

    (continued)

    This mdBlake3.bas module implements BLAKE3 multi-purpose hasher which can be used as an ordinary hash, MAC and KDF.

    For keyed hash (MAC) provide Key parameter to CryptoBlake3Init, CryptoBlake3ByteArray or CryptoBlake3Text functions and for key derivation (KDF) w/ these same functions provide Context parameter instead.

    Also note that OutSize parameter allows generating output of arbitrary size (akin to SHA-3) in all povided modes.

    Code:
    '--- mdBlake3.bas
    Option Explicit
    DefObj A-Z
    
    #Const HasPtrSafe = (VBA7 <> 0)
    #Const HasOperators = (TWINBASIC <> 0)
    
    #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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) 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 Long)
    Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #End If
    
    Private Const LNG_OUT_LEN               As Long = 32
    Private Const LNG_KEY_LEN               As Long = 32
    Private Const LNG_BLOCK_LEN             As Long = 64
    Private Const LNG_CHUNK_LEN             As Long = 1024
    
    Private Type ArrayLong8
        Item(0 To 7) As Long
    End Type
    
    Private Type ArrayLong16
        Item(0 To 15) As Long
    End Type
    
    Private Enum Blake3Flags
        LNG_CHUNK_START = 2 ^ 0
        LNG_CHUNK_END = 2 ^ 1
        LNG_PARENT = 2 ^ 2
        LNG_ROOT = 2 ^ 3
        LNG_KEYED_HASH = 2 ^ 4
        LNG_DERIVE_KEY_CONTEXT = 2 ^ 5
        LNG_DERIVE_KEY_MATERIAL = 2 ^ 6
    End Enum
    
    Private Type Blake3ChunkState
        ChainingValue           As ArrayLong8
        ChunkCounter            As Long
        Block(0 To LNG_BLOCK_LEN - 1) As Byte
        BlockLen                As Byte
        BlocksCompressed        As Byte
        Flags                   As Blake3Flags
    End Type
    
    Private Type Blake3Output
        InputChainingValue      As ArrayLong8
        BlockWords              As ArrayLong16
        Counter                 As Currency
        BlockLen                As Byte
        Flags                   As Blake3Flags
    End Type
    
    Public Type CryptoBlake3Context
        ChunkState              As Blake3ChunkState
        KeyWords                As ArrayLong8
        CvStack(0 To 53)        As ArrayLong8
        CvStackLen              As Byte
        Flags                   As Blake3Flags
    End Type
    
    Private LNG_IV                      As ArrayLong8
    
    #If Not HasOperators Then
    Private LNG_POW2(0 To 31)           As Long
    
    Private Function RotR32(ByVal lX As Long, ByVal lN As Long) As Long
        '--- RotR32 = RShift32(X, n) Or LShift32(X, 32 - n)
        Debug.Assert lN <> 0
        RotR32 = ((lX And &H7FFFFFFF) \ LNG_POW2(lN) - (lX < 0) * LNG_POW2(31 - lN)) Or _
            ((lX And (LNG_POW2(lN - 1) - 1)) * LNG_POW2(32 - lN) Or -((lX And LNG_POW2(lN - 1)) <> 0) * &H80000000)
    End Function
    
    Private Function UAdd32(ByVal lX As Long, ByVal lY As Long) As Long
        If (lX Xor lY) >= 0 Then
            UAdd32 = ((lX Xor &H80000000) + lY) Xor &H80000000
        Else
            UAdd32 = lX + lY
        End If
    End Function
    
    Private Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
        lA = UAdd32(UAdd32(lA, lB), lX)
        lD = RotR32(lD Xor lA, 16)
        lC = UAdd32(lC, lD)
        lB = RotR32(lB Xor lC, 12)
        lA = UAdd32(UAdd32(lA, lB), lY)
        lD = RotR32(lD Xor lA, 8)
        lC = UAdd32(lC, lD)
        lB = RotR32(lB Xor lC, 7)
    End Sub
    #Else
    [ IntegerOverflowChecks (False) ]
    Private Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
        lA = lA + lB + lX
        lD = (lD Xor lA) >> 16 Or (lD Xor lA) << 16
        lC = lC + lD
        lB = (lB Xor lC) >> 12 Or (lB Xor lC) << 20
        lA = lA + lB + lY
        lD = (lD Xor lA) >> 8 Or (lD Xor lA) << 24
        lC = lC + lD
        lB = (lB Xor lC) >> 7 Or (lB Xor lC) << 25
    End Sub
    #End If
    
    Private Sub pvCompress(uState As ArrayLong8, uBlock As ArrayLong16, ByVal cCounter As Currency, ByVal lBlockLen As Long, ByVal eFlags As Blake3Flags, uRetVal As ArrayLong16, Optional ByVal HalfOnly As Boolean)
        Static S(0 To 1)    As Long
        Dim V0              As Long
        Dim V1              As Long
        Dim V2              As Long
        Dim V3              As Long
        Dim V4              As Long
        Dim V5              As Long
        Dim V6              As Long
        Dim V7              As Long
        Dim V8              As Long
        Dim V9              As Long
        Dim V10             As Long
        Dim V11             As Long
        Dim V12             As Long
        Dim V13             As Long
        Dim V14             As Long
        Dim V15             As Long
        
        With uState
            V0 = .Item(0):  V1 = .Item(1)
            V2 = .Item(2):  V3 = .Item(3)
            V4 = .Item(4):  V5 = .Item(5)
            V6 = .Item(6):  V7 = .Item(7)
        End With
        With LNG_IV
            V8 = .Item(0):  V9 = .Item(1)
            V10 = .Item(2): V11 = .Item(3)
        End With
        cCounter = cCounter / 10000@
        Call CopyMemory(S(0), cCounter, 8)
        V12 = S(0)
        V13 = S(1)
        V14 = lBlockLen
        V15 = eFlags
        With uBlock
            '--- Round 1
            pvQuarter32 V0, V4, V8, V12, .Item(0), .Item(1)
            pvQuarter32 V1, V5, V9, V13, .Item(2), .Item(3)
            pvQuarter32 V2, V6, V10, V14, .Item(4), .Item(5)
            pvQuarter32 V3, V7, V11, V15, .Item(6), .Item(7)
            pvQuarter32 V0, V5, V10, V15, .Item(8), .Item(9)
            pvQuarter32 V1, V6, V11, V12, .Item(10), .Item(11)
            pvQuarter32 V2, V7, V8, V13, .Item(12), .Item(13)
            pvQuarter32 V3, V4, V9, V14, .Item(14), .Item(15)
            '--- Round 2
            pvQuarter32 V0, V4, V8, V12, .Item(2), .Item(6)
            pvQuarter32 V1, V5, V9, V13, .Item(3), .Item(10)
            pvQuarter32 V2, V6, V10, V14, .Item(7), .Item(0)
            pvQuarter32 V3, V7, V11, V15, .Item(4), .Item(13)
            pvQuarter32 V0, V5, V10, V15, .Item(1), .Item(11)
            pvQuarter32 V1, V6, V11, V12, .Item(12), .Item(5)
            pvQuarter32 V2, V7, V8, V13, .Item(9), .Item(14)
            pvQuarter32 V3, V4, V9, V14, .Item(15), .Item(8)
            '--- Round 3
            pvQuarter32 V0, V4, V8, V12, .Item(3), .Item(4)
            pvQuarter32 V1, V5, V9, V13, .Item(10), .Item(12)
            pvQuarter32 V2, V6, V10, V14, .Item(13), .Item(2)
            pvQuarter32 V3, V7, V11, V15, .Item(7), .Item(14)
            pvQuarter32 V0, V5, V10, V15, .Item(6), .Item(5)
            pvQuarter32 V1, V6, V11, V12, .Item(9), .Item(0)
            pvQuarter32 V2, V7, V8, V13, .Item(11), .Item(15)
            pvQuarter32 V3, V4, V9, V14, .Item(8), .Item(1)
            '--- Round 4
            pvQuarter32 V0, V4, V8, V12, .Item(10), .Item(7)
            pvQuarter32 V1, V5, V9, V13, .Item(12), .Item(9)
            pvQuarter32 V2, V6, V10, V14, .Item(14), .Item(3)
            pvQuarter32 V3, V7, V11, V15, .Item(13), .Item(15)
            pvQuarter32 V0, V5, V10, V15, .Item(4), .Item(0)
            pvQuarter32 V1, V6, V11, V12, .Item(11), .Item(2)
            pvQuarter32 V2, V7, V8, V13, .Item(5), .Item(8)
            pvQuarter32 V3, V4, V9, V14, .Item(1), .Item(6)
            '--- Round 5
            pvQuarter32 V0, V4, V8, V12, .Item(12), .Item(13)
            pvQuarter32 V1, V5, V9, V13, .Item(9), .Item(11)
            pvQuarter32 V2, V6, V10, V14, .Item(15), .Item(10)
            pvQuarter32 V3, V7, V11, V15, .Item(14), .Item(8)
            pvQuarter32 V0, V5, V10, V15, .Item(7), .Item(2)
            pvQuarter32 V1, V6, V11, V12, .Item(5), .Item(3)
            pvQuarter32 V2, V7, V8, V13, .Item(0), .Item(1)
            pvQuarter32 V3, V4, V9, V14, .Item(6), .Item(4)
            '--- Round 6
            pvQuarter32 V0, V4, V8, V12, .Item(9), .Item(14)
            pvQuarter32 V1, V5, V9, V13, .Item(11), .Item(5)
            pvQuarter32 V2, V6, V10, V14, .Item(8), .Item(12)
            pvQuarter32 V3, V7, V11, V15, .Item(15), .Item(1)
            pvQuarter32 V0, V5, V10, V15, .Item(13), .Item(3)
            pvQuarter32 V1, V6, V11, V12, .Item(0), .Item(10)
            pvQuarter32 V2, V7, V8, V13, .Item(2), .Item(6)
            pvQuarter32 V3, V4, V9, V14, .Item(4), .Item(7)
            '--- Round 7
            pvQuarter32 V0, V4, V8, V12, .Item(11), .Item(15)
            pvQuarter32 V1, V5, V9, V13, .Item(5), .Item(0)
            pvQuarter32 V2, V6, V10, V14, .Item(1), .Item(9)
            pvQuarter32 V3, V7, V11, V15, .Item(8), .Item(6)
            pvQuarter32 V0, V5, V10, V15, .Item(14), .Item(10)
            pvQuarter32 V1, V6, V11, V12, .Item(2), .Item(12)
            pvQuarter32 V2, V7, V8, V13, .Item(3), .Item(4)
            pvQuarter32 V3, V4, V9, V14, .Item(7), .Item(13)
        End With
        With uRetVal
            .Item(0) = V0 Xor V8: .Item(1) = V1 Xor V9
            .Item(2) = V2 Xor V10: .Item(3) = V3 Xor V11
            .Item(4) = V4 Xor V12: .Item(5) = V5 Xor V13
            .Item(6) = V6 Xor V14: .Item(7) = V7 Xor V15
            If Not HalfOnly Then
                .Item(8) = V8 Xor uState.Item(0)
                .Item(9) = V9 Xor uState.Item(1)
                .Item(10) = V10 Xor uState.Item(2)
                .Item(11) = V11 Xor uState.Item(3)
                .Item(12) = V12 Xor uState.Item(4)
                .Item(13) = V13 Xor uState.Item(5)
                .Item(14) = V14 Xor uState.Item(6)
                .Item(15) = V15 Xor uState.Item(7)
            End If
        End With
    End Sub
    
    Private Sub pvUpdateChunk(uChunk As Blake3ChunkState, baInput() As Byte, ByVal lPos As Long, ByVal lSize As Long)
        Dim eStartFlag      As Blake3Flags
        Dim lRemaining      As Long
        
        With uChunk
            Do While lSize > 0
                If .BlockLen = LNG_BLOCK_LEN Then
                    eStartFlag = -(.BlocksCompressed = 0) * LNG_CHUNK_START
                    #If HasOperators Then
                        pvCompress .ChainingValue, VarPtr(.Block(0)), .ChunkCounter, .BlockLen, .Flags Or eStartFlag, VarPtr(.ChainingValue), HalfOnly:=True
                    #Else
                        Static uTemp As ArrayLong16
                        Call CopyMemory(uTemp, .Block(0), LNG_BLOCK_LEN)
                        pvCompress .ChainingValue, uTemp, .ChunkCounter, .BlockLen, .Flags Or eStartFlag, uTemp
                        Call CopyMemory(.ChainingValue, uTemp, LNG_BLOCK_LEN \ 2)
                    #End If
                    .BlocksCompressed = .BlocksCompressed + 1
                    .BlockLen = 0
                End If
                lRemaining = LNG_BLOCK_LEN - .BlockLen
                If lRemaining > lSize Then
                    lRemaining = lSize
                End If
                Call CopyMemory(.Block(.BlockLen), baInput(lPos), lRemaining)
                .BlockLen = .BlockLen + lRemaining
                lPos = lPos + lRemaining
                lSize = lSize - lRemaining
            Loop
        End With
    End Sub
    
    Private Sub pvGetChunkOutput(uChunk As Blake3ChunkState, uOutput As Blake3Output)
        Dim eStartFlag      As Blake3Flags
        
        With uChunk
            uOutput.InputChainingValue = .ChainingValue
            If .BlockLen > 0 Then
                Call CopyMemory(uOutput.BlockWords, .Block(0), .BlockLen)
            End If
            uOutput.Counter = .ChunkCounter
            uOutput.BlockLen = .BlockLen
            eStartFlag = -(.BlocksCompressed = 0) * LNG_CHUNK_START
            uOutput.Flags = .Flags Or eStartFlag Or LNG_CHUNK_END
        End With
    End Sub
    
    Private Function pvGetChunkLen(uChunk As Blake3ChunkState) As Long
        With uChunk
            pvGetChunkLen = .BlocksCompressed * LNG_BLOCK_LEN + .BlockLen
        End With
    End Function
    
    Private Sub pvMakeParentOutput(uLeft As ArrayLong8, uRight As ArrayLong8, uKeyWords As ArrayLong8, ByVal eFlags As Blake3Flags, uOutput As Blake3Output)
        With uOutput
            .InputChainingValue = uKeyWords
            Call CopyMemory(.BlockWords.Item(0), uLeft, LNG_BLOCK_LEN \ 2)
            Call CopyMemory(.BlockWords.Item(8), uRight, LNG_BLOCK_LEN \ 2)
            .Counter = 0
            .BlockLen = LNG_BLOCK_LEN
            .Flags = eFlags Or LNG_PARENT
        End With
    End Sub
    
    Private Sub pvGetChainingValue(uOutput As Blake3Output, uRetVal As ArrayLong8)
        With uOutput
            #If HasOperators Then
                pvCompress .InputChainingValue, .BlockWords, .Counter, .BlockLen, .Flags, VarPtr(uRetVal), HalfOnly:=True
            #Else
                Static uTemp As ArrayLong16
                pvCompress .InputChainingValue, .BlockWords, .Counter, .BlockLen, .Flags, uTemp
                Call CopyMemory(uRetVal, uTemp, LNG_BLOCK_LEN \ 2)
            #End If
        End With
    End Sub
    
    Private Sub pvGetRootBytes(uOutput As Blake3Output, baOutput() As Byte, ByVal lOutSize As Long)
        Dim uTemp           As ArrayLong16
        Dim cCounter        As Currency
        Dim lPos            As Long
        Dim lRemaining      As Long
        
        With uOutput
            ReDim baOutput(0 To lOutSize - 1) As Byte
            Do While lPos < lOutSize
                pvCompress .InputChainingValue, .BlockWords, cCounter, .BlockLen, .Flags Or LNG_ROOT, uTemp
                lRemaining = lOutSize - lPos
                If lRemaining > LNG_BLOCK_LEN Then
                    lRemaining = LNG_BLOCK_LEN
                End If
                Call CopyMemory(baOutput(lPos), uTemp, lRemaining)
                lPos = lPos + lRemaining
                cCounter = cCounter + 1
            Loop
        End With
    End Sub
    
    Private Sub pvInitHasher(uCtx As CryptoBlake3Context, ByVal lKeyPtr As LongPtr, Optional ByVal eFlags As Blake3Flags)
        Call FillMemory(uCtx, LenB(uCtx), 0)
        With uCtx
            Call CopyMemory(.KeyWords, ByVal lKeyPtr, LNG_KEY_LEN)
            .Flags = eFlags
            .ChunkState.ChainingValue = .KeyWords
            .ChunkState.Flags = .Flags
        End With
    End Sub
    
    Public Sub CryptoBlake3Init(uCtx As CryptoBlake3Context, Optional Key As Variant, Optional Context As Variant)
        Dim vElem           As Variant
        Dim lIdx            As Long
        Dim baKey()         As Byte
        Dim baContext()     As Byte
        
        If LNG_IV.Item(0) = 0 Then
            For Each vElem In Split("6A09E667 BB67AE85 3C6EF372 A54FF53A 510E527F 9B05688C 1F83D9AB 5BE0CD19")
                LNG_IV.Item(lIdx) = "&H" & vElem
                lIdx = lIdx + 1
            Next
            #If Not HasOperators Then
                LNG_POW2(0) = 1
                For lIdx = 1 To 30
                    LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
                Next
                LNG_POW2(31) = &H80000000
            #End If
        End If
        With uCtx
            If Not IsMissing(Key) Then
                If IsArray(Key) Then
                    baKey = Key
                Else
                    baKey = ToUtf8Array(CStr(Key))
                End If
                ReDim Preserve baKey(0 To LNG_KEY_LEN - 1) As Byte
                pvInitHasher uCtx, VarPtr(baKey(0)), LNG_KEYED_HASH
            ElseIf Not IsMissing(Context) Then
                If IsArray(Context) Then
                    baContext = Context
                Else
                    baContext = ToUtf8Array(CStr(Context))
                End If
                pvInitHasher uCtx, VarPtr(LNG_IV), LNG_DERIVE_KEY_CONTEXT
                CryptoBlake3Update uCtx, baContext
                CryptoBlake3Finalize uCtx, baKey
                pvInitHasher uCtx, VarPtr(baKey(0)), LNG_DERIVE_KEY_MATERIAL
            Else
                pvInitHasher uCtx, VarPtr(LNG_IV)
            End If
        End With
    End Sub
    
    Public Sub CryptoBlake3Update(uCtx As CryptoBlake3Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
        Dim uOutput         As Blake3Output
        Dim uRight          As ArrayLong8
        Dim lTotalChunks    As Long
        Dim lRemaining      As Long
        
        With uCtx
            If Size < 0 Then
                Size = UBound(baInput) + 1 - Pos
            End If
            Do While Size > 0
                If pvGetChunkLen(.ChunkState) = LNG_CHUNK_LEN Then
                    pvGetChunkOutput .ChunkState, uOutput
                    pvGetChainingValue uOutput, uRight
                    lTotalChunks = .ChunkState.ChunkCounter + 1
                    Do While (lTotalChunks And 1) = 0
                        .CvStackLen = .CvStackLen - 1
                        pvMakeParentOutput .CvStack(.CvStackLen), uRight, .KeyWords, .Flags, uOutput
                        pvGetChainingValue uOutput, uRight
                        lTotalChunks = lTotalChunks \ 2
                    Loop
                    .CvStack(.CvStackLen) = uRight
                    .CvStackLen = .CvStackLen + 1
                    .ChunkState.ChainingValue = .KeyWords
                    .ChunkState.ChunkCounter = .ChunkState.ChunkCounter + 1
                    .ChunkState.BlockLen = 0
                    .ChunkState.BlocksCompressed = 0
                    .ChunkState.Flags = .Flags
                End If
                lRemaining = LNG_CHUNK_LEN - pvGetChunkLen(.ChunkState)
                If lRemaining > Size Then
                    lRemaining = Size
                End If
                pvUpdateChunk .ChunkState, baInput, Pos, lRemaining
                Pos = Pos + lRemaining
                Size = Size - lRemaining
            Loop
        End With
    End Sub
    
    Public Sub CryptoBlake3Finalize(uCtx As CryptoBlake3Context, baOutput() As Byte, Optional ByVal OutSize As Long)
        Dim uOutput         As Blake3Output
        Dim uRight          As ArrayLong8
        
        With uCtx
            pvGetChunkOutput .ChunkState, uOutput
            Do While .CvStackLen > 0
                pvGetChainingValue uOutput, uRight
                .CvStackLen = .CvStackLen - 1
                pvMakeParentOutput .CvStack(.CvStackLen), uRight, .KeyWords, .Flags, uOutput
            Loop
            If OutSize <= 0 Then
                OutSize = LNG_OUT_LEN
            End If
            pvGetRootBytes uOutput, baOutput, OutSize
        End With
    End Sub
    
    Public Function CryptoBlake3ByteArray(baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Key As Variant, Optional Context As Variant, Optional OutSize As Long) As Byte()
        Dim uCtx            As CryptoBlake3Context
        
        CryptoBlake3Init uCtx, Key:=Key, Context:=Context
        CryptoBlake3Update uCtx, baInput, Pos, Size
        CryptoBlake3Finalize uCtx, CryptoBlake3ByteArray, OutSize:=OutSize
    End Function
    
    Private Function ToUtf8Array(sText As String) As Byte()
        Const CP_UTF8       As Long = 65001
        Dim baRetVal()      As Byte
        Dim lSize           As Long
        
        lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
        If lSize > 0 Then
            ReDim baRetVal(0 To lSize - 1) As Byte
            Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
        Else
            baRetVal = vbNullString
        End If
        ToUtf8Array = baRetVal
    End Function
    
    Private Function ToHex(baData() As Byte) As String
        Dim lIdx            As Long
        Dim sByte           As String
        
        ToHex = String$(UBound(baData) * 2 + 2, 48)
        For lIdx = 0 To UBound(baData)
            sByte = LCase$(Hex$(baData(lIdx)))
            If Len(sByte) = 1 Then
                Mid$(ToHex, lIdx * 2 + 2, 1) = sByte
            Else
                Mid$(ToHex, lIdx * 2 + 1, 2) = sByte
            End If
        Next
    End Function
    
    Public Function CryptoBlake3Text(sText As String, Optional Key As Variant, Optional Context As Variant, Optional OutSize As Long) As String
        CryptoBlake3Text = ToHex(CryptoBlake3ByteArray(ToUtf8Array(sText), Key:=Key, Context:=Context, OutSize:=OutSize))
    End Function
    cheers,
    </wqw>

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width