Support all protocols by default (incl. SSL2 and SSL3) in native backend

wqweto · Nov 9, 2023 · 7d20880 · 7d20880
1 parent efdf0f1
commit 7d20880
Show file tree

Hide file tree

Showing 4 changed files with 33 additions and 11 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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