This mdCurve25519.bas module implements X25519 key exchange and Ed25519 signatures in pure VB6.
EdDSA signatures use SHA-512 hashes internally so you'll need mdSha512.bas from this thread included in your project and CRYPT_HAS_SHA512 = 1 declared in conditional compilation for the CryptoEd25519Sign and CryptoEd25519Open functions to use CryptoSha512 routine from there.
Implementing X25519 key exchange with CryptoX25519PrivateKey, CryptoX25519PublicKey and CryptoX25519SharedSecret routines can be done without SHA-512 or any other source dependency.
cheers,
</wqw>
EdDSA signatures use SHA-512 hashes internally so you'll need mdSha512.bas from this thread included in your project and CRYPT_HAS_SHA512 = 1 declared in conditional compilation for the CryptoEd25519Sign and CryptoEd25519Open functions to use CryptoSha512 routine from there.
Implementing X25519 key exchange with CryptoX25519PrivateKey, CryptoX25519PublicKey and CryptoX25519SharedSecret routines can be done without SHA-512 or any other source dependency.
Code:
'--- mdCurve25519.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 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_uGf0 As FieldElement
Private m_uGf1 As FieldElement
Private m_uGfD As FieldElement
Private m_uGfD2 As FieldElement
Private m_uGfX As FieldElement
Private m_uGfY As FieldElement
Private m_uGfI As FieldElement
Private m_aL(0 To 63) As Byte
Private Type FieldElement
#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
Item(0 To 3) As FieldElement
End Type
Private Type Array64
#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()
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_uGf1.Item(0) = 0 Then
pvCurveAssign m_uGf0, "0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0"
pvCurveAssign m_uGf1, "1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0"
pvCurveAssign m_uGfD, "78A3 1359 4DCA 75EB D8AB 4141 0A4D 0070 E898 7779 4079 8CC7 FE73 2B6F 6CEE 5203"
pvCurveAssign m_uGfD2, "F159 26B2 9B94 EBD6 B156 8283 149A 00E0 D130 EEF3 80F2 198E FCE7 56DF D9DC 2406"
pvCurveAssign m_uGfX, "D51A 8F25 2D60 C956 A7B2 9525 C760 692C DC5C FDD6 E231 C0A4 53FE CD6E 36D3 2169"
pvCurveAssign m_uGfY, "6658 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666"
pvCurveAssign m_uGfI, "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(lIdx) = CByte("&H" & vElem)
lIdx = lIdx + 1
Next
End If
End Sub
Private Sub pvCurveSel(uA As FieldElement, uB As FieldElement, 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 pvCurveCar(uRetVal As FieldElement)
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 pvCurveAdd(uRetVal As FieldElement, uA As FieldElement, uB As FieldElement)
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 pvCurveSub(uRetVal As FieldElement, uA As FieldElement, uB As FieldElement)
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 pvCurveMul(uRetVal As FieldElement, uA As FieldElement, uB As FieldElement)
#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
pvCurveCar uRetVal
pvCurveCar uRetVal
End Sub
Private Sub pvCurveSqr(uRetVal As FieldElement, uA As FieldElement)
pvCurveMul uRetVal, uA, uA
End Sub
Private Sub pvCurveInv(uRetVal As FieldElement, uA As FieldElement)
Dim uTemp As FieldElement
Dim lIdx As Long
uTemp = uA
For lIdx = 253 To 0 Step -1
pvCurveMul uTemp, uTemp, uTemp
If lIdx <> 2 And lIdx <> 4 Then
pvCurveMul uTemp, uTemp, uA
End If
Next
uRetVal = uTemp
End Sub
Private Sub pvCurvePow2523(uRetVal As FieldElement, uA As FieldElement)
Dim uTemp As FieldElement
Dim lIdx As Long
uTemp = uA
For lIdx = 250 To 0 Step -1
pvCurveSqr uTemp, uTemp
If lIdx <> 1 Then
pvCurveMul uTemp, uTemp, uA
End If
Next
uRetVal = uTemp
End Sub
Private Function pvCurveNeq(uA As FieldElement, uB As FieldElement) As Boolean
Dim baA() As Byte
Dim baB() As Byte
Dim lIdx As Long
Dim lAccum As Long
pvCurvePack baA, uA
pvCurvePack baB, uB
For lIdx = 0 To UBound(baA)
lAccum = lAccum Or (baA(lIdx) Xor baB(lIdx))
Next
pvCurveNeq = lAccum <> 0
End Function
Private Sub pvCurveUnpack(uRetVal As FieldElement, 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 pvCurvePack(baRetVal() As Byte, uA As FieldElement)
Dim lRetry As Long
Dim lIdx As Long
Dim uTemp As FieldElement
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)
pvCurveSel 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 pvCurveClampKey(baPriv() As Byte)
baPriv(0) = baPriv(0) And &HF8
baPriv(31) = baPriv(31) And &H7F Or &H40
End Sub
Private Sub pvCurveAssign(uRetVal As FieldElement, 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 pvCurveScalarMult(baRetVal() As Byte, baPriv() As Byte, baPub() As Byte)
Dim baKey() As Byte
Dim uX As FieldElement
Dim uA As FieldElement
Dim uB As FieldElement
Dim uC As FieldElement
Dim uD As FieldElement
Dim uE As FieldElement
Dim uF As FieldElement
Dim uG As FieldElement
Dim lIdx As Long
Dim lFlag As Long
Dim lPrev As Long
baKey = baPriv
pvCurveClampKey baKey
pvCurveUnpack uA, EmptyByteArray
pvCurveUnpack 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
pvCurveSel uA, uB, lFlag Xor lPrev
pvCurveSel uC, uD, lFlag Xor lPrev
pvCurveAdd uE, uA, uC ' e = a + c
pvCurveSub uA, uA, uC ' a = a - c
pvCurveAdd uC, uB, uD ' c = b + d
pvCurveSub uB, uB, uD ' b = b - d
pvCurveMul uD, uE, uE ' d = e * e
pvCurveMul uF, uA, uA ' f = a * a
pvCurveMul uA, uC, uA ' a = c * a
pvCurveMul uC, uB, uE ' c = b * e
pvCurveAdd uE, uA, uC ' e = a + c
pvCurveSub uA, uA, uC ' a = a - c
pvCurveMul uB, uA, uA ' b = a * a
pvCurveSub uC, uD, uF ' c = d - f
pvCurveMul uA, uC, uG ' a = c * g
pvCurveAdd uA, uA, uD ' a = a + d
pvCurveMul uC, uC, uA ' c = c * a
pvCurveMul uA, uD, uF ' a = d * f
pvCurveMul uD, uB, uX ' d = b * x
pvCurveMul uB, uE, uE ' b = e * e
Next
pvCurveInv uC, uC
pvCurveMul uX, uA, uC
pvCurvePack baRetVal, uX
End Sub
Private Sub pvCurveScalarBase(baRetVal() As Byte, baPriv() As Byte)
Dim baBase(0 To LNG_KEYSZ - 1) As Byte
baBase(0) = 9
pvCurveScalarMult 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
pvCurveClampKey baRetVal
End Sub
Public Sub CryptoX25519PublicKey(baRetVal() As Byte, baPriv() As Byte)
pvInit
pvCurveScalarBase baRetVal, baPriv
End Sub
Public Sub CryptoX25519SharedSecret(baRetVal() As Byte, baPriv() As Byte, baPub() As Byte)
pvInit
pvCurveScalarMult baRetVal, baPriv, baPub
End Sub
'= XyztPoint =============================================================
Private Sub pvEdDsaAdd(uP As XyztPoint, uQ As XyztPoint)
Dim uA As FieldElement
Dim uB As FieldElement
Dim uC As FieldElement
Dim uD As FieldElement
Dim uE As FieldElement
Dim uF As FieldElement
Dim uG As FieldElement
Dim uH As FieldElement
Dim uT As FieldElement
pvCurveSub uA, uP.Item(1), uP.Item(0)
pvCurveSub uT, uQ.Item(1), uQ.Item(0)
pvCurveMul uA, uA, uT
pvCurveAdd uB, uP.Item(0), uP.Item(1)
pvCurveAdd uT, uQ.Item(0), uQ.Item(1)
pvCurveMul uB, uB, uT
pvCurveMul uC, uP.Item(3), uQ.Item(3)
pvCurveMul uC, uC, m_uGfD2
pvCurveMul uD, uP.Item(2), uQ.Item(2)
pvCurveAdd uD, uD, uD
pvCurveSub uE, uB, uA
pvCurveSub uF, uD, uC
pvCurveAdd uG, uD, uC
pvCurveAdd uH, uB, uA
pvCurveMul uP.Item(0), uE, uF
pvCurveMul uP.Item(1), uH, uG
pvCurveMul uP.Item(2), uG, uF
pvCurveMul uP.Item(3), uE, uH
End Sub
Private Sub pvEdDsaCSwap(uP As XyztPoint, uQ As XyztPoint, ByVal bSwap As Boolean)
pvCurveSel uP.Item(0), uQ.Item(0), bSwap
pvCurveSel uP.Item(1), uQ.Item(1), bSwap
pvCurveSel uP.Item(2), uQ.Item(2), bSwap
pvCurveSel uP.Item(3), uQ.Item(3), bSwap
End Sub
Private Sub pvEdDsaPack(baRetVal() As Byte, ByVal lOutPos As Long, uP As XyztPoint)
Dim uTx As FieldElement
Dim uTy As FieldElement
Dim uZi As FieldElement
Dim baTemp() As Byte
pvCurveInv uZi, uP.Item(2)
pvCurveMul uTx, uP.Item(0), uZi
pvCurveMul uTy, uP.Item(1), uZi
pvCurvePack baTemp, uTy
Debug.Assert UBound(baRetVal) + 1 >= lOutPos + LNG_KEYSZ
Call CopyMemory(baRetVal(lOutPos), baTemp(0), LNG_KEYSZ)
pvCurvePack baTemp, uTx
lOutPos = lOutPos + LNG_KEYSZ - 1
baRetVal(lOutPos) = baRetVal(lOutPos) Xor ((baTemp(0) And 1) * &H80)
End Sub
Private Sub pvEdDsaScalarMult(uP As XyztPoint, uQ As XyztPoint, baKey() As Byte, Optional ByVal lPos As Long)
Dim lIdx As Long
Dim lFlag As Long
pvInit
uP.Item(0) = m_uGf0
uP.Item(1) = m_uGf1
uP.Item(2) = m_uGf1
uP.Item(3) = m_uGf0
For lIdx = 255 To 0 Step -1
lFlag = (baKey(lPos + lIdx \ 8) \ LNG_POW2(lIdx And 7)) And 1
pvEdDsaCSwap uP, uQ, lFlag
pvEdDsaAdd uQ, uP
pvEdDsaAdd uP, uP
pvEdDsaCSwap uP, uQ, lFlag
Next
End Sub
Private Sub pvEdDsaScalarBase(uP As XyztPoint, baKey() As Byte, Optional ByVal lPos As Long)
Dim uQ As XyztPoint
uQ.Item(0) = m_uGfX
uQ.Item(1) = m_uGfY
uQ.Item(2) = m_uGf1
pvCurveMul uQ.Item(3), m_uGfX, m_uGfY
pvEdDsaScalarMult uP, uQ, baKey, lPos
End Sub
Private Sub pvEdDsaModL(aRetVal() As Byte, ByVal lOutPos As Long, uX As Array64)
#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
uX.Item(lJdx) = uX.Item(lJdx) + lCarry - 16 * uX.Item(lIdx) * m_aL(lJdx - (lIdx - 32))
lCarry = (uX.Item(lJdx) + 128 And -&H100) \ &H100
uX.Item(lJdx) = uX.Item(lJdx) - lCarry * &H100
Next
uX.Item(lJdx) = uX.Item(lJdx) + lCarry
uX.Item(lIdx) = 0
Next
lCarry = 0
For lJdx = 0 To 31
uX.Item(lJdx) = uX.Item(lJdx) + lCarry - ((uX.Item(31) And -&H10) \ &H10) * m_aL(lJdx)
lCarry = (uX.Item(lJdx) And -&H100) \ &H100
uX.Item(lJdx) = uX.Item(lJdx) And &HFF
Next
For lJdx = 0 To 31
uX.Item(lJdx) = uX.Item(lJdx) - lCarry * m_aL(lJdx)
Next
For lIdx = 0 To 31
uX.Item(lIdx + 1) = uX.Item(lIdx + 1) + ((uX.Item(lIdx) And -&H100) \ &H100)
aRetVal(lOutPos + lIdx) = CByte(uX.Item(lIdx) And &HFF)
Next
End Sub
Private Sub pvEdDsaReduce(aRetVal() As Byte)
Dim uX As Array64
Dim lIdx As Long
For lIdx = 0 To 63
uX.Item(lIdx) = m_lZero + aRetVal(lIdx)
aRetVal(lIdx) = 0
Next
pvEdDsaModL aRetVal, 0, uX
End Sub
Private Function pvEdDsaUnpackNeg(uR As XyztPoint, baKey() As Byte) As Boolean
Dim uT As FieldElement
Dim uChk As FieldElement
Dim uNum As FieldElement
Dim uDen As FieldElement
Dim uDen2 As FieldElement
Dim uDen4 As FieldElement
Dim uDen6 As FieldElement
Dim baTemp() As Byte
uR.Item(2) = m_uGf1
pvCurveUnpack uR.Item(1), baKey
pvCurveSqr uNum, uR.Item(1)
pvCurveMul uDen, uNum, m_uGfD
pvCurveSub uNum, uNum, m_uGf1
pvCurveAdd uDen, uDen, m_uGf1
pvCurveSqr uDen2, uDen
pvCurveSqr uDen4, uDen2
pvCurveMul uDen6, uDen4, uDen2
pvCurveMul uT, uDen6, uNum
pvCurveMul uT, uT, uDen
pvCurvePow2523 uT, uT
pvCurveMul uT, uT, uNum
pvCurveMul uT, uT, uDen
pvCurveMul uT, uT, uDen
pvCurveMul uR.Item(0), uT, uDen
pvCurveSqr uChk, uR.Item(0)
pvCurveMul uChk, uChk, uDen
If pvCurveNeq(uChk, uNum) Then
pvCurveMul uR.Item(0), uR.Item(0), m_uGfI
End If
pvCurveSqr uChk, uR.Item(0)
pvCurveMul uChk, uChk, uDen
If pvCurveNeq(uChk, uNum) Then
GoTo QH
End If
pvCurvePack baTemp, uR.Item(0)
If (baTemp(0) And 1) = (baKey(31) \ &H80) Then
pvCurveSub uR.Item(0), m_uGf0, uR.Item(0) '-- X = -X
End If
pvCurveMul uR.Item(3), uR.Item(0), uR.Item(1)
'--- success
pvEdDsaUnpackNeg = True
QH:
End Function
Private Function pvEdDsaHash(baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
#If HasSha512 Then
CryptoSha512 512, baOutput, 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 pvEdDsaPublicKey(baRetVal() As Byte, ByVal lOutPos As Long, baPriv() As Byte)
Dim baD() As Byte
Dim uP As XyztPoint
pvEdDsaHash baD, baPriv
pvCurveClampKey baD
pvEdDsaScalarBase uP, baD
pvEdDsaPack 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
ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
pvEdDsaPublicKey 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 uX As Array64
Dim lIdx As Long
Dim lJdx As Long
Debug.Assert UBound(baPriv) + 1 >= LNG_KEYSZ
pvInit
pvEdDsaHash baDelta, baPriv
pvCurveClampKey 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
pvEdDsaHash baR, baRetVal, Pos:=LNG_HALFHASHSZ
pvEdDsaReduce baR
pvEdDsaScalarBase uP, baR
pvEdDsaPack baRetVal, 0, uP
pvEdDsaPublicKey baRetVal, LNG_HALFHASHSZ, baPriv
pvEdDsaHash baHash, baRetVal
pvEdDsaReduce baHash
For lIdx = 0 To LNG_HALFHASHSZ - 1
uX.Item(lIdx) = baR(lIdx)
Next
For lIdx = 0 To LNG_HALFHASHSZ - 1
For lJdx = 0 To LNG_HALFHASHSZ - 1
uX.Item(lIdx + lJdx) = uX.Item(lIdx + lJdx) + (m_lZero + baHash(lIdx)) * baDelta(lJdx)
Next
Next
pvEdDsaModL baRetVal, LNG_HALFHASHSZ, uX
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
If Size < 0 Then
Size = UBound(baSigMsg) + 1 - Pos
End If
If Size < LNG_HASHSZ Then
GoTo QH
End If
If Not pvEdDsaUnpackNeg(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)
pvEdDsaHash baHash, baRetVal
pvEdDsaReduce baHash
pvEdDsaScalarMult uP, uQ, baHash
pvEdDsaScalarBase uQ, baSigMsg, LNG_HALFHASHSZ
pvEdDsaAdd uP, uQ
pvEdDsaPack 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</wqw>