diff --git a/src/cTlsSocket.cls b/src/cTlsSocket.cls index 2920e27..7ba92a2 100644 --- a/src/cTlsSocket.cls +++ b/src/cTlsSocket.cls @@ -1237,6 +1237,7 @@ Public Function SyncReceiveText( _ Dim baRecv() As Byte Dim lPos As Long Dim baBuffer() As Byte + Dim bResult As Boolean On Error GoTo EH If m_bUseTls Then @@ -1245,6 +1246,7 @@ Public Function SyncReceiveText( _ End If baBuffer = vbNullString dblTimer = TimerEx + bResult = True Do If NeedLen = 0 Then If Not ReceiveArray(baBuffer) Then @@ -1269,9 +1271,10 @@ Public Function SyncReceiveText( _ GoTo QH End If End If - If Not SyncWaitForEvent(Timeout - lElapsed, ucsSfdRead) Then + If Not bResult Then GoTo QH End If + bResult = SyncWaitForEvent(Timeout - lElapsed, ucsSfdRead) Loop Else SyncReceiveText = m_oSocket.SyncReceiveText(NeedLen:=NeedLen, Timeout:=Timeout, CodePage:=CodePage) @@ -1291,6 +1294,7 @@ Public Function SyncReceiveArray( _ Dim dblTimer As Double Dim baRecv() As Byte Dim lPos As Long + Dim bResult As Boolean On Error GoTo EH If m_bUseTls Then @@ -1299,6 +1303,7 @@ Public Function SyncReceiveArray( _ End If Buffer = vbNullString dblTimer = TimerEx + bResult = True Do If NeedLen = 0 Then If Not ReceiveArray(Buffer) Then @@ -1322,9 +1327,10 @@ Public Function SyncReceiveArray( _ GoTo QH End If End If - If Not SyncWaitForEvent(Timeout - lElapsed, ucsSfdRead) Then + If Not bResult Then GoTo QH End If + bResult = SyncWaitForEvent(Timeout - lElapsed, ucsSfdRead) Loop '--- success SyncReceiveArray = True diff --git a/src/mdTlsNative.bas b/src/mdTlsNative.bas index d36d8a6..1b375a6 100644 --- a/src/mdTlsNative.bas +++ b/src/mdTlsNative.bas @@ -33,7 +33,6 @@ Private Const SCH_CREDENTIALS_VERSION As Long = 5 Private Const SP_PROT_TLS1_0 As Long = &H40 Or &H80 Private Const SP_PROT_TLS1_1 As Long = &H100 Or &H200 Private Const SP_PROT_TLS1_2 As Long = &H400 Or &H800 -Private Const SP_PROT_TLS1_3 As Long = &H1000 Or &H2000 Private Const SCH_CRED_MANUAL_CRED_VALIDATION As Long = 8 Private Const SCH_CRED_NO_DEFAULT_CREDS As Long = &H10 Private Const SCH_CRED_REVOCATION_CHECK_CHAIN_EXCLUDE_ROOT As Long = &H400 @@ -553,6 +552,7 @@ End Function Public Function TlsHandshake(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSize As Long, baOutput() As Byte, lOutputPos As Long) As Boolean Const FUNC_NAME As String = "TlsHandshake" + Const ucsTlsSupportAllTo12 As Long = ucsTlsSupportTls10 Or ucsTlsSupportTls11 Or ucsTlsSupportTls12 Dim uCred As SCHANNEL_CRED Dim uNewCred As SCH_CREDENTIALS Dim uNewParams As TLS_PARAMETERS @@ -606,9 +606,11 @@ Public Function TlsHandshake(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSi RetryCredentials: If .hTlsCredentials = 0 Then uCred.dwVersion = SCHANNEL_CRED_VERSION - uCred.grbitEnabledProtocols = IIf((.LocalFeatures And ucsTlsSupportTls10) <> 0, SP_PROT_TLS1_0, 0) Or _ - IIf((.LocalFeatures And ucsTlsSupportTls11) <> 0, SP_PROT_TLS1_1, 0) Or _ - IIf((.LocalFeatures And ucsTlsSupportTls12) <> 0, SP_PROT_TLS1_2, 0) + If (.LocalFeatures And ucsTlsSupportAllTo12) <> ucsTlsSupportAllTo12 Then + uCred.grbitEnabledProtocols = IIf((.LocalFeatures And ucsTlsSupportTls10) <> 0, SP_PROT_TLS1_0, 0) Or _ + IIf((.LocalFeatures And ucsTlsSupportTls11) <> 0, SP_PROT_TLS1_1, 0) Or _ + IIf((.LocalFeatures And ucsTlsSupportTls12) <> 0, SP_PROT_TLS1_2, 0) + End If uCred.dwFlags = uCred.dwFlags Or SCH_CRED_MANUAL_CRED_VALIDATION ' Prevent Schannel from validating the received server certificate chain. uCred.dwFlags = uCred.dwFlags Or SCH_CRED_NO_DEFAULT_CREDS ' Prevent Schannel from attempting to automatically supply a certificate chain for client authentication. uCred.dwFlags = uCred.dwFlags Or SCH_CRED_REVOCATION_CHECK_CHAIN_EXCLUDE_ROOT ' Force TLS certificate status request extension (commonly known as OCSP stapling) to be sent on Vista or later @@ -631,8 +633,9 @@ RetryCredentials: 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)) + If uCred.grbitEnabledProtocols <> 0 Then + uNewParams.grbitDisabledProtocols = Not uCred.grbitEnabledProtocols + End If hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uNewCred, 0, 0, .hTlsCredentials, 0) End If End If @@ -853,7 +856,7 @@ Public Function TlsReceive(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSize On Error GoTo EH With uCtx - If .State = ucsTlsStateClosed Then + If .State = ucsTlsStateClosed Or .hTlsContext = 0 Then pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED GoTo QH End If @@ -954,7 +957,7 @@ Public Function TlsSend(uCtx As UcsTlsContext, baPlainText() As Byte, ByVal lSiz On Error GoTo EH With uCtx - If .State = ucsTlsStateClosed Then + If .State = ucsTlsStateClosed Or .hTlsContext = 0 Then pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED GoTo QH End If @@ -1179,6 +1182,8 @@ End Function #If ImplUseDebugLog Then Private Function pvTlsGetAlgName(ByVal lAlgId As Long) As String Select Case lAlgId + Case &H8& + pvTlsGetAlgName = "SSL2_CLIENT" Case &H20& pvTlsGetAlgName = "SSL3_CLIENT" Case &H80& @@ -1189,6 +1194,8 @@ Private Function pvTlsGetAlgName(ByVal lAlgId As Long) As String pvTlsGetAlgName = "TLS1_2_CLIENT" Case &H2000& pvTlsGetAlgName = "TLS1_3_CLIENT" + Case &H4& + pvTlsGetAlgName = "SSL2_SERVER" Case &H10& pvTlsGetAlgName = "SSL3_SERVER" Case &H40& diff --git a/test/Secure/Form2.frm b/test/Secure/Form2.frm index 039f5b3..84995f6 100644 --- a/test/Secure/Form2.frm +++ b/test/Secure/Form2.frm @@ -157,7 +157,7 @@ Private Sub Form_Load() m_oRootCa.ImportPemRootCaCertStore App.Path & "\ca-bundle.pem" Set m_oServerSocket = New cTlsSocket ChDir App.Path - If Not m_oServerSocket.InitServerTls(STR_CERTFILE, STR_PASSWORD) Then + If Not m_oServerSocket.InitServerTls(STR_CERTFILE, STR_PASSWORD, CertSubject:=Environ$("_UCS_CERTSUBJECT")) Then MsgBox "Error starting TLS server on localhost:10443" & vbCrLf & vbCrLf & m_oServerSocket.LastError.Description, vbExclamation GoTo QH End If @@ -339,6 +339,10 @@ Private Function pvIsKnownBadCertificate(sHost As String) As Boolean Const STR_HOSTS As String = "mikestoolbox.org|localhost|client.tlsfingerprint.io" Dim vElem As Variant + If Not (sHost Like "*[!0-9.]*") Then + pvIsKnownBadCertificate = True + Exit Function + End If For Each vElem In Split(STR_HOSTS, "|") If Right$(LCase$(sHost), Len(vElem)) = vElem Then pvIsKnownBadCertificate = True @@ -426,6 +430,10 @@ Friend Sub frRemoveHandler(sKey As String) RemoveCollection m_cRequestHandlers, sKey End Sub +Friend Sub frLogError(sKey As String, oErr As VBA.ErrObject) + pvAppendLogText txtResult, "Error: " & oErr.Description & " (" & sKey & ")" & vbCrLf +End Sub + Private Function pvSetVisible(oCtl As Object, ByVal bValue As Boolean) As Boolean oCtl.Visible = bValue pvSetVisible = True diff --git a/test/Secure/cRequestHandler.cls b/test/Secure/cRequestHandler.cls index 5074648..2368381 100644 --- a/test/Secure/cRequestHandler.cls +++ b/test/Secure/cRequestHandler.cls @@ -127,6 +127,7 @@ Private Sub m_oSocket_OnError(ByVal ErrorCode As Long, ByVal EventMask As UcsAsy #Else Debug.Print "Error: " & .Description & " &H" & Hex$(.Number) & " [" & MODULE_NAME & "." & FUNC_NAME & ", " & Replace(.Source, vbCrLf, ", ") & "]" #End If + Parent.frLogError m_sKey, m_oSocket.LastError End If End With Parent.frRemoveHandler m_sKey