-
Feb 27th, 2021, 01:19 AM
#1
Thread Starter
Member
-
Feb 27th, 2021, 02:51 AM
#2
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
-
Feb 27th, 2021, 03:04 AM
#3
Re: vb6 Secure Websocket
Originally Posted by Schmidt
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>
-
Feb 27th, 2021, 03:16 AM
#4
Thread Starter
Member
Re: vb6 Secure Websocket
Originally Posted by Schmidt
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.
-
Feb 27th, 2021, 10:09 PM
#5
Fanatic Member
Re: vb6 Secure Websocket
Originally Posted by joshyfrancis
in my system7 chinese
if i click the button "Send Chat-Message",then wss closed . cannot Connect
-
Feb 27th, 2021, 10:38 PM
#6
Thread Starter
Member
Re: vb6 Secure Websocket
Originally Posted by xxdoc123
in my system7 chinese
if i click the button "Send Chat-Message",then wss closed . cannot Connect
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.
-
Feb 28th, 2021, 03:45 AM
#7
Fanatic Member
Re: vb6 Secure Websocket
Originally Posted by joshyfrancis
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
-
Feb 28th, 2021, 07:53 AM
#8
Thread Starter
Member
Re: vb6 Secure Websocket
Originally Posted by xxdoc123
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.
-
Mar 1st, 2021, 02:59 AM
#9
Thread Starter
Member
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
-
Mar 1st, 2021, 05:04 AM
#10
Fanatic Member
Re: vb6 Secure Websocket
Originally Posted by joshyfrancis
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.
-
Sep 12th, 2021, 09:41 PM
#11
Thread Starter
Member
Re: vb6 Websocket Server ssl
I have revised frame decoding and capturing packets. Please download archive and test.
-
Sep 13th, 2021, 09:33 AM
#12
Re: vb6 Websocket Server ssl
Your technology is really pure. You have done a very good job.
-
Sep 13th, 2021, 12:57 PM
#13
Thread Starter
Member
Re: vb6 Websocket Server ssl
Originally Posted by xiaoyao
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.
-
Sep 17th, 2021, 08:28 PM
#14
Fanatic Member
Re: vb6 Websocket Server ssl
Originally Posted by joshyfrancis
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
-
Sep 18th, 2021, 12:32 AM
#15
Thread Starter
Member
Re: vb6 Websocket Server ssl
I have updated the archive. Please download again and try.
-
Sep 18th, 2021, 05:51 AM
#16
Fanatic Member
Re: vb6 Websocket Server ssl
i download the new project,have the same questions
-
Sep 20th, 2021, 04:48 AM
#17
Thread Starter
Member
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.
Last edited by joshyfrancis; Sep 20th, 2021 at 04:51 AM.
-
Sep 20th, 2021, 08:01 PM
#18
Fanatic Member
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.
-
Sep 20th, 2021, 10:22 PM
#19
Thread Starter
Member
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.
-
Sep 21st, 2021, 03:07 AM
#20
Fanatic Member
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.
-
Sep 23rd, 2021, 01:02 AM
#21
Thread Starter
Member
Re: vb6 Websocket Server ssl
Thank you for your valuable suggestions. I have revised code according to that. Please download and test.
-
Sep 23rd, 2021, 07:31 AM
#22
Fanatic Member
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.
-
Sep 23rd, 2021, 10:06 AM
#23
Thread Starter
Member
Re: vb6 Websocket Server ssl
Thank God, I figured it out.
Attachment 182373
Please download updated archive and try now.
-
Sep 23rd, 2021, 08:21 PM
#24
Fanatic Member
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
-
Sep 23rd, 2021, 09:01 PM
#25
Thread Starter
Member
Re: vb6 Websocket Server ssl
Originally Posted by xxdoc123
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.
-
May 7th, 2023, 04:49 AM
#26
Re: vb6 Websocket Server ssl
how to start as websocket server or client,only for send /get text?
i connet by this:
https://github.com/wenshui2008/WebsocketVB
onerror:Connection failed! HTTP code 200
Onclose
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|