Like 0
Fork 0

Last active 10 months ago

csmith1865's Avatar csmith1865 revised this gist 10 months ago. Go to revision

1 file changed, 585 insertions

mdAesCtr.bas(file created)

@@ -0,0 +1,585 @@
1 + '--- mdAesCtr.bas
2 + Option Explicit
3 + DefObj A-Z
4 +
5 + #Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)
6 +
7 + '=========================================================================
8 + ' API
9 + '=========================================================================
10 +
11 + #If Win64 Then
12 + Private Const PTR_SIZE As Long = 8
13 + #Else
14 + Private Const PTR_SIZE As Long = 4
15 + #End If
16 +
17 + #If HasPtrSafe Then
18 + Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As LongPtr)
19 + Private Declare PtrSafe Function ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) As LongPtr
20 + Private Declare PtrSafe Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
21 + Private Declare PtrSafe Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
22 + '--- bcrypt
23 + Private Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "bcrypt" (phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
24 + Private Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
25 + Private Declare PtrSafe Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, pbOutput As Any, ByVal cbOutput As Long, cbResult As Long, ByVal dwFlags As Long) As Long
26 + Private Declare PtrSafe Function BCryptSetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByVal pbInput As LongPtr, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
27 + Private Declare PtrSafe Function BCryptGenerateSymmetricKey Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
28 + Private Declare PtrSafe Function BCryptDestroyKey Lib "bcrypt" (ByVal hKey As LongPtr) As Long
29 + Private Declare PtrSafe Function BCryptEncrypt Lib "bcrypt" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal pPaddingInfo As LongPtr, ByVal pbIV As LongPtr, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, pcbResult As Long, ByVal dwFlags As Long) As Long
30 + Private Declare PtrSafe Function BCryptDeriveKeyPBKDF2 Lib "bcrypt" (ByVal hPrf As LongPtr, pbPassword As Any, ByVal cbPassword As Long, pbSalt As Any, ByVal cbSalt As Long, ByVal cIterations As currency, pbDerivedKey As Any, ByVal cbDerivedKey As Long, ByVal dwFlags As Long) As Long
31 + Private Declare PtrSafe Function BCryptCreateHash Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phHash As LongPtr, ByVal pbHashObject As LongPtr, ByVal cbHashObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
32 + Private Declare PtrSafe Function BCryptDestroyHash Lib "bcrypt" (ByVal hHash As LongPtr) As Long
33 + Private Declare PtrSafe Function BCryptHashData Lib "bcrypt" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
34 + Private Declare PtrSafe Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
35 + #Else
36 + Private Enum LongPtr
37 + [_]
38 + End Enum
39 + Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As LongPtr)
40 + Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
41 + Private Declare Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
42 + Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
43 + '--- bcrypt
44 + Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" (phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
45 + Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
46 + Private Declare Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, pbOutput As Any, ByVal cbOutput As Long, cbResult As Long, ByVal dwFlags As Long) As Long
47 + Private Declare Function BCryptSetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByVal pbInput As LongPtr, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
48 + Private Declare Function BCryptGenerateSymmetricKey Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
49 + Private Declare Function BCryptDestroyKey Lib "bcrypt" (ByVal hKey As LongPtr) As Long
50 + Private Declare Function BCryptEncrypt Lib "bcrypt" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal pPaddingInfo As LongPtr, ByVal pbIV As LongPtr, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, pcbResult As Long, ByVal dwFlags As Long) As Long
51 + Private Declare Function BCryptDeriveKeyPBKDF2 Lib "bcrypt" (ByVal hPrf As LongPtr, pbPassword As Any, ByVal cbPassword As Long, pbSalt As Any, ByVal cbSalt As Long, ByVal cIterations As Currency, pbDerivedKey As Any, ByVal cbDerivedKey As Long, ByVal dwFlags As Long) As Long
52 + Private Declare Function BCryptCreateHash Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phHash As LongPtr, ByVal pbHashObject As LongPtr, ByVal cbHashObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
53 + Private Declare Function BCryptDestroyHash Lib "bcrypt" (ByVal hHash As LongPtr) As Long
54 + Private Declare Function BCryptHashData Lib "bcrypt" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
55 + Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
56 + #End If
57 + #If Not ImplUseShared Then
58 + #If HasPtrSafe Then
59 + 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, pdwSkip As Long, pdwFlags As Long) As Long
60 + Private Declare PtrSafe Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As LongPtr, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As LongPtr, pcchString As Long) As Long
61 + Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
62 + Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
63 + Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As LongPtr, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Args As LongPtr) As Long
64 + #Else
65 + 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, pdwSkip As Long, pdwFlags As Long) As Long
66 + Private Declare Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As LongPtr, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As LongPtr, pcchString As Long) As Long
67 + Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
68 + Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
69 + Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As LongPtr, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Args As LongPtr) As Long
70 + #End If
71 + #End If
72 +
73 + '=========================================================================
74 + ' Constants and member variables
75 + '=========================================================================
76 +
77 + Private Const AES_BLOCK_SIZE As Long = 16
78 + Private Const AES_KEYLEN As Long = 32 '-- 32 -> AES-256, 24 -> AES-196, 16 -> AES-128
79 + Private Const AES_IVLEN As Long = AES_BLOCK_SIZE
80 + Private Const KDF_SALTLEN As Long = 8
81 + Private Const KDF_ITER As Long = 10000
82 + Private Const KDF_HASH As String = "SHA512"
83 + Private Const HMAC_HASH As String = "SHA256"
84 + Private Const OPENSSL_MAGIC As String = "Salted__" '-- for openssl compatibility
85 + Private Const OPENSSL_MAGICLEN As Long = 8
86 + Private Const ERR_UNSUPPORTED_ENCR As String = "Unsupported encryption"
87 + Private Const ERR_CHUNKED_NOT_INIT As String = "AES chunked context not initialized"
88 +
89 + Private Type UcsCryptoContextType
90 + hPbkdf2Alg As LongPtr
91 + hHmacAlg As LongPtr
92 + hHmacHash As LongPtr
93 + HashLen As Long
94 + hAesAlg As LongPtr
95 + hAesKey As LongPtr
96 + AesKeyObjData() As Byte
97 + AesKeyObjLen As Long
98 + Nonce(0 To 3) As Long
99 + EncrData() As Byte
100 + EncrPos As Long
101 + LastError As String
102 + End Type
103 +
104 + Private m_uChunkedCtx As UcsCryptoContextType
105 +
106 + '=========================================================================
107 + ' Functions
108 + '=========================================================================
109 +
110 + '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{Password} -in {sText}.file -a`
111 + Public Function AesEncryptString(sText As String, Optional Password As Variant) As String
112 + Const PREFIXLEN As Long = OPENSSL_MAGICLEN + KDF_SALTLEN
113 + Dim baData() As Byte
114 + Dim baPass() As Byte
115 + Dim baSalt() As Byte
116 + Dim baKey() As Byte
117 + Dim sError As String
118 +
119 + baData = ToUtf8Array(sText)
120 + baPass = vbNullString
121 + baSalt = vbNullString
122 + If Not IsArray(Password) Then
123 + If Not IsMissing(Password) Then
124 + baPass = ToUtf8Array(Password & vbNullString)
125 + End If
126 + ReDim baSalt(0 To KDF_SALTLEN - 1) As Byte
127 + Call RtlGenRandom(baSalt(0), KDF_SALTLEN)
128 + Else
129 + baKey = Password
130 + End If
131 + If Not AesCryptArray(baData, baPass, baSalt, baKey, Error:=sError) Then
132 + Err.Raise vbObjectError, , sError
133 + End If
134 + If Not IsArray(Password) Then
135 + ReDim Preserve baData(0 To UBound(baData) + PREFIXLEN) As Byte
136 + If UBound(baData) >= PREFIXLEN Then
137 + Call CopyMemory(baData(PREFIXLEN), baData(0), UBound(baData) + 1 - PREFIXLEN)
138 + End If
139 + Call CopyMemory(baData(OPENSSL_MAGICLEN), baSalt(0), KDF_SALTLEN)
140 + Call CopyMemory(baData(0), ByVal OPENSSL_MAGIC, OPENSSL_MAGICLEN)
141 + End If
142 + AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
143 + End Function
144 +
145 + '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{Password} -in {sEncr}.file -a -d`
146 + Public Function AesDecryptString(sEncr As String, Optional Password As Variant) As String
147 + Const PREFIXLEN As Long = OPENSSL_MAGICLEN + KDF_SALTLEN
148 + Dim baData() As Byte
149 + Dim baPass() As Byte
150 + Dim baSalt() As Byte
151 + Dim baKey() As Byte
152 + Dim sMagic As String
153 + Dim sError As String
154 +
155 + baData = FromBase64Array(sEncr)
156 + baPass = vbNullString
157 + baSalt = vbNullString
158 + If Not IsArray(Password) Then
159 + If Not IsMissing(Password) Then
160 + baPass = ToUtf8Array(Password & vbNullString)
161 + End If
162 + If UBound(baData) >= PREFIXLEN - 1 Then
163 + sMagic = String$(OPENSSL_MAGICLEN, 0)
164 + Call CopyMemory(ByVal sMagic, baData(0), OPENSSL_MAGICLEN)
165 + If sMagic = OPENSSL_MAGIC Then
166 + ReDim baSalt(0 To KDF_SALTLEN - 1) As Byte
167 + Call CopyMemory(baSalt(0), baData(OPENSSL_MAGICLEN), KDF_SALTLEN)
168 + If UBound(baData) >= PREFIXLEN Then
169 + Call CopyMemory(baData(0), baData(PREFIXLEN), UBound(baData) + 1 - PREFIXLEN)
170 + ReDim Preserve baData(0 To UBound(baData) - PREFIXLEN) As Byte
171 + Else
172 + baData = vbNullString
173 + End If
174 + End If
175 + End If
176 + Else
177 + baKey = Password
178 + End If
179 + If Not AesCryptArray(baData, baPass, baSalt, baKey, Error:=sError) Then
180 + Err.Raise vbObjectError, , sError
181 + End If
182 + AesDecryptString = FromUtf8Array(baData)
183 + End Function
184 +
185 + Public Function AesCryptArray( _
186 + baData() As Byte, _
187 + Optional Password As Variant, _
188 + Optional Salt As Variant, _
189 + Optional Key As Variant, _
190 + Optional ByVal KeyLen As Long, _
191 + Optional Error As String, _
192 + Optional Hmac As Variant) As Boolean
193 + Const VT_BYREF As Long = &H4000
194 + Dim uCtx As UcsCryptoContextType
195 + Dim vErr As Variant
196 + Dim bHashBefore As Boolean
197 + Dim bHashAfter As Boolean
198 + Dim baPass() As Byte
199 + Dim baSalt() As Byte
200 + Dim baKey() As Byte
201 + Dim baTemp() As Byte
202 + Dim lPtr As LongPtr
203 +
204 + On Error GoTo EH
205 + If IsArray(Hmac) Then
206 + bHashBefore = (Hmac(0) <= 0)
207 + bHashAfter = (Hmac(0) > 0)
208 + End If
209 + If IsMissing(Password) Then
210 + baPass = vbNullString
211 + ElseIf IsArray(Password) Then
212 + baPass = Password
213 + Else
214 + baPass = ToUtf8Array(Password & vbNullString)
215 + End If
216 + If IsMissing(Salt) Then
217 + baSalt = baPass
218 + ElseIf IsArray(Salt) Then
219 + baSalt = Salt
220 + Else
221 + baSalt = ToUtf8Array(Salt & vbNullString)
222 + End If
223 + If IsArray(Key) Then
224 + baKey = Key
225 + End If
226 + If KeyLen <= 0 Then
227 + KeyLen = AES_KEYLEN
228 + End If
229 + If Not pvCryptoAesCtrInit(uCtx, baPass, baSalt, baKey, KeyLen) Then
230 + Error = uCtx.LastError
231 + GoTo QH
232 + End If
233 + If Not pvCryptoAesCtrCrypt(uCtx, baData, HashBefore:=bHashBefore, HashAfter:=bHashAfter) Then
234 + Error = uCtx.LastError
235 + GoTo QH
236 + End If
237 + If IsArray(Hmac) Then
238 + baTemp = pvCryptoGetFinalHash(uCtx, UBound(Hmac) + 1)
239 + #If Win64 Then
240 + lPtr = PeekPtr(VarPtr(Hmac) + 8)
241 + #Else
242 + lPtr = PeekPtr((VarPtr(Hmac) Xor &H80000000) + 8 Xor &H80000000)
243 + #End If
244 + If (PeekPtr(VarPtr(Hmac)) And VT_BYREF) <> 0 Then
245 + lPtr = PeekPtr(lPtr)
246 + End If
247 + #If Win64 Then
248 + lPtr = PeekPtr(lPtr + 16)
249 + #Else
250 + lPtr = PeekPtr((lPtr Xor &H80000000) + 12 Xor &H80000000)
251 + #End If
252 + Call CopyMemory(ByVal lPtr, baTemp(0), UBound(baTemp) + 1)
253 + End If
254 + '--- success
255 + AesCryptArray = True
256 + QH:
257 + pvCryptoAesCtrTerminate uCtx
258 + Exit Function
259 + EH:
260 + vErr = Array(Err.Number, Err.Source, Err.Description)
261 + pvCryptoAesCtrTerminate uCtx
262 + Err.Raise vErr(0), vErr(1), vErr(2)
263 + End Function
264 +
265 + Public Function AesChunkedInit(Optional Key As Variant, Optional ByVal KeyLen As Long) As Boolean
266 + Dim baEmpty() As Byte
267 + Dim baKey() As Byte
268 +
269 + pvCryptoAesCtrTerminate m_uChunkedCtx
270 + baEmpty = vbNullString
271 + If IsArray(Key) Then
272 + baKey = Key
273 + End If
274 + If KeyLen <= 0 Then
275 + KeyLen = AES_KEYLEN
276 + End If
277 + AesChunkedInit = pvCryptoAesCtrInit(m_uChunkedCtx, baEmpty, baEmpty, baKey, KeyLen)
278 + End Function
279 +
280 + Public Function AesChunkedCryptArray(baInput() As Byte, baOutput() As Byte, Optional ByVal Final As Boolean = True) As Boolean
281 + If m_uChunkedCtx.hAesAlg = 0 Then
282 + m_uChunkedCtx.LastError = ERR_CHUNKED_NOT_INIT
283 + Exit Function
284 + End If
285 + baOutput = baInput
286 + AesChunkedCryptArray = pvCryptoAesCtrCrypt(m_uChunkedCtx, baOutput)
287 + If Final Then
288 + pvCryptoAesCtrTerminate m_uChunkedCtx
289 + End If
290 + End Function
291 +
292 + Public Function AesChunkedGetLastError() As String
293 + AesChunkedGetLastError = m_uChunkedCtx.LastError
294 + End Function
295 +
296 + '= private ===============================================================
297 +
298 + Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As Byte, baSalt() As Byte, baDerivedKey() As Byte, ByVal lKeyLen As Long) As Boolean
299 + Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"
300 + Const BCRYPT_ALG_HANDLE_HMAC_FLAG As Long = 8
301 + Dim hResult As Long
302 +
303 + With uCtx
304 + '--- init member vars
305 + .EncrData = vbNullString
306 + .EncrPos = 0
307 + .LastError = vbNullString
308 + ReDim Preserve baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
309 + If UBound(baPass) >= 0 Or UBound(baSalt) >= 0 Then
310 + '--- generate RFC 2898 based derived key
311 + On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
312 + hResult = BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr(KDF_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
313 + If hResult < 0 Then
314 + GoTo QH
315 + End If
316 + hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
317 + KDF_ITER / 10000@, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
318 + If hResult < 0 Then
319 + GoTo QH
320 + End If
321 + On Error GoTo 0
322 + End If
323 + '--- init AES key from first half of derived key
324 + On Error GoTo EH_Unsupported '--- CNG API missing on XP
325 + hResult = BCryptOpenAlgorithmProvider(.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0)
326 + If hResult < 0 Then
327 + GoTo QH
328 + End If
329 + On Error GoTo 0
330 + hResult = BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, 0, 0)
331 + If hResult < 0 Then
332 + GoTo QH
333 + End If
334 + hResult = BCryptSetProperty(.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), 30, 0) ' 30 = LenB("ChainingModeECB")
335 + If hResult < 0 Then
336 + GoTo QH
337 + End If
338 + ReDim .AesKeyObjData(0 To .AesKeyObjLen - 1) As Byte
339 + hResult = BCryptGenerateSymmetricKey(.hAesAlg, .hAesKey, .AesKeyObjData(0), .AesKeyObjLen, baDerivedKey(0), lKeyLen, 0)
340 + If hResult < 0 Then
341 + GoTo QH
342 + End If
343 + '--- init AES IV from second half of derived key
344 + Call CopyMemory(.Nonce(0), baDerivedKey(lKeyLen), AES_IVLEN)
345 + '--- init HMAC key from last HashLen bytes of derived key
346 + hResult = BCryptOpenAlgorithmProvider(.hHmacAlg, StrPtr(HMAC_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
347 + If hResult < 0 Then
348 + GoTo QH
349 + End If
350 + hResult = BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, 0, 0)
351 + If hResult < 0 Then
352 + GoTo QH
353 + End If
354 + hResult = BCryptCreateHash(.hHmacAlg, .hHmacHash, 0, 0, baDerivedKey(lKeyLen + AES_IVLEN - .HashLen), .HashLen, 0)
355 + If hResult < 0 Then
356 + GoTo QH
357 + End If
358 + End With
359 + '--- success
360 + pvCryptoAesCtrInit = True
361 + Exit Function
362 + QH:
363 + uCtx.LastError = GetSystemMessage(hResult)
364 + Exit Function
365 + EH_Unsupported:
366 + uCtx.LastError = ERR_UNSUPPORTED_ENCR
367 + End Function
368 +
369 + Private Sub pvCryptoAesCtrTerminate(uCtx As UcsCryptoContextType)
370 + With uCtx
371 + If .hPbkdf2Alg <> 0 Then
372 + Call BCryptCloseAlgorithmProvider(.hPbkdf2Alg, 0)
373 + .hPbkdf2Alg = 0
374 + End If
375 + If .hHmacHash <> 0 Then
376 + Call BCryptDestroyHash(.hHmacHash)
377 + .hHmacHash = 0
378 + End If
379 + If .hHmacAlg <> 0 Then
380 + Call BCryptCloseAlgorithmProvider(.hHmacAlg, 0)
381 + .hHmacAlg = 0
382 + End If
383 + If .hAesKey <> 0 Then
384 + Call BCryptDestroyKey(.hAesKey)
385 + .hAesKey = 0
386 + End If
387 + If .hAesAlg <> 0 Then
388 + Call BCryptCloseAlgorithmProvider(.hAesAlg, 0)
389 + .hAesAlg = 0
390 + End If
391 + End With
392 + End Sub
393 +
394 + Private Function pvCryptoAesCtrCrypt( _
395 + uCtx As UcsCryptoContextType, _
396 + baData() As Byte, _
397 + Optional ByVal Offset As Long, _
398 + Optional ByVal Size As Long = -1, _
399 + Optional ByVal HashBefore As Boolean, _
400 + Optional ByVal HashAfter As Boolean) As Boolean
401 + Dim lIdx As Long
402 + Dim lJdx As Long
403 + Dim lPadSize As Long
404 + Dim hResult As Long
405 +
406 + With uCtx
407 + If Size < 0 Then
408 + Size = pvArraySize(baData) - Offset
409 + End If
410 + If HashBefore Then
411 + hResult = BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0)
412 + If hResult < 0 Then
413 + GoTo QH
414 + End If
415 + End If
416 + '--- reuse .EncrData from prev call until next AES_BLOCK_SIZE boundary
417 + For lIdx = Offset To Offset + Size - 1
418 + If (.EncrPos And (AES_BLOCK_SIZE - 1)) = 0 Then
419 + Exit For
420 + End If
421 + baData(lIdx) = baData(lIdx) Xor .EncrData(.EncrPos)
422 + .EncrPos = .EncrPos + 1
423 + Next
424 + If lIdx < Offset + Size Then
425 + '--- pad remaining input size to AES_BLOCK_SIZE
426 + lPadSize = (Offset + Size - lIdx + AES_BLOCK_SIZE - 1) And -AES_BLOCK_SIZE
427 + If UBound(.EncrData) + 1 < lPadSize Then
428 + ReDim .EncrData(0 To lPadSize - 1) As Byte
429 + End If
430 + '--- encrypt incremental Nonce in .EncrData
431 + For lJdx = 0 To lPadSize - 1 Step AES_BLOCK_SIZE
432 + Call CopyMemory(.EncrData(lJdx), .Nonce(0), AES_BLOCK_SIZE)
433 + If pvInc(.Nonce(3)) Then
434 + If pvInc(.Nonce(2)) Then
435 + If pvInc(.Nonce(1)) Then
436 + If pvInc(.Nonce(0)) Then
437 + '--- do nothing
438 + End If
439 + End If
440 + End If
441 + End If
442 + Next
443 + hResult = BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0)
444 + If hResult < 0 Then
445 + GoTo QH
446 + End If
447 + '--- XOR remaining input and leave anything extra in .EncrData for reuse
448 + For .EncrPos = 0 To Offset + Size - lIdx - 1
449 + baData(lIdx) = baData(lIdx) Xor .EncrData(.EncrPos)
450 + lIdx = lIdx + 1
451 + Next
452 + End If
453 + If HashAfter Then
454 + hResult = BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0)
455 + If hResult < 0 Then
456 + GoTo QH
457 + End If
458 + End If
459 + End With
460 + '--- success
461 + pvCryptoAesCtrCrypt = True
462 + Exit Function
463 + QH:
464 + uCtx.LastError = GetSystemMessage(hResult)
465 + End Function
466 +
467 + Private Function pvCryptoGetFinalHash(uCtx As UcsCryptoContextType, ByVal lSize As Long) As Byte()
468 + Dim baResult() As Byte
469 +
470 + ReDim baResult(0 To uCtx.HashLen - 1) As Byte
471 + Call BCryptFinishHash(uCtx.hHmacHash, baResult(0), uCtx.HashLen, 0)
472 + ReDim Preserve baResult(0 To lSize - 1) As Byte
473 + pvCryptoGetFinalHash = baResult
474 + End Function
475 +
476 + Private Function pvInc(lValue As Long) As Boolean
477 + lValue = htonl(lValue)
478 + If lValue = -1 Then
479 + lValue = 0
480 + '--- signal carry
481 + pvInc = True
482 + Else
483 + lValue = (lValue Xor &H80000000) + 1 Xor &H80000000
484 + lValue = htonl(lValue)
485 + End If
486 + End Function
487 +
488 + Private Property Get pvArrayPtr(baArray() As Byte, Optional ByVal Index As Long) As LongPtr
489 + Dim lPtr As LongPtr
490 +
491 + '--- peek long at ArrPtr(baArray)
492 + Call CopyMemory(lPtr, ByVal ArrPtr(baArray), PTR_SIZE)
493 + If lPtr <> 0 Then
494 + If 0 <= Index And Index <= UBound(baArray) - LBound(baArray) Then
495 + pvArrayPtr = VarPtr(baArray(LBound(baArray) + Index))
496 + End If
497 + End If
498 + End Property
499 +
500 + Private Property Get pvArraySize(baArray() As Byte) As Long
501 + Dim lPtr As LongPtr
502 +
503 + '--- peek long at ArrPtr(baArray)
504 + Call CopyMemory(lPtr, ByVal ArrPtr(baArray), PTR_SIZE)
505 + If lPtr <> 0 Then
506 + pvArraySize = UBound(baArray) + 1 - LBound(baArray)
507 + End If
508 + End Property
509 +
510 + '= shared ================================================================
511 +
512 + #If Not ImplUseShared Then
513 + Public Function ToBase64Array(baData() As Byte) As String
514 + Const CRYPT_STRING_BASE64 As Long = 1
515 + Dim lSize As Long
516 +
517 + If UBound(baData) >= 0 Then
518 + ToBase64Array = String$(2 * UBound(baData) + 6, 0)
519 + lSize = Len(ToBase64Array) + 1
520 + Call CryptBinaryToString(VarPtr(baData(0)), UBound(baData) + 1, CRYPT_STRING_BASE64, StrPtr(ToBase64Array), lSize)
521 + ToBase64Array = Left$(ToBase64Array, lSize)
522 + End If
523 + End Function
524 +
525 + Public Function FromBase64Array(sText As String) As Byte()
526 + Const CRYPT_STRING_BASE64 As Long = 1
527 + Dim lSize As Long
528 + Dim baOutput() As Byte
529 +
530 + lSize = Len(sText) + 1
531 + ReDim baOutput(0 To lSize - 1) As Byte
532 + Call CryptStringToBinary(StrPtr(sText), Len(sText), CRYPT_STRING_BASE64, VarPtr(baOutput(0)), lSize, 0, 0)
533 + If lSize > 0 Then
534 + ReDim Preserve baOutput(0 To lSize - 1) As Byte
535 + FromBase64Array = baOutput
536 + Else
537 + FromBase64Array = vbNullString
538 + End If
539 + End Function
540 +
541 + Public Function ToUtf8Array(sText As String) As Byte()
542 + Const CP_UTF8 As Long = 65001
543 + Dim baRetVal() As Byte
544 + Dim lSize As Long
545 +
546 + lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
547 + If lSize > 0 Then
548 + ReDim baRetVal(0 To lSize - 1) As Byte
549 + Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
550 + Else
551 + baRetVal = vbNullString
552 + End If
553 + ToUtf8Array = baRetVal
554 + End Function
555 +
556 + Public Function FromUtf8Array(baText() As Byte) As String
557 + Const CP_UTF8 As Long = 65001
558 + Dim lSize As Long
559 +
560 + If UBound(baText) >= 0 Then
561 + FromUtf8Array = String$(2 * (UBound(baText) + 1), 0)
562 + lSize = MultiByteToWideChar(CP_UTF8, 0, baText(0), UBound(baText) + 1, StrPtr(FromUtf8Array), Len(FromUtf8Array))
563 + FromUtf8Array = Left$(FromUtf8Array, lSize)
564 + End If
565 + End Function
566 +
567 + Public Function GetSystemMessage(ByVal lLastDllError As Long) As String
568 + Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
569 + Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
570 + Dim lSize As Long
571 +
572 + GetSystemMessage = Space$(2000)
573 + lSize = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDllError, 0, GetSystemMessage, Len(GetSystemMessage), 0)
574 + If lSize > 2 Then
575 + If Mid$(GetSystemMessage, lSize - 1, 2) = vbCrLf Then
576 + lSize = lSize - 2
577 + End If
578 + End If
579 + GetSystemMessage = Left$(GetSystemMessage, lSize) & " &H" & Hex(lLastDllError)
580 + End Function
581 +
582 + Private Function PeekPtr(ByVal lPtr As LongPtr) As LongPtr
583 + Call CopyMemory(PeekPtr, ByVal lPtr, PTR_SIZE)
584 + End Function
585 + #End If
Newer Older

Powered by Opengist ⋅ Load: 210ms⋅

English