diff --git a/src/cTlsSocket.cls b/src/cTlsSocket.cls index cf23eea..1c3425f 100644 --- a/src/cTlsSocket.cls +++ b/src/cTlsSocket.cls @@ -2317,7 +2317,7 @@ Private Function pvPkiPkcs12ImportCertificates(sPfxFile As String, sPassword As End If uBlob.cbData = UBound(baPfx) + 1 uBlob.pbData = VarPtr(baPfx(0)) - dwFlags = CRYPT_EXPORTABLE Or IIf(OsVersion < ucsOsvXp, 0, PKCS12_NO_PERSIST_KEY) + dwFlags = CRYPT_EXPORTABLE Or IIf(OsVersion <= ucsOsvXp, 0, PKCS12_NO_PERSIST_KEY) hPfxStore = PFXImportCertStore(uBlob, StrPtr(sPassword), dwFlags) If hPfxStore = 0 And Err.LastDllError <> NTE_BAD_ALGID Then hPfxStore = PFXImportCertStore(baPfx(0), 0, dwFlags) diff --git a/src/mdTlsNative.bas b/src/mdTlsNative.bas index 2923c9e..232d9ef 100644 --- a/src/mdTlsNative.bas +++ b/src/mdTlsNative.bas @@ -91,6 +91,7 @@ Private Const CERT_STORE_CREATE_NEW_FLAG As Long = &H2000 Private Const CERT_STORE_ADD_USE_EXISTING As Long = 2 '--- for CryptAcquireContext Private Const PROV_RSA_FULL As Long = 1 +Private Const PROV_RSA_SCHANNEL As Long = 12 Private Const CRYPT_NEWKEYSET As Long = &H8 Private Const CRYPT_DELETEKEYSET As Long = &H10 Private Const AT_KEYEXCHANGE As Long = 1 @@ -571,6 +572,7 @@ Public Function TlsHandshake(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSi Dim uCipherInfo As SecPkgContext_CipherInfo Dim baAlpnBuffer() As Byte Dim uAppProtocol As SecPkgContext_ApplicationProtocol + Dim eVersion As UcsOsVersionEnum On Error GoTo EH With uCtx @@ -616,19 +618,21 @@ RetryCredentials: .ContextReq = .ContextReq Or ISC_REQ_USE_SUPPLIED_CREDS ' Schannel must not attempt to supply credentials for the client automatically. End If End If - If RealOsVersion(BuildNo:=lIdx) = ucsOsvWin10 And lIdx >= 20348 Then '--- 20348 = Windows Server 2022 - '--- use new credentials struct for TLS 1.3 support - uNewCred.dwVersion = SCH_CREDENTIALS_VERSION - uNewCred.cCreds = uCred.cCreds - uNewCred.paCred = uCred.paCred - uNewCred.dwFlags = uCred.dwFlags Or SCH_USE_STRONG_CRYPTO - uNewCred.cTlsParameters = 1 - uNewCred.pTlsParameters = VarPtr(uNewParams) - uNewParams.grbitDisabledProtocols = Not (uCred.grbitEnabledProtocols Or _ - IIf((.LocalFeatures And ucsTlsSupportTls13) <> 0, SP_PROT_TLS1_3, 0)) - hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uNewCred, 0, 0, .hTlsCredentials, 0) - Else - hResult = -1 + hResult = -1 + If (.LocalFeatures And ucsTlsSupportTls13) <> 0 Then + eVersion = RealOsVersion(BuildNo:=lIdx) + If eVersion > ucsOsvWin10 Or (eVersion = ucsOsvWin10 And lIdx >= 20348) Then '--- 20348 = Windows Server 2022 + '--- use new credentials struct for TLS 1.3 support + uNewCred.dwVersion = SCH_CREDENTIALS_VERSION + uNewCred.cCreds = uCred.cCreds + uNewCred.paCred = uCred.paCred + uNewCred.dwFlags = uCred.dwFlags Or SCH_USE_STRONG_CRYPTO + uNewCred.cTlsParameters = 1 + uNewCred.pTlsParameters = VarPtr(uNewParams) + uNewParams.grbitDisabledProtocols = Not (uCred.grbitEnabledProtocols Or _ + IIf((.LocalFeatures And ucsTlsSupportTls13) <> 0, SP_PROT_TLS1_3, 0)) + hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uNewCred, 0, 0, .hTlsCredentials, 0) + End If End If If hResult < 0 Then hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uCred, 0, 0, .hTlsCredentials, 0) @@ -1378,7 +1382,7 @@ Private Function pvTlsImportToCertStore(cCerts As Collection, cPrivKey As Collec Select Case pvToStringA(uPublicKeyInfo.Algorithm.pszObjId) Case szOID_RSA_RSA uProvInfo.pwszContainerName = StrPtr(sKeyName) - uProvInfo.dwProvType = PROV_RSA_FULL + uProvInfo.dwProvType = PROV_RSA_SCHANNEL '--- note: PROV_RSA_FULL fails on WinXP uProvInfo.dwKeySpec = AT_KEYEXCHANGE If CryptAcquireContext(hProv, uProvInfo.pwszContainerName, uProvInfo.pwszProvName, uProvInfo.dwProvType, uProvInfo.dwFlags) = 0 Then If CryptAcquireContext(hProv, uProvInfo.pwszContainerName, uProvInfo.pwszProvName, uProvInfo.dwProvType, uProvInfo.dwFlags Or CRYPT_NEWKEYSET) = 0 Then diff --git a/test/Secure/Form2.frm b/test/Secure/Form2.frm index 830b180..039f5b3 100644 --- a/test/Secure/Form2.frm +++ b/test/Secure/Form2.frm @@ -144,7 +144,7 @@ Private Sub Form_Load() If txtResult.Font.Name = "Arial" Then txtResult.Font.Name = "Courier New" End If - For Each vElem In Split("www.howsmyssl.com/a/check|clienttest.ssllabs.com:8443/ssltest/viewMyClient.html|client.tlsfingerprint.io:8443|tls13.1d.pw|localhost:44330/renegcert|websocket.org|www.mikestoolbox.org|swifttls.org|rsa8192.badssl.com|rsa4096.badssl.com|rsa2048.badssl.com|ecc384.badssl.com|ecc256.badssl.com|dir.bg|host.bg|bgdev.org|cnn.com|gmail.com|google.com|saas.bg|saas.bg:465|www.cloudflare.com|devblogs.microsoft.com|www.brentozar.com|ayende.com/blog|www.nerds2nerds.com|robert.ocallahan.org|distrowatch.com|server.cryptomix.com|www.integralblue.com/testhandshake/|tlshello.agwa.name|client.badssl.com", "|") + For Each vElem In Split("www.howsmyssl.com/a/check|tls.peet.ws/api/all|clienttest.ssllabs.com:8443/ssltest/viewMyClient.html|client.tlsfingerprint.io:8443|tls13.1d.pw|localhost:44330/renegcert|websocket.org|www.mikestoolbox.org|swifttls.org|rsa8192.badssl.com|rsa4096.badssl.com|rsa2048.badssl.com|ecc384.badssl.com|ecc256.badssl.com|dir.bg|host.bg|bgdev.org|cnn.com|gmail.com|google.com|saas.bg|saas.bg:465|www.cloudflare.com|devblogs.microsoft.com|www.brentozar.com|ayende.com/blog|www.nerds2nerds.com|robert.ocallahan.org|distrowatch.com|server.cryptomix.com|www.integralblue.com/testhandshake/|tlshello.agwa.name|client.badssl.com", "|") cobUrl.AddItem vElem Next sAddr = GetSetting(App.Title, "Form1", "Url", cobUrl.Text) @@ -158,10 +158,10 @@ Private Sub Form_Load() Set m_oServerSocket = New cTlsSocket ChDir App.Path If Not m_oServerSocket.InitServerTls(STR_CERTFILE, STR_PASSWORD) Then - MsgBox "Error starting TLS server on localhost:10443" & vbCrLf & vbCrLf & "No private key found!", vbExclamation + MsgBox "Error starting TLS server on localhost:10443" & vbCrLf & vbCrLf & m_oServerSocket.LastError.Description, vbExclamation GoTo QH End If - If Not m_oServerSocket.Create(SocketPort:=10443, SocketAddress:="localhost") Then + If Not m_oServerSocket.Create(SocketPort:=10443, SocketAddress:="0.0.0.0") Then GoTo QH End If If Not m_oServerSocket.Listen() Then