Skip to content

Instantly share code, notes, and snippets.

@wqweto

wqweto/mdCurve25519.bas

Last active February 14, 2025 14:51
Show Gist options
  • Save wqweto/f7d637236bd9f68bcf0b8b27370fd4f6 to your computer and use it in GitHub Desktop.
Save wqweto/f7d637236bd9f68bcf0b8b27370fd4f6 to your computer and use it in GitHub Desktop.
Download ZIP
[VB6/VBA] X25519 for ECDH key exchange and Ed25519 for EdDSA signatures
Raw
mdCurve25519.bas
'--- mdCurve25519.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 0)
#Const HasSha512 = (CRYPT_HAS_SHA512 <> 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 RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength 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 RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
#End If
Private Const LNG_ELEMSZ As Long = 16
Private Const LNG_KEYSZ As Long = 32
Private Const LNG_HASHSZ As Long = 64 '--- SHA-512
Private Const LNG_HALFHASHSZ As Long = LNG_HASHSZ \ 2
Private Const LNG_POW16 As Long = 2 ^ 16
#If HasPtrSafe Then
Private m_lZero As LongLong
#Else
Private m_lZero As Variant
#End If
Private LNG_POW2(0 To 7) As Long
Private EmptyByteArray() As Byte
Private m_gf0 As GF25519Element
Private m_gf1 As GF25519Element
Private m_gfD As GF25519Element
Private m_gfD2 As GF25519Element
Private m_gfX As GF25519Element
Private m_gfY As GF25519Element
Private m_gfI As GF25519Element
Private m_aL As ArrayLong64
Private Type GF25519Element
#If HasPtrSafe Then
Item(0 To LNG_ELEMSZ - 1) As LongLong
#Else
Item(0 To LNG_ELEMSZ - 1) As Variant
#End If
End Type
Private Type XyztPoint
gfX As GF25519Element
gfY As GF25519Element
gfZ As GF25519Element
gfT As GF25519Element
End Type
Private Type ArrayLong64
#If HasPtrSafe Then
Item(0 To 63) As LongLong
#Else
Item(0 To 63) As Variant
#End If
End Type
#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 pvInit(Optional ByVal Extended As Boolean)
Dim lIdx As Long
Dim vElem As Variant
If LNG_POW2(0) = 0 Then
LNG_POW2(0) = 1
For lIdx = 1 To UBound(LNG_POW2)
LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
Next
EmptyByteArray = vbNullString
m_lZero = CLngLng(0)
End If
If m_gf1.Item(0) = 0 And Extended Then
pvGF25519Assign m_gf0, "0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0"
pvGF25519Assign m_gf1, "1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0"
pvGF25519Assign m_gfD, "78A3 1359 4DCA 75EB D8AB 4141 0A4D 0070 E898 7779 4079 8CC7 FE73 2B6F 6CEE 5203"
pvGF25519Assign m_gfD2, "F159 26B2 9B94 EBD6 B156 8283 149A 00E0 D130 EEF3 80F2 198E FCE7 56DF D9DC 2406"
pvGF25519Assign m_gfX, "D51A 8F25 2D60 C956 A7B2 9525 C760 692C DC5C FDD6 E231 C0A4 53FE CD6E 36D3 2169"
pvGF25519Assign m_gfY, "6658 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666"
pvGF25519Assign m_gfI, "A0B0 4A0E 1B27 C4EE E478 AD2F 1806 2F43 D7A7 3DFB 0099 2B4D DF0B 4FC1 2480 2B83"
lIdx = 0
For Each vElem In Split("ED D3 F5 5C 1A 63 12 58 D6 9C F7 A2 DE F9 DE 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10")
m_aL.Item(lIdx) = CLngLng(CStr("&H" & vElem))
lIdx = lIdx + 1
Next
End If
End Sub
Private Sub pvGF25519Sel(uA As GF25519Element, uB As GF25519Element, ByVal bSwap As Boolean)
Dim lIdx As Long
#If HasPtrSafe Then
Dim lTemp As LongLong
#Else
Dim lTemp As Variant
#End If
For lIdx = 0 To LNG_ELEMSZ - 1
lTemp = (uA.Item(lIdx) Xor uB.Item(lIdx)) And bSwap
uA.Item(lIdx) = uA.Item(lIdx) Xor lTemp
uB.Item(lIdx) = uB.Item(lIdx) Xor lTemp
Next
End Sub
Private Sub pvGF25519Car(uRetVal As GF25519Element)
Dim lIdx As Long
Dim lNext As Long
#If HasPtrSafe Then
Dim lCarry As LongLong
#Else
Dim lCarry As Variant
#End If
For lIdx = 0 To LNG_ELEMSZ - 1
uRetVal.Item(lIdx) = uRetVal.Item(lIdx) + LNG_POW16
lCarry = (uRetVal.Item(lIdx) And -LNG_POW16) \ LNG_POW16
uRetVal.Item(lIdx) = uRetVal.Item(lIdx) - lCarry * LNG_POW16
If lIdx = LNG_ELEMSZ - 1 Then
lCarry = 38 * (lCarry - 1)
Else
lCarry = lCarry - 1
End If
lNext = (lIdx + 1) Mod LNG_ELEMSZ
uRetVal.Item(lNext) = uRetVal.Item(lNext) + lCarry
Next
End Sub
Private Sub pvGF25519Add(uRetVal As GF25519Element, uA As GF25519Element, uB As GF25519Element)
Dim lIdx As Long
For lIdx = 0 To LNG_ELEMSZ - 1
uRetVal.Item(lIdx) = uA.Item(lIdx) + uB.Item(lIdx)
Next
End Sub
Private Sub pvGF25519Sub(uRetVal As GF25519Element, uA As GF25519Element, uB As GF25519Element)
Dim lIdx As Long
For lIdx = 0 To LNG_ELEMSZ - 1
uRetVal.Item(lIdx) = uA.Item(lIdx) - uB.Item(lIdx)
Next
End Sub
Private Sub pvGF25519Mul(uRetVal As GF25519Element, uA As GF25519Element, uB As GF25519Element)
#If HasPtrSafe Then
Static aTemp(0 To LNG_ELEMSZ * 2 - 1) As LongLong
#Else
Static aTemp(0 To LNG_ELEMSZ * 2 - 1) As Variant
#End If
Dim lIdx As Long
Dim lJdx As Long
For lIdx = 0 To UBound(aTemp)
aTemp(lIdx) = CLng(0)
Next
For lIdx = 0 To LNG_ELEMSZ - 1
For lJdx = 0 To LNG_ELEMSZ - 1
aTemp(lIdx + lJdx) = aTemp(lIdx + lJdx) + uA.Item(lIdx) * uB.Item(lJdx)
Next
Next
For lIdx = 0 To LNG_ELEMSZ - 1
If lIdx < LNG_ELEMSZ - 1 Then
uRetVal.Item(lIdx) = aTemp(lIdx) + 38 * aTemp(lIdx + LNG_ELEMSZ)
Else
uRetVal.Item(lIdx) = aTemp(lIdx)
End If
Next
pvGF25519Car uRetVal
pvGF25519Car uRetVal
End Sub
Private Sub pvGF25519Sqr(uRetVal As GF25519Element, uA As GF25519Element)
pvGF25519Mul uRetVal, uA, uA
End Sub
Private Sub pvGF25519Inv(uRetVal As GF25519Element, uA As GF25519Element)
Dim uTemp As GF25519Element
Dim lIdx As Long
uTemp = uA
For lIdx = 253 To 0 Step -1
pvGF25519Mul uTemp, uTemp, uTemp
If lIdx <> 2 And lIdx <> 4 Then
pvGF25519Mul uTemp, uTemp, uA
End If
Next
uRetVal = uTemp
End Sub
Private Sub pvGF25519Pow2523(uRetVal As GF25519Element, uA As GF25519Element)
Dim uTemp As GF25519Element
Dim lIdx As Long
uTemp = uA
For lIdx = 250 To 0 Step -1
pvGF25519Sqr uTemp, uTemp
If lIdx <> 1 Then
pvGF25519Mul uTemp, uTemp, uA
End If
Next
uRetVal = uTemp
End Sub
Private Function pvGF25519Neq(uA As GF25519Element, uB As GF25519Element) As Boolean
Dim baA() As Byte
Dim baB() As Byte
Dim lIdx As Long
Dim lAccum As Long
pvGF25519Pack baA, uA
pvGF25519Pack baB, uB
For lIdx = 0 To UBound(baA)
lAccum = lAccum Or (baA(lIdx) Xor baB(lIdx))
Next
pvGF25519Neq = lAccum <> 0
End Function
Private Sub pvGF25519Unpack(uRetVal As GF25519Element, baInput() As Byte)
Dim aTemp(0 To LNG_ELEMSZ - 1) As Integer
Dim lIdx As Long
If UBound(baInput) >= 0 Then
Debug.Assert (UBound(aTemp) + 1) * 2 >= UBound(baInput) + 1
Call CopyMemory(aTemp(0), baInput(0), UBound(baInput) + 1)
End If
For lIdx = 0 To LNG_ELEMSZ - 1
If aTemp(lIdx) < 0 Then
uRetVal.Item(lIdx) = m_lZero + LNG_POW16 + aTemp(lIdx)
Else
uRetVal.Item(lIdx) = m_lZero + aTemp(lIdx)
End If
Next
End Sub
Private Sub pvGF25519Pack(baRetVal() As Byte, uA As GF25519Element)
Dim lRetry As Long
Dim lIdx As Long
Dim uTemp As GF25519Element
Dim lFlag As Long
ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
For lRetry = 0 To 1
uTemp.Item(0) = uA.Item(0) - &HFFED&
For lIdx = 1 To LNG_ELEMSZ - 1
lFlag = -((uTemp.Item(lIdx - 1) And LNG_POW16) <> 0)
If lIdx = LNG_ELEMSZ - 1 Then
lFlag = &H7FFF& + lFlag
Else
lFlag = &HFFFF& + lFlag
End If
uTemp.Item(lIdx) = uA.Item(lIdx) - lFlag
uTemp.Item(lIdx - 1) = uTemp.Item(lIdx - 1) And &HFFFF&
Next
lFlag = -((uTemp.Item(LNG_ELEMSZ - 1) And LNG_POW16) <> 0)
pvGF25519Sel uA, uTemp, lFlag = 0
Next
For lIdx = 0 To LNG_ELEMSZ - 1
lFlag = CLng(uA.Item(lIdx) And LNG_POW16 - 1)
Call CopyMemory(baRetVal(2 * lIdx), lFlag, 2)
Next
End Sub
Private Sub pvGF25519Clamp(baPriv() As Byte)
baPriv(0) = baPriv(0) And &HF8
baPriv(31) = baPriv(31) And &H7F Or &H40
End Sub
Private Sub pvGF25519Assign(uRetVal As GF25519Element, sText As String)
Dim vElem As Variant
Dim lIdx As Long
For Each vElem In Split(sText)
uRetVal.Item(lIdx) = CLngLng(CStr("&H" & vElem))
lIdx = lIdx + 1
Next
End Sub
Private Sub pvGF25519ScalarMult(baRetVal() As Byte, baPriv() As Byte, baPub() As Byte)
Dim baKey() As Byte
Dim uX As GF25519Element
Dim uA As GF25519Element
Dim uB As GF25519Element
Dim uC As GF25519Element
Dim uD As GF25519Element
Dim uE As GF25519Element
Dim uF As GF25519Element
Dim uG As GF25519Element
Dim lIdx As Long
Dim lFlag As Long
Dim lPrev As Long
baKey = baPriv
pvGF25519Clamp baKey
pvGF25519Unpack uA, EmptyByteArray
pvGF25519Unpack uX, baPub
uB = uX
uC = uA
uD = uA
uG = uA
uG.Item(0) = uG.Item(0) + &HDB41&
uG.Item(1) = uG.Item(1) + 1
uA.Item(0) = uG.Item(1) ' a[0] = 1
uD.Item(0) = uG.Item(1) ' d[0] = 1
For lIdx = 254 To 0 Step -1
lPrev = lFlag
lFlag = (baKey(lIdx \ 8) \ LNG_POW2(lIdx And 7)) And 1
pvGF25519Sel uA, uB, lFlag Xor lPrev
pvGF25519Sel uC, uD, lFlag Xor lPrev
pvGF25519Add uE, uA, uC ' e = a + c
pvGF25519Sub uA, uA, uC ' a = a - c
pvGF25519Add uC, uB, uD ' c = b + d
pvGF25519Sub uB, uB, uD ' b = b - d
pvGF25519Mul uD, uE, uE ' d = e * e
pvGF25519Mul uF, uA, uA ' f = a * a
pvGF25519Mul uA, uC, uA ' a = c * a
pvGF25519Mul uC, uB, uE ' c = b * e
pvGF25519Add uE, uA, uC ' e = a + c
pvGF25519Sub uA, uA, uC ' a = a - c
pvGF25519Mul uB, uA, uA ' b = a * a
pvGF25519Sub uC, uD, uF ' c = d - f
pvGF25519Mul uA, uC, uG ' a = c * g
pvGF25519Add uA, uA, uD ' a = a + d
pvGF25519Mul uC, uC, uA ' c = c * a
pvGF25519Mul uA, uD, uF ' a = d * f
pvGF25519Mul uD, uB, uX ' d = b * x
pvGF25519Mul uB, uE, uE ' b = e * e
Next
pvGF25519Inv uC, uC
pvGF25519Mul uX, uA, uC
pvGF25519Pack baRetVal, uX
End Sub
Private Sub pvGF25519ScalarBase(baRetVal() As Byte, baPriv() As Byte)
Dim baBase(0 To LNG_KEYSZ - 1) As Byte
baBase(0) = 9
pvGF25519ScalarMult baRetVal, baPriv, baBase
End Sub
Public Sub CryptoX25519PrivateKey(baRetVal() As Byte, Optional Seed As Variant)
If Not IsMissing(Seed) Then
baRetVal = Seed
ReDim Preserve baRetVal(0 To LNG_KEYSZ - 1) As Byte
Else
ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
Call RtlGenRandom(baRetVal(0), UBound(baRetVal) + 1)
End If
pvGF25519Clamp baRetVal
End Sub
Public Sub CryptoX25519PublicKey(baRetVal() As Byte, baPriv() As Byte)
pvInit
pvGF25519ScalarBase baRetVal, baPriv
End Sub
Public Sub CryptoX25519SharedSecret(baRetVal() As Byte, baPriv() As Byte, baPub() As Byte)
pvInit
pvGF25519ScalarMult baRetVal, baPriv, baPub
End Sub
'= XyztPoint =============================================================
Private Sub pvEdwardsAdd(uP As XyztPoint, uQ As XyztPoint)
Dim gfA As GF25519Element
Dim gfB As GF25519Element
Dim gfC As GF25519Element
Dim gfD As GF25519Element
Dim gfE As GF25519Element
Dim gfF As GF25519Element
Dim gfG As GF25519Element
Dim gfH As GF25519Element
Dim gfT As GF25519Element
pvGF25519Sub gfA, uP.gfY, uP.gfX
pvGF25519Sub gfT, uQ.gfY, uQ.gfX
pvGF25519Mul gfA, gfA, gfT
pvGF25519Add gfB, uP.gfX, uP.gfY
pvGF25519Add gfT, uQ.gfX, uQ.gfY
pvGF25519Mul gfB, gfB, gfT
pvGF25519Mul gfC, uP.gfT, uQ.gfT
pvGF25519Mul gfC, gfC, m_gfD2
pvGF25519Mul gfD, uP.gfZ, uQ.gfZ
pvGF25519Add gfD, gfD, gfD
pvGF25519Sub gfE, gfB, gfA
pvGF25519Sub gfF, gfD, gfC
pvGF25519Add gfG, gfD, gfC
pvGF25519Add gfH, gfB, gfA
pvGF25519Mul uP.gfX, gfE, gfF
pvGF25519Mul uP.gfY, gfH, gfG
pvGF25519Mul uP.gfZ, gfG, gfF
pvGF25519Mul uP.gfT, gfE, gfH
End Sub
Private Sub pvEdwardsCSwap(uP As XyztPoint, uQ As XyztPoint, ByVal bSwap As Boolean)
pvGF25519Sel uP.gfX, uQ.gfX, bSwap
pvGF25519Sel uP.gfY, uQ.gfY, bSwap
pvGF25519Sel uP.gfZ, uQ.gfZ, bSwap
pvGF25519Sel uP.gfT, uQ.gfT, bSwap
End Sub
Private Sub pvEdwardsPack(baRetVal() As Byte, ByVal lOutPos As Long, uP As XyztPoint)
Dim gfTx As GF25519Element
Dim gfTy As GF25519Element
Dim gfZi As GF25519Element
Dim baTemp() As Byte
pvGF25519Inv gfZi, uP.gfZ
pvGF25519Mul gfTx, uP.gfX, gfZi
pvGF25519Mul gfTy, uP.gfY, gfZi
pvGF25519Pack baTemp, gfTy
Debug.Assert UBound(baRetVal) + 1 >= lOutPos + LNG_KEYSZ
Call CopyMemory(baRetVal(lOutPos), baTemp(0), LNG_KEYSZ)
pvGF25519Pack baTemp, gfTx
lOutPos = lOutPos + LNG_KEYSZ - 1
baRetVal(lOutPos) = baRetVal(lOutPos) Xor ((baTemp(0) And 1) * &H80)
End Sub
Private Sub pvEdwardsScalarMult(uP As XyztPoint, uQ As XyztPoint, baKey() As Byte, Optional ByVal lPos As Long)
Dim lIdx As Long
Dim lFlag As Long
pvInit Extended:=True
uP.gfX = m_gf0
uP.gfY = m_gf1
uP.gfZ = m_gf1
uP.gfT = m_gf0
For lIdx = 255 To 0 Step -1
lFlag = (baKey(lPos + lIdx \ 8) \ LNG_POW2(lIdx And 7)) And 1
pvEdwardsCSwap uP, uQ, lFlag
pvEdwardsAdd uQ, uP
pvEdwardsAdd uP, uP
pvEdwardsCSwap uP, uQ, lFlag
Next
End Sub
Private Sub pvEdwardsScalarBase(uP As XyztPoint, baKey() As Byte, Optional ByVal lPos As Long)
Dim uQ As XyztPoint
uQ.gfX = m_gfX
uQ.gfY = m_gfY
uQ.gfZ = m_gf1
pvGF25519Mul uQ.gfT, m_gfX, m_gfY
pvEdwardsScalarMult uP, uQ, baKey, lPos
End Sub
Private Sub pvEdwardsModL(baRetVal() As Byte, ByVal lOutPos As Long, aX As ArrayLong64)
#If HasPtrSafe Then
Dim lCarry As LongLong
#Else
Dim lCarry As Variant
#End If
Dim lIdx As Long
Dim lJdx As Long
For lIdx = 63 To 32 Step -1
lCarry = m_lZero
For lJdx = lIdx - 32 To lIdx - 13
aX.Item(lJdx) = aX.Item(lJdx) + lCarry - 16 * aX.Item(lIdx) * m_aL.Item(lJdx - (lIdx - 32))
lCarry = (aX.Item(lJdx) + 128 And -&H100) \ &H100
aX.Item(lJdx) = aX.Item(lJdx) - lCarry * &H100
Next
aX.Item(lJdx) = aX.Item(lJdx) + lCarry
aX.Item(lIdx) = 0
Next
lCarry = 0
For lJdx = 0 To 31
aX.Item(lJdx) = aX.Item(lJdx) + lCarry - ((aX.Item(31) And -&H10) \ &H10) * m_aL.Item(lJdx)
lCarry = (aX.Item(lJdx) And -&H100) \ &H100
aX.Item(lJdx) = aX.Item(lJdx) And &HFF
Next
For lJdx = 0 To 31
aX.Item(lJdx) = aX.Item(lJdx) - lCarry * m_aL.Item(lJdx)
Next
For lIdx = 0 To 31
aX.Item(lIdx + 1) = aX.Item(lIdx + 1) + ((aX.Item(lIdx) And -&H100) \ &H100)
baRetVal(lOutPos + lIdx) = CByte(aX.Item(lIdx) And &HFF)
Next
End Sub
Private Sub pvEdwardsReduce(baRetVal() As Byte)
Dim aX As ArrayLong64
Dim lIdx As Long
For lIdx = 0 To 63
aX.Item(lIdx) = m_lZero + baRetVal(lIdx)
baRetVal(lIdx) = 0
Next
pvEdwardsModL baRetVal, 0, aX
End Sub
Private Function pvEdwardsUnpackNeg(uR As XyztPoint, baKey() As Byte) As Boolean
Dim gfT As GF25519Element
Dim gfChk As GF25519Element
Dim gfNum As GF25519Element
Dim gfDen As GF25519Element
Dim gfDen2 As GF25519Element
Dim gfDen4 As GF25519Element
Dim gfDen6 As GF25519Element
Dim baTemp() As Byte
uR.gfZ = m_gf1
pvGF25519Unpack uR.gfY, baKey
pvGF25519Sqr gfNum, uR.gfY
pvGF25519Mul gfDen, gfNum, m_gfD
pvGF25519Sub gfNum, gfNum, m_gf1
pvGF25519Add gfDen, gfDen, m_gf1
pvGF25519Sqr gfDen2, gfDen
pvGF25519Sqr gfDen4, gfDen2
pvGF25519Mul gfDen6, gfDen4, gfDen2
pvGF25519Mul gfT, gfDen6, gfNum
pvGF25519Mul gfT, gfT, gfDen
pvGF25519Pow2523 gfT, gfT
pvGF25519Mul gfT, gfT, gfNum
pvGF25519Mul gfT, gfT, gfDen
pvGF25519Mul gfT, gfT, gfDen
pvGF25519Mul uR.gfX, gfT, gfDen
pvGF25519Sqr gfChk, uR.gfX
pvGF25519Mul gfChk, gfChk, gfDen
If pvGF25519Neq(gfChk, gfNum) Then
pvGF25519Mul uR.gfX, uR.gfX, m_gfI
End If
pvGF25519Sqr gfChk, uR.gfX
pvGF25519Mul gfChk, gfChk, gfDen
If pvGF25519Neq(gfChk, gfNum) Then
GoTo QH
End If
pvGF25519Pack baTemp, uR.gfX
If (baTemp(0) And 1) = (baKey(31) \ &H80) Then
pvGF25519Sub uR.gfX, m_gf0, uR.gfX '-- X = -X
End If
pvGF25519Mul uR.gfT, uR.gfX, uR.gfY
'--- success
pvEdwardsUnpackNeg = True
QH:
End Function
Private Function pvEdwardsHash(baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
#If HasSha512 Then
baOutput = CryptoSha512ByteArray(512, baInput, Pos, Size)
Debug.Assert UBound(baOutput) + 1 >= LNG_HASHSZ
#Else
Err.Raise vbObjectError, , "SHA-512 not compiled (use CRYPT_HAS_SHA512 = 1)"
#End If
End Function
Public Sub pvEdwardsPublicKey(baRetVal() As Byte, ByVal lOutPos As Long, baPriv() As Byte)
Dim baD() As Byte
Dim uP As XyztPoint
pvEdwardsHash baD, baPriv
pvGF25519Clamp baD
pvEdwardsScalarBase uP, baD
pvEdwardsPack baRetVal, lOutPos, uP
End Sub
Public Sub CryptoEd25519PrivateKey(baRetVal() As Byte, Optional Seed As Variant)
If Not IsMissing(Seed) Then
baRetVal = Seed
ReDim Preserve baRetVal(0 To LNG_KEYSZ - 1) As Byte
Else
ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
Call RtlGenRandom(baRetVal(0), UBound(baRetVal) + 1)
End If
End Sub
Public Sub CryptoEd25519PublicKey(baRetVal() As Byte, baPriv() As Byte)
Debug.Assert UBound(baPriv) + 1 >= LNG_KEYSZ
pvInit Extended:=True
ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
pvEdwardsPublicKey baRetVal, 0, baPriv
End Sub
Public Sub CryptoEd25519Sign(baRetVal() As Byte, baPriv() As Byte, baMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim baDelta() As Byte
Dim baHash() As Byte
Dim baR() As Byte
Dim uP As XyztPoint
Dim aX As ArrayLong64
Dim lIdx As Long
Dim lJdx As Long
Debug.Assert UBound(baPriv) + 1 >= LNG_KEYSZ
pvInit Extended:=True
pvEdwardsHash baDelta, baPriv
pvGF25519Clamp baDelta
If Size < 0 Then
Size = UBound(baMsg) + 1 - Pos
End If
ReDim baRetVal(0 To LNG_HASHSZ + Size - 1) As Byte
Call CopyMemory(baRetVal(LNG_HALFHASHSZ), baDelta(LNG_HALFHASHSZ), LNG_HALFHASHSZ)
If Size > 0 Then
Call CopyMemory(baRetVal(LNG_HASHSZ), baMsg(Pos), Size)
End If
pvEdwardsHash baR, baRetVal, Pos:=LNG_HALFHASHSZ
pvEdwardsReduce baR
pvEdwardsScalarBase uP, baR
pvEdwardsPack baRetVal, 0, uP
pvEdwardsPublicKey baRetVal, LNG_HALFHASHSZ, baPriv
pvEdwardsHash baHash, baRetVal
pvEdwardsReduce baHash
For lIdx = 0 To LNG_HALFHASHSZ - 1
aX.Item(lIdx) = baR(lIdx)
Next
For lIdx = 0 To LNG_HALFHASHSZ - 1
For lJdx = 0 To LNG_HALFHASHSZ - 1
aX.Item(lIdx + lJdx) = aX.Item(lIdx + lJdx) + (m_lZero + baHash(lIdx)) * baDelta(lJdx)
Next
Next
pvEdwardsModL baRetVal, LNG_HALFHASHSZ, aX
End Sub
Public Function CryptoEd25519Open(baRetVal() As Byte, baPub() As Byte, baSigMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Boolean
Dim uP As XyztPoint
Dim uQ As XyztPoint
Dim baHash() As Byte
Dim baTemp(0 To LNG_KEYSZ - 1) As Byte
Dim lIdx As Long
Debug.Assert UBound(baPub) + 1 >= LNG_KEYSZ
pvInit Extended:=True
If Size < 0 Then
Size = UBound(baSigMsg) + 1 - Pos
End If
If Size < LNG_HASHSZ Then
GoTo QH
End If
If Not pvEdwardsUnpackNeg(uQ, baPub) Then
GoTo QH
End If
ReDim baRetVal(0 To Size - 1) As Byte
Debug.Assert UBound(baSigMsg) + 1 >= Pos + Size
Call CopyMemory(baRetVal(0), baSigMsg(Pos), Size)
Call CopyMemory(baRetVal(LNG_HALFHASHSZ), baPub(0), LNG_HALFHASHSZ)
pvEdwardsHash baHash, baRetVal
pvEdwardsReduce baHash
pvEdwardsScalarMult uP, uQ, baHash
pvEdwardsScalarBase uQ, baSigMsg, LNG_HALFHASHSZ
pvEdwardsAdd uP, uQ
pvEdwardsPack baTemp, 0, uP
For lIdx = 0 To LNG_HALFHASHSZ - 1
If baTemp(lIdx) <> baSigMsg(lIdx) Then
GoTo QH
End If
Next
If UBound(baSigMsg) + 1 > LNG_HASHSZ Then
ReDim baRetVal(0 To UBound(baSigMsg) - LNG_HASHSZ) As Byte
Call CopyMemory(baRetVal(0), baSigMsg(LNG_HASHSZ), UBound(baRetVal) + 1)
Else
baRetVal = vbNullString
End If
'--- success
CryptoEd25519Open = True
QH:
End Function
Public Sub CryptoEd25519SignDetached(baRetVal() As Byte, baPriv() As Byte, baMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
CryptoEd25519Sign baRetVal, baPriv, baMsg, Pos, Size
ReDim Preserve baRetVal(0 To LNG_HASHSZ - 1) As Byte
End Sub
Public Function CryptoEd25519VerifyDetached(baSig() As Byte, baPub() As Byte, baMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Boolean
Dim baSigMsg() As Byte
Dim baTemp() As Byte
If UBound(baSig) + 1 < LNG_HASHSZ Then
GoTo QH
End If
If Size < 0 Then
Size = UBound(baMsg) + 1 - Pos
End If
ReDim baSigMsg(0 To LNG_HASHSZ + UBound(baMsg)) As Byte
Call CopyMemory(baSigMsg(0), baSig(0), LNG_HASHSZ)
If UBound(baMsg) >= 0 Then
Call CopyMemory(baSigMsg(LNG_HASHSZ), baMsg(0), UBound(baMsg) + 1)
End If
CryptoEd25519VerifyDetached = CryptoEd25519Open(baTemp, baPub, baSigMsg)
QH:
End Function
Raw
mdEccX25519.bas
'--- mdEccX25519.bas
Option Explicit
DefObj A-Z
Private Const BCRYPT_ECDH_PUBLIC_GENERIC_MAGIC As Long = &H504B4345 ' ECKP
Private Const BCRYPT_ECDH_PRIVATE_GENERIC_MAGIC As Long = &H564B4345 ' ECKV
Private Const BCRYPT_NO_KEY_VALIDATION As Long = &H8
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
'--- bcrypt
Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" (ByRef hAlgorithm As Long, ByVal pszAlgId As Long, ByVal pszImplementation As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptSetProperty Lib "bcrypt" (ByVal hObject As Long, ByVal pszProperty As Long, ByVal pbInput As Long, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptImportKeyPair Lib "bcrypt" (ByVal hAlgorithm As Long, ByVal hImportKey As Long, ByVal pszBlobType As Long, ByRef hKey As Long, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptExportKey Lib "bcrypt" (ByVal hKey As Long, ByVal hExportKey As Long, ByVal pszBlobType As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef cbResult As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDestroyKey Lib "bcrypt" (ByVal hKey As Long) As Long
Private Declare Function BCryptSecretAgreement Lib "bcrypt" (ByVal hPrivKey As Long, ByVal hPubKey As Long, ByRef phSecret As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDestroySecret Lib "bcrypt" (ByVal hSecret As Long) As Long
Private Declare Function BCryptDeriveKey Lib "bcrypt" (ByVal hSharedSecret As Long, ByVal pwszKDF As Long, ByVal pParameterList As Long, ByVal pbDerivedKey As Long, ByVal cbDerivedKey As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Private Type BCRYPT_ECCKEY_BLOB
dwMagic As Long
cbKey As Long
Buffer(0 To 1023) As Byte
End Type
Private Const sizeof_BCRYPT_ECCKEY_BLOB As Long = 8
Public Sub EccX25519PrivateKey(baRetVal() As Byte, Optional Seed As Variant)
Const LNG_KEYSZ As Long = 32
If Not IsMissing(Seed) Then
baRetVal = Seed
ReDim Preserve baRetVal(0 To LNG_KEYSZ - 1) As Byte
Else
ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
Call RtlGenRandom(baRetVal(0), UBound(baRetVal) + 1)
End If
'--- clamp
baRetVal(0) = baRetVal(0) And &HF8
baRetVal(31) = baRetVal(31) And &H7F Or &H40
End Sub
Public Sub EccX25519PublicKey(baRetVal() As Byte, baPriv() As Byte)
Dim hAlg As Long
Dim hResult As Long
Dim hKey As Long
Dim lSize As Long
Dim uBlob As BCRYPT_ECCKEY_BLOB
Dim sApiSource As String
Dim vErr As Variant
On Error GoTo EH
'--- setup X25519 for ECDH
hResult = BCryptOpenAlgorithmProvider(hAlg, StrPtr("ECDH"), 0, 0)
If hResult < 0 Then
sApiSource = "BCryptOpenAlgorithmProvider"
GoTo QH
End If
hResult = BCryptSetProperty(hAlg, StrPtr("ECCCurveName"), StrPtr("curve25519"), LenB("curve25519") + 2, 0)
If hResult < 0 Then
sApiSource = "BCryptSetProperty"
GoTo QH
End If
'--- import private key
uBlob.dwMagic = BCRYPT_ECDH_PRIVATE_GENERIC_MAGIC
uBlob.cbKey = UBound(baPriv) + 1
Call CopyMemory(uBlob.Buffer(2 * uBlob.cbKey), baPriv(0), UBound(baPriv) + 1)
hResult = BCryptImportKeyPair(hAlg, 0, StrPtr("ECCPRIVATEBLOB"), hKey, uBlob, sizeof_BCRYPT_ECCKEY_BLOB + 3 * uBlob.cbKey, BCRYPT_NO_KEY_VALIDATION)
If hResult < 0 Then
sApiSource = "BCryptImportKeyPair"
GoTo QH
End If
'--- export public key
hResult = BCryptExportKey(hKey, 0&, StrPtr("ECCPUBLICBLOB"), uBlob, LenB(uBlob), lSize, 0)
If hResult < 0 Then
sApiSource = "BCryptExportKey"
GoTo QH
End If
ReDim baRetVal(0 To uBlob.cbKey - 1) As Byte
Call CopyMemory(baRetVal(0), uBlob.Buffer(0), uBlob.cbKey)
QH:
On Error GoTo 0
If hKey <> 0 Then
Call BCryptDestroyKey(hKey)
End If
If hAlg <> 0 Then
Call BCryptCloseAlgorithmProvider(hAlg, 0)
End If
If LenB(sApiSource) <> 0 Then
Err.Raise hResult, , "Error &H" & Hex$(hResult) & " [" & sApiSource & "]"
End If
If IsArray(vErr) Then
Err.Raise vErr(0), vErr(1), vErr(2)
End If
Exit Sub
EH:
vErr = Array(Err.Number, Err.Source, Err.Description)
Resume QH
End Sub
Public Sub EccX25519SharedSecret(baRetVal() As Byte, baPriv() As Byte, baPub() As Byte)
Dim hAlg As Long
Dim hResult As Long
Dim hPrivKey As Long
Dim hPubKey As Long
Dim hAgreedSecret As Long
Dim lSize As Long
Dim uBlob As BCRYPT_ECCKEY_BLOB
Dim lTemp As Long
Dim sApiSource As String
Dim vErr As Variant
On Error GoTo EH
'--- setup X25519 for ECDH
hResult = BCryptOpenAlgorithmProvider(hAlg, StrPtr("ECDH"), 0, 0)
If hResult < 0 Then
sApiSource = "BCryptOpenAlgorithmProvider"
GoTo QH
End If
hResult = BCryptSetProperty(hAlg, StrPtr("ECCCurveName"), StrPtr("curve25519"), LenB("curve25519") + 2, 0)
If hResult < 0 Then
sApiSource = "BCryptSetProperty"
GoTo QH
End If
'--- import private key
uBlob.dwMagic = BCRYPT_ECDH_PRIVATE_GENERIC_MAGIC
uBlob.cbKey = UBound(baPriv) + 1
Call CopyMemory(uBlob.Buffer(2 * uBlob.cbKey), baPriv(0), UBound(baPriv) + 1)
hResult = BCryptImportKeyPair(hAlg, 0, StrPtr("ECCPRIVATEBLOB"), hPrivKey, uBlob, sizeof_BCRYPT_ECCKEY_BLOB + 3 * uBlob.cbKey, BCRYPT_NO_KEY_VALIDATION)
If hResult < 0 Then
sApiSource = "BCryptImportKeyPair(ECCPRIVATEBLOB)"
GoTo QH
End If
'--- import public key
uBlob.dwMagic = BCRYPT_ECDH_PUBLIC_GENERIC_MAGIC
uBlob.cbKey = UBound(baPub) + 1
Erase uBlob.Buffer
Call CopyMemory(uBlob.Buffer(0), baPub(0), UBound(baPub) + 1)
hResult = BCryptImportKeyPair(hAlg, 0, StrPtr("ECCPUBLICBLOB"), hPubKey, uBlob, sizeof_BCRYPT_ECCKEY_BLOB + 2 * uBlob.cbKey, 0)
If hResult < 0 Then
sApiSource = "BCryptImportKeyPair(ECCPUBLICBLOB)"
GoTo QH
End If
'--- derive key agreement
hResult = BCryptSecretAgreement(hPrivKey, hPubKey, hAgreedSecret, 0)
If hResult < 0 Then
sApiSource = "BCryptSecretAgreement"
GoTo QH
End If
ReDim baRetVal(0 To 1023) As Byte
hResult = BCryptDeriveKey(hAgreedSecret, StrPtr("TRUNCATE"), 0, VarPtr(baRetVal(0)), UBound(baRetVal) + 1, lSize, 0)
If hResult < 0 Then
sApiSource = "BCryptDeriveKey"
GoTo QH
End If
ReDim Preserve baRetVal(0 To lSize - 1) As Byte
'--- reverse result to big endian
For lSize = 0 To UBound(baRetVal) \ 2
lTemp = baRetVal(lSize)
baRetVal(lSize) = baRetVal(UBound(baRetVal) - lSize)
baRetVal(UBound(baRetVal) - lSize) = lTemp
Next
QH:
On Error GoTo 0
If hAgreedSecret <> 0 Then
Call BCryptDestroySecret(hAgreedSecret)
End If
If hPubKey <> 0 Then
Call BCryptDestroyKey(hPubKey)
End If
If hPrivKey <> 0 Then
Call BCryptDestroyKey(hPrivKey)
End If
If hAlg <> 0 Then
Call BCryptCloseAlgorithmProvider(hAlg, 0)
End If
If LenB(sApiSource) <> 0 Then
Err.Raise hResult, , "Error &H" & Hex$(hResult) & " [" & sApiSource & "]"
End If
If IsArray(vErr) Then
Err.Raise vErr(0), vErr(1), vErr(2)
End If
Exit Sub
EH:
vErr = Array(Err.Number, Err.Source, Err.Description)
Resume QH
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment