2017/07/08 - 最新的封装模块在:http://www.cnblogs.com/xiii/p/7135233.html,这篇可以忽略了
早就写好了,看这方面资料比较少,索性贴出来.只是一个DEMO中的,没有做优化,代码比较草.由于没地方上传附件,所以只把一些主要的代码贴出来.
这只是服务端,不过客户端可以反推出来,其实了解了websocket协议就简单多了...开始了...
请求头构造:
req_heads = "HTTP/1.1 101 Web Socket Protocol Handshake" & vbCrLf req_heads = req_heads & "Upgrade: websocket" & vbCrLf req_heads = req_heads & "Connection: Upgrade" & vbCrLf req_heads = req_heads & "Sec-WebSocket-Accept: [KEY]" & vbCrLf req_heads = req_heads & "WebSocket-Origin: [ORGN]" & vbCrLf req_heads = req_heads & "WebSocket-Location: [HOST]" & vbCrLf & vbCrLf
Winsock接收部分:
Private Sub SerSock_DataArrival(Index As Integer, ByVal bytesTotal As Long) Dim s As String Dim b() As Byte Dim i As Long Showlog Index & "bytesTotal:" & bytesTotal SerSock(Index).GetData b If Client(Index) Then'判断该客户端是否进行过验证 Dim k As String Dim rs As String s = StrConv(b, vbUnicode) k = Trim(MidEx(s, "Sec-WebSocket-Key:", vbCrLf)) If Len(k) <> 0 Then k = AcceptKey(k) rs = Replace(woshou, "[KEY]", k) k = Trim(MidEx(s, "Origin:", vbCrLf)) rs = Replace(rs, "[ORGN]", k) k = Trim(MidEx(s, "Host:", vbCrLf)) rs = Replace(rs, "[HOST]", k) Client(Index).SendData rs bool(Index) = False End If Else If b(0) = &H81 Then If PickData(b) = True Then For i = 0 To Client.Count - 1 If Client(i).State = 7 Then Client(i).SendData b Next i End If Else For i = 0 To UBound(b) s = s & b(i) & " " Next i Showlog ">>> " & s End If End If End Sub Private Function PickData(byt() As Byte) As Boolean Dim i As Long Dim mask(3) As Byte Dim bData() As Byte Dim Lb(3) As Byte Dim L As Long Dim inx As Long '偏移 Dim sti As Long Dim s As String i = UBound(byt) - 3 ReDim b(i) b(0) = 62 b(1) = 62 L = byt(1) Xor &H80 '128 If L < 126 Then If UBound(byt) <> L + 5 Then Exit Function If L < 125 Then ' ReDim bData(L + 2) Else ReDim bData(L + 1): L = L - 1 End If ' ReDim bData(L) bData(0) = &H81 bData(1) = CByte(L + 1) CopyMemory mask(0), byt(2), 4 inx = 6 sti = 2 ElseIf L = 126 Then Lb(0) = byt(3) Lb(1) = byt(2) CopyMemory L, Lb(0), 4 If UBound(byt) <> L + 7 Then Exit Function CopyMemory mask(0), byt(4), 4 ReDim bData(L + 4) L = L + 1 CopyMemory Lb(0), L, 4 bData(0) = &H81 bData(1) = &H7E bData(2) = Lb(1) bData(3) = Lb(0) inx = 8 sti = 4 ElseIf L = 127 Then If UBound(byt) <> L + 9 Then Exit Function Lb(0) = byt(5) Lb(1) = byt(4) Lb(2) = byt(3) Lb(3) = byt(2) CopyMemory L, Lb(0), 4 CopyMemory mask(0), byt(6), 4 inx = 10 sti = 6 L = 0 '由于本次应用不处理长帧,所以设为0 End If If L <= 0 Then Exit Function For i = inx To UBound(byt) bData(sti) = byt(i) Xor mask((i - inx) Mod 4) sti = sti + 1 Next i '========================================================= 'Debug '========================================================= ' s = "Pick[" & UBound(bData) + 1 & "]" & vbCrLf ' For i = 0 To UBound(bData) ' s = s & bData(i) & " " ' Next i ' s = s & vbCrLf & "Scor[" & UBound(byt) + 1 & "]" & vbCrLf ' For i = 0 To UBound(byt) ' s = s & byt(i) & " " ' Next i ' Showlog s '========================================================= byt = bData PickData = True End Function
SHA1加密,算法来源于网络上做了一些修改:
Option Explicit Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) ' TITLE: ' Secure Hash Algorithm, SHA-1 ' AUTHORS: ' Adapted by Iain Buchan from Visual Basic code posted at Planet-Source-Code by Peter Girard ' http://www.planetsourcecode.com/xq/ASP/txtCodeId.13565/lngWId.1/qx/vb/scripts/ShowCode.htm ' PURPOSE: ' Creating a secure identifier from person-identifiable data ' The function SecureHash generates a 160-bit (20-hex-digit) message digest for a given message (String). ' It is computationally infeasable to recover the message from the digest. ' The digest is unique to the message within the realms of practical probability. ' The only way to find the source message for a digest is by hashing all possible messages and comparison of their digests. ' REFERENCES: ' For a fuller description see FIPS Publication 180-1: ' http://www.itl.nist.gov/fipspubs/fip180-1.htm ' SAMPLE: ' Message: "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" ' Returns Digest: "84983E441C3BD26EBAAE4AA1F95129E5E54670F1" ' Message: "abc" ' Returns Digest: "A9993E364706816ABA3E25717850C26C9CD0D89D" Private Type Word B0 As Byte B1 As Byte B2 As Byte B3 As Byte End Type 'Public Function idcode(cr As Range) As String ' Dim tx As String ' Dim ob As Object ' For Each ob In cr ' tx = tx & LCase(CStr(ob.Value2)) ' Next ' idcode = sha1(tx) 'End Function 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 256 i = CLng(w1.B2) + w2.B2 + (i 256) w.B2 = i Mod 256 i = CLng(w1.B1) + w2.B1 + (i 256) w.B1 = i Mod 256 i = CLng(w1.B0) + w2.B0 + (i 256) w.B0 = i Mod 256 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 * (2 ^ n) d2 = d2 / (2 ^ (32 - n)) CircShiftLeftW = OrW(DoubleToWord(d1), DoubleToWord(d2)) End Function Private Function WordToHex(w As Word) As String WordToHex = Right$("0" & Hex$(w.B0), 2) & Right$("0" & Hex$(w.B1), 2) _ & Right$("0" & Hex$(w.B2), 2) & Right$("0" & Hex$(w.B3), 2) 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, 2 ^ 32) / (2 ^ 24)) DoubleToWord.B1 = Int(DMod(n, 2 ^ 24) / (2 ^ 16)) DoubleToWord.B2 = Int(DMod(n, 2 ^ 16) / (2 ^ 8)) DoubleToWord.B3 = Int(DMod(n, 2 ^ 8)) End Function Private Function WordToDouble(w As Word) As Double WordToDouble = (w.B0 * (2 ^ 24)) + (w.B1 * (2 ^ 16)) + (w.B2 * (2 ^ 8)) _ + w.B3 End Function Private Function DMod(value As Double, divisor As Double) As Double DMod = value - (Int(value / divisor) * divisor) If DMod < 0 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 <= 19 F = OrW(AndW(b, C), AndW(NotW(b), D)) Case Is <= 39 F = XorW(XorW(b, C), D) Case Is <= 59 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(0 To 79) As Word Dim blockText As String Dim wordText As String Dim i As Long, t As Long Dim temp As Word Dim k(0 To 3) 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) * 8) padMessage = inMessage & ChrB(128) _ & StrConv(String((128 - (inLen Mod 64) - 9) Mod 64 + 4, Chr(0)), 128) _ & ChrB(inLenW.B0) & ChrB(inLenW.B1) & ChrB(inLenW.B2) & ChrB(inLenW.B3) numBlocks = LenB(padMessage) / 64 ' initialize constants k(0) = HexToWord("5A827999") k(1) = HexToWord("6ED9EBA1") k(2) = HexToWord("8F1BBCDC") k(3) = HexToWord("CA62C1D6") ' initialize 160-bit (5 words) buffer H0 = HexToWord("67452301") H1 = HexToWord("EFCDAB89") H2 = HexToWord("98BADCFE") H3 = HexToWord("10325476") H4 = HexToWord("C3D2E1F0") ' each 512 byte message block consists of 16 words (W) but W is expanded For i = 0 To numBlocks - 1 blockText = MidB$(padMessage, (i * 64) + 1, 64) ' initialize a message block For t = 0 To 15 wordText = MidB$(blockText, (t * 4) + 1, 4) w(t).B0 = AscB(MidB$(wordText, 1, 1)) w(t).B1 = AscB(MidB$(wordText, 2, 1)) w(t).B2 = AscB(MidB$(wordText, 3, 1)) w(t).B3 = AscB(MidB$(wordText, 4, 1)) Next ' create extra words from the message block For t = 16 To 79 ' W(t) = S^1 (W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - 3), w(t - 8)), _ w(t - 14)), w(t - 16)), 1) Next ' make initial assignments to the buffer A = H0 b = H1 C = H2 D = H3 E = H4 ' process the block For t = 0 To 79 temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, 5), _ F(t, b, C, D)), E), w(t)), k(t 20)) E = D D = C C = CircShiftLeftW(b, 30) 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 Public Function SHA1(inMessage() As Byte) As Byte() ' 计算字节数组的SHA1摘要 Dim inLen As Long Dim inLenW As Word Dim numBlocks As Long Dim w(0 To 79) As Word Dim blockText As String Dim wordText As String Dim t As Long Dim temp As Word Dim k(0 To 3) 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) + 1 inLenW = DoubleToWord(CDbl(inLen) * 8) lngPadMessageLen = inLen + 1 + (128 - (inLen Mod 64) - 9) Mod 64 + 8 ReDim padMessage(lngPadMessageLen - 1) As Byte For i = 0 To inLen - 1 padMessage(i) = inMessage(i) Next i padMessage(inLen) = 128 padMessage(lngPadMessageLen - 4) = inLenW.B0 padMessage(lngPadMessageLen - 3) = inLenW.B1 padMessage(lngPadMessageLen - 2) = inLenW.B2 padMessage(lngPadMessageLen - 1) = inLenW.B3 numBlocks = lngPadMessageLen / 64 ' initialize constants k(0) = HexToWord("5A827999") k(1) = HexToWord("6ED9EBA1") k(2) = HexToWord("8F1BBCDC") k(3) = HexToWord("CA62C1D6") ' initialize 160-bit (5 words) buffer H0 = HexToWord("67452301") H1 = HexToWord("EFCDAB89") H2 = HexToWord("98BADCFE") H3 = HexToWord("10325476") H4 = HexToWord("C3D2E1F0") ' each 512 byte message block consists of 16 words (W) but W is expanded ' to 80 words For i = 0 To numBlocks - 1 ' initialize a message block For t = 0 To 15 w(t).B0 = padMessage(lngPos) w(t).B1 = padMessage(lngPos + 1) w(t).B2 = padMessage(lngPos + 2) w(t).B3 = padMessage(lngPos + 3) lngPos = lngPos + 4 Next ' create extra words from the message block For t = 16 To 79 ' W(t) = S^1 (W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - 3), w(t - 8)), _ w(t - 14)), w(t - 16)), 1) Next ' make initial assignments to the buffer A = H0 b = H1 C = H2 D = H3 E = H4 ' process the block For t = 0 To 79 temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, 5), _ F(t, b, C, D)), E), w(t)), k(t 20)) E = D D = C C = CircShiftLeftW(b, 30) 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(19) As Byte CopyMemory byt(0), H0, 4 CopyMemory byt(4), H1, 4 CopyMemory byt(8), H2, 4 CopyMemory byt(12), H3, 4 CopyMemory byt(16), H4, 4 SHA1 = byt End Function
BASE64编码:
Function Base64EncodeEX(Str() As Byte) As String On Error GoTo over Dim buf() As Byte, length As Long, mods As Long Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" mods = (UBound(Str) + 1) Mod 3 length = UBound(Str) + 1 - mods ReDim buf(length / 3 * 4 + IIf(mods <> 0, 4, 0) - 1) Dim i As Long For i = 0 To length - 1 Step 3 buf(i / 3 * 4) = (Str(i) And &HFC) / &H4 buf(i / 3 * 4 + 1) = (Str(i) And &H3) * &H10 + (Str(i + 1) And &HF0) / &H10 buf(i / 3 * 4 + 2) = (Str(i + 1) And &HF) * &H4 + (Str(i + 2) And &HC0) / &H40 buf(i / 3 * 4 + 3) = Str(i + 2) And &H3F Next If mods = 1 Then buf(length / 3 * 4) = (Str(length) And &HFC) / &H4 buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10 buf(length / 3 * 4 + 2) = 64 buf(length / 3 * 4 + 3) = 64 ElseIf mods = 2 Then buf(length / 3 * 4) = (Str(length) And &HFC) / &H4 buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10 + (Str(length + 1) And &HF0) / &H10 buf(length / 3 * 4 + 2) = (Str(length + 1) And &HF) * &H4 buf(length / 3 * 4 + 3) = 64 End If For i = 0 To UBound(buf) Base64EncodeEX = Base64EncodeEX + Mid(B64_CHAR_DICT, buf(i) + 1, 1) Next over: End Function
很多人卡在计算key上,需要调用上面的sha1加密和base64编码函数:
Private Function AcceptKey(k As String) As String Dim b() As Byte b = SHA1(StrConv(k & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode)) AcceptKey = Base64EncodeEX(b) End Function
剩下应该就没多少问题了...
有兴趣加群一起交流吧:369088586