Skip to content

Instantly share code, notes, and snippets.

@wqweto

wqweto/mdAES.bas

Last active May 31, 2024 11:40
Show Gist options
  • Save wqweto/7cc2b5a31147798850e06d80379be18e to your computer and use it in GitHub Desktop.
Save wqweto/7cc2b5a31147798850e06d80379be18e to your computer and use it in GitHub Desktop.
Download ZIP
Pure VB6 impl of AES in CBC, CTR, GCM, CCM, EAX and OCB modes
Raw
mdAES.bas
'--- mdAES.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 ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) 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 LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
#End If
Private Const LNG_BLOCKSZ As Long = 16
Private Const LNG_POLY As Long = &H11B
Private Const LNG_POW2_1 As Long = 2 ^ 1
Private Const LNG_POW2_2 As Long = 2 ^ 2
Private Const LNG_POW2_3 As Long = 2 ^ 3
Private Const LNG_POW2_4 As Long = 2 ^ 4
Private Const LNG_POW2_7 As Long = 2 ^ 7
Private Const LNG_POW2_8 As Long = 2 ^ 8
Private Const LNG_POW2_16 As Long = 2 ^ 16
Private Const LNG_POW2_23 As Long = 2 ^ 23
Private Const LNG_POW2_24 As Long = 2 ^ 24
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 Type ArrayLong256
Item(0 To 255) As Long
End Type
Private Type ArrayLong60
Item(0 To 59) As Long
End Type
Private Type AesTables
Item(0 To 4) As ArrayLong256
End Type
Private Type AesBlock
Item(0 To 3) As Long
End Type
Private m_uEncTables As AesTables
Private m_uDecTables As AesTables
Private m_aBlock() As AesBlock
Private m_uPeekBlock As SAFEARRAY1D
Public Type CryptoAesContext
KeyLen As Long
EncKey As ArrayLong60
DecKey As ArrayLong60
Nonce As AesBlock
End Type
Private Function BSwap32(ByVal lX As Long) As Long
#If Not HasOperators Then
BSwap32 = (lX And &H7F) * &H1000000 Or (lX And &HFF00&) * &H100 Or (lX And &HFF0000) \ &H100 Or _
(lX And &HFF000000) \ &H1000000 And &HFF Or -((lX And &H80) <> 0) * &H80000000
#Else
Return ((lX And &H000000FF&) << 24) Or _
((lX And &H0000FF00&) << 8) Or _
((lX And &H00FF0000&) >> 8) Or _
((lX And &HFF000000&) >> 24)
#End If
End Function
Private Function pvWrapIncBE(lValue As Long) As Boolean
If lValue <> -1 Then
lValue = BSwap32((BSwap32(lValue) Xor &H80000000) + 1 Xor &H80000000)
Else
lValue = 0
'--- has carry
pvWrapIncBE = True
End If
End Function
Private Function pvWrapIncLE(lValue As Long) As Boolean
If lValue <> -1 Then
lValue = (lValue Xor &H80000000) + 1 Xor &H80000000
Else
lValue = 0
'--- has carry
pvWrapIncLE = True
End If
End Function
Private Sub pvInit(uEncTable As AesTables, uDecTable As AesTables)
Const FADF_AUTO As Long = 1
Dim lIdx As Long
Dim uDbl As ArrayLong256
Dim uThd As ArrayLong256
Dim lX As Long
Dim lX2 As Long
Dim lX4 As Long
Dim lX8 As Long
Dim lXInv As Long
Dim lS As Long
Dim lDec As Long
Dim lEnc As Long
Dim lTemp As Long
Dim pDummy As LongPtr
'--- double and third tables
For lIdx = 0 To 255
#If HasOperators Then
lTemp = (lIdx << 1) Xor (lIdx >> 7) * LNG_POLY
#Else
lTemp = (lIdx * LNG_POW2_1) Xor (lIdx \ LNG_POW2_7) * LNG_POLY
#End If
uDbl.Item(lIdx) = lTemp
uThd.Item(lTemp Xor lIdx) = lIdx
Next
Do While uEncTable.Item(4).Item(lX) = 0
'--- sbox
lS = lXInv Xor lXInv * LNG_POW2_1 Xor lXInv * LNG_POW2_2 Xor lXInv * LNG_POW2_3 Xor lXInv * LNG_POW2_4
#If HasOperators Then
lS = (lS >> 8) Xor (lS And 255) Xor &H63
#Else
lS = (lS \ LNG_POW2_8) Xor (lS And 255) Xor &H63
#End If
#If HasOperators Then
uEncTable.Item(4).Item(lX) = lS * &H1010101
uDecTable.Item(4).Item(lS) = lX * &H1010101
#Else
uEncTable.Item(4).Item(lX) = (lS And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lS And LNG_POW2_7) <> 0) * &H80000000 Or lS * &H10101
uDecTable.Item(4).Item(lS) = (lX And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lX And LNG_POW2_7) <> 0) * &H80000000 Or lX * &H10101
#End If
'--- mixcolumns
lX2 = uDbl.Item(lX)
lX4 = uDbl.Item(lX2)
lX8 = uDbl.Item(lX4)
#If HasOperators Then
lDec = lX8 * &H1010101 Xor lX4 * &H1000100 Xor lX2 * &H1010000 Xor lX * &H10101
lEnc = uDbl.Item(lS) * &H1010000 Xor lS * &H10101
#Else
lDec = ((lX8 And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lX8 And LNG_POW2_7) <> 0) * &H80000000 Or lX8 * &H10101) _
Xor ((lX4 And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lX4 And LNG_POW2_7) <> 0) * &H80000000 Or lX4 * &H100) _
Xor ((lX2 And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lX2 And LNG_POW2_7) <> 0) * &H80000000 Or lX2 * &H10000) _
Xor lX * &H10101
lEnc = ((uDbl.Item(lS) And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((uDbl.Item(lS) And LNG_POW2_7) <> 0) * &H80000000 Or uDbl.Item(lS) * &H10000) _
Xor lS * &H10101
#End If
For lIdx = 0 To 3
#If HasOperators Then
lEnc = (lEnc << 8) Xor (lEnc >> 24)
lDec = (lDec << 8) Xor (lDec >> 24)
#Else
lEnc = ((lEnc And (LNG_POW2_23 - 1)) * LNG_POW2_8 Or -((lEnc And LNG_POW2_23) <> 0) * &H80000000) _
Xor ((lEnc And &H7FFFFFFF) \ LNG_POW2_24 Or -(lEnc < 0) * LNG_POW2_7)
lDec = ((lDec And (LNG_POW2_23 - 1)) * LNG_POW2_8 Or -((lDec And LNG_POW2_23) <> 0) * &H80000000) _
Xor ((lDec And &H7FFFFFFF) \ LNG_POW2_24 Or -(lDec < 0) * LNG_POW2_7)
#End If
uEncTable.Item(lIdx).Item(lX) = lEnc
uDecTable.Item(lIdx).Item(lS) = lDec
Next
If lX2 <> 0 Then
lX = lX Xor lX2
Else
lX = lX Xor 1
End If
lXInv = uThd.Item(lXInv)
If lXInv = 0 Then
lXInv = 1
End If
Loop
With m_uPeekBlock
.cDims = 1
.fFeatures = FADF_AUTO
.cbElements = 16
.cLocks = 1
End With
Call CopyMemory(ByVal ArrPtr(m_aBlock), VarPtr(m_uPeekBlock), LenB(pDummy))
End Sub
Private Sub pvInitPeek(uArray As SAFEARRAY1D, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
If Size < 0 Then
Size = UBound(baBuffer) + 1 - Pos
End If
With uArray
If Size > 0 Then
.pvData = VarPtr(baBuffer(Pos))
Else
.pvData = 0
End If
.cElements = Size \ .cbElements
End With
End Sub
Private Function pvKeySchedule(baKey() As Byte, uSbox As ArrayLong256, uDecTable As AesTables, uEncKey As ArrayLong60, uDecKey As ArrayLong60) As Long
Dim lIdx As Long
Dim lJdx As Long
Dim lRCon As Long
Dim lKeyLen As Long
Dim lPrev As Long
Dim lTemp As Long
lKeyLen = (UBound(baKey) + 1) \ 4
If Not (lKeyLen = 4 Or lKeyLen = 6 Or lKeyLen = 8) Then
Err.Raise vbObjectError, , "Invalid key bit-size for AES (" & lKeyLen * 32 & ")"
End If
lRCon = 1
Call CopyMemory(uEncKey.Item(0), baKey(0), lKeyLen * 4)
For lIdx = lKeyLen To 4 * lKeyLen + 27
lPrev = uEncKey.Item(lIdx - 1)
'--- sbox
If lIdx Mod lKeyLen = 0 Then
#If HasOperators Then
lPrev = (lPrev << 24) Or (lPrev >> 8)
lPrev = (uSbox.Item(lPrev And &HFF&) And &HFF&) _
Xor (uSbox.Item((lPrev >> 8) And &HFF&) And &HFF00&) _
Xor (uSbox.Item((lPrev >> 16) And &HFF&) And &HFF0000) _
Xor (uSbox.Item((lPrev >> 24) And &HFF&) And &HFF000000) Xor lRCon
lRCon = (lRCon << 1) Xor (lRCon >> 7) * LNG_POLY
#Else
lPrev = ((lPrev And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lPrev And LNG_POW2_7) <> 0) * &H80000000) _
Xor ((lPrev And &H7FFFFFFF) \ LNG_POW2_8 Or -(lPrev < 0) * LNG_POW2_23)
lPrev = (uSbox.Item(lPrev And &HFF&) And &HFF&) _
Xor (uSbox.Item((lPrev And &HFF00&) \ LNG_POW2_8) And &HFF00&) _
Xor (uSbox.Item((lPrev And &HFF0000) \ LNG_POW2_16) And &HFF0000) _
Xor (uSbox.Item((lPrev And &H7F000000) \ LNG_POW2_24 Or -(lPrev < 0) * LNG_POW2_7) And &HFF000000) Xor lRCon
lRCon = lRCon * LNG_POW2_1 Xor (lRCon \ LNG_POW2_7) * LNG_POLY
#End If
ElseIf lIdx Mod lKeyLen = 4 And lKeyLen > 6 Then
#If HasOperators Then
lPrev = (uSbox.Item(lPrev And 255) And &HFF&) _
Xor (uSbox.Item((lPrev >> 8) And 255) And &HFF00&) _
Xor (uSbox.Item((lPrev >> 16) And 255) And &HFF0000) _
Xor (uSbox.Item(lPrev >> 24) And &HFF000000)
#Else
lPrev = (uSbox.Item(lPrev And &HFF&) And &HFF&) _
Xor (uSbox.Item((lPrev And &HFF00&) \ LNG_POW2_8) And &HFF00&) _
Xor (uSbox.Item((lPrev And &HFF0000) \ LNG_POW2_16) And &HFF0000) _
Xor (uSbox.Item((lPrev And &H7F000000) \ LNG_POW2_24 Or -(lPrev < 0) * LNG_POW2_7) And &HFF000000)
#End If
End If
uEncKey.Item(lIdx) = uEncKey.Item(lIdx - lKeyLen) Xor lPrev
Next
pvKeySchedule = lIdx
'--- inverse
For lJdx = 0 To lIdx - 1
If (lIdx And 3) <> 0 Then
lPrev = uEncKey.Item(lIdx)
Else
lPrev = uEncKey.Item(lIdx - 4)
End If
If lIdx <= 4 Or lJdx < 4 Then
uDecKey.Item(lJdx) = lPrev
Else
#If HasOperators Then
uDecKey.Item(lJdx) = uDecTable.Item(0).Item(uSbox.Item(lPrev And 255) And &HFF&) _
Xor uDecTable.Item(1).Item(uSbox.Item((lPrev >> 8) And 255) And &HFF&) _
Xor uDecTable.Item(2).Item(uSbox.Item((lPrev >> 16) And 255) And &HFF&) _
Xor uDecTable.Item(3).Item(uSbox.Item(lPrev >> 24) And &HFF&)
#Else
lTemp = (lPrev And &H7FFFFFFF) \ LNG_POW2_24 Or -(lPrev < 0) * LNG_POW2_7
uDecKey.Item(lJdx) = uDecTable.Item(0).Item(uSbox.Item(lPrev And &HFF&) And &HFF&) _
Xor uDecTable.Item(1).Item(uSbox.Item((lPrev And &HFF00&) \ LNG_POW2_8) And &HFF&) _
Xor uDecTable.Item(2).Item(uSbox.Item((lPrev And &HFF0000) \ LNG_POW2_16) And &HFF&) _
Xor uDecTable.Item(3).Item(uSbox.Item(lTemp) And &HFF&)
#End If
End If
lIdx = lIdx - 1
Next
End Function
Private Sub pvCrypt(uInput As AesBlock, uOutput As AesBlock, ByVal bDecrypt As Boolean, uKey As ArrayLong60, ByVal lKeyLen As Long, _
uT0 As ArrayLong256, uT1 As ArrayLong256, uT2 As ArrayLong256, uT3 As ArrayLong256, uSbox As ArrayLong256)
Dim lIdx As Long
Dim lJdx As Long
Dim lKdx As Long
Dim lA As Long
Dim lB As Long
Dim lC As Long
Dim lD As Long
Dim lTemp1 As Long
Dim lTemp2 As Long
Dim lTemp3 As Long
'--- first round
lA = uInput.Item(0) Xor uKey.Item(0)
lB = uInput.Item(1 - bDecrypt * 2) Xor uKey.Item(1)
lC = uInput.Item(2) Xor uKey.Item(2)
lD = uInput.Item(3 + bDecrypt * 2) Xor uKey.Item(3)
'--- inner rounds
lKdx = 4
For lIdx = 1 To lKeyLen \ 4 - 2
#If HasOperators Then
lTemp1 = uT0.Item(lA And 255) Xor uT1.Item((lB >> 8) And 255) Xor uT2.Item((lC >> 16) And 255) Xor uT3.Item(lD >> 24) Xor uKey.Item(lKdx + 0)
lTemp2 = uT0.Item(lB And 255) Xor uT1.Item((lC >> 8) And 255) Xor uT2.Item((lD >> 16) And 255) Xor uT3.Item(lA >> 24) Xor uKey.Item(lKdx + 1)
lTemp3 = uT0.Item(lC And 255) Xor uT1.Item((lD >> 8) And 255) Xor uT2.Item((lA >> 16) And 255) Xor uT3.Item(lB >> 24) Xor uKey.Item(lKdx + 2)
lD = uT0.Item(lD And 255) Xor uT1.Item((lA >> 8) And 255) Xor uT2.Item((lB >> 16) And 255) Xor uT3.Item(lC >> 24) Xor uKey.Item(lKdx + 3)
#Else
lTemp1 = uT0.Item(lA And 255) _
Xor uT1.Item((lB And &HFF00&) \ LNG_POW2_8) _
Xor uT2.Item((lC And &HFF0000) \ LNG_POW2_16) _
Xor uT3.Item((lD And &H7F000000) \ LNG_POW2_24 Or -(lD < 0) * LNG_POW2_7) _
Xor uKey.Item(lKdx + 0)
lTemp2 = uT0.Item(lB And 255) _
Xor uT1.Item((lC And &HFF00&) \ LNG_POW2_8) _
Xor uT2.Item((lD And &HFF0000) \ LNG_POW2_16) _
Xor uT3.Item((lA And &H7F000000) \ LNG_POW2_24 Or -(lA < 0) * LNG_POW2_7) _
Xor uKey.Item(lKdx + 1)
lTemp3 = uT0.Item(lC And 255) _
Xor uT1.Item((lD And &HFF00&) \ LNG_POW2_8) _
Xor uT2.Item((lA And &HFF0000) \ LNG_POW2_16) _
Xor uT3.Item((lB And &H7F000000) \ LNG_POW2_24 Or -(lB < 0) * LNG_POW2_7) _
Xor uKey.Item(lKdx + 2)
lD = uT0.Item(lD And 255) _
Xor uT1.Item((lA And &HFF00&) \ LNG_POW2_8) _
Xor uT2.Item((lB And &HFF0000) \ LNG_POW2_16) _
Xor uT3.Item((lC And &H7F000000) \ LNG_POW2_24 Or -(lC < 0) * LNG_POW2_7) _
Xor uKey.Item(lKdx + 3)
#End If
lKdx = lKdx + 4
lA = lTemp1: lB = lTemp2: lC = lTemp3
Next
'--- last round
For lIdx = 0 To 3
If bDecrypt Then
lJdx = -lIdx And 3
Else
lJdx = lIdx
End If
#If HasOperators Then
uOutput.Item(lJdx) = (uSbox.Item(lA And 255) And &HFF&) _
Xor (uSbox.Item((lB >> 8) And 255) And &HFF00&) _
Xor (uSbox.Item((lC >> 16) And 255) And &HFF0000) _
Xor (uSbox.Item(lD >> 24) And &HFF000000) Xor uKey.Item(lKdx)
#Else
uOutput.Item(lJdx) = (uSbox.Item(lA And 255) And &HFF&) _
Xor (uSbox.Item((lB And &HFF00&) \ LNG_POW2_8) And &HFF00&) _
Xor (uSbox.Item((lC And &HFF0000) \ LNG_POW2_16) And &HFF0000) _
Xor (uSbox.Item((lD And &H7F000000) \ LNG_POW2_24 Or -(lD < 0) * LNG_POW2_7) And &HFF000000) _
Xor uKey.Item(lKdx)
#End If
lKdx = lKdx + 1
lTemp1 = lA: lA = lB: lB = lC: lC = lD: lD = lTemp1
Next
End Sub
Private Sub pvProcess(uCtx As CryptoAesContext, ByVal bDecrypt As Boolean, uInput As AesBlock, uOutput As AesBlock)
If bDecrypt Then
pvCrypt uInput, uOutput, bDecrypt, uCtx.DecKey, uCtx.KeyLen, m_uDecTables.Item(0), m_uDecTables.Item(1), m_uDecTables.Item(2), m_uDecTables.Item(3), m_uDecTables.Item(4)
Else
pvCrypt uInput, uOutput, bDecrypt, uCtx.EncKey, uCtx.KeyLen, m_uEncTables.Item(0), m_uEncTables.Item(1), m_uEncTables.Item(2), m_uEncTables.Item(3), m_uEncTables.Item(4)
End If
End Sub
Public Sub CryptoAesInit(uCtx As CryptoAesContext, baKey() As Byte, Optional Nonce As Variant)
If m_uEncTables.Item(0).Item(0) = 0 Then
pvInit m_uEncTables, m_uDecTables
End If
With uCtx
.KeyLen = pvKeySchedule(baKey, m_uEncTables.Item(4), m_uDecTables, .EncKey, .DecKey)
CryptoAesSetNonce uCtx, Nonce
End With
End Sub
Public Sub CryptoAesSetNonce(uCtx As CryptoAesContext, Nonce As Variant, Optional ByVal CounterWords As Long)
Dim baNonce() As Byte
With uCtx
If IsMissing(Nonce) Or IsNumeric(Nonce) Then
baNonce = vbNullString
Else
baNonce = Nonce
End If
If UBound(baNonce) <> LNG_BLOCKSZ - 1 Then
ReDim Preserve baNonce(0 To LNG_BLOCKSZ - 1) As Byte
End If
Call CopyMemory(.Nonce, baNonce(0), LNG_BLOCKSZ)
If IsNumeric(Nonce) Then
.Nonce.Item(3) = Nonce
End If
If CounterWords > 0 Then
If pvWrapIncBE(uCtx.Nonce.Item(3)) And CounterWords > 1 Then
pvWrapIncBE uCtx.Nonce.Item(2)
End If
End If
End With
End Sub
Public Sub CryptoAesProcess(uCtx As CryptoAesContext, baBlock() As Byte, Optional ByVal Pos As Long, Optional ByVal Decrypt As Boolean)
Debug.Assert UBound(baBlock) + 1 >= Pos + LNG_BLOCKSZ
m_uPeekBlock.pvData = VarPtr(baBlock(Pos))
m_uPeekBlock.cElements = 1
pvProcess uCtx, Decrypt, m_aBlock(0), m_aBlock(0)
End Sub
Public Sub CryptoAesProcessPtr(uCtx As CryptoAesContext, ByVal lPtr As Long, Optional ByVal Decrypt As Boolean)
m_uPeekBlock.pvData = lPtr
m_uPeekBlock.cElements = 1
pvProcess uCtx, Decrypt, m_aBlock(0), m_aBlock(0)
End Sub
'= AES-CBC ===============================================================
Public Sub CryptoAesCbcEncrypt(uCtx As CryptoAesContext, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional ByVal Final As Boolean = True)
Dim lIdx As Long
Dim lJdx As Long
Dim lNumBlocks As Long
Dim uBlock As AesBlock
Dim lPad As Long
If Size < 0 Then
Size = UBound(baBuffer) + 1 - Pos
End If
If Final Then
lNumBlocks = Size \ LNG_BLOCKSZ
Else
If Size Mod LNG_BLOCKSZ <> 0 Then
Err.Raise vbObjectError, , "Invalid non-final block size for CBC mode (" & Size Mod LNG_BLOCKSZ & ")"
End If
lNumBlocks = Size \ LNG_BLOCKSZ - 1
End If
pvInitPeek m_uPeekBlock, baBuffer, Pos, Size
For lIdx = 0 To lNumBlocks
If lIdx = lNumBlocks And Final Then
'--- append PKCS#5 padding
lPad = (LNG_BLOCKSZ - Size Mod LNG_BLOCKSZ) * &H1010101
uBlock.Item(0) = lPad: uBlock.Item(1) = lPad: uBlock.Item(2) = lPad: uBlock.Item(3) = lPad
lJdx = lIdx * LNG_BLOCKSZ
If Size - lJdx > 0 Then
Call CopyMemory(uBlock, baBuffer(Pos + lJdx), Size - lJdx)
End If
ReDim Preserve baBuffer(0 To Pos + lJdx + LNG_BLOCKSZ - 1) As Byte
pvInitPeek m_uPeekBlock, baBuffer, Pos, lJdx + LNG_BLOCKSZ
With uBlock
m_aBlock(lIdx).Item(0) = .Item(0)
m_aBlock(lIdx).Item(1) = .Item(1)
m_aBlock(lIdx).Item(2) = .Item(2)
m_aBlock(lIdx).Item(3) = .Item(3)
End With
End If
With uCtx.Nonce
.Item(0) = .Item(0) Xor m_aBlock(lIdx).Item(0)
.Item(1) = .Item(1) Xor m_aBlock(lIdx).Item(1)
.Item(2) = .Item(2) Xor m_aBlock(lIdx).Item(2)
.Item(3) = .Item(3) Xor m_aBlock(lIdx).Item(3)
End With
pvProcess uCtx, False, uCtx.Nonce, uCtx.Nonce
With uCtx.Nonce
m_aBlock(lIdx).Item(0) = .Item(0)
m_aBlock(lIdx).Item(1) = .Item(1)
m_aBlock(lIdx).Item(2) = .Item(2)
m_aBlock(lIdx).Item(3) = .Item(3)
End With
Next
End Sub
Public Function CryptoAesCbcDecrypt(uCtx As CryptoAesContext, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional ByVal Final As Boolean = True) As Boolean
Dim lIdx As Long
Dim lJdx As Long
Dim lNumBlocks As Long
Dim uInput As AesBlock
Dim uBlock As AesBlock
Dim lPad As Long
If Size < 0 Then
Size = UBound(baBuffer) + 1 - Pos
End If
If Size Mod LNG_BLOCKSZ <> 0 Then
Err.Raise vbObjectError, , "Invalid partial block size for CBC mode (" & Size Mod LNG_BLOCKSZ & ")"
End If
lNumBlocks = Size \ LNG_BLOCKSZ - 1
pvInitPeek m_uPeekBlock, baBuffer, Pos, Size
For lIdx = 0 To lNumBlocks
With uInput
.Item(0) = m_aBlock(lIdx).Item(0)
.Item(1) = m_aBlock(lIdx).Item(1)
.Item(2) = m_aBlock(lIdx).Item(2)
.Item(3) = m_aBlock(lIdx).Item(3)
End With
pvProcess uCtx, True, uInput, uBlock
With uBlock
.Item(0) = .Item(0) Xor uCtx.Nonce.Item(0)
.Item(1) = .Item(1) Xor uCtx.Nonce.Item(1)
.Item(2) = .Item(2) Xor uCtx.Nonce.Item(2)
.Item(3) = .Item(3) Xor uCtx.Nonce.Item(3)
End With
With uCtx.Nonce
.Item(0) = uInput.Item(0)
.Item(1) = uInput.Item(1)
.Item(2) = uInput.Item(2)
.Item(3) = uInput.Item(3)
End With
With uBlock
m_aBlock(lIdx).Item(0) = .Item(0)
m_aBlock(lIdx).Item(1) = .Item(1)
m_aBlock(lIdx).Item(2) = .Item(2)
m_aBlock(lIdx).Item(3) = .Item(3)
End With
If lIdx = lNumBlocks And Final Then
Pos = Pos + lIdx * LNG_BLOCKSZ
'--- check and remove PKCS#5 padding
lPad = baBuffer(Pos + LNG_BLOCKSZ - 1)
If lPad = 0 Or lPad > LNG_BLOCKSZ Then
Exit Function
End If
For lJdx = 1 To lPad
If baBuffer(Pos + LNG_BLOCKSZ - lJdx) <> lPad Then
Exit Function
End If
Next
Pos = Pos + LNG_BLOCKSZ - lPad
If Pos = 0 Then
baBuffer = vbNullString
Else
ReDim Preserve baBuffer(0 To Pos - 1) As Byte
End If
End If
Next
'--- success
CryptoAesCbcDecrypt = True
End Function
Public Sub CryptoAesCtrCrypt(uCtx As CryptoAesContext, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional ByVal CounterWords As Long = 2)
Dim lIdx As Long
Dim lJdx As Long
Dim lFinal As Long
Dim uBlock As AesBlock
Dim uTemp As AesBlock
If Size < 0 Then
Size = UBound(baBuffer) + 1 - Pos
End If
If Size = 0 Then
Exit Sub
End If
lFinal = Size \ LNG_BLOCKSZ
pvInitPeek m_uPeekBlock, baBuffer, Pos, Size
For lIdx = 0 To (Size - 1) \ LNG_BLOCKSZ
pvProcess uCtx, False, uCtx.Nonce, uBlock
If lIdx = lFinal Then
lJdx = lIdx * LNG_BLOCKSZ
Call CopyMemory(uTemp, baBuffer(Pos + lJdx), Size - lJdx)
With uTemp
.Item(0) = .Item(0) Xor uBlock.Item(0)
.Item(1) = .Item(1) Xor uBlock.Item(1)
.Item(2) = .Item(2) Xor uBlock.Item(2)
.Item(3) = .Item(3) Xor uBlock.Item(3)
End With
Call CopyMemory(baBuffer(Pos + lJdx), uTemp, Size - lJdx)
Else
With uBlock
m_aBlock(lIdx).Item(0) = m_aBlock(lIdx).Item(0) Xor .Item(0)
m_aBlock(lIdx).Item(1) = m_aBlock(lIdx).Item(1) Xor .Item(1)
m_aBlock(lIdx).Item(2) = m_aBlock(lIdx).Item(2) Xor .Item(2)
m_aBlock(lIdx).Item(3) = m_aBlock(lIdx).Item(3) Xor .Item(3)
End With
End If
If CounterWords < 0 Then
If pvWrapIncLE(uCtx.Nonce.Item(0)) And CounterWords < -1 Then
pvWrapIncLE uCtx.Nonce.Item(1)
End If
Else
If pvWrapIncBE(uCtx.Nonce.Item(3)) And CounterWords > 1 Then
pvWrapIncBE uCtx.Nonce.Item(2)
End If
End If
Next
End Sub
Raw
mdAesCcm.bas
'--- mdAesCcm.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 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 ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) 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 LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
#End If
Private Const LNG_BLOCKSZ As Long = 16
Private Const LNG_POW2_2 As Long = 2 ^ 2
Private Const LNG_POW2_6 As Long = 2 ^ 6
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 Type AesBlock
Item(0 To 3) As Long
End Type
Private Function BSwap32(ByVal lX As Long) As Long
BSwap32 = (lX And &H7F) * &H1000000 Or (lX And &HFF00&) * &H100 Or (lX And &HFF0000) \ &H100 Or _
(lX And &HFF000000) \ &H1000000 And &HFF Or -((lX And &H80) <> 0) * &H80000000
End Function
Private Function BSwap16(ByVal lX As Long) As Long
BSwap16 = (lX And &HFF) * &H100 Or (lX And &HFF00&) \ &H100
End Function
Private Function pvComputeLengthSize(baNonce() As Byte, baBuffer() As Byte) As Long
pvComputeLengthSize = 2
Do While 2 ^ (8 * pvComputeLengthSize) < UBound(baBuffer) + 1
pvComputeLengthSize = pvComputeLengthSize + 1
Loop
If pvComputeLengthSize < (15 - UBound(baNonce) - 1) Then
pvComputeLengthSize = (15 - UBound(baNonce) - 1)
End If
End Function
Private Sub pvMac(uCtx As CryptoAesContext, baInput() As Byte, ByVal lPos As Long, baTag() As Byte)
Const FADF_AUTO As Long = 1
Dim aBlock() As AesBlock
Dim uPeekBlock As SAFEARRAY1D
Dim uTag As AesBlock
Dim pDummy As LongPtr
Dim lIdx As Long
Dim lJdx As Long
If UBound(baInput) >= 0 Then
If lPos + 4 * LNG_BLOCKSZ <= UBound(baInput) + 1 Then
With uPeekBlock
.cDims = 1
.fFeatures = FADF_AUTO
.cbElements = LenB(uTag)
.cLocks = 1
.pvData = VarPtr(baInput(0))
.cElements = (UBound(baInput) + 1) \ .cbElements
End With
Call CopyMemory(ByVal ArrPtr(aBlock), VarPtr(uPeekBlock), LenB(pDummy))
Call CopyMemory(uTag.Item(0), baTag(0), LNG_BLOCKSZ)
Do While lPos + LNG_BLOCKSZ <= UBound(baInput) + 1
uTag.Item(0) = uTag.Item(0) Xor aBlock(lJdx).Item(0)
uTag.Item(1) = uTag.Item(1) Xor aBlock(lJdx).Item(1)
uTag.Item(2) = uTag.Item(2) Xor aBlock(lJdx).Item(2)
uTag.Item(3) = uTag.Item(3) Xor aBlock(lJdx).Item(3)
CryptoAesProcessPtr uCtx, VarPtr(uTag.Item(0))
lPos = lPos + LNG_BLOCKSZ
lJdx = lJdx + 1
Loop
Call CopyMemory(baTag(0), uTag.Item(0), LNG_BLOCKSZ)
End If
Do While lPos <= UBound(baInput)
For lIdx = 0 To LNG_BLOCKSZ - 1
If lPos <= UBound(baInput) Then
baTag(lIdx) = baTag(lIdx) Xor baInput(lPos)
lPos = lPos + 1
End If
Next
CryptoAesProcess uCtx, baTag
Loop
End If
End Sub
Private Sub pvComputeTag(uCtx As CryptoAesContext, baNonce() As Byte, baAad() As Byte, baInput() As Byte, ByVal lLengthSize As Long, baTag() As Byte, ByVal lTagSize As Long)
Const MAX_SHORT_SIZE As Long = &HFEFF&
Dim baBlock(0 To LNG_BLOCKSZ - 1) As Byte
Dim lIdx As Long
Dim lSize As Long
If lTagSize < 4 Or lTagSize > 16 Or (lTagSize And 1) = 1 Then
Err.Raise vbObjectError, , "Invalid tag size for AES-CCM (" & lTagSize & ")"
End If
If UBound(baNonce) + 1 < 7 Or UBound(baNonce) + 1 > 15 Then
Err.Raise vbObjectError, , "Invalid nonce size for AES-CCM (" & UBound(baNonce) + 1 & ")"
End If
ReDim baTag(0 To LNG_BLOCKSZ - 1) As Byte
'--- [0] = flags
baTag(0) = -(UBound(baAad) >= 0) * LNG_POW2_6 Or (lTagSize - 2) * LNG_POW2_2 Or (lLengthSize - 1)
'--- [1 to 15-L] = nonce
lIdx = UBound(baNonce) + 1
If lIdx > 15 - lLengthSize Then
lIdx = 15 - lLengthSize
End If
Call CopyMemory(baTag(1), baNonce(0), lIdx)
'--- [15-L to 15] = big-endian plaintext length
Call CopyMemory(lIdx, baTag(12), LenB(lIdx))
lIdx = lIdx Xor BSwap32(UBound(baInput) + 1)
Call CopyMemory(baTag(12), lIdx, LenB(lIdx))
CryptoAesProcess uCtx, baTag
'--- mac the AAD
lSize = UBound(baAad) + 1
If lSize > 0 Then
If lSize < MAX_SHORT_SIZE Then
lSize = BSwap16(lSize)
Call CopyMemory(baBlock(0), lSize, 2)
lIdx = 2
Else
lSize = BSwap32(lSize)
Call CopyMemory(baBlock(2), lSize, 4)
lSize = BSwap16(MAX_SHORT_SIZE)
Call CopyMemory(baBlock(0), lSize, 2)
lIdx = 6
End If
lSize = UBound(baAad) + 1
If lSize > LNG_BLOCKSZ - lIdx Then
lSize = LNG_BLOCKSZ - lIdx
End If
Call CopyMemory(baBlock(lIdx), baAad(0), lSize)
For lIdx = 0 To LNG_BLOCKSZ - 1
baTag(lIdx) = baTag(lIdx) Xor baBlock(lIdx)
Next
CryptoAesProcess uCtx, baTag
pvMac uCtx, baAad, lSize, baTag
End If
'--- mac the plaintext
pvMac uCtx, baInput, 0, baTag
End Sub
Public Sub CryptoAesCcmEncrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baBuffer() As Byte, baTag() As Byte, Optional ByVal TagSize As Long = LNG_BLOCKSZ)
Dim uCtx As CryptoAesContext
Dim lLengthSize As Long
Dim baBlock(0 To LNG_BLOCKSZ - 1) As Byte
Dim lTemp As Long
CryptoAesInit uCtx, baKey
lLengthSize = pvComputeLengthSize(baNonce, baBuffer)
pvComputeTag uCtx, baNonce, baAad, baBuffer, lLengthSize, baTag, TagSize
'--- [0] = flags
baBlock(0) = 0 * LNG_POW2_6 Or 0 * LNG_POW2_2 Or (lLengthSize - 1)
'--- [1 to 15-L] = nonce
lTemp = UBound(baNonce) + 1
If lTemp > 15 - lLengthSize Then
lTemp = 15 - lLengthSize
End If
Call CopyMemory(baBlock(1), baNonce(0), lTemp)
CryptoAesSetNonce uCtx, baBlock
lTemp = (lLengthSize + 3) \ 4
CryptoAesCtrCrypt uCtx, baTag, CounterWords:=lTemp
CryptoAesCtrCrypt uCtx, baBuffer, CounterWords:=lTemp
ReDim Preserve baTag(0 To TagSize - 1) As Byte
End Sub
Public Function CryptoAesCcmDecrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baBuffer() As Byte, baTag() As Byte) As Boolean
Dim uCtx As CryptoAesContext
Dim lLengthSize As Long
Dim baBlock(0 To LNG_BLOCKSZ - 1) As Byte
Dim lTemp As Long
Dim lTagSize As Long
Dim baTemp() As Byte
CryptoAesInit uCtx, baKey
lLengthSize = pvComputeLengthSize(baNonce, baBuffer)
'--- [0] = flags
baBlock(0) = 0 * LNG_POW2_6 Or 0 * LNG_POW2_2 Or (lLengthSize - 1)
'--- [1 to 15-L] = nonce
lTemp = UBound(baNonce) + 1
If lTemp > 15 - lLengthSize Then
lTemp = 15 - lLengthSize
End If
Call CopyMemory(baBlock(1), baNonce(0), lTemp)
CryptoAesSetNonce uCtx, baBlock
lTagSize = UBound(baTag) + 1
If lTagSize <> LNG_BLOCKSZ Then
ReDim Preserve baTag(0 To LNG_BLOCKSZ - 1) As Byte
End If
lTemp = (lLengthSize + 3) \ 4
CryptoAesCtrCrypt uCtx, baTag, CounterWords:=lTemp
CryptoAesCtrCrypt uCtx, baBuffer, CounterWords:=lTemp
pvComputeTag uCtx, baNonce, baAad, baBuffer, lLengthSize, baTemp, lTagSize
If lTagSize <> LNG_BLOCKSZ Then
ReDim Preserve baTag(0 To lTagSize - 1) As Byte
End If
If InStrB(baTemp, baTag) <> 1 Then
GoTo QH
End If
'--- success
CryptoAesCcmDecrypt = True
QH:
End Function
Raw
mdAesEax.bas
'--- mdAesEax.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 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 ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) 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 LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
#End If
Private Const LNG_BLOCKSZ As Long = 16
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 Type ArrayLong4
Item(0 To 3) As Long
End Type
Private Type ArrayByte16
Item(0 To 15) As Byte
End Type
Public Type CryptoCmacContext
AesCtx As CryptoAesContext
K1 As ArrayByte16
K2 As ArrayByte16
HashArray As ArrayByte16
NPosition As Long
End Type
'= CMAC ==================================================================
Private Sub pvDouble(uInput As ArrayByte16, uOutput As ArrayByte16)
Const LNG_POLY As Long = &H87
Dim lIdx As Long
Dim lTemp As Long
Dim lCarry As Long
For lIdx = LNG_BLOCKSZ - 1 To 0 Step -1
lTemp = uInput.Item(lIdx)
uOutput.Item(lIdx) = (lTemp * 2) And &HFF Or lCarry
lCarry = -((lTemp And &H80) <> 0)
Next
uOutput.Item(LNG_BLOCKSZ - 1) = uOutput.Item(LNG_BLOCKSZ - 1) Xor lCarry * LNG_POLY
End Sub
Public Sub CryptoCmacInit(uCtx As CryptoCmacContext, baKey() As Byte)
Dim uEmpty As ArrayByte16
With uCtx
.HashArray = uEmpty
.NPosition = 0
CryptoAesInit .AesCtx, baKey
CryptoAesProcess .AesCtx, uEmpty.Item
pvDouble uEmpty, .K1
pvDouble .K1, .K2
End With
End Sub
Public Sub CryptoCmacReset(uCtx As CryptoCmacContext)
Dim uEmpty As ArrayByte16
With uCtx
.HashArray = uEmpty
.NPosition = 0
End With
End Sub
Public Sub CryptoCmacUpdate(uCtx As CryptoCmacContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Const FADF_AUTO As Long = 1
Dim lIdx As Long
Dim aBlock() As ArrayLong4
Dim uPeekBlock As SAFEARRAY1D
Dim uTag As ArrayLong4
Dim pDummy As LongPtr
Dim lJdx As Long
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
With uCtx
For lIdx = 0 To Size - 1
If .NPosition = LNG_BLOCKSZ Then
If lIdx + 4 * LNG_BLOCKSZ <= Size Then
With uPeekBlock
.cDims = 1
.fFeatures = FADF_AUTO
.cbElements = LenB(uTag)
.cLocks = 1
.pvData = VarPtr(baInput(lIdx))
.cElements = (Size - lIdx) \ .cbElements
End With
Call CopyMemory(ByVal ArrPtr(aBlock), VarPtr(uPeekBlock), LenB(pDummy))
Call CopyMemory(uTag.Item(0), .HashArray.Item(0), LNG_BLOCKSZ)
Do While lIdx + LNG_BLOCKSZ <= Size
CryptoAesProcessPtr .AesCtx, VarPtr(uTag.Item(0))
uTag.Item(0) = uTag.Item(0) Xor aBlock(lJdx).Item(0)
uTag.Item(1) = uTag.Item(1) Xor aBlock(lJdx).Item(1)
uTag.Item(2) = uTag.Item(2) Xor aBlock(lJdx).Item(2)
uTag.Item(3) = uTag.Item(3) Xor aBlock(lJdx).Item(3)
lIdx = lIdx + LNG_BLOCKSZ
lJdx = lJdx + 1
Loop
Call CopyMemory(.HashArray.Item(0), uTag.Item(0), LNG_BLOCKSZ)
If lIdx = Size Then
Exit For
End If
End If
CryptoAesProcess .AesCtx, .HashArray.Item
.NPosition = 0
End If
.HashArray.Item(.NPosition) = .HashArray.Item(.NPosition) Xor baInput(Pos + lIdx)
.NPosition = .NPosition + 1
Next
End With
End Sub
Public Sub CryptoCmacFinalize(uCtx As CryptoCmacContext, baTag() As Byte, Optional ByVal TagSize As Long = LNG_BLOCKSZ)
Dim uKey As ArrayByte16
Dim lIdx As Long
If TagSize < 4 Or TagSize > LNG_BLOCKSZ Then
Err.Raise vbObjectError, , "Invalid tag size for CMAC (" & TagSize & ")"
End If
With uCtx
If .NPosition = LNG_BLOCKSZ Then
uKey = .K1
Else
.HashArray.Item(.NPosition) = .HashArray.Item(.NPosition) Xor &H80
uKey = .K2
End If
For lIdx = 0 To LNG_BLOCKSZ - 1
.HashArray.Item(lIdx) = .HashArray.Item(lIdx) Xor uKey.Item(lIdx)
Next
CryptoAesProcess .AesCtx, .HashArray.Item
.NPosition = 0
baTag = .HashArray.Item
ReDim Preserve baTag(0 To TagSize - 1) As Byte
End With
End Sub
'= AES-EAX ===============================================================
Private Sub pvMac(uCtx As CryptoCmacContext, ByVal lStep As Long, baInput() As Byte, baTag() As Byte)
Dim uBlock As ArrayByte16
CryptoCmacReset uCtx
uBlock.Item(LNG_BLOCKSZ - 1) = lStep
CryptoCmacUpdate uCtx, uBlock.Item
CryptoCmacUpdate uCtx, baInput
CryptoCmacFinalize uCtx, baTag
End Sub
Public Sub CryptoAesEaxEncrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baBuffer() As Byte, baTag() As Byte, Optional ByVal TagSize As Long = LNG_BLOCKSZ)
Dim uAesCtx As CryptoAesContext
Dim uCtx As CryptoCmacContext
Dim baTagNonce() As Byte
Dim baTagAad() As Byte
Dim lIdx As Long
If TagSize < 4 Or TagSize > LNG_BLOCKSZ Then
Err.Raise vbObjectError, , "Invalid tag size for EAX (" & TagSize & ")"
End If
CryptoCmacInit uCtx, baKey
pvMac uCtx, 0, baNonce, baTagNonce
pvMac uCtx, 1, baAad, baTagAad
CryptoAesInit uAesCtx, baKey, baTagNonce
CryptoAesCtrCrypt uAesCtx, baBuffer
CryptoCmacInit uCtx, baKey
pvMac uCtx, 2, baBuffer, baTag
For lIdx = 0 To LNG_BLOCKSZ - 1
baTag(lIdx) = baTag(lIdx) Xor baTagNonce(lIdx) Xor baTagAad(lIdx)
Next
ReDim Preserve baTag(0 To TagSize - 1) As Byte
End Sub
Public Function CryptoAesEaxDecrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baBuffer() As Byte, baTag() As Byte) As Boolean
Dim uCtx As CryptoCmacContext
Dim baTagNonce() As Byte
Dim baTagAad() As Byte
Dim baCalc() As Byte
Dim uAesCtx As CryptoAesContext
Dim lIdx As Long
CryptoCmacInit uCtx, baKey
pvMac uCtx, 0, baNonce, baTagNonce
pvMac uCtx, 1, baAad, baTagAad
pvMac uCtx, 2, baBuffer, baCalc
For lIdx = 0 To LNG_BLOCKSZ - 1
baCalc(lIdx) = baCalc(lIdx) Xor baTagNonce(lIdx) Xor baTagAad(lIdx)
Next
If UBound(baTag) <> UBound(baCalc) Then
ReDim Preserve baCalc(0 To UBound(baTag)) As Byte
End If
If InStrB(baTag, baCalc) <> 1 Then
Exit Function
End If
CryptoAesInit uAesCtx, baKey, baTagNonce
CryptoAesCtrCrypt uAesCtx, baBuffer
'--- success
CryptoAesEaxDecrypt = True
End Function
Raw
mdAesGcm.bas
'--- mdAesGcm.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 VirtualAlloc Lib "kernel32" (ByVal lpAddress As LongPtr, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (ByVal lpAddress As LongPtr, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare PtrSafe Function VirtualFree Lib "kernel32" (ByVal lpAddress As LongPtr, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare PtrSafe Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As LongPtr, pcbBinary As Long, Optional ByVal pdwSkip As LongPtr, Optional ByVal pdwFlags As LongPtr) 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 VirtualAlloc Lib "kernel32" (ByVal lpAddress As LongPtr, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As LongPtr
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As LongPtr, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As LongPtr, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As LongPtr, pcbBinary As Long, Optional ByVal pdwSkip As LongPtr, Optional ByVal pdwFlags As LongPtr) As Long
#End If
Private Const LNG_BLOCKSZ As Long = 16
Private Const LNG_POW2_1 As Long = 2 ^ 1
Private Const LNG_POW2_3 As Long = 2 ^ 3
Private Const LNG_POW2_4 As Long = 2 ^ 4
Private Const LNG_POW2_27 As Long = 2 ^ 27
Private Const LNG_POW2_28 As Long = 2 ^ 28
Private Const LNG_POW2_30 As Long = 2 ^ 30
Private Const LNG_POW2_31 As Long = &H80000000
Private Type ArrayLong4
Item(0 To 3) As Long
End Type
Private Type ArrayByte16
Item(0 To 15) As Byte
End Type
Private Type ShoupTable
Item(0 To 15) As ArrayLong4
End Type
Public Type CryptoGhashContext
KeyTable As ShoupTable
HashArray As ArrayByte16
NPosition As Long
End Type
Public Type CryptoAesGcmContext
AesCtx As CryptoAesContext
GhashCtx As CryptoGhashContext
Counter(0 To LNG_BLOCKSZ - 1) As Byte
AadSize As Currency
TotalSize As Currency
End Type
Private m_aReverse(0 To 15) As Long
Private m_aReduce(0 To 15) As Long
Private m_hMulThunk As LongPtr
Private Function BSwap32(ByVal lX As Long) As Long
#If Not HasOperators Then
BSwap32 = (lX And &H7F) * &H1000000 Or (lX And &HFF00&) * &H100 Or (lX And &HFF0000) \ &H100 Or _
(lX And &HFF000000) \ &H1000000 And &HFF Or -((lX And &H80) <> 0) * &H80000000
#Else
Return ((lX And &H000000FF&) << 24) Or _
((lX And &H0000FF00&) << 8) Or _
((lX And &H00FF0000&) >> 8) Or _
((lX And &HFF000000&) >> 24)
#End If
End Function
Private Sub pvInit()
Const LNG_POLY1 As Long = &HE1000000 '--- GHASH irreducible polynomial
Const LNG_POLY2 As Long = LNG_POLY1 \ 2 And &H7FFFFFFF
Const LNG_POLY4 As Long = LNG_POLY2 \ 2
Const LNG_POLY8 As Long = LNG_POLY4 \ 2
Dim lIdx As Long
For lIdx = 0 To 15
m_aReverse(lIdx) = -((lIdx And 1) <> 0) * 8 Xor -((lIdx And 2) <> 0) * 4 _
Xor -((lIdx And 4) <> 0) * 2 Xor -((lIdx And 8) <> 0) * 1
m_aReduce(lIdx) = -((lIdx And 1) <> 0) * LNG_POLY8 Xor -((lIdx And 2) <> 0) * LNG_POLY4 _
Xor -((lIdx And 4) <> 0) * LNG_POLY2 Xor -((lIdx And 8) <> 0) * LNG_POLY1
Next
m_hMulThunk = pvThunkAllocate
End Sub
#If WIN64 = 1 Then
Private Function pvThunkAllocate() As LongPtr
End Function
Private Function pvPatchTrampoline(ByVal Pfn As LongPtr, Optional ByVal Noop As Boolean) As Boolean
#If Pfn And Noop Then '--- touch
#End If
pvPatchTrampoline = True
End Function
#Else
Private Function pvThunkAllocate() As LongPtr
Const MEM_COMMIT As Long = &H1000
Const MEM_DECOMMIT As Long = &H4000
Const PAGE_EXECUTE_READWRITE As Long = &H40
Const CRYPT_STRING_BASE64 As Long = 1
Const THUNK_SIZE As Long = 327
Dim STR_THUNK As String: STR_THUNK = "VYvsi0UIg+wQU1ZXhcB1IkCNffAzyVMPoovzW4kHiXcEiU8IiVcMi0X4g+AC6QwBAAAPECiLRQzHRfAPDg0Mx0X0CwoJCMdF+AcGBQQPEAjHRfwDAgEADxB18GYPOADOZg84AO4PKNUPKMVmDzpEwQFmDzpE0RBmD+/QDyjdZg86RNkAZg86ROkRDyjCZg9z2ghmD3P4CGYP7+pmD+/YDyjlDyjDZg9y1B9mD3LQH2YPcvMBDyjIZg9z/ARmD3P5BGYP68tmD3PYDA8o2WYPcvUBZg9y8x9mD+vlZg/r4A8owWYPcvAeZg/v2A8owWYPcvAZZg/v2A8o02YPc9sEZg9z+gxmD+/RDyjKDyjCZg9y0QJmD3LQAWYP78gPKMJmD3LQB2YP78hmD+/LZg/vymYP78xmDzgAzg8RCDPAX15bi+VdwggA" ' 327, 16.12.2023 15:55:18
Dim lPtr As LongPtr
lPtr = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If lPtr = 0 Then
GoTo QH
End If
If CryptStringToBinary(StrPtr(STR_THUNK), Len(STR_THUNK), CRYPT_STRING_BASE64, lPtr, THUNK_SIZE) = 0 Then
GoTo QH
End If
pvPatchTrampoline AddressOf pvCallMult
If pvCallMult(lPtr, 0, 0) = 0 Then '--- checks if PCLMULQDQ instruction supported
GoTo QH
End If
pvPatchTrampoline AddressOf pvMult
'--- success
pvThunkAllocate = lPtr
lPtr = 0
QH:
If lPtr <> 0 Then
Call VirtualFree(lPtr, THUNK_SIZE, MEM_DECOMMIT)
End If
End Function
Private Function pvPatchTrampoline(ByVal Pfn As LongPtr, Optional ByVal Noop As Boolean) As Boolean
Const PAGE_EXECUTE_READWRITE As Long = &H40
Dim bInIde As Boolean
If Noop Then
pvPatchTrampoline = True
Exit Function
End If
Debug.Assert pvSetTrue(bInIde)
If bInIde Then
Call CopyMemory(Pfn, ByVal Pfn + &H16, 4)
Else
Call VirtualProtect(Pfn, 8, PAGE_EXECUTE_READWRITE, 0)
End If
' 0: 58 pop eax
' 1: 59 pop ecx
' 2: 50 push eax
' 3: ff e1 jmp ecx
' 5: 90 nop
' 6: 90 nop
' 7: 90 nop
Call CopyMemory(ByVal Pfn, -802975883527609.7192@, 8)
'--- success
pvPatchTrampoline = True
End Function
Private Function pvSetTrue(bValue As Boolean) As Boolean
#If TWINBASIC = 0 Then
bValue = True
#End If
pvSetTrue = True
End Function
Private Function pvCallMult(ByVal Pfn As LongPtr, ByVal lPtr1 As LongPtr, ByVal lPtr2 As LongPtr) As Long
'--- trampoline
End Function
#End If
Private Sub pvPrecompute(baKey() As Byte, uKeyTable As ShoupTable)
Dim lIdx As Long
Dim uOne As ArrayLong4
Dim uTemp As ArrayLong4
Dim lCarry As Long
lIdx = UBound(baKey) + 1
If lIdx > LNG_BLOCKSZ Then
lIdx = LNG_BLOCKSZ
End If
If m_hMulThunk <> 0 Then
Call CopyMemory(uKeyTable, baKey(0), lIdx)
Exit Sub
End If
Call CopyMemory(uTemp.Item(0), baKey(0), lIdx)
With uOne
.Item(0) = BSwap32(uTemp.Item(3))
.Item(1) = BSwap32(uTemp.Item(2))
.Item(2) = BSwap32(uTemp.Item(1))
.Item(3) = BSwap32(uTemp.Item(0))
End With
'--- precompute all multiples of H needed for Shoup's method
With uKeyTable
'--- M(1) = H * 1 % POLY
lIdx = 1
.Item(m_aReverse(lIdx)) = uOne
For lIdx = 2 To UBound(.Item)
If (lIdx And 1) <> 0 Then
'--- M(i) = M(i - 1) + M(1) % POLY
uTemp = .Item(m_aReverse(lIdx - 1))
With uTemp
.Item(0) = .Item(0) Xor uOne.Item(0)
.Item(1) = .Item(1) Xor uOne.Item(1)
.Item(2) = .Item(2) Xor uOne.Item(2)
.Item(3) = .Item(3) Xor uOne.Item(3)
End With
Else
'--- M(i) = M(i / 2) * x % POLY
uTemp = .Item(m_aReverse(lIdx \ 2))
With uTemp
lCarry = .Item(0) And 1
#If HasOperators Then
.Item(0) = (.Item(0) >> 1) Or (.Item(1) << 31)
.Item(1) = (.Item(1) >> 1) Or (.Item(2) << 31)
.Item(2) = (.Item(2) >> 1) Or (.Item(3) << 31)
.Item(3) = (.Item(3) >> 1) Xor lCarry * m_aReduce(m_aReverse(1))
#Else
.Item(0) = (.Item(0) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(0) < 0) * LNG_POW2_30 Or (.Item(1) And 1) * LNG_POW2_31
.Item(1) = (.Item(1) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(1) < 0) * LNG_POW2_30 Or (.Item(2) And 1) * LNG_POW2_31
.Item(2) = (.Item(2) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(2) < 0) * LNG_POW2_30 Or (.Item(3) And 1) * LNG_POW2_31
.Item(3) = (.Item(3) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(3) < 0) * LNG_POW2_30 Xor lCarry * m_aReduce(m_aReverse(1))
#End If
End With
End If
.Item(m_aReverse(lIdx)) = uTemp
Next
End With
End Sub
Private Sub pvMult(ByVal Pfn As LongPtr, uKeyTable As ShoupTable, uArray As ArrayByte16)
Dim uBlock As ArrayLong4
Dim lIdx As Long
Dim lNibble As Long
Dim lCarry As Long
Dim uResult As ArrayLong4
With uBlock
lNibble = uArray.Item(LNG_BLOCKSZ - 1) And &HF
.Item(0) = uKeyTable.Item(lNibble).Item(0)
.Item(1) = uKeyTable.Item(lNibble).Item(1)
.Item(2) = uKeyTable.Item(lNibble).Item(2)
.Item(3) = uKeyTable.Item(lNibble).Item(3)
For lIdx = LNG_BLOCKSZ - 1 To 0 Step -1
If lIdx <> LNG_BLOCKSZ - 1 Then
'--- mul 16
lCarry = .Item(0) And &HF
#If HasOperators Then
.Item(0) = (.Item(0) >> 4) Or (.Item(1) << 28)
.Item(1) = (.Item(1) >> 4) Or (.Item(2) << 28)
.Item(2) = (.Item(2) >> 4) Or (.Item(3) << 28)
.Item(3) = (.Item(3) >> 4) Xor m_aReduce(lCarry)
#Else
.Item(0) = (.Item(0) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(0) < 0) * LNG_POW2_27 _
Or (.Item(1) And (LNG_POW2_3 - 1)) * LNG_POW2_28 Or -((.Item(1) And LNG_POW2_3) <> 0) * LNG_POW2_31
.Item(1) = (.Item(1) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(1) < 0) * LNG_POW2_27 _
Or (.Item(2) And (LNG_POW2_3 - 1)) * LNG_POW2_28 Or -((.Item(2) And LNG_POW2_3) <> 0) * LNG_POW2_31
.Item(2) = (.Item(2) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(2) < 0) * LNG_POW2_27 _
Or (.Item(3) And (LNG_POW2_3 - 1)) * LNG_POW2_28 Or -((.Item(3) And LNG_POW2_3) <> 0) * LNG_POW2_31
.Item(3) = (.Item(3) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(3) < 0) * LNG_POW2_27 _
Xor m_aReduce(lCarry)
#End If
'--- add lower nibble
lNibble = uArray.Item(lIdx) And &HF
.Item(0) = .Item(0) Xor uKeyTable.Item(lNibble).Item(0)
.Item(1) = .Item(1) Xor uKeyTable.Item(lNibble).Item(1)
.Item(2) = .Item(2) Xor uKeyTable.Item(lNibble).Item(2)
.Item(3) = .Item(3) Xor uKeyTable.Item(lNibble).Item(3)
End If
'--- mul 16
lCarry = .Item(0) And &HF
#If HasOperators Then
.Item(0) = (.Item(0) >> 4) Or (.Item(1) << 28)
.Item(1) = (.Item(1) >> 4) Or (.Item(2) << 28)
.Item(2) = (.Item(2) >> 4) Or (.Item(3) << 28)
.Item(3) = (.Item(3) >> 4) Xor m_aReduce(lCarry)
#Else
.Item(0) = (.Item(0) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(0) < 0) * LNG_POW2_27 _
Or (.Item(1) And (LNG_POW2_3 - 1)) * LNG_POW2_28 Or -((.Item(1) And LNG_POW2_3) <> 0) * LNG_POW2_31
.Item(1) = (.Item(1) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(1) < 0) * LNG_POW2_27 _
Or (.Item(2) And (LNG_POW2_3 - 1)) * LNG_POW2_28 Or -((.Item(2) And LNG_POW2_3) <> 0) * LNG_POW2_31
.Item(2) = (.Item(2) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(2) < 0) * LNG_POW2_27 _
Or (.Item(3) And (LNG_POW2_3 - 1)) * LNG_POW2_28 Or -((.Item(3) And LNG_POW2_3) <> 0) * LNG_POW2_31
.Item(3) = (.Item(3) And &H7FFFFFFF) \ LNG_POW2_4 Or -(.Item(3) < 0) * LNG_POW2_27 _
Xor m_aReduce(lCarry)
#End If
'--- add upper nibble
lNibble = (uArray.Item(lIdx) \ LNG_POW2_4) And &HF
.Item(0) = .Item(0) Xor uKeyTable.Item(lNibble).Item(0)
.Item(1) = .Item(1) Xor uKeyTable.Item(lNibble).Item(1)
.Item(2) = .Item(2) Xor uKeyTable.Item(lNibble).Item(2)
.Item(3) = .Item(3) Xor uKeyTable.Item(lNibble).Item(3)
Next
End With
With uResult
.Item(0) = BSwap32(uBlock.Item(3))
.Item(1) = BSwap32(uBlock.Item(2))
.Item(2) = BSwap32(uBlock.Item(1))
.Item(3) = BSwap32(uBlock.Item(0))
End With
LSet uArray = uResult
End Sub
Private Function pvUpdate(uKeyTable As ShoupTable, uArray As ArrayByte16, baInput() As Byte, ByVal lPos As Long, ByVal lSize As Long, Optional ByVal Offset As Long) As Long
Dim lIdx As Long
With uArray
For lIdx = 0 To lSize - 1
.Item(Offset) = .Item(Offset) Xor baInput(lPos + lIdx)
Offset = Offset + 1
If Offset = LNG_BLOCKSZ Then
Offset = 0
#If TWINBASIC = 0 Then
Debug.Assert pvPatchTrampoline(AddressOf pvMult, m_hMulThunk = 0)
#End If
pvMult m_hMulThunk, uKeyTable, uArray
End If
Next
End With
pvUpdate = Offset
End Function
Public Sub CryptoGhashInit(uCtx As CryptoGhashContext, baKey() As Byte)
Dim uEmpty As ArrayByte16
If m_aReduce(1) = 0 Then
pvInit
End If
With uCtx
pvPrecompute baKey, .KeyTable
.HashArray = uEmpty
.NPosition = 0
End With
End Sub
Public Sub CryptoGhashGenerCounter(uCtx As CryptoGhashContext, baInput() As Byte, baOutput() As Byte)
Dim lSize As Long
Dim uResult As ArrayByte16
Dim uArray As ArrayByte16
lSize = UBound(baInput) + 1
If lSize = 12 Then '--- 96 bits
Call CopyMemory(uResult.Item(0), baInput(0), lSize)
uResult.Item(LNG_BLOCKSZ - 1) = 1
Else
pvUpdate uCtx.KeyTable, uResult, baInput, 0, lSize
If lSize Mod LNG_BLOCKSZ <> 0 Then
pvUpdate uCtx.KeyTable, uResult, uArray.Item, 0, LNG_BLOCKSZ - lSize Mod LNG_BLOCKSZ, lSize Mod LNG_BLOCKSZ
End If
lSize = BSwap32(lSize * 8)
Call CopyMemory(uArray.Item(12), lSize, LenB(lSize))
pvUpdate uCtx.KeyTable, uResult, uArray.Item, 0, LNG_BLOCKSZ
End If
If UBound(baOutput) <> LNG_BLOCKSZ - 1 Then
ReDim baOutput(0 To LNG_BLOCKSZ - 1) As Byte
End If
Call CopyMemory(baOutput(0), uResult.Item(0), LNG_BLOCKSZ)
End Sub
Public Sub CryptoGhashUpdate(uCtx As CryptoGhashContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
uCtx.NPosition = pvUpdate(uCtx.KeyTable, uCtx.HashArray, baInput, Pos, Size, Offset:=uCtx.NPosition)
End Sub
Public Sub CryptoGhashPad(uCtx As CryptoGhashContext)
If uCtx.NPosition > 0 Then
#If TWINBASIC = 0 Then
Debug.Assert pvPatchTrampoline(AddressOf pvMult, m_hMulThunk = 0)
#End If
pvMult m_hMulThunk, uCtx.KeyTable, uCtx.HashArray
uCtx.NPosition = 0
End If
End Sub
Public Sub CryptoGhashFinalize(uCtx As CryptoGhashContext, ByVal lTagSize As Long, baTag() As Byte)
If lTagSize < 4 Or lTagSize > LNG_BLOCKSZ Then
Err.Raise vbObjectError, , "Invalid tag size for Ghash (" & lTagSize & ")"
End If
With uCtx
ReDim baTag(0 To lTagSize - 1) As Byte
Call CopyMemory(baTag(0), .HashArray, lTagSize)
End With
End Sub
'= AES-GCM ===============================================================
Private Function pvFinalize(uCtx As CryptoAesGcmContext, ByVal lTagSize As Long, baTag() As Byte)
Dim cTemp As Currency
Dim aTemp(0 To 1) As Long
Dim uBlock As ArrayLong4
Dim uArray As ArrayByte16
Dim lIdx As Long
With uCtx
CryptoGhashPad .GhashCtx
'--- absorb bit-size of AAD and plaintext
cTemp = .AadSize * 8@ / 10000@
Call CopyMemory(aTemp(0), cTemp, 8)
uBlock.Item(0) = BSwap32(aTemp(1))
uBlock.Item(1) = BSwap32(aTemp(0))
cTemp = .TotalSize * 8@ / 10000@
Call CopyMemory(aTemp(0), cTemp, 8)
uBlock.Item(2) = BSwap32(aTemp(1))
uBlock.Item(3) = BSwap32(aTemp(0))
LSet uArray = uBlock
CryptoGhashUpdate .GhashCtx, uArray.Item
'--- finalize hash
CryptoGhashFinalize .GhashCtx, lTagSize, baTag
For lIdx = 0 To lTagSize - 1
baTag(lIdx) = baTag(lIdx) Xor .Counter(lIdx)
Next
End With
End Function
Public Sub CryptoAesGcmInit(uCtx As CryptoAesGcmContext, baKey() As Byte, baNonce() As Byte, baAad() As Byte)
Dim baAuthKey(0 To LNG_BLOCKSZ - 1) As Byte
If UBound(baNonce) + 1 = 0 Then
Err.Raise vbObjectError, , "Invalid Nonce size for AES-GCM (" & UBound(baNonce) + 1 & ")"
End If
With uCtx
CryptoAesInit uCtx.AesCtx, baKey
'--- encrypt a block of zeroes to create the hashing key
CryptoAesProcess .AesCtx, baAuthKey
CryptoGhashInit .GhashCtx, baAuthKey
CryptoGhashGenerCounter .GhashCtx, baNonce, .Counter
'--- setup AES counter
CryptoAesSetNonce .AesCtx, .Counter, CounterWords:=1
CryptoAesProcess .AesCtx, .Counter
'--- absorb AAD into the hash
CryptoGhashUpdate .GhashCtx, baAad
CryptoGhashPad .GhashCtx
.AadSize = UBound(baAad) + 1
.TotalSize = 0
End With
End Sub
Public Sub CryptoAesGcmEncrypt(uCtx As CryptoAesGcmContext, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional TagSize As Long, Optional Tag As Variant)
Dim baTag() As Byte
If Size < 0 Then
Size = UBound(baBuffer) + 1 - Pos
End If
With uCtx
CryptoAesCtrCrypt .AesCtx, baBuffer, Pos, Size, CounterWords:=1
CryptoGhashUpdate .GhashCtx, baBuffer, Pos, Size
.TotalSize = .TotalSize + Size
If TagSize > 0 Then
pvFinalize uCtx, TagSize, baTag
Tag = baTag
End If
End With
End Sub
Public Function CryptoAesGcmDecrypt(uCtx As CryptoAesGcmContext, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Tag As Variant) As Boolean
Dim baTag() As Byte
Dim baCalc() As Byte
If Size < 0 Then
Size = UBound(baBuffer) + 1 - Pos
End If
With uCtx
CryptoGhashUpdate .GhashCtx, baBuffer, Pos, Size
.TotalSize = .TotalSize + Size
If Not IsMissing(Tag) Then
baTag = Tag
pvFinalize uCtx, UBound(baTag) + 1, baCalc
If InStrB(baTag, baCalc) <> 1 Then
Exit Function
End If
End If
CryptoAesCtrCrypt .AesCtx, baBuffer, Pos, Size, CounterWords:=1
End With
'--- success
CryptoAesGcmDecrypt = True
End Function
'= POLYVAL ===============================================================
Private Function pvReverseArray(baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
Dim baOutput() As Byte
Dim lIdx As Long
Dim lJdx As Long
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
lJdx = ((Size + LNG_BLOCKSZ - 1) And -LNG_BLOCKSZ) - 1
ReDim baOutput(0 To lJdx) As Byte
For lIdx = 0 To Size - 1
lJdx = (lIdx And -LNG_BLOCKSZ) + (LNG_BLOCKSZ - 1) - (lIdx And (LNG_BLOCKSZ - 1))
baOutput(lJdx) = baInput(Pos + lIdx)
Next
pvReverseArray = baOutput
End Function
Private Function pvMulX(baInput() As Byte) As Byte()
Dim lIdx As Long
Dim uTemp As ArrayLong4
Dim lCarry As Long
Dim baOutput() As Byte
If m_aReduce(1) = 0 Then
pvInit
End If
lIdx = UBound(baInput) + 1
If lIdx > LNG_BLOCKSZ Then
lIdx = LNG_BLOCKSZ
End If
Call CopyMemory(uTemp.Item(0), baInput(0), lIdx)
With uTemp
lCarry = .Item(0) And 1
#If HasOperators Then
.Item(0) = (.Item(0) >> 1) Or (.Item(1) << 31)
.Item(1) = (.Item(1) >> 1) Or (.Item(2) << 31)
.Item(2) = (.Item(2) >> 1) Or (.Item(3) << 31)
.Item(3) = (.Item(3) >> 1) Xor lCarry * m_aReduce(m_aReverse(1))
#Else
.Item(0) = (.Item(0) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(0) < 0) * LNG_POW2_30 Or (.Item(1) And 1) * LNG_POW2_31
.Item(1) = (.Item(1) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(1) < 0) * LNG_POW2_30 Or (.Item(2) And 1) * LNG_POW2_31
.Item(2) = (.Item(2) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(2) < 0) * LNG_POW2_30 Or (.Item(3) And 1) * LNG_POW2_31
.Item(3) = (.Item(3) And &H7FFFFFFF) \ LNG_POW2_1 Or -(.Item(3) < 0) * LNG_POW2_30 Xor lCarry * m_aReduce(m_aReverse(1))
#End If
End With
ReDim baOutput(0 To LNG_BLOCKSZ - 1) As Byte
Call CopyMemory(baOutput(0), uTemp.Item(0), LNG_BLOCKSZ)
pvMulX = baOutput
End Function
Public Sub CryptoPolyvalInit(uCtx As CryptoGhashContext, baKey() As Byte)
CryptoGhashInit uCtx, pvReverseArray(pvMulX(baKey))
End Sub
Public Sub CryptoPolyvalUpdate(uCtx As CryptoGhashContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Const LNG_STEP As Long = 16 * LNG_BLOCKSZ
Dim lIdx As Long
Dim baTemp(0 To LNG_STEP - 1) As Byte
Dim lJdx As Long
Dim lKdx As Long
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
For lIdx = 0 To Size \ LNG_STEP - 1
lKdx = Pos + lIdx * LNG_STEP + LNG_STEP - 1
For lJdx = 0 To LNG_STEP - 1
baTemp(lJdx) = baInput(lKdx - lJdx)
Next
CryptoGhashUpdate uCtx, baTemp
Next
If Size > lIdx * LNG_STEP Then
CryptoGhashUpdate uCtx, pvReverseArray(baInput, Pos + lIdx * LNG_STEP)
End If
End Sub
Public Sub CryptoPolyvalFinalize(uCtx As CryptoGhashContext, ByVal lTagSize As Long, baTag() As Byte)
CryptoGhashFinalize uCtx, lTagSize, baTag
baTag = pvReverseArray(baTag)
End Sub
'= AES-GCM-SIV ===============================================================
Public Sub pvDeriveKeys(uCtx As CryptoAesGcmContext, baKey() As Byte, baNonce() As Byte)
Const LNG_HALFSZ As Long = LNG_BLOCKSZ \ 2
Dim baEncKey() As Byte
Dim baAuthKey() As Byte
Dim baDerived() As Byte
Dim baBlock() As Byte
Dim lIdx As Long
If UBound(baKey) + 1 <> 16 And UBound(baKey) + 1 <> 32 Then
Err.Raise vbObjectError, , "Invalid key size for AES-GCM-SIV (" & UBound(baKey) + 1 & ")"
End If
If UBound(baNonce) + 1 <> 12 Then
Err.Raise vbObjectError, , "Invalid nonce size for AES-GCM-SIV (" & UBound(baNonce) + 1 & ")"
End If
With uCtx
CryptoAesInit uCtx.AesCtx, baKey
ReDim baEncKey(0 To UBound(baKey)) As Byte
ReDim baAuthKey(0 To LNG_BLOCKSZ - 1) As Byte
ReDim baDerived(0 To LNG_BLOCKSZ + UBound(baEncKey)) As Byte
ReDim baBlock(0 To LNG_BLOCKSZ - 1) As Byte
For lIdx = 0 To UBound(baDerived) \ LNG_HALFSZ
Call CopyMemory(baBlock(0), lIdx, LenB(lIdx))
Call CopyMemory(baBlock(4), baNonce(0), UBound(baNonce) + 1)
CryptoAesProcess .AesCtx, baBlock
Call CopyMemory(baDerived(lIdx * LNG_HALFSZ), baBlock(0), LNG_HALFSZ)
Next
Call CopyMemory(baAuthKey(0), baDerived(0), LNG_BLOCKSZ)
Call CopyMemory(baEncKey(0), baDerived(LNG_BLOCKSZ), UBound(baKey) + 1)
CryptoAesInit uCtx.AesCtx, baEncKey
CryptoPolyvalInit .GhashCtx, baAuthKey
End With
End Sub
Public Sub CryptoAesGcmSivEncrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baBuffer() As Byte, baTag() As Byte)
Dim uCtx As CryptoAesGcmContext
Dim baTemp() As Byte
Dim cTemp As Currency
Dim lIdx As Long
pvDeriveKeys uCtx, baKey, baNonce
With uCtx
CryptoPolyvalUpdate .GhashCtx, baAad
CryptoPolyvalUpdate .GhashCtx, baBuffer
ReDim baTemp(0 To LNG_BLOCKSZ - 1) As Byte
cTemp = (UBound(baAad) + 1) * 8@ / 10000@
Call CopyMemory(baTemp(0), cTemp, 8)
cTemp = (UBound(baBuffer) + 1) * 8@ / 10000@
Call CopyMemory(baTemp(8), cTemp, 8)
CryptoPolyvalUpdate .GhashCtx, baTemp
CryptoPolyvalFinalize .GhashCtx, LNG_BLOCKSZ, baTemp
For lIdx = 0 To UBound(baNonce)
baTemp(lIdx) = baTemp(lIdx) Xor baNonce(lIdx)
Next
baTemp(15) = baTemp(15) And &H7F
CryptoAesProcess .AesCtx, baTemp
baTag = baTemp
baTemp(15) = baTemp(15) Or &H80
CryptoAesSetNonce .AesCtx, baTemp
CryptoAesCtrCrypt .AesCtx, baBuffer, CounterWords:=-1
End With
End Sub
Public Function CryptoAesGcmSivDecrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baBuffer() As Byte, baTag() As Byte) As Boolean
Dim uCtx As CryptoAesGcmContext
Dim baTemp() As Byte
Dim cTemp As Currency
Dim lIdx As Long
If UBound(baTag) + 1 <> 16 Then
Err.Raise vbObjectError, , "Invalid tag size for AES-GCM-SIV (" & UBound(baTag) + 1 & ")"
End If
pvDeriveKeys uCtx, baKey, baNonce
With uCtx
baTemp = baTag
baTemp(15) = baTemp(15) Or &H80
CryptoAesSetNonce .AesCtx, baTemp
CryptoAesCtrCrypt .AesCtx, baBuffer, CounterWords:=-1
CryptoPolyvalUpdate .GhashCtx, baAad
CryptoPolyvalUpdate .GhashCtx, baBuffer
cTemp = (UBound(baAad) + 1) * 8@ / 10000@
Call CopyMemory(baTemp(0), cTemp, 8)
cTemp = (UBound(baBuffer) + 1) * 8@ / 10000@
Call CopyMemory(baTemp(8), cTemp, 8)
CryptoPolyvalUpdate .GhashCtx, baTemp
CryptoPolyvalFinalize .GhashCtx, LNG_BLOCKSZ, baTemp
For lIdx = 0 To UBound(baNonce)
baTemp(lIdx) = baTemp(lIdx) Xor baNonce(lIdx)
Next
baTemp(15) = baTemp(15) And &H7F
CryptoAesProcess .AesCtx, baTemp
If InStrB(baTemp, baTag) <> 1 Then
GoTo QH
End If
End With
'--- success
CryptoAesGcmSivDecrypt = True
QH:
End Function
Raw
mdAesOcb.bas
'--- mdAesOcb.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 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 ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) 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 LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
#End If
Private Const LNG_BLOCKSZ As Long = 16
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 Type ArrayLong4
Item(0 To 3) As Long
End Type
Public Type CryptoAesOcbContext
AesCtx As CryptoAesContext
K1 As ArrayLong4
K2 As ArrayLong4
L() As ArrayLong4
NumLookups As Long
Offset As ArrayLong4
Checksum As ArrayLong4
Sum As ArrayLong4
NumBlocks As Long
End Type
Private Sub pvShift(baInput() As Byte, ByVal lPos As Long, ByVal lBits As Long, uOutput As ArrayLong4)
Dim lPow1 As Long
Dim lPow2 As Long
Dim lIdx As Long
Dim lNext As Long
Dim lCarry As Long
Dim baOutput(0 To LNG_BLOCKSZ - 1) As Byte
lPow1 = 2 ^ (8 - lBits)
lPow2 = 2 ^ lBits
lCarry = baInput(lPos + LNG_BLOCKSZ) \ lPow1
For lIdx = LNG_BLOCKSZ - 1 To 0 Step -1
lNext = baInput(lPos + lIdx) \ lPow1
baOutput(lIdx) = (baInput(lPos + lIdx) * lPow2) And &HFF Or lCarry
lCarry = lNext
Next
Call CopyMemory(uOutput, baOutput(0), LNG_BLOCKSZ)
End Sub
Private Sub pvDouble(uInput As ArrayLong4, uOutput As ArrayLong4)
Const LNG_POLY As Long = &H87
Dim baInput(0 To LNG_BLOCKSZ - 1) As Byte
Dim baOutput(0 To LNG_BLOCKSZ - 1) As Byte
Dim lIdx As Long
Dim lTemp As Long
Dim lCarry As Long
Call CopyMemory(baInput(0), uInput, LNG_BLOCKSZ)
For lIdx = LNG_BLOCKSZ - 1 To 0 Step -1
lTemp = baInput(lIdx)
baOutput(lIdx) = (lTemp * 2) And &HFF Or lCarry
lCarry = -((lTemp And &H80) <> 0)
Next
baOutput(LNG_BLOCKSZ - 1) = baOutput(LNG_BLOCKSZ - 1) Xor lCarry * LNG_POLY
Call CopyMemory(uOutput, baOutput(0), LNG_BLOCKSZ)
End Sub
Private Function pvNtz(ByVal lBlock As Long) As Long
'--- find first not-zero bit
Do While (lBlock And 1) = 0
pvNtz = pvNtz + 1
lBlock = lBlock \ 2
Loop
End Function
Private Sub pvLookupL(uCtx As CryptoAesOcbContext, ByVal lBlock As Long, uOutput As ArrayLong4)
Dim lNtz As Long
lNtz = pvNtz(lBlock)
With uCtx
If lNtz > UBound(.L) Then
ReDim Preserve .L(0 To lNtz + 3) As ArrayLong4
End If
Do While .NumLookups < lNtz
pvDouble .L(.NumLookups), .L(.NumLookups + 1)
.NumLookups = .NumLookups + 1
Loop
uOutput = .L(lNtz)
End With
End Sub
Public Function pvProcess(uCtx As CryptoAesOcbContext, ByVal bDecrypt As Boolean, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long, ByVal lTagSize As Long, Tag As Variant) As Boolean
Const FADF_AUTO As Long = 1
Dim aBlock() As ArrayLong4
Dim uPeekBlock As SAFEARRAY1D
Dim lIdx As Long
Dim lJdx As Long
Dim uTemp As ArrayLong4
Dim baCalcTag() As Byte
Dim uPad As ArrayLong4
Dim uChecksumPad As ArrayLong4
Dim lNtz As Long
If lSize < 0 Then
lSize = UBound(baBuffer) + 1 - lPos
End If
With uCtx
If lSize >= LNG_BLOCKSZ Then
With uPeekBlock
.cDims = 1
.fFeatures = FADF_AUTO
.cbElements = LNG_BLOCKSZ
.cLocks = 1
.pvData = VarPtr(baBuffer(lPos))
.cElements = lSize \ .cbElements
End With
Call CopyMemory(ByVal ArrPtr(aBlock), VarPtr(uPeekBlock), 4)
End If
lIdx = .NumBlocks + lSize \ LNG_BLOCKSZ
Do While lIdx > 0
lIdx = lIdx \ 2
lNtz = lNtz + 1
Loop
If lNtz > UBound(.L) Then
ReDim Preserve .L(0 To lNtz + 3) As ArrayLong4
End If
Do While .NumLookups < lNtz
pvDouble .L(.NumLookups), .L(.NumLookups + 1)
.NumLookups = .NumLookups + 1
Loop
For lJdx = 0 To lSize \ LNG_BLOCKSZ - 1
.NumBlocks = .NumBlocks + 1
lNtz = pvNtz(.NumBlocks)
.Offset.Item(0) = .Offset.Item(0) Xor .L(lNtz).Item(0)
.Offset.Item(1) = .Offset.Item(1) Xor .L(lNtz).Item(1)
.Offset.Item(2) = .Offset.Item(2) Xor .L(lNtz).Item(2)
.Offset.Item(3) = .Offset.Item(3) Xor .L(lNtz).Item(3)
If Not bDecrypt Then
.Checksum.Item(0) = .Checksum.Item(0) Xor aBlock(lJdx).Item(0)
.Checksum.Item(1) = .Checksum.Item(1) Xor aBlock(lJdx).Item(1)
.Checksum.Item(2) = .Checksum.Item(2) Xor aBlock(lJdx).Item(2)
.Checksum.Item(3) = .Checksum.Item(3) Xor aBlock(lJdx).Item(3)
End If
aBlock(lJdx).Item(0) = aBlock(lJdx).Item(0) Xor .Offset.Item(0)
aBlock(lJdx).Item(1) = aBlock(lJdx).Item(1) Xor .Offset.Item(1)
aBlock(lJdx).Item(2) = aBlock(lJdx).Item(2) Xor .Offset.Item(2)
aBlock(lJdx).Item(3) = aBlock(lJdx).Item(3) Xor .Offset.Item(3)
CryptoAesProcessPtr .AesCtx, VarPtr(aBlock(lJdx)), Decrypt:=bDecrypt
aBlock(lJdx).Item(0) = aBlock(lJdx).Item(0) Xor .Offset.Item(0)
aBlock(lJdx).Item(1) = aBlock(lJdx).Item(1) Xor .Offset.Item(1)
aBlock(lJdx).Item(2) = aBlock(lJdx).Item(2) Xor .Offset.Item(2)
aBlock(lJdx).Item(3) = aBlock(lJdx).Item(3) Xor .Offset.Item(3)
If bDecrypt Then
.Checksum.Item(0) = .Checksum.Item(0) Xor aBlock(lJdx).Item(0)
.Checksum.Item(1) = .Checksum.Item(1) Xor aBlock(lJdx).Item(1)
.Checksum.Item(2) = .Checksum.Item(2) Xor aBlock(lJdx).Item(2)
.Checksum.Item(3) = .Checksum.Item(3) Xor aBlock(lJdx).Item(3)
End If
lPos = lPos + LNG_BLOCKSZ
Next
If lTagSize > 0 Then
lSize = lSize Mod LNG_BLOCKSZ
If lSize > 0 Then
For lIdx = 0 To 3
.Offset.Item(lIdx) = .Offset.Item(lIdx) Xor .K1.Item(lIdx)
Next
uTemp = .Offset
CryptoAesProcessPtr .AesCtx, VarPtr(uTemp)
Call CopyMemory(uPad, baBuffer(lPos), lSize)
Call CopyMemory(ByVal VarPtr(uPad) + lSize, &H80, 1)
For lIdx = 0 To 3
If Not bDecrypt Then
uChecksumPad.Item(lIdx) = .Checksum.Item(lIdx) Xor uPad.Item(lIdx)
End If
uPad.Item(lIdx) = uPad.Item(lIdx) Xor uTemp.Item(lIdx)
If bDecrypt Then
Call CopyMemory(ByVal VarPtr(uPad) + lSize, &H80, 1)
uChecksumPad.Item(lIdx) = .Checksum.Item(lIdx) Xor uPad.Item(lIdx)
End If
Next
Call CopyMemory(baBuffer(lPos), uPad, lSize)
Call CopyMemory(.Checksum, uChecksumPad, lSize + 1)
End If
pvFinalize uCtx, lTagSize, baCalcTag
If bDecrypt Then
If InStrB(baCalcTag, Tag) <> 1 Then
GoTo QH
End If
Else
Tag = baCalcTag
End If
Else
Debug.Assert lSize Mod 16 = 0
End If
End With
'--- success
pvProcess = True
QH:
End Function
Private Sub pvFinalize(uCtx As CryptoAesOcbContext, ByVal lTagSize As Long, baTag() As Byte)
Dim uTemp As ArrayLong4
Dim lIdx As Long
With uCtx
If lTagSize < 1 Or lTagSize > LNG_BLOCKSZ Then
Err.Raise vbObjectError, , "Invalid tag size for AES-OCB (" & lTagSize & ")"
End If
For lIdx = 0 To 3
uTemp.Item(lIdx) = .Offset.Item(lIdx) Xor .Checksum.Item(lIdx) Xor .K2.Item(lIdx)
Next
CryptoAesProcessPtr .AesCtx, VarPtr(uTemp)
For lIdx = 0 To 3
uTemp.Item(lIdx) = uTemp.Item(lIdx) Xor .Sum.Item(lIdx)
Next
ReDim baTag(0 To lTagSize - 1) As Byte
Call CopyMemory(baTag(0), uTemp, lTagSize)
End With
End Sub
Public Sub CryptoAesOcbInit(uCtx As CryptoAesOcbContext, baKey() As Byte, baNonce() As Byte, baAad() As Byte, Optional ByVal TagSize As Long = LNG_BLOCKSZ)
Dim uEmpty As ArrayLong4
Dim lIdx As Long
Dim lSize As Long
Dim lBottom As Long
Dim baKtop(0 To LNG_BLOCKSZ - 1) As Byte
Dim baStretch(0 To LNG_BLOCKSZ + LNG_BLOCKSZ \ 2 - 1) As Byte
Dim lJdx As Long
Dim lBlock As Long
Dim lPos As Long
Dim uLookup As ArrayLong4
Dim uOffset As ArrayLong4
Dim uTemp As ArrayLong4
Dim uAad As ArrayLong4
With uCtx
CryptoAesInit .AesCtx, baKey
.K1 = uEmpty
CryptoAesProcessPtr .AesCtx, VarPtr(.K1)
pvDouble .K1, .K2
.NumLookups = 4
ReDim .L(0 To .NumLookups) As ArrayLong4
pvDouble .K2, .L(0)
For lIdx = 1 To .NumLookups
pvDouble .L(lIdx - 1), .L(lIdx)
Next
.Offset = uEmpty
.Checksum = uEmpty
.Sum = uEmpty
.NumBlocks = 0
'--- setup IV
lSize = UBound(baNonce) + 1
If lSize > LNG_BLOCKSZ - 1 Or lSize <= 0 Then
Err.Raise vbObjectError, , "Invalid Nonce size for AES-OCB (" & lSize & ")"
End If
'--- Nonce = num2str(TAGLEN mod 128,7) || zeros(120-bitlen(N)) || 1 || N
baKtop(0) = (TagSize * 8 Mod 128) * 2
baKtop(LNG_BLOCKSZ - lSize - 1) = baKtop(LNG_BLOCKSZ - lSize - 1) Or 1
Call CopyMemory(baKtop(LNG_BLOCKSZ - lSize), baNonce(0), lSize)
'--- bottom = str2num(Nonce[123..128])
lBottom = baKtop(LNG_BLOCKSZ - 1) And &H3F
'--- Ktop = ENCIPHER(K, Nonce[1..122] || zeros(6))
baKtop(LNG_BLOCKSZ - 1) = baKtop(LNG_BLOCKSZ - 1) And &HC0
CryptoAesProcess .AesCtx, baKtop
'--- Stretch = Ktop || (Ktop[1..64] xor Ktop[9..72])
Call CopyMemory(baStretch(0), baKtop(0), LNG_BLOCKSZ)
For lIdx = 0 To LNG_BLOCKSZ \ 2 - 1
baStretch(lIdx + LNG_BLOCKSZ) = baKtop(lIdx) Xor baKtop(lIdx + 1)
Next
'--- Offset_0 = Stretch[1+bottom..128+bottom]
pvShift baStretch, lBottom \ 8, lBottom Mod 8, .Offset
'--- setup AAD
lSize = UBound(baAad) + 1
For lJdx = 0 To lSize \ LNG_BLOCKSZ - 1
lBlock = lBlock + 1
pvLookupL uCtx, lBlock, uLookup
Call CopyMemory(uAad, baAad(lPos), LNG_BLOCKSZ)
For lIdx = 0 To 3
uOffset.Item(lIdx) = uOffset.Item(lIdx) Xor uLookup.Item(lIdx)
uTemp.Item(lIdx) = uAad.Item(lIdx) Xor uOffset.Item(lIdx)
Next
CryptoAesProcessPtr .AesCtx, VarPtr(uTemp)
For lIdx = 0 To 3
.Sum.Item(lIdx) = .Sum.Item(lIdx) Xor uTemp.Item(lIdx)
Next
lPos = lPos + LNG_BLOCKSZ
Next
lSize = lSize Mod LNG_BLOCKSZ
If lSize > 0 Then
uAad = uEmpty
Call CopyMemory(uAad, baAad(lPos), lSize)
Call CopyMemory(ByVal VarPtr(uAad) + lSize, &H80, 1)
For lIdx = 0 To 3
uTemp.Item(lIdx) = uAad.Item(lIdx) Xor uOffset.Item(lIdx) Xor .K1.Item(lIdx)
Next
CryptoAesProcessPtr .AesCtx, VarPtr(uTemp)
For lIdx = 0 To 3
.Sum.Item(lIdx) = .Sum.Item(lIdx) Xor uTemp.Item(lIdx)
Next
End If
End With
End Sub
Public Sub CryptoAesOcbEncrypt(uCtx As CryptoAesOcbContext, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional ByVal TagSize As Long, Optional Tag As Variant)
pvProcess uCtx, False, baBuffer, Pos, Size, TagSize, Tag
End Sub
Public Function CryptoAesOcbDecrypt(uCtx As CryptoAesOcbContext, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Tag As Variant) As Boolean
CryptoAesOcbDecrypt = pvProcess(uCtx, True, baBuffer, Pos, Size, LNG_BLOCKSZ, Tag)
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment