一共就下面的两个模块,调用只使用到mWSProtocol模块,所有调用函数功能简单介绍一下:
建立连接后就开始握手,服务端用Handshake()验证,如果是客户端自己发送握手封包
接收数据,先用AnalyzeHeader()得到数据帧结构(DataFrame)
然后再用PickDataV()或PickData()得到源数据进行处理
发送数据需要先进行数据帧包装:
服务端向客户端发送无需掩码,用PackString()或PackData()
而模拟客户端向服务器的发送需要加掩码,用PackMaskString()或PackMaskData()
相关资料下载：《WebSocket协议中文版.pdf》
第二次写了,完全是为了分享...如果对你有帮助就支持一下吧
mWSProtocol:
Option Explicit
Option Compare Text
'==============================================================
'By: 悠悠然
'QQ: 2860898817
'E-mail: ur1986@foxmail.com
'完整运行示例放Q群文件共享:369088586
'==============================================================
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
Public Enum OpcodeType
opContin = '连续消息片断
opText = '文本消息片断
opBinary = '二进制消息片断
'3 - 7 非控制帧保留
opClose = '连接关闭
opPing = '心跳检查的ping
opPong = '心跳检查的pong
'11-15 控制帧保留
End Enum
Public Type DataFrame
FIN As Boolean '0表示不是当前消息的最后一帧，后面还有消息,1表示这是当前消息的最后一帧；
RSV1 As Boolean '1位，若没有自定义协议,必须为0,否则必须断开.
RSV2 As Boolean '1位，若没有自定义协议,必须为0,否则必须断开.
RSV3 As Boolean '1位，若没有自定义协议,必须为0,否则必须断开.
Opcode As OpcodeType '4位操作码，定义有效负载数据，如果收到了一个未知的操作码，连接必须断开.
MASK As Boolean '1位，定义传输的数据是否有加掩码,如果有掩码则存放在MaskingKey
MaskingKey() As Byte '32位的掩码
Payloadlen As Long '传输数据的长度
DataOffset As Long '数据源起始位
End Type '==============================================================
'握手部分,只有一个开放调用函数 Handshake(requestHeader As String) As Byte()
'==============================================================
Private Const MagicKey = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
Private Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
Public Function Handshake(requestHeader As String) As Byte()
Dim clientKey As String
clientKey = getHeaderValue(requestHeader, "Sec-WebSocket-Key:")
Dim AcceptKey As String
AcceptKey = getAcceptKey(clientKey)
Dim response As String
response = "HTTP/1.1 101 Web Socket Protocol Handshake" & vbCrLf
response = response & "Upgrade: WebSocket" & vbCrLf
response = response & "Connection: Upgrade" & vbCrLf
response = response & "Sec-WebSocket-Accept: " & AcceptKey & vbCrLf
response = response & "WebSocket-Origin: " & getHeaderValue(requestHeader, "Sec-WebSocket-Origin:") & vbCrLf
response = response & "WebSocket-Location: " & getHeaderValue(requestHeader, "Host:") & vbCrLf
response = response & vbCrLf
'Debug.Print response
Handshake = StrConv(response, vbFromUnicode)
End Function
Private Function getHeaderValue(str As String, pname As String) As String
Dim i As Long, j As Long
i = InStr(str, pname)
If i > Then
j = InStr(i, str, vbCrLf)
If j > Then
i = i + Len(pname)
getHeaderValue = Trim(Mid(str, i, j - i))
End If
End If
End Function
Private Function getAcceptKey(key As String) As String
Dim b() As Byte
b = mSHA1.SHA1(StrConv(key & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode))
getAcceptKey = EnBase64(b)
End Function
Private Function EnBase64(str() As Byte) As String
On Error GoTo over
Dim buf() As Byte, length As Long, mods As Long
mods = (UBound(str) + ) Mod
length = UBound(str) + - mods
ReDim buf(length / * + IIf(mods <> , , ) - )
Dim i As Long
For i = To length - Step
buf(i / * ) = (str(i) And &HFC) / &H4
buf(i / * + ) = (str(i) And &H3) * &H10 + (str(i + ) And &HF0) / &H10
buf(i / * + ) = (str(i + ) And &HF) * &H4 + (str(i + ) And &HC0) / &H40
buf(i / * + ) = str(i + ) And &H3F
Next
If mods = Then
buf(length / * ) = (str(length) And &HFC) / &H4
buf(length / * + ) = (str(length) And &H3) * &H10
buf(length / * + ) =
buf(length / * + ) =
ElseIf mods = Then
buf(length / * ) = (str(length) And &HFC) / &H4
buf(length / * + ) = (str(length) And &H3) * &H10 + (str(length + ) And &HF0) / &H10
buf(length / * + ) = (str(length + ) And &HF) * &H4
buf(length / * + ) =
End If
For i = To UBound(buf)
EnBase64 = EnBase64 + Mid(B64_CHAR_DICT, buf(i) + , )
Next
over:
End Function
'==============================================================
'数据帧解析,返回帧结构
'==============================================================
Public Function AnalyzeHeader(byt() As Byte) As DataFrame
Dim DF As DataFrame
DF.FIN = IIf((byt() And &H80) = &H80, True, False)
DF.RSV1 = IIf((byt() And &H40) = &H40, True, False)
DF.RSV2 = IIf((byt() And &H20) = &H20, True, False)
DF.RSV3 = IIf((byt() And &H10) = &H10, True, False)
DF.Opcode = byt() And &H7F
DF.MASK = IIf((byt() And &H80) = &H80, True, False)
Dim plen As Byte
plen = byt() And &H7F
If plen < Then
DF.Payloadlen = plen
If DF.MASK Then
CopyMemory DF.MaskingKey(), byt(),
DF.DataOffset =
Else
DF.DataOffset =
End If
ElseIf plen = Then
Dim l() As Byte
l() = byt()
l() = byt()
CopyMemory DF.Payloadlen, l(),
If DF.MASK Then
CopyMemory DF.MaskingKey(), byt(),
DF.DataOffset =
Else
DF.DataOffset =
End If
ElseIf plen = Then
'这部分没有什么意义就不写了,因为VB没有64位的整型可供使用
'所以对长度设定为-1,自己再判断
DF.Payloadlen = -
'If df.mask Then
' CopyMemory df.MaskingKey(0), byt(10), 4
' df.DataOffset = 14
'Else
' df.DataOffset = 10
'End If
End If
AnalyzeHeader = DF
End Function
'==============================================================
'接收的数据处理,有掩码就反掩码
'PickDataV 方法是出于性能的考虑,用于有时数据只是为了接收,做一些逻辑判断,并不需要对数据块进行单独提炼
'PickData 不赘述了...
'==============================================================
Public Sub PickDataV(byt() As Byte, dataType As DataFrame)
Dim lenLimit As Long
lenLimit = dataType.DataOffset + dataType.Payloadlen -
If dataType.MASK And lenLimit <= UBound(byt) Then
Dim i As Long, j As Long
For i = dataType.DataOffset To lenLimit
byt(i) = byt(i) Xor dataType.MaskingKey(j)
j = j +
If j = Then j =
Next i
End If
End Sub
Public Function PickData(byt() As Byte, dataType As DataFrame) As Byte()
Dim b() As Byte
PickDataV byt, dataType
ReDim b(dataType.Payloadlen - )
CopyMemory b(), byt(dataType.DataOffset), dataType.Payloadlen
PickData = b
End Function '==============================================================
'发送的数据处理,该部分未联网测试,使用下面的方式测试验证
'Private Sub Command1_Click()
' Dim str As String, b() As Byte, bs() As Byte
' Dim DF As DataFrame
' str = "abc123"
' Showlog "组装前数据:" & str
' b = mWSProtocol.PackMaskString(str): Showlog "掩码后字节:" & BytesToHex(b)
' DF = mWSProtocol.AnalyzeHeader(b): Showlog "结构体偏移:" & DF.DataOffset & " 长度:" & DF.Payloadlen
' bs = mWSProtocol.PickData(b, DF): Showlog "还原后字节:" & BytesToHex(bs)
' Showlog "还原后数据:" & StrConv(bs, vbUnicode)
'End Sub
'==============================================================
'无掩码数据的组装,用于服务端向客户端发送
'--------------------------------------------------------------
Public Function PackString(str As String, Optional dwOpcode As OpcodeType = opText) As Byte()
Dim b() As Byte
b = StrConv(str, vbFromUnicode)
PackString = PackData(b, dwOpcode)
End Function
Public Function PackData(data() As Byte, Optional dwOpcode As OpcodeType = opText) As Byte()
Dim length As Long
Dim byt() As Byte
length = UBound(data) + If length < Then
ReDim byt(length + )
byt() = CByte(length)
CopyMemory byt(), data(), length
ElseIf length <= Then
ReDim byt(length + )
Dim l() As Byte
byt() = &H7E
CopyMemory l(), length,
byt() = l()
byt() = l()
CopyMemory byt(), data(), length
'ElseIf length <= 999999999999999# Then
'这么长不处理了...
'VB6也没有这么大的整型
'有需要就根据上面调整来写吧
End If
'------------------------------
'关于下面的 byt(0) = &H80 Or dwOpcode 中，&H80 对应的是 DataFrame 结构中的FIN + RSV1 + RSV2 + RSV3
'FIN 的中文解释是：指示这个是消息的最后片段，第一个片段可能也是最后的片段。
'这里我不是很理解，可能是自定义分包用到吧，但貌似分包应该不是自己可控的，所以我默认是 1。
'------------------------------
byt() = &H80 Or dwOpcode
PackData = byt
End Function
'--------------------------------------------------------------
'有掩码数据的组装,用于替代客户端想服务端发送
'--------------------------------------------------------------
Public Function PackMaskString(str As String) As Byte()
Dim b() As Byte
b = StrConv(str, vbFromUnicode)
PackMaskString = PackMaskData(b)
End Function
Public Function PackMaskData(data() As Byte) As Byte()
'对源数据做掩码处理
Dim mKey() As Byte
mKey() = : mKey() = : mKey() = : mKey() = '掩码,你也可以自己定义
Dim i As Long, j As Long
For i = To UBound(data)
data(i) = data(i) Xor mKey(j)
j = j +
If j = Then j =
Next i
'包装,和上面的无掩码包装PackData()大体相同
Dim length As Long
Dim byt() As Byte
length = UBound(data) +
If length < Then
ReDim byt(length + )
byt() = &H81 '注意这里是按照OpcodeType里面的文本类型,其他类型,比如字节包应该是 byt(0) = &h80 or OpcodeType.opBinary
byt() = (CByte(length) Or &H80)
CopyMemory byt(), mKey(),
CopyMemory byt(), data(), length
ElseIf length <= Then
ReDim byt(length + )
Dim l() As Byte
byt() = &H81 '同上注意
byt() = &HFE '固定 掩码位+126
CopyMemory l(), length,
byt() = l()
byt() = l()
CopyMemory byt(), mKey(),
CopyMemory byt(), data(), length
'ElseIf length <= 999999999999999# Then
'这么长不处理了...有需要就根据上面调整来写吧
End If
PackMaskData = byt
End Function
'==============================================================
'控制帧相关,Ping、Pong、Close 用于服务端向客户端发送未经掩码的信号
'我用的0长度,其实是可以包含数据的,但是附带数据客户端处理又麻烦了
'
'* 如果有附带信息的需求,也可以用PackString或PackData,可选参数指定OpcodeType
'==============================================================
Public Function PingFrame() As Byte()
Dim b() As Byte
b() = &H89
b() = &H0
PingFrame = b
'发送一个包含"Hello"的Ping信号: 0x89 0x05 0x48 0x65 0x6c 0x6c 0x6f
End Function
Public Function PongFrame() As Byte()
Dim b() As Byte
b() = &H8A
b() = &H0
PongFrame = b
'发送一个包含"Hello"的Pong信号: 0x8A 0x05 0x48 0x65 0x6c 0x6c 0x6f
End Function
Public Function CloseFrame() As Byte()
Dim b() As Byte
b() = &H88
b() = &H0
CloseFrame = b
'发送一个包含"Close"的Pong信号: 0x8A 0x05 0x43 0x6c 0x6f 0x73 0x65
End Function
mSHA1:
Option Explicit
'==============================================================
'该模块来自网络资料,进行了小改动,源作者不详
'==============================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
Private Type Word
B0 As Byte
B1 As Byte
B2 As Byte
B3 As Byte
End Type
Private Function AndW(w1 As Word, w2 As Word) As Word
AndW.B0 = w1.B0 And w2.B0
AndW.B1 = w1.B1 And w2.B1
AndW.B2 = w1.B2 And w2.B2
AndW.B3 = w1.B3 And w2.B3
End Function Private Function OrW(w1 As Word, w2 As Word) As Word
OrW.B0 = w1.B0 Or w2.B0
OrW.B1 = w1.B1 Or w2.B1
OrW.B2 = w1.B2 Or w2.B2
OrW.B3 = w1.B3 Or w2.B3
End Function Private Function XorW(w1 As Word, w2 As Word) As Word
XorW.B0 = w1.B0 Xor w2.B0
XorW.B1 = w1.B1 Xor w2.B1
XorW.B2 = w1.B2 Xor w2.B2
XorW.B3 = w1.B3 Xor w2.B3
End Function Private Function NotW(w As Word) As Word
NotW.B0 = Not w.B0
NotW.B1 = Not w.B1
NotW.B2 = Not w.B2
NotW.B3 = Not w.B3
End Function Private Function AddW(w1 As Word, w2 As Word) As Word
Dim i As Long, w As Word
i = CLng(w1.B3) + w2.B3
w.B3 = i Mod
i = CLng(w1.B2) + w2.B2 + (i \ )
w.B2 = i Mod
i = CLng(w1.B1) + w2.B1 + (i \ )
w.B1 = i Mod
i = CLng(w1.B0) + w2.B0 + (i \ )
w.B0 = i Mod
AddW = w
End Function Private Function CircShiftLeftW(w As Word, n As Long) As Word
Dim d1 As Double, d2 As Double
d1 = WordToDouble(w)
d2 = d1
d1 = d1 * ( ^ n)
d2 = d2 / ( ^ ( - n))
CircShiftLeftW = OrW(DoubleToWord(d1), DoubleToWord(d2))
End Function Private Function WordToHex(w As Word) As String
WordToHex = Right$("" & Hex$(w.B0), ) & Right$("" & Hex$(w.B1), ) & Right$("" & Hex$(w.B2), ) & Right$("" & Hex$(w.B3), )
End Function Private Function HexToWord(H As String) As Word
HexToWord = DoubleToWord(Val("&H" & H & "#"))
End Function Private Function DoubleToWord(n As Double) As Word
DoubleToWord.B0 = Int(DMod(n, ^ ) / ( ^ ))
DoubleToWord.B1 = Int(DMod(n, ^ ) / ( ^ ))
DoubleToWord.B2 = Int(DMod(n, ^ ) / ( ^ ))
DoubleToWord.B3 = Int(DMod(n, ^ ))
End Function Private Function WordToDouble(w As Word) As Double
WordToDouble = (w.B0 * ( ^ )) + (w.B1 * ( ^ )) + (w.B2 * ( ^ )) + w.B3
End Function Private Function DMod(value As Double, divisor As Double) As Double
DMod = value - (Int(value / divisor) * divisor)
If DMod < Then DMod = DMod + divisor
End Function Private Function F(t As Long, b As Word, C As Word, D As Word) As Word
Select Case t
Case Is <=
F = OrW(AndW(b, C), AndW(NotW(b), D))
Case Is <=
F = XorW(XorW(b, C), D)
Case Is <=
F = OrW(OrW(AndW(b, C), AndW(b, D)), AndW(C, D))
Case Else
F = XorW(XorW(b, C), D)
End Select
End Function
Public Function StringSHA1(inMessage As String) As String
' 计算字符串的SHA1摘要
Dim inLen As Long
Dim inLenW As Word
Dim padMessage As String
Dim numBlocks As Long
Dim w( To ) As Word
Dim blockText As String
Dim wordText As String
Dim i As Long, t As Long
Dim temp As Word
Dim k( To ) As Word
Dim H0 As Word
Dim H1 As Word
Dim H2 As Word
Dim H3 As Word
Dim H4 As Word
Dim A As Word
Dim b As Word
Dim C As Word
Dim D As Word
Dim E As Word
inMessage = StrConv(inMessage, vbFromUnicode)
inLen = LenB(inMessage)
inLenW = DoubleToWord(CDbl(inLen) * )
padMessage = inMessage & ChrB() _
& StrConv(String(( - (inLen Mod ) - ) Mod + , Chr()), ) _
& ChrB(inLenW.B0) & ChrB(inLenW.B1) & ChrB(inLenW.B2) & ChrB(inLenW.B3)
numBlocks = LenB(padMessage) /
k() = HexToWord("5A827999")
k() = HexToWord("6ED9EBA1")
k() = HexToWord("8F1BBCDC")
k() = HexToWord("CA62C1D6")
H0 = HexToWord("")
H1 = HexToWord("EFCDAB89")
H2 = HexToWord("98BADCFE")
H3 = HexToWord("")
H4 = HexToWord("C3D2E1F0")
For i = To numBlocks -
blockText = MidB$(padMessage, (i * ) + , )
For t = To
wordText = MidB$(blockText, (t * ) + , )
w(t).B0 = AscB(MidB$(wordText, , ))
w(t).B1 = AscB(MidB$(wordText, , ))
w(t).B2 = AscB(MidB$(wordText, , ))
w(t).B3 = AscB(MidB$(wordText, , ))
Next
For t = To
w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - ), w(t - )), w(t - )), w(t - )), )
Next
A = H0
b = H1
C = H2
D = H3
E = H4
For t = To
temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, ), _
F(t, b, C, D)), E), w(t)), k(t \ ))
E = D
D = C
C = CircShiftLeftW(b, )
b = A
A = temp
Next
H0 = AddW(H0, A)
H1 = AddW(H1, b)
H2 = AddW(H2, C)
H3 = AddW(H3, D)
H4 = AddW(H4, E)
Next
StringSHA1 = WordToHex(H0) & WordToHex(H1) & WordToHex(H2) & WordToHex(H3) & WordToHex(H4)
End Function
'计算字节数组的SHA1摘要
Public Function SHA1(inMessage() As Byte) As Byte()
Dim inLen As Long
Dim inLenW As Word
Dim numBlocks As Long
Dim w( To ) As Word
Dim blockText As String
Dim wordText As String
Dim t As Long
Dim temp As Word
Dim k( To ) As Word
Dim H0 As Word
Dim H1 As Word
Dim H2 As Word
Dim H3 As Word
Dim H4 As Word
Dim A As Word
Dim b As Word
Dim C As Word
Dim D As Word
Dim E As Word
Dim i As Long
Dim lngPos As Long
Dim lngPadMessageLen As Long
Dim padMessage() As Byte
inLen = UBound(inMessage) +
inLenW = DoubleToWord(CDbl(inLen) * )
lngPadMessageLen = inLen + + ( - (inLen Mod ) - ) Mod +
ReDim padMessage(lngPadMessageLen - ) As Byte
For i = To inLen -
padMessage(i) = inMessage(i)
Next i
padMessage(inLen) =
padMessage(lngPadMessageLen - ) = inLenW.B0
padMessage(lngPadMessageLen - ) = inLenW.B1
padMessage(lngPadMessageLen - ) = inLenW.B2
padMessage(lngPadMessageLen - ) = inLenW.B3
numBlocks = lngPadMessageLen /
k() = HexToWord("5A827999")
k() = HexToWord("6ED9EBA1")
k() = HexToWord("8F1BBCDC")
k() = HexToWord("CA62C1D6")
H0 = HexToWord("")
H1 = HexToWord("EFCDAB89")
H2 = HexToWord("98BADCFE")
H3 = HexToWord("")
H4 = HexToWord("C3D2E1F0")
For i = To numBlocks -
For t = To
w(t).B0 = padMessage(lngPos)
w(t).B1 = padMessage(lngPos + )
w(t).B2 = padMessage(lngPos + )
w(t).B3 = padMessage(lngPos + )
lngPos = lngPos +
Next
For t = To
w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - ), w(t - )), w(t - )), w(t - )), )
Next
A = H0
b = H1
C = H2
D = H3
E = H4
For t = To
temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, ), _
F(t, b, C, D)), E), w(t)), k(t \ ))
E = D
D = C
C = CircShiftLeftW(b, )
b = A
A = temp
Next
H0 = AddW(H0, A)
H1 = AddW(H1, b)
H2 = AddW(H2, C)
H3 = AddW(H3, D)
H4 = AddW(H4, E)
Next
Dim byt() As Byte
CopyMemory byt(), H0,
CopyMemory byt(), H1,
CopyMemory byt(), H2,
CopyMemory byt(), H3,
CopyMemory byt(), H4,
SHA1 = byt
End Function
