Results 1 to 25 of 25

Thread: vb6 Websocket Server ssl

  1. #1

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Thumbs up vb6 Websocket Server ssl

    Secure webSocket Server in Pure VB6 no external Libraries or ActiveX.
    Now wss://localhost:8088 is possible.
    Now Lengthy(char length more than 65536) messages possible.

    Thanks goes to :
    Vladimir Vissoultchev(wqweto)
    Olaf Schmidt
    xxdoc123
    and many others.
    https://github.com/wqweto/VbAsyncSocket

    https://www.vbforums.com/showthread....ushServer-Demo

    https://github.com/bloatless/php-websocket

    https://www.cnblogs.com/xiii/p/5165303.html



    In order to create a self-signed ssl certificate you need open-ssl. In my case I have done it in my cloud server and downloaded.
    Follow the instructions given here :

    https://www.freecodecamp.org/news/ho...-7af615770eec/

    after install the certificate. open rootCa.crt -> Install Certificate - > Next -> Place all certificates in the following store -> Browse
    -> Trusted Root Certification Authorities - > OK -> Next - > Finish - > Install/Approve

    Notes:

    I have combined and ported codes from here and there, and given the references, detailed code explanations can be found there.

    Update: Sep 24,2021
    Attached Images Attached Images  
    Attached Files Attached Files
    Last edited by joshyfrancis; Sep 23rd, 2021 at 09:00 PM. Reason: Fixed Unicode problems

  2. #2
    PowerPoster
    Join Date
    Jun 2013
    Posts
    5,611

    Re: vb6 Secure Websocket

    Nice...

    Just a note about a constant-definition within cAsyncSocket (also @wqweto):
    Code:
    Private Const MAX_SOCKETS           As Long = &HC000 - WM_SOCKET_NOTIFY
    The above line currently resolves to a negative Value of: -17410

    The intent was probably:
    Code:
    Private Const MAX_SOCKETS           As Long = &HC000& - WM_SOCKET_NOTIFY
    It works so far (with multiple connections), because there's a decently sized SockPointer-Buffer-Initializing of:
    ReDim .SocketPtr(0 To 511) As Long 'in Class_Initialize
    (Max_Sockets would comes into play later only, when the Ubound of this Array needs to be expanded).

    HTH

    Olaf

  3. #3
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Posts
    3,293

    Re: vb6 Secure Websocket

    Quote Originally Posted by Schmidt View Post
    Nice...

    Just a note about a constant-definition within cAsyncSocket (also @wqweto):
    Code:
    Private Const MAX_SOCKETS           As Long = &HC000 - WM_SOCKET_NOTIFY
    The above line currently resolves to a negative Value of: -17410

    The intent was probably:
    Code:
    Private Const MAX_SOCKETS           As Long = &HC000& - WM_SOCKET_NOTIFY
    It works so far (with multiple connections), because there's a decently sized SockPointer-Buffer-Initializing of:
    ReDim .SocketPtr(0 To 511) As Long 'in Class_Initialize
    (Max_Sockets would comes into play later only, when the Ubound of this Array needs to be expanded).

    HTH

    Olaf
    Ouch!

    Fixed in commit 0ebeeda

    cheers,
    </wqw>

  4. #4

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Secure Websocket

    Quote Originally Posted by Schmidt View Post
    Nice...

    Just a note about a constant-definition within cAsyncSocket (also @wqweto):
    Code:
    Private Const MAX_SOCKETS           As Long = &HC000 - WM_SOCKET_NOTIFY
    The above line currently resolves to a negative Value of: -17410

    The intent was probably:
    Code:
    Private Const MAX_SOCKETS           As Long = &HC000& - WM_SOCKET_NOTIFY
    It works so far (with multiple connections), because there's a decently sized SockPointer-Buffer-Initializing of:
    ReDim .SocketPtr(0 To 511) As Long 'in Class_Initialize
    (Max_Sockets would comes into play later only, when the Ubound of this Array needs to be expanded).

    HTH

    Olaf
    Nice suggestion too. Thanks for reply. Thanks @wqweto for the quick updation.

  5. #5
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Secure Websocket

    Quote Originally Posted by joshyfrancis View Post
    Secure webSocket in Pure VB6 no external Libraries or ActiveX.
    Now wss://localhost:8088 is possible.
    Now Lengthy(char length more than 65536) messages possible.

    Thanks goes to :
    Vladimir Vissoultchev(wqweto)
    Olaf Schmidt
    and many others.
    https://github.com/wqweto/VbAsyncSocket

    https://www.vbforums.com/showthread....ushServer-Demo

    https://github.com/bloatless/php-websocket

    https://www.cnblogs.com/xiii/p/5165303.html



    In order to create a self-signed ssl certificate you need open-ssl. In my case I have done it in my cloud server and downloaded.
    Follow the instructions given here :

    https://www.freecodecamp.org/news/ho...-7af615770eec/

    after install the certificate. open rootCa.crt -> Install Certificate - > Next -> Place all certificates in the following store -> Browse
    -> Trusted Root Certification Authorities - > OK -> Next - > Finish - > Install/Approve

    Download the attachment

    Attachment 180338

    Notes:

    I have combined and ported codes from here and there, and given the references, detailed code explanations can be found there.
    in my system7 chinese

    if i click the button "Send Chat-Message",then wss closed . cannot Connect

    Name:  无标题.bmp
Views: 583
Size:  135.1 KB

  6. #6

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Secure Websocket

    Quote Originally Posted by xxdoc123 View Post
    in my system7 chinese

    if i click the button "Send Chat-Message",then wss closed . cannot Connect

    Name:  无标题.bmp
Views: 583
Size:  135.1 KB
    In the data arrival section http request header parsing is done but not handling unicode characters.
    Header must have vbcrlf , if not it is data. In this case the splitting by vbcrlf must be replaced and some
    other logic should be applied.

  7. #7
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Secure Websocket

    Quote Originally Posted by joshyfrancis View Post
    In the data arrival section http request header parsing is done but not handling unicode characters.
    Header must have vbcrlf , if not it is data. In this case the splitting by vbcrlf must be replaced and some
    other logic should be applied.
    thanks .

    I did not modify the code. My actions are as follows

    Click the button Subscribe to ChatMsg

    then return

    ws was opened on: wss://localhost:8088/SubscribeToChatMsg -------------work ok



    Click the button Send Chat-Message

    then return

    ws was closed on: wss://localhost:8088/SubscribeToChatMsg -----Server and webpage disconnected

    in your screen-shot.png .Service is not disconnected

  8. #8

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Secure Websocket

    Quote Originally Posted by xxdoc123 View Post
    thanks .

    I did not modify the code. My actions are as follows

    Click the button Subscribe to ChatMsg

    then return

    ws was opened on: wss://localhost:8088/SubscribeToChatMsg -------------work ok



    Click the button Send Chat-Message

    then return

    ws was closed on: wss://localhost:8088/SubscribeToChatMsg -----Server and webpage disconnected

    in your screen-shot.png .Service is not disconnected
    Please try this in

    Private Sub ctxServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    ...

    ctxServer(Index).GetData sRequest
    ...
    vSplit = Split(sRequest, vbCrLf)
    ' If UBound(vSplit) >= 0 Then' comment this

    If sRequest Like "GET*HTTP/1.?*" Then' add this
    Last edited by joshyfrancis; Feb 28th, 2021 at 10:30 PM.

  9. #9

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Secure Websocket

    There is a little correction to Function hybi10Encode
    Code:
     
                 ElseIf payloadLength > 125 Then
                frameLength = frameLength + 1
              ReDim Preserve frame(frameLength)
               frame(frameLength) = IIf(masked, 254, 126) ' I missed the masked bit
    *I updated the code archive

  10. #10
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Secure Websocket

    Quote Originally Posted by joshyfrancis View Post
    Secure webSocket in Pure VB6 no external Libraries or ActiveX.
    Now wss://localhost:8088 is possible.
    Now Lengthy(char length more than 65536) messages possible.

    Thanks goes to :
    Vladimir Vissoultchev(wqweto)
    Olaf Schmidt
    and many others.
    https://github.com/wqweto/VbAsyncSocket

    https://www.vbforums.com/showthread....ushServer-Demo

    https://github.com/bloatless/php-websocket

    https://www.cnblogs.com/xiii/p/5165303.html



    In order to create a self-signed ssl certificate you need open-ssl. In my case I have done it in my cloud server and downloaded.
    Follow the instructions given here :

    https://www.freecodecamp.org/news/ho...-7af615770eec/

    after install the certificate. open rootCa.crt -> Install Certificate - > Next -> Place all certificates in the following store -> Browse
    -> Trusted Root Certification Authorities - > OK -> Next - > Finish - > Install/Approve

    Download the attachment
    Attachment 180338

    Notes:

    I have combined and ported codes from here and there, and given the references, detailed code explanations can be found there.

    Code:
      '    Debug.Print "ctxServer_DataArrival, bytesTotal=" & bytesTotal, Timer
        ctxServer(Index).GetData sRequest
    
        Dim secKey As String, i As Long, b() As Byte, AcceptKey As String, Origin As String, Host As String
    
        b = StrConv(sRequest, vbFromUnicode)  ------move to here
    
        If b(0) = &H81 Or websocket_data_available Then  '129 websocket send data
    now work ok

    how can hybi10Decode function decryption unicode ?


    now i found code by the Author https://www.cnblogs.com/xiii/p/5165303.html

    It can be achieved using his code

    Code:
        ctxServer(Index).GetData sRequest
    
        Dim secKey As String, i As Long, b() As Byte, AcceptKey As String, Origin As String, Host As String
    
        b = clscTlsSocket.ToTextArray(sRequest, ucsScpAcp) ''StrConv(sRequest, vbFromUnicode)
    
        If b(0) = &H81 Or websocket_data_available Then  '129 websocket send data
    
            If websocket_data_available And b(0) <> &H81 Then
                sBody = decodeMasked(b, 0)
                Text1 = sBody
            Else
                websocket_data_available = False
    
                'sBody = hybi10Decode(b, ctxServer(Index))
                'Text1 = Text1 & vbCrLf & sBody
                Dim DF     As DataFrame
    
                Dim str    As String
    
                Dim buff() As Byte
    
                DF = mWSProtocol.AnalyzeHeader(b)
                buff = mWSProtocol.PickData(b, DF)  '获取反掩码后的数据
                str = mUTF8.ToUnicodeString(buff)     '字节组转字符串
                Debug.Print "RECV: " & str
        
                Text1 = Text1 & vbCrLf & str
                
            End If
    Last edited by xxdoc123; Mar 1st, 2021 at 07:00 AM.

  11. #11

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    I have revised frame decoding and capturing packets. Please download archive and test.

  12. #12
    Frenzied Member
    Join Date
    Jan 2020
    Posts
    1,621

    Re: vb6 Websocket Server ssl

    Your technology is really pure. You have done a very good job.

  13. #13

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    Quote Originally Posted by xiaoyao View Post
    Your technology is really pure. You have done a very good job.
    Thank you.

    I was not handling the continuation frames. Now it is updated. Please download the archive again.

    If you click continuously on the Send Lengthy Message Button without delay it will case an Out of stack space Error. That is because Server is busy.Now it is fixed
    Last edited by joshyfrancis; Sep 14th, 2021 at 08:45 AM.

  14. #14
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Websocket Server ssl

    Quote Originally Posted by joshyfrancis View Post
    Thank you.

    I was not handling the continuation frames. Now it is updated. Please download the archive again.

    If you click continuously on the Send Lengthy Message Button without delay it will case an Out of stack space Error. That is because Server is busy.Now it is fixed
    Name:  bug.jpg
Views: 188
Size:  18.0 KB

  15. #15

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    I have updated the archive. Please download again and try.

  16. #16
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Websocket Server ssl

    i download the new project,have the same questions

  17. #17

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    Please let me know which browser you are using and which version. I tried Interenet explorer 11 and is ok.

    Name:  clipimage.jpg
Views: 157
Size:  24.6 KB
    Last edited by joshyfrancis; Sep 20th, 2021 at 04:51 AM.

  18. #18
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Websocket Server ssl

    i used win 10 and chrome.exe. may is my used Chinese system


    Code:
    Private Sub ctxServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
        Dim sRequest        As String
        Dim vSplit          As Variant
        Dim sBody           As String
        Dim clscTlsSocket   As New cAsyncSocket
        Dim sRequestArray() As Byte
        
        '    Debug.Print "ctxServer_DataArrival, bytesTotal=" & bytesTotal, Timer
        If bytesTotal > -1 Then
            ctxServer(Index).GetData sRequestArray, vbByte + vbArray
            sRequest = clscTlsSocket.FromTextArray(sRequestArray, ucsScpAcp)
        End If
    
        Dim secKey As String, i As Long, b() As Byte, AcceptKey As String, Origin As String, Host As String
        
        If sRequest Like "GET*HTTP/1.?*" Then
            vSplit = Split(sRequest, vbCrLf)
    
            If InStr(vSplit(0), "/SubscribeToChatMsg") > 0 Then
    
                For i = 0 To UBound(vSplit)
    
                    If InStr(LCase(vSplit(i)), "sec-websocket-key: ") > 0 Then
                        secKey = Trim(Mid(vSplit(i), InStr(vSplit(i), ":") + 1))
                    End If
    
                    If InStr(LCase(vSplit(i)), "origin: ") > 0 Then
                        Origin = Trim(Mid(vSplit(i), InStr(vSplit(i), ":") + 1))
                    End If
    
                    If InStr(LCase(vSplit(i)), "host: ") > 0 Then
                        Host = Trim(Mid(vSplit(i), InStr(vSplit(i), ":") + 1))
                    End If
    
                Next
                 
                '            b = SHA1(StrConv(secKey & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode))
                b = SHA1(StrConv(secKey & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode))
                AcceptKey = Base64EncodeEX(b)
                     
                ctxServer(Index).SendData "HTTP/1.1 101 Web Socket Protocol Handshake" & vbCrLf & "Upgrade: websocket" & vbCrLf & "Connection: Upgrade" & vbCrLf & "Sec-WebSocket-Accept: " & AcceptKey & vbCrLf & "Sec-WebSocket-Origin: " & Origin & vbCrLf & "WebSocket-Location: " & Host & vbCrLf & vbCrLf
                ReDim Preserve webSocket_clients(websocket_count)
                webSocket_clients(websocket_count) = Index
                websocket_count = websocket_count + 1
                cmdSendTextMessage.Enabled = True
            Else
                '            Debug.Print vSplit(0)
                sBody = "<html><body><p>" & Join(vSplit, "</p>" & vbCrLf & "<p>" & Index & ": ") & "</p>" & vbCrLf & "<p>" & Index & ": Current time is " & Now & "</p>" & "<p>" & Index & ": RemoteHostIP is " & ctxServer(Index).RemoteHostIP & "</p>" & vbCrLf & "<p>" & Index & ": RemotePort is " & ctxServer(Index).RemotePort & "</p>" & vbCrLf & "</body></html>" & vbCrLf
                Dim F As Integer
                F = FreeFile
                Open App.Path & "\wsTest.html" For Binary As F
                sBody = Input(LOF(F), F)
                Close F
                    
                ctxServer(Index).SendData "HTTP/1.1 200 OK" & vbCrLf & "Content-Type: text/html" & vbCrLf & "Content-Length: " & Len(sBody) & vbCrLf & vbCrLf & sBody
            End If
    
        Else 'Handle websocket packets
            Dim c As Long, wsd As ws_Data, wi As Long
            wi = -1
            '        For C = 1 To q_ws.Count
            '                wsd.RemotePort = 0
            '                wsd.ContentLength = 0
            '                wsd.RawData = ""
            '                wsd.sData = ""
            '            DeserializeFromBytes q_ws.Item(C), wsd
            ''            If wsd.RemotePort = ctxServer(Index).RemotePort Then 'Causes Stack Overflow
            '            If wsd.SocketIndex = Index Then
            '                wi = C
            '                Exit For
            '            End If
            '        Next
            wi = Find_ws_Data_By_Index(Index)
    
            If wi <> -1 Then
                '           q_ws.Remove wi
                wsd = a_q_ws(wi)
                Remove_ws_Data wi
            End If
    
            '            wsd.RemotePort = ctxServer(Index).RemotePort'Causes Stack Overflow
            wsd.SocketIndex = Index
                
            Dim Data()          As Byte
            Dim firstByteBinary As Byte, secondByteBinary As Byte, opcode As Long
            Dim payloadOffset   As Long, payloadLength As Long
            Dim ubData          As Long, dataLengthInt As Integer, dataLengthCur As Currency, sBin As String
            Dim DataLength      As Long, isMasked As Boolean, mask() As Byte, hasContinuation As Boolean
            
            Dim bSuccess        As Boolean, NextFrame As String
            sRequest = sRequestArray
    
            If wsd.RawData <> "" Then
                
                sRequest = wsd.RawData & sRequest
                wsd.RawData = ""
            End If
            
            Data = sRequest
            ubData = UBound(Data)
            hasContinuation = False
    
            If ubData > -1 Then
                firstByteBinary = Data(0)
    
                If firstByteBinary = 1 Then
                    firstByteBinary = 129
                    'Has Continuation frames
                    hasContinuation = True
                ElseIf firstByteBinary = 128 Then
                    'Is Continuation
                    hasContinuation = True
                End If
    
                secondByteBinary = Data(1)
                opcode = firstByteBinary And Not 128
                isMasked = secondByteBinary And 128 > 0
                payloadLength = Data(1) And 127
                     
            End If
    
            Select Case opcode
    
                Case 0 'Continuation
    
                    If ubData > -1 Then
                        '                        wsd.sData = wsd.sData & deCodeFrame(sRequest)
                    End If
    
                Case 1 ' text frame:
    
                Case 2 'binary
    
                Case 8 'connection close frame
                    'When a browser closes the Tab or Reload the Tab
                    Exit Sub
    
                Case 9 'ping frame
    
                Case 10 'pong frame
    
                Case Else
    
                    If bytesTotal < -4 Then 'Escape possible 'Out of Stack space' Error
                        'Send close frame
                        ctxServer(Index).SendData hybi10Encode(StrConv("", vbFromUnicode), "close", False)   'A server must not mask any frames that it sends to the client.
                                
                        Exit Sub
                    End If
    
                    If ubData > -1 Then
                        wsd.RawData = wsd.RawData & sRequest
                        '                        q_ws.Add SerializeToBytes(wsd), "W" & Index
                        Add_ws_Data wsd
                                
                        ctxServer_DataArrival Index, IIf(bytesTotal > 0, -1, bytesTotal - 1)
                        Exit Sub
                    End If
    
            End Select
    
            DataLength = 0
    
            If payloadLength = 126 Then
                payloadOffset = 8
                dataLengthCur = 0
                sBin = ""
    
                For i = 0 To 1
                    sBin = sBin & DecimalToBinary(Data(i + 2))
                Next
    
                dataLengthCur = BinaryToDecimal(sBin)
                DataLength = dataLengthCur + payloadOffset
            ElseIf payloadLength = 127 Then
                payloadOffset = 14
                dataLengthCur = 0
                sBin = ""
    
                For i = 0 To 7
                    sBin = sBin & DecimalToBinary(Data(i + 2))
                Next
    
                dataLengthCur = BinaryToDecimal(sBin)
                DataLength = dataLengthCur + payloadOffset
            ElseIf payloadLength > 0 Then
                payloadOffset = 6
                DataLength = payloadLength + payloadOffset
            End If
    
            If LenB(sRequest) < DataLength Then
                wsd.RawData = sRequest        
                '                q_ws.Add SerializeToBytes(wsd), "W" & Index
                Add_ws_Data wsd
                Exit Sub
            Else
                sBin = deCodeFrame(Data, bSuccess, NextFrame)
    
                If bSuccess = False Then
                    wsd.RawData = sRequest        
                Else
                    wsd.sData = wsd.sData & sBin
                    wsd.ContentLength = wsd.ContentLength + (DataLength - payloadOffset)
    
                    If opcode = 0 And hasContinuation = True Then
                        hasContinuation = False
                    Else
    
                        If opcode = 0 Then
                            hasContinuation = True
                        End If
                    End If
                End If
            End If
    
            If hasContinuation = False And wsd.ContentLength = Len(wsd.sData) Then 'And Right$(wsd.sData, 1) = "}" Then
                web_socket_DataArrival wsd.sData, ctxServer(Index)
            Else
                '            q_ws.Add SerializeToBytes(wsd), "W" & Index
                Add_ws_Data wsd
                Exit Sub
            End If
        End If
    
        '    Debug.Print "ctxServer_DataArrival, done", Timer
    End Sub
    NOW WORK OK.BUT CONNOT SUPPORT UNICODE~
    Last edited by xxdoc123; Sep 21st, 2021 at 01:25 AM.

  19. #19

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    As you previously mentioned about Unicode Chinese characters, that may break the frame parsing, may be a reason for your problem. If you can capture and provide me the raw packets , I could analyse and solve it. Now I have tried in Win 7 and Win 10 systems without any problems.

  20. #20
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Websocket Server ssl

    Code:
    Attribute VB_Name = "mUTF8"
    Option Explicit
    
    'UTF-8
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
    Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
    Private Const CP_UTF8 = 65001
    'utf8תunicode
    Public Function ToUnicodeData(ByRef Utf() As Byte) As Byte()
        Dim lret As Long
        Dim lLength As Long
        Dim lBufferSize As Long
        Dim BT() As Byte
        lLength = UBound(Utf) + 1
        If lLength <= 0 Then Exit Function
        lBufferSize = lLength * 2 - 1
        ReDim BT(lBufferSize)
        lret = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, VarPtr(BT(0)), lBufferSize + 1)
        If lret <> 0 Then
            ReDim Preserve BT(lret - 1)
            ToUnicodeData = BT
        End If
    End Function
    'utf8תunicode
    Public Function ToUnicodeString(ByRef Utf() As Byte) As String
        Dim lret As Long
        Dim lLength As Long
        Dim lBufferSize As Long
        On Error GoTo errline:
        lLength = UBound(Utf) + 1
        If lLength <= 0 Then Exit Function
        lBufferSize = lLength * 2
        ToUnicodeString = String$(lBufferSize, Chr(0))
        lret = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(ToUnicodeString), lBufferSize)
        If lret <> 0 Then
            ToUnicodeString = Left(ToUnicodeString, lret)
        End If
        Exit Function
    errline:
        ToUnicodeString = ""
    End Function
    'unicodeתutf8
    Public Function Encoding(ByVal UCS As String) As Byte()
        Dim lLength As Long
        Dim lBufferSize As Long
        Dim lResult As Long
        Dim abUTF8() As Byte
        lLength = Len(UCS)
        If lLength = 0 Then Exit Function
        lBufferSize = lLength * 3 + 1
        ReDim abUTF8(lBufferSize - 1)
        lResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UCS), lLength, abUTF8(0), lBufferSize, vbNullString, 0)
        If lResult <> 0 Then
        lResult = lResult - 1
        ReDim Preserve abUTF8(lResult)
        Encoding = abUTF8
        End If
    End Function

    now i change then function deCodeFrame


    Code:
    'Function deCodeFrame(ByVal RawData As String, bSuccess As Boolean) As String
    Function deCodeFrame(Data() As Byte, bSuccess As Boolean, NextFrame As String) As String
        'Dim data() As Byte
        Dim firstByteBinary As Byte, secondByteBinary As Byte, opcode As Long, payloadLength As Long
        Dim payloadOffset   As Long, sData As String, j As Long
        Dim ubData          As Long, dataLengthInt As Integer, dataLengthCur As Currency, sBin As String
        Dim DataLength      As Long, isMasked As Boolean, mask() As Byte
        Dim offset          As Long, i As Long, DataAvailable As Long
        bSuccess = False
        sData = ""
        NextFrame = ""
    
        '            data = StrConv(RawData, vbFromUnicode)
        ubData = UBound(Data)
    
        If ubData = -1 Then Exit Function
        firstByteBinary = Data(0)
        secondByteBinary = Data(1)
                
        opcode = firstByteBinary And Not 128
        isMasked = secondByteBinary And 128 > 0
        payloadLength = Data(1) And 127
        
        Select Case opcode
    
            Case 0 ' Continuation
    
            Case 1 ' text frame:
    
            Case 2 'binary
    
            Case 8 'connection close frame
    
            Case 9 'ping frame
    
            Case 10 'pong frame
    
            Case Else
                Exit Function
        End Select
    
        ReDim mask(3)
    
        If payloadLength = 126 Then
            CopyMemory mask(0), Data(4), Len(Data(2)) * 4
            payloadOffset = 8
            dataLengthCur = 0
            sBin = ""
    
            For i = 0 To 1
                sBin = sBin & DecimalToBinary(Data(i + 2))
            Next
    
            dataLengthCur = BinaryToDecimal(sBin)
            DataLength = dataLengthCur + payloadOffset
        ElseIf payloadLength = 127 Then
            CopyMemory mask(0), Data(10), Len(Data(2)) * 4
            payloadOffset = 14
            dataLengthCur = 0
            sBin = ""
    
            For i = 0 To 7
                sBin = sBin & DecimalToBinary(Data(i + 2))
            Next
    
            dataLengthCur = BinaryToDecimal(sBin)
            DataLength = dataLengthCur + payloadOffset
        Else
            CopyMemory mask(0), Data(2), Len(Data(2)) * 4
            payloadOffset = 6
            DataLength = payloadLength + payloadOffset
        End If
    
        If DataLength > 0 And opcode < 3 Then
            If isMasked = True Then
                offset = payloadOffset
                DataAvailable = IIf((DataLength - 1) > ubData, ubData, DataLength - 1)
    
                '                DataLength = DataLength - offset
                If ((DataAvailable + 1)) <> DataLength Then
                    bSuccess = False
                    Exit Function
                End If
                Dim dataA() As Byte
                ReDim dataA(DataAvailable - offset)
                For i = offset To DataAvailable 'ubData
                    j = i - offset
                    j = j Mod 4
                    dataA(i - offset) = Data(i) Xor mask(j) And 255
                    sData = sData & Chr(Data(i) Xor mask(j) And 255)
                Next
                 sData = ToUnicodeString(dataA)  '------------work ok'
                DataAvailable = DataAvailable + offset
            Else
                payloadOffset = payloadOffset - 4
                DataAvailable = IIf((DataLength - 1) > ubData, ubData, DataLength - 1)
    
                If ((DataAvailable + 1) - payloadOffset) <> DataLength Then
                    bSuccess = False
                    Exit Function
                End If
    
                sData = Space(DataAvailable + 1)
                CopyMemory ByVal VarPtr(sData), Data(payloadOffset), DataAvailable + 1 'DataLength
                Dim mbuff() As Byte
                ReDim mbuff(DataAvailable)
                CopyMemory mbuff(0), Data(payloadOffset), DataAvailable + 1 'DataLength
                sData = ToUnicodeString(mbuff)'
                
                DataAvailable = DataAvailable + 4
            End If
    
            '            If DataAvailable < (ubData) Then
            '                offset = DataAvailable + 1
            '                DataAvailable = (ubData) - DataAvailable
            '                NextFrame = Space(DataAvailable + 1)
            '                CopyMemory ByVal VarPtr(sData), data(payloadOffset), DataAvailable + 1
            '            End If
        Else
            Exit Function
        End If
    
        deCodeFrame = sData
        bSuccess = True
    End Function
    Code:
    Private Sub ctxServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
        Dim sRequest        As String
        Dim vSplit          As Variant
        Dim sBody           As String
        Dim clscTlsSocket   As New cAsyncSocket
        Dim sRequestArray() As Byte
        
        '    Debug.Print "ctxServer_DataArrival, bytesTotal=" & bytesTotal, Timer
        If bytesTotal > -1 Then
            ctxServer(Index).GetData sRequestArray, vbByte + vbArray
            sRequest = clscTlsSocket.FromTextArray(sRequestArray, ucsScpAcp)
        End If
    
        Dim secKey As String, i As Long, b() As Byte, AcceptKey As String, Origin As String, Host As String
        
        If sRequest Like "GET*HTTP/1.?*" Then
            vSplit = Split(sRequest, vbCrLf)
    
            If InStr(vSplit(0), "/SubscribeToChatMsg") > 0 Then
    
                For i = 0 To UBound(vSplit)
    
                    If InStr(LCase(vSplit(i)), "sec-websocket-key: ") > 0 Then
                        secKey = Trim(Mid(vSplit(i), InStr(vSplit(i), ":") + 1))
                    End If
    
                    If InStr(LCase(vSplit(i)), "origin: ") > 0 Then
                        Origin = Trim(Mid(vSplit(i), InStr(vSplit(i), ":") + 1))
                    End If
    
                    If InStr(LCase(vSplit(i)), "host: ") > 0 Then
                        Host = Trim(Mid(vSplit(i), InStr(vSplit(i), ":") + 1))
                    End If
    
                Next
                 
                '            b = SHA1(StrConv(secKey & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode))
                b = SHA1(StrConv(secKey & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode))
                AcceptKey = Base64EncodeEX(b)
                     
                ctxServer(Index).SendData "HTTP/1.1 101 Web Socket Protocol Handshake" & vbCrLf & "Upgrade: websocket" & vbCrLf & "Connection: Upgrade" & vbCrLf & "Sec-WebSocket-Accept: " & AcceptKey & vbCrLf & "Sec-WebSocket-Origin: " & Origin & vbCrLf & "WebSocket-Location: " & Host & vbCrLf & vbCrLf
                ReDim Preserve webSocket_clients(websocket_count)
                webSocket_clients(websocket_count) = Index
                websocket_count = websocket_count + 1
                cmdSendTextMessage.Enabled = True
            Else
                '            Debug.Print vSplit(0)
                sBody = "<html><body><p>" & Join(vSplit, "</p>" & vbCrLf & "<p>" & Index & ": ") & "</p>" & vbCrLf & "<p>" & Index & ": Current time is " & Now & "</p>" & "<p>" & Index & ": RemoteHostIP is " & ctxServer(Index).RemoteHostIP & "</p>" & vbCrLf & "<p>" & Index & ": RemotePort is " & ctxServer(Index).RemotePort & "</p>" & vbCrLf & "</body></html>" & vbCrLf
                Dim F As Integer
                F = FreeFile
                Open App.Path & "\wsTest.html" For Binary As F
                sBody = Input(LOF(F), F)
                Close F
                    
                ctxServer(Index).SendData "HTTP/1.1 200 OK" & vbCrLf & "Content-Type: text/html" & vbCrLf & "Content-Length: " & Len(sBody) & vbCrLf & vbCrLf & sBody
            End If
    
        Else 'Handle websocket packets
            Dim c As Long, wsd As ws_Data, wi As Long
            wi = -1
            '        For C = 1 To q_ws.Count
            '                wsd.RemotePort = 0
            '                wsd.ContentLength = 0
            '                wsd.RawData = ""
            '                wsd.sData = ""
            '            DeserializeFromBytes q_ws.Item(C), wsd
            ''            If wsd.RemotePort = ctxServer(Index).RemotePort Then 'Causes Stack Overflow
            '            If wsd.SocketIndex = Index Then
            '                wi = C
            '                Exit For
            '            End If
            '        Next
            wi = Find_ws_Data_By_Index(Index)
    
            If wi <> -1 Then
                '           q_ws.Remove wi
                wsd = a_q_ws(wi)
                Remove_ws_Data wi
            End If
    
            '            wsd.RemotePort = ctxServer(Index).RemotePort'Causes Stack Overflow
            wsd.SocketIndex = Index
                
            Dim Data()          As Byte
            Dim firstByteBinary As Byte, secondByteBinary As Byte, opcode As Long
            Dim payloadOffset   As Long, payloadLength As Long
            Dim ubData          As Long, dataLengthInt As Integer, dataLengthCur As Currency, sBin As String
            Dim DataLength      As Long, isMasked As Boolean, mask() As Byte, hasContinuation As Boolean
            
            Dim bSuccess        As Boolean, NextFrame As String
            sRequest = sRequestArray
    
            If wsd.RawData <> "" Then
                
                sRequest = wsd.RawData & sRequest
                wsd.RawData = ""
            End If
            
            Data = sRequest
            ubData = UBound(Data)
            hasContinuation = False
    
            If ubData > -1 Then
                firstByteBinary = Data(0)
    
                If firstByteBinary = 1 Then
                    firstByteBinary = 129
                    'Has Continuation frames
                    hasContinuation = True
                ElseIf firstByteBinary = 128 Then
                    'Is Continuation
                    hasContinuation = True
                End If
    
                secondByteBinary = Data(1)
                opcode = firstByteBinary And Not 128
                isMasked = secondByteBinary And 128 > 0
                payloadLength = Data(1) And 127
                     
            End If
    
            Select Case opcode
    
                Case 0 'Continuation
    
                    If ubData > -1 Then
                        '                        wsd.sData = wsd.sData & deCodeFrame(sRequest)
                    End If
    
                Case 1 ' text frame:
    
                Case 2 'binary
    
                Case 8 'connection close frame
                    'When a browser closes the Tab or Reload the Tab
                    Exit Sub
    
                Case 9 'ping frame
    
                Case 10 'pong frame
    
                Case Else
    
                    If bytesTotal < -4 Then 'Escape possible 'Out of Stack space' Error
                        'Send close frame
                        ctxServer(Index).SendData hybi10Encode(StrConv("", vbFromUnicode), "close", False)   'A server must not mask any frames that it sends to the client.
                                
                        Exit Sub
                    End If
    
                    If ubData > -1 Then
                        wsd.RawData = wsd.RawData & sRequest
                        '                        q_ws.Add SerializeToBytes(wsd), "W" & Index
                        Add_ws_Data wsd
                                
                        ctxServer_DataArrival Index, IIf(bytesTotal > 0, -1, bytesTotal - 1)
                        Exit Sub
                    End If
    
            End Select
    
            DataLength = 0
    
            If payloadLength = 126 Then
                payloadOffset = 8
                dataLengthCur = 0
                sBin = ""
    
                For i = 0 To 1
                    sBin = sBin & DecimalToBinary(Data(i + 2))
                Next
    
                dataLengthCur = BinaryToDecimal(sBin)
                DataLength = dataLengthCur + payloadOffset
            ElseIf payloadLength = 127 Then
                payloadOffset = 14
                dataLengthCur = 0
                sBin = ""
    
                For i = 0 To 7
                    sBin = sBin & DecimalToBinary(Data(i + 2))
                Next
    
                dataLengthCur = BinaryToDecimal(sBin)
                DataLength = dataLengthCur + payloadOffset
            ElseIf payloadLength > 0 Then
                payloadOffset = 6
                DataLength = payloadLength + payloadOffset
            End If
    
            If LenB(sRequest) < DataLength Then
                wsd.RawData = sRequest        
                '                q_ws.Add SerializeToBytes(wsd), "W" & Index
                Add_ws_Data wsd
                Exit Sub
            Else
                sBin = deCodeFrame(Data, bSuccess, NextFrame)
    
                If bSuccess = False Then
                    wsd.RawData = sRequest        
                Else
                    wsd.sData = wsd.sData & sBin
                    wsd.ContentLength = wsd.ContentLength + (DataLength - payloadOffset)
    
                    If opcode = 0 And hasContinuation = True Then
                        hasContinuation = False
                    Else
    
                        If opcode = 0 Then
                            hasContinuation = True
                        End If
                    End If
                End If
            End If
    
            If hasContinuation = False And wsd.ContentLength = UBound(Encoding(wsd.sData)) + 1   Then 'And Right$(wsd.sData, 1) = "}" Then
                web_socket_DataArrival wsd.sData, ctxServer(Index)
            Else
                '            q_ws.Add SerializeToBytes(wsd), "W" & Index
                Add_ws_Data wsd
                Exit Sub
            End If
        End If
    
        '    Debug.Print "ctxServer_DataArrival, done", Timer
    End Sub
    in my chinese system .

    this is my change:


    open the wsTest.html change

    Code:
    <!DOCTYPE html>
    <html>
    <head>
    <meta charset="GBK">
    <script>
    function LogText(id, txt){ var l=document.getElementById(id); l.value += txt + '\n'; l.scrollTop += 100; }
    function SetText(id, txt){ var t=document.getElementById(id); t.value = txt; }
    
    var wsTimerMsg = null;
    var wsChatMsg  = null;
     
    function wsSubscribeTo(strServerSubscribeURL, fnMessageHandler){
        switch(strServerSubscribeURL){
            case 'SubscribeToTimerMsg': wsClose(wsTimerMsg); break;
            case 'SubscribeToChatMsg' : wsClose(wsChatMsg);  break;
        }
    	if(location.protocol==='https:'){
    		ws = new WebSocket('wss://' + window.location.host + '/' + strServerSubscribeURL);
    	}else{
    		ws = new WebSocket('ws://' + window.location.host + '/' + strServerSubscribeURL);
    	}
        ws.onmessage = fnMessageHandler;
    	ws.onopen =  function(msg) { LogText('logWS', 'ws was opened on: ' + this.url); };	
        ws.onclose = function(msg) { LogText('logWS', 'ws was closed on: ' + this.url); };	
    	return ws;
    }
    function wsClose(ws){ if (ws && ws.readyState) ws.close(); }
    
    function Server_TimerMsg(msg){ SetText('TimerMsg', msg.data); }
    function Server_ChatMsg(msg) { LogText('logChat', msg.data);  }
     
    function GetStringReflection(){
    var oJSON = {};
        oJSON.MethodName = 'GetStringReflection';
        oJSON.StringToReflect = document.getElementById('txtStringReflect').value;
    	jsonAjaxRPC(oJSON);
    }
    
    function GetDynamicImage(){
    var req = new XMLHttpRequest();
        req.open('POST', '/dynamicImgRPC', true);
        req.responseType = 'blob'; //<- returns the raw-response-content as a JavaScript-Blob-Object (createObjectURL expects a BLOB-object as a param)
        req.onload = function() { document.getElementById('imgDynamic').src = (window.URL || window.webkitURL).createObjectURL(req.response); }
        req.send();
    }
    
    function SendChatMessage(){
    	var oJSON = {};
        oJSON.MethodName = 'SendChatMessage';
        oJSON.ChatUsr = document.getElementById('txtChatUsr').value;
    	oJSON.ChatMsg = document.getElementById('txtChatMsg').value;
    	//jsonAjaxRPC(oJSON);
    	if(wsChatMsg){
    		wsChatMsg.send(JSON.stringify(oJSON));
    	}
    }
    function SendLengthyChatMessage(){
    	var oJSON = {};
        oJSON.MethodName = 'SendChatMessage';
        oJSON.ChatUsr = document.getElementById('txtChatUsr').value;
    	oJSON.ChatMsg ='<BEGIN>' +  (new Array(65535).join('a啊123')) +'<END>' ;
    	//jsonAjaxRPC(oJSON);
    	if(wsChatMsg){
    		wsChatMsg.send(JSON.stringify(oJSON));
    	}
    } 
    function jsonAjaxRPC(oJSON){
    var req = new XMLHttpRequest();
        req.open('POST', '/jsonAjaxRPC', true);
        req.onload = function(){ jsonResponseHandler(JSON.parse(req.responseText)); }
        req.send(JSON.stringify(oJSON));
    }
    
    function jsonResponseHandler(oJSON){
        switch(oJSON.MethodName){
            case 'GetStringReflection': SetText('txtStringReflect', oJSON.StringToReflect); break;
            //... etc. for other MethodNames, in case they return something
        }
    }
    
    </script>
    </head>
    
    <body>
    <br/>
    	<!--
    <button id="btnGetStringReflection" type="button" onclick="GetStringReflection()">jsonAjaxRPC String-Reflection</button> 
    <input id="txtStringReflect" type="text" value="ABC" />
    
    <br/><br/> 
    <button id="btnGetDynamicImage" type="button" onclick="GetDynamicImage()" style="float:left; margin-right:5px;">binary RPC (Dynamic-Image-Retrieval)</button> 
    <img id="imgDynamic" alt="dynamic ImageContent will be placed here" style="border:1px solid black; width:auto;"/>
     
     -->
    <br/><br/><br/>
    <div style="margin-bottom:3px;">
    	<!--
    	<button id="btnSubscribeToTimerMsg" type="button" onclick="wsTimerMsg=wsSubscribeTo('SubscribeToTimerMsg', Server_TimerMsg);">Subscribe to TimerMsg</button> 
    	-->
    	<button id="btnSubscribeToChatMsg" type="button" onclick="wsChatMsg=wsSubscribeTo('SubscribeToChatMsg', Server_ChatMsg);">Subscribe to ChatMsg</button> 
    </div>
    
    <textarea id="logWS" cols="60" rows="10" style="vertical-align: top;"></textarea>
    <!--
    <br><br><hr/><span>Pushed Server-Time -></span> <input id="TimerMsg" type="text" readonly /><br><br>
    -->
    <hr/><span>Simple Chat... Chat-UserName:</span> <input id="txtChatUsr" type="text" value="User1" /><br><br>
    
    <div style="margin-bottom:3px;">
    <button id="btnSendChatMessage" type="button" onclick="SendChatMessage()">Send Chat-Message</button>
    
    <input id="txtChatMsg" type="text" value="Chat-Message" />
    <button  type="button" onclick="SendLengthyChatMessage();">Send Lengthy Message</button> 
    </div>
    
    <textarea id="logChat" cols="60" rows="10" style="vertical-align: top;"></textarea>
    
    </body>
    </html>
    save as code ANSI

    Start WSS Server then load the html

    now work ok ..

    {"MethodName":"SendChatMessage...啊123a啊123a啊123a啊123a啊123<END>"}
    {"MethodName":"SendChatMessage...Usr":"User1","ChatMsg":"啊a123"}


    Actually I donít know why


    Another problem. If you canít execute it multiple times, this function Send Lengthy Message .Can only be run once

    run once can get all data and wsd.ContentLength= 458813

    then run again .can not get all data wsd.ContentLength= 458187 .The remaining data is lost..
    Last edited by xxdoc123; Sep 22nd, 2021 at 10:48 PM.

  21. #21

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    Thank you for your valuable suggestions. I have revised code according to that. Please download and test.

  22. #22
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Websocket Server ssl

    After you change. SendLengthyChatMessage function unsuccessful~。。English strings can be successful。
    Code:
    wi = Find_ws_Data_By_Index(Index)
                wsd.bData = vbNullStringÖ?i think is not right
    Last edited by xxdoc123; Sep 23rd, 2021 at 09:57 AM.

  23. #23

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    Thank God, I figured it out.
    Attachment 182373
    Please download updated archive and try now.

  24. #24
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    531

    Re: vb6 Websocket Server ssl

    thanks .work well

    i change the some code


    Code:
    F = FreeFile
                Open App.Path & "\wsTest.html" For Binary As F
                sBodyArray = InputB(LOF(F), F)
                Close F
                sBody = StrConv("HTTP/1.1 200 OK" & vbCrLf & "Content-Type: text/html" & vbCrLf & "Content-Length: " & UBound(sBodyArray) + 1 & vbCrLf & vbCrLf, vbFromUnicode)
                Dim sBody2 As String, sBodyArray2() As Byte
                sBody2 = sBodyArray
                sBody = sBody & sBody2
                sBodyArray2 = sBody
                ctxServer(Index).SendData sBodyArray2, ucsScpAcp

  25. #25

    Thread Starter
    Junior Member
    Join Date
    Jan 2018
    Posts
    31

    Re: vb6 Websocket Server ssl

    Quote Originally Posted by xxdoc123 View Post
    thanks .work well

    i change the some code


    Code:
    F = FreeFile
                Open App.Path & "\wsTest.html" For Binary As F
                sBodyArray = InputB(LOF(F), F)
                Close F
                sBody = StrConv("HTTP/1.1 200 OK" & vbCrLf & "Content-Type: text/html" & vbCrLf & "Content-Length: " & UBound(sBodyArray) + 1 & vbCrLf & vbCrLf, vbFromUnicode)
                Dim sBody2 As String, sBodyArray2() As Byte
                sBody2 = sBodyArray
                sBody = sBody & sBody2
                sBodyArray2 = sBody
                ctxServer(Index).SendData sBodyArray2, ucsScpAcp
    Thank you I have updated this.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width