|
-
Dec 17th, 2022, 12:36 PM
#1
[VB6/VBA] SipHash cryptographically secure keyed hash function
These mdSiphash.bas and mdHalfSiphash.bas modules implement SipHash and HalfSipHash high-speed secure pseudorandom function for short messages in pure VB6.
Output size and number of iterations for update and finalize can be set with calls to CryptoSiphashInit and CryptoHalfSiphashInit respectively while procedures containing SipHash24 in the name are using 2 rounds on updates and 4 rounds on finalize with 8-byte output, while SipHash13 named procedures use 1 round on updates and 3 rounds on finalize with 8-byte output again (can be 16 bytes). For HalfSipHash the output is 4 bytes long by default (can be 8 bytes).
The speed of compiled VB6 code is not very great when using Variants for LongLongs for SipHash but HalfSipHash is specifically designed for 32-bit operations and this results in better performance in VB6:
SipHash-2-4 - 3.2MB/s, SipHash-1-3 - 6.4MB/s, HalfSipHash-2-4 - 110MB/s, HalfSipHash-1-3 - 240MB/s
In TwinBASIC the same SipHash imlementation outperforms HalfSipHash in both x86 and x64 configurations, here are x64 compiled results:
SipHash-2-4 - 156MB/s, SipHash-1-3 - 215MB/s, HalfSipHash-2-4 - 102MB/s, HalfSipHash-1-3 - 147MB/s
Code:
'--- mdSiphash.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 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 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 = 8
Private Const LNG_KEYSZ As Long = 16
Public Type CryptoSiphashContext
#If HasPtrSafe Then
V0 As LongLong
V1 As LongLong
V2 As LongLong
V3 As LongLong
#Else
V0 As Variant
V1 As Variant
V2 As Variant
V3 As Variant
#End If
Partial(0 To LNG_BLOCKSZ - 1) As Byte
NPartial As Long
NInput As Currency
UpdateIters As Long
FinalizeIters As Long
OutSize As Long
End Type
#If HasPtrSafe Then
#If Not HasOperators Then
Private LNG_POW2(0 To 63) As LongLong
Private LNG_SIGN_BIT As LongLong ' 2 ^ 63
#End If
Private LNG_ZERO As LongLong
Private LNG_IV(0 To 3) As LongLong
#Else
Private LNG_POW2(0 To 63) As Variant
Private LNG_SIGN_BIT As Variant
Private LNG_ZERO As Variant
Private LNG_IV(0 To 3) As Variant
#End If
#If Not HasOperators Then
#If HasPtrSafe Then
Private Function RotL64(ByVal lX As LongLong, ByVal lN As Long) As LongLong
#Else
Private Function RotL64(lX As Variant, ByVal lN As Long) As Variant
#End If
'--- 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_SIGN_BIT) Or _
((lX And (LNG_SIGN_BIT Xor -1)) \ LNG_POW2(64 - lN) Or -(lX < 0) * LNG_POW2(lN - 1))
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
Private Sub pvCompress(uCtx As CryptoSiphashContext, ByVal lRounds As Long)
With uCtx
Do While lRounds > 0
.V0 = UAdd64(.V0, .V1)
.V2 = UAdd64(.V2, .V3)
.V1 = RotL64(.V1, 13)
.V3 = RotL64(.V3, 16)
.V1 = .V1 Xor .V0
.V3 = .V3 Xor .V2
.V0 = RotL64(.V0, 32)
.V2 = UAdd64(.V2, .V1)
.V0 = UAdd64(.V0, .V3)
.V1 = RotL64(.V1, 17)
.V3 = RotL64(.V3, 21)
.V1 = .V1 Xor .V2
.V3 = .V3 Xor .V0
.V2 = RotL64(.V2, 32)
lRounds = lRounds - 1
Loop
End With
End Sub
#Else
[ IntegerOverflowChecks (False) ]
Private Sub pvCompress(uCtx As CryptoSiphashContext, ByVal lRounds As Long)
With uCtx
Do While lRounds > 0
.V0 += .V1
.V2 += .V3
.V1 = (.V1 << 13) Or (.V1 >> 51)
.V3 = (.V3 << 16) Or (.V3 >> 48)
.V1 = .V1 Xor .V0
.V3 = .V3 Xor .V2
.V0 = (.V0 << 32) Or (.V0 >> 32)
.V2 += .V1
.V0 += .V3
.V1 = (.V1 << 17) Or (.V1 >> 47)
.V3 = (.V3 << 21) Or (.V3 >> 43)
.V1 = .V1 Xor .V2
.V3 = .V3 Xor .V0
.V2 = (.V2 << 32) Or (.V2 >> 32)
lRounds -= 1
Loop
End With
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
Public Sub CryptoSiphashInit(uCtx As CryptoSiphashContext, baKey() As Byte, _
Optional ByVal UpdateIters As Long = 2, _
Optional ByVal FinalizeIters As Long = 4, _
Optional ByVal OutSize As Long = 8)
#If HasPtrSafe Then
Static K(0 To 1) As LongLong
#Else
Static K(0 To 1) As Variant
#End If
Dim lIdx As Long
If LNG_IV(0) = 0 Then
LNG_IV(0) = CLngLng("&H736f6d6570736575")
LNG_IV(1) = CLngLng("&H646f72616e646f6d")
LNG_IV(2) = CLngLng("&H6c7967656e657261")
LNG_IV(3) = CLngLng("&H7465646279746573")
LNG_ZERO = CLngLng(0)
#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 UBound(baKey) + 1 < LNG_KEYSZ Then
K(0) = LNG_ZERO: K(1) = LNG_ZERO
#If HasPtrSafe Then
If UBound(baKey) >= 0 Then
Call CopyMemory(K(0), baKey(0), UBound(baKey) + 1)
End If
#Else
lIdx = UBound(baKey) + 1
If lIdx > 0 Then
Call CopyMemory(ByVal VarPtr(K(0)) + 8, baKey(0), IIf(lIdx > 8, 8, lIdx))
End If
lIdx = UBound(baKey) - 7
If lIdx > 0 Then
Call CopyMemory(ByVal VarPtr(K(1)) + 8, baKey(8), lIdx)
End If
#End If
Else
#If HasPtrSafe Then
Call CopyMemory(K(0), baKey(0), LNG_KEYSZ)
#Else
K(0) = LNG_ZERO: K(1) = LNG_ZERO
Call CopyMemory(ByVal VarPtr(K(0)) + 8, baKey(0), 8)
Call CopyMemory(ByVal VarPtr(K(1)) + 8, baKey(8), 8)
#End If
End If
With uCtx
If OutSize > 8 Then
lIdx = &HEE
Else
lIdx = 0
End If
.V0 = LNG_IV(0) Xor K(0)
.V1 = LNG_IV(1) Xor K(1) Xor lIdx
.V2 = LNG_IV(2) Xor K(0)
.V3 = LNG_IV(3) Xor K(1)
.NPartial = 0
.NInput = 0
.UpdateIters = UpdateIters
.FinalizeIters = FinalizeIters
.OutSize = OutSize
End With
End Sub
Public Sub CryptoSiphashUpdate(uCtx As CryptoSiphashContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
#If HasPtrSafe Then
Static B As LongLong
#Else
Static B As Variant
#End If
Dim lIdx As Long
With uCtx
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
.NInput = .NInput + Size
If .NPartial > 0 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 Or .NPartial = LNG_BLOCKSZ
If .NPartial <> 0 Then
#If HasPtrSafe Then
Call CopyMemory(B, .Partial(0), LNG_BLOCKSZ)
#Else
B = LNG_ZERO
Call CopyMemory(ByVal VarPtr(B) + 8, .Partial(0), LNG_BLOCKSZ)
#End If
.NPartial = 0
ElseIf Size >= LNG_BLOCKSZ Then
#If HasPtrSafe Then
Call CopyMemory(B, baInput(Pos), LNG_BLOCKSZ)
#Else
B = LNG_ZERO
Call CopyMemory(ByVal VarPtr(B) + 8, baInput(Pos), LNG_BLOCKSZ)
#End If
Pos = Pos + LNG_BLOCKSZ
Size = Size - LNG_BLOCKSZ
Else
Call CopyMemory(.Partial(0), baInput(Pos), Size)
.NPartial = Size
Exit Do
End If
.V3 = .V3 Xor B
pvCompress uCtx, .UpdateIters
.V0 = .V0 Xor B
Loop
End With
End Sub
Public Sub CryptoSiphashFinalize(uCtx As CryptoSiphashContext, baOutput() As Byte)
#If HasPtrSafe Then
Static B As LongLong
#Else
Static B As Variant
#End If
Dim lIdx As Long
With uCtx
ReDim baOutput(0 To .OutSize - 1) As Byte
#If HasOperators Then
B = CLngLng(.NInput) << 56
#Else
B = RotL64(CLngLng(.NInput) And &HFF, 56)
#End If
#If HasPtrSafe Then
Call CopyMemory(B, .Partial(0), .NPartial)
#Else
Call CopyMemory(ByVal VarPtr(B) + 8, .Partial(0), .NPartial)
#End If
.V3 = .V3 Xor B
pvCompress uCtx, .UpdateIters
.V0 = .V0 Xor B
If .OutSize > 8 Then
lIdx = &HEE
Else
lIdx = &HFF
End If
.V2 = .V2 Xor lIdx
pvCompress uCtx, .FinalizeIters
B = .V0 Xor .V1 Xor .V2 Xor .V3
If .OutSize < 8 Then
lIdx = .OutSize
Else
lIdx = 8
End If
#If HasPtrSafe Then
Call CopyMemory(baOutput(0), B, lIdx)
#Else
Call CopyMemory(baOutput(0), ByVal VarPtr(B) + 8, lIdx)
#End If
If .OutSize > 8 Then
.V1 = .V1 Xor &HDD
pvCompress uCtx, .FinalizeIters
B = .V0 Xor .V1 Xor .V2 Xor .V3
If .OutSize < 16 Then
lIdx = .OutSize - 8
Else
lIdx = 8
End If
#If HasPtrSafe Then
Call CopyMemory(baOutput(8), B, lIdx)
#Else
Call CopyMemory(baOutput(8), ByVal VarPtr(B) + 8, lIdx)
#End If
End If
End With
End Sub
Public Function CryptoSiphash24ByteArray(baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
Dim uCtx As CryptoSiphashContext
CryptoSiphashInit uCtx, baKey, UpdateIters:=2, FinalizeIters:=4
CryptoSiphashUpdate uCtx, baInput, Pos, Size
CryptoSiphashFinalize uCtx, CryptoSiphash24ByteArray
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 CryptoSiphash24Text(sKey As String, sText As String) As String
CryptoSiphash24Text = ToHex(CryptoSiphash24ByteArray(ToUtf8Array(sKey), ToUtf8Array(sText)))
End Function
Public Function CryptoSiphash13ByteArray(baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
Dim uCtx As CryptoSiphashContext
CryptoSiphashInit uCtx, baKey, UpdateIters:=1, FinalizeIters:=3
CryptoSiphashUpdate uCtx, baInput, Pos, Size
CryptoSiphashFinalize uCtx, CryptoSiphash13ByteArray
End Function
Public Function CryptoSiphash13Text(sKey As String, sText As String) As String
CryptoSiphash13Text = ToHex(CryptoSiphash13ByteArray(ToUtf8Array(sKey), ToUtf8Array(sText)))
End Function
cheers,
</wqw>
Last edited by wqweto; Dec 18th, 2022 at 01:41 PM.
-
Dec 17th, 2022, 12:36 PM
#2
Re: [VB6/VBA] SipHash cryptographically secure keyed hash function
(continued)
Code:
'--- mdHalfSiphash.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 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
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#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 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
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Private Const LNG_BLOCKSZ As Long = 4
Private Const LNG_KEYSZ As Long = 8
Private Const LNG_POW2_4 As Long = 2 ^ 4
Private Const LNG_POW2_5 As Long = 2 ^ 5
Private Const LNG_POW2_6 As Long = 2 ^ 6
Private Const LNG_POW2_7 As Long = 2 ^ 7
Private Const LNG_POW2_8 As Long = 2 ^ 8
Private Const LNG_POW2_12 As Long = 2 ^ 12
Private Const LNG_POW2_13 As Long = 2 ^ 13
Private Const LNG_POW2_15 As Long = 2 ^ 15
Private Const LNG_POW2_16 As Long = 2 ^ 16
Private Const LNG_POW2_18 As Long = 2 ^ 18
Private Const LNG_POW2_19 As Long = 2 ^ 19
Private Const LNG_POW2_23 As Long = 2 ^ 23
Private Const LNG_POW2_24 As Long = 2 ^ 24
Private Const LNG_POW2_25 As Long = 2 ^ 25
Private Const LNG_POW2_26 As Long = 2 ^ 26
Private Const LNG_POW2_27 As Long = 2 ^ 27
Private Const LNG_POW2_31 As Long = &H80000000
Private Type ArrayLong128
Item(0 To 127) As Long
End Type
Public Type CryptoHalfSiphashContext
V0 As Long
V1 As Long
V2 As Long
V3 As Long
Partial(0 To LNG_BLOCKSZ - 1) As Byte
NPartial As Long
NInput As Currency
UpdateIters As Long
FinalizeIters As Long
OutSize As Long
End Type
#If Not HasOperators Then
Private Sub pvCompress(uCtx As CryptoHalfSiphashContext, ByVal lRounds As Long)
With uCtx
Do While lRounds > 0
' .V0 = UAdd32(.V0, .V1)
' .V1 = RotL32(.V1, 5) Xor .V0
' .V2 = UAdd32(.V2, .V3)
' .V3 = RotL32(.V3, 8) Xor .V2
' .V0 = RotL32(.V0, 16)
If (.V0 Xor .V1) >= 0 Then
.V0 = ((.V0 Xor &H80000000) + .V1) Xor &H80000000
Else
.V0 = .V0 + .V1
End If
.V1 = ((.V1 And (LNG_POW2_26 - 1)) * LNG_POW2_5 Or -((.V1 And LNG_POW2_26) <> 0) * LNG_POW2_31) Or _
((.V1 And (LNG_POW2_31 Xor -1)) \ LNG_POW2_27 Or -(.V1 < 0) * LNG_POW2_4) Xor .V0
If (.V2 Xor .V3) >= 0 Then
.V2 = ((.V2 Xor &H80000000) + .V3) Xor &H80000000
Else
.V2 = .V2 + .V3
End If
.V3 = ((.V3 And (LNG_POW2_23 - 1)) * LNG_POW2_8 Or -((.V3 And LNG_POW2_23) <> 0) * LNG_POW2_31) Or _
((.V3 And (LNG_POW2_31 Xor -1)) \ LNG_POW2_24 Or -(.V3 < 0) * LNG_POW2_7) Xor .V2
.V0 = ((.V0 And (LNG_POW2_15 - 1)) * LNG_POW2_16 Or -((.V0 And LNG_POW2_15) <> 0) * LNG_POW2_31) Or _
((.V0 And (LNG_POW2_31 Xor -1)) \ LNG_POW2_16 Or -(.V0 < 0) * LNG_POW2_15)
' .V2 = UAdd32(.V2, .V1)
' .V1 = RotL32(.V1, 13) Xor .V2
' .V0 = UAdd32(.V0, .V3)
' .V3 = RotL32(.V3, 7) Xor .V0
' .V2 = RotL32(.V2, 16)
If (.V2 Xor .V1) >= 0 Then
.V2 = ((.V2 Xor &H80000000) + .V1) Xor &H80000000
Else
.V2 = .V2 + .V1
End If
.V1 = ((.V1 And (LNG_POW2_18 - 1)) * LNG_POW2_13 Or -((.V1 And LNG_POW2_18) <> 0) * LNG_POW2_31) Or _
((.V1 And (LNG_POW2_31 Xor -1)) \ LNG_POW2_19 Or -(.V1 < 0) * LNG_POW2_12) Xor .V2
If (.V0 Xor .V3) >= 0 Then
.V0 = ((.V0 Xor &H80000000) + .V3) Xor &H80000000
Else
.V0 = .V0 + .V3
End If
.V3 = ((.V3 And (LNG_POW2_24 - 1)) * LNG_POW2_7 Or -((.V3 And LNG_POW2_24) <> 0) * LNG_POW2_31) Or _
((.V3 And (LNG_POW2_31 Xor -1)) \ LNG_POW2_25 Or -(.V3 < 0) * LNG_POW2_6) Xor .V0
.V2 = ((.V2 And (LNG_POW2_15 - 1)) * LNG_POW2_16 Or -((.V2 And LNG_POW2_15) <> 0) * LNG_POW2_31) Or _
((.V2 And (LNG_POW2_31 Xor -1)) \ LNG_POW2_16 Or -(.V2 < 0) * LNG_POW2_15)
lRounds = lRounds - 1
Loop
End With
End Sub
#Else
[ IntegerOverflowChecks (False) ]
Private Sub pvCompress(uCtx As CryptoHalfSiphashContext, ByVal lRounds As Long)
With uCtx
Do While lRounds > 0
.V0 += .V1
.V1 = ((.V1 << 5) Or (.V1 >> 27)) Xor .V0
.V2 += .V3
.V3 = ((.V3 << 8) Or (.V3 >> 24)) Xor .V2
.V0 = (.V0 << 16) Or (.V0 >> 16)
.V2 += .V1
.V1 = ((.V1 << 13) Or (.V1 >> 19)) Xor .V2
.V0 += .V3
.V3 = ((.V3 << 7) Or (.V3 >> 25)) Xor .V0
.V2 = (.V2 << 16) Or (.V2 >> 16)
lRounds -= 1
Loop
End With
End Sub
#End If
Private Function pvCompressArray(uCtx As CryptoHalfSiphashContext, ByVal lSize As Long, uBlock As ArrayLong128, NotUsed As Long) As Long
Dim lIdx As Long
With uCtx
For lIdx = 0 To lSize - 1
.V3 = .V3 Xor uBlock.Item(lIdx)
pvCompress uCtx, .UpdateIters
.V0 = .V0 Xor uBlock.Item(lIdx)
Next
End With
End Function
Public Sub CryptoHalfSiphashInit(uCtx As CryptoHalfSiphashContext, baKey() As Byte, _
Optional ByVal UpdateIters As Long = 2, _
Optional ByVal FinalizeIters As Long = 4, _
Optional ByVal OutSize As Long = 4)
Static K(0 To 1) As Long
Dim lIdx As Long
If UBound(baKey) + 1 < LNG_KEYSZ Then
K(0) = 0: K(1) = 0
If UBound(baKey) >= 0 Then
Call CopyMemory(K(0), baKey(0), UBound(baKey) + 1)
End If
Else
Call CopyMemory(K(0), baKey(0), LNG_KEYSZ)
End If
With uCtx
If OutSize > 4 Then
lIdx = &HEE
Else
lIdx = 0
End If
.V0 = K(0)
.V1 = K(1) Xor lIdx
.V2 = &H6C796765 Xor K(0)
.V3 = &H74656462 Xor K(1)
.NPartial = 0
.NInput = 0
.UpdateIters = UpdateIters
.FinalizeIters = FinalizeIters
.OutSize = OutSize
End With
End Sub
Public Sub CryptoHalfSiphashUpdate(uCtx As CryptoHalfSiphashContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim B As Long
Dim lIdx As Long
Dim lBlocks As Long
With uCtx
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
.NInput = .NInput + Size
If .NPartial > 0 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 Or .NPartial = LNG_BLOCKSZ
If .NPartial <> 0 Then
Call CopyMemory(B, .Partial(0), LNG_BLOCKSZ)
.NPartial = 0
.V3 = .V3 Xor B
pvCompress uCtx, .UpdateIters
.V0 = .V0 Xor B
ElseIf Size >= 128 * LNG_BLOCKSZ Then
lBlocks = Size \ (128 * LNG_BLOCKSZ)
For lIdx = 0 To lBlocks - 1
Call CallWindowProc(AddressOf pvCompressArray, VarPtr(uCtx), 128, VarPtr(baInput(Pos)), VarPtr(0))
Pos = Pos + 128 * LNG_BLOCKSZ
Size = Size - 128 * LNG_BLOCKSZ
Next
ElseIf Size >= LNG_BLOCKSZ Then
lIdx = Size \ LNG_BLOCKSZ
Call CallWindowProc(AddressOf pvCompressArray, VarPtr(uCtx), lIdx, VarPtr(baInput(Pos)), VarPtr(0))
Pos = Pos + lIdx * LNG_BLOCKSZ
Size = Size - lIdx * LNG_BLOCKSZ
Else
Call CopyMemory(.Partial(0), baInput(Pos), Size)
.NPartial = Size
Exit Do
End If
Loop
End With
End Sub
Public Sub CryptoHalfSiphashFinalize(uCtx As CryptoHalfSiphashContext, baOutput() As Byte)
Dim B As Long
Dim lIdx As Long
With uCtx
ReDim baOutput(0 To .OutSize - 1) As Byte
#If HasOperators Then
B = CLng(.NInput) << 24
#Else
B = .NInput And &HFF
' B = RotL32(B, 24)
B = ((B And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((B And LNG_POW2_7) <> 0) * LNG_POW2_31) Or _
((B And (LNG_POW2_31 Xor -1)) \ LNG_POW2_8 Or -(B < 0) * LNG_POW2_23)
#End If
Call CopyMemory(B, .Partial(0), .NPartial)
.V3 = .V3 Xor B
pvCompress uCtx, .UpdateIters
.V0 = .V0 Xor B
If .OutSize > 4 Then
lIdx = &HEE
Else
lIdx = &HFF
End If
.V2 = .V2 Xor lIdx
pvCompress uCtx, .FinalizeIters
B = .V1 Xor .V3
If .OutSize < 4 Then
lIdx = .OutSize
Else
lIdx = 4
End If
Call CopyMemory(baOutput(0), B, lIdx)
If .OutSize > 4 Then
.V1 = .V1 Xor &HDD
pvCompress uCtx, .FinalizeIters
B = .V1 Xor .V3
If .OutSize < 8 Then
lIdx = .OutSize - 4
Else
lIdx = 4
End If
Call CopyMemory(baOutput(4), B, lIdx)
End If
End With
End Sub
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 CryptoHalfSiphash24ByteArray(baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
Dim uCtx As CryptoHalfSiphashContext
CryptoHalfSiphashInit uCtx, baKey, UpdateIters:=2, FinalizeIters:=4
CryptoHalfSiphashUpdate uCtx, baInput, Pos, Size
CryptoHalfSiphashFinalize uCtx, CryptoHalfSiphash24ByteArray
End Function
Public Function CryptoHalfSiphash24Long(baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Long
Dim baOuput() As Byte
baOuput = CryptoHalfSiphash24ByteArray(baKey, baInput, Pos, Size)
Call CopyMemory(CryptoHalfSiphash24Long, baOuput(0), 4)
End Function
Public Function CryptoHalfSiphash24Text(sKey As String, sText As String) As String
CryptoHalfSiphash24Text = ToHex(CryptoHalfSiphash24ByteArray(ToUtf8Array(sKey), ToUtf8Array(sText)))
End Function
Public Function CryptoHalfSiphash13ByteArray(baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
Dim uCtx As CryptoHalfSiphashContext
CryptoHalfSiphashInit uCtx, baKey, UpdateIters:=1, FinalizeIters:=3
CryptoHalfSiphashUpdate uCtx, baInput, Pos, Size
CryptoHalfSiphashFinalize uCtx, CryptoHalfSiphash13ByteArray
End Function
Public Function CryptoHalfSiphash13Long(baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Long
Dim baOuput() As Byte
baOuput = CryptoHalfSiphash13ByteArray(baKey, baInput, Pos, Size)
Call CopyMemory(CryptoHalfSiphash13Long, baOuput(0), 4)
End Function
Public Function CryptoHalfSiphash13Text(sKey As String, sText As String) As String
CryptoHalfSiphash13Text = ToHex(CryptoHalfSiphash13ByteArray(ToUtf8Array(sKey), ToUtf8Array(sText)))
End Function
cheers,
</wqw>
Last edited by wqweto; Dec 18th, 2022 at 01:46 PM.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote