VB6+Winsock编写的websocket服务端

早就写好了,看这方面资料比较少,索性贴出来.只是一个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 StringDim b() As ByteDim i As LongShowlog Index & "bytesTotal:" & bytesTotal    SerSock(Index).GetData bIf Client(Index) Then'判断该客户端是否进行过验证Dim k As StringDim rs As Strings = StrConv(b, vbUnicode)        k = Trim(MidEx(s, "Sec-WebSocket-Key:", vbCrLf))If Len(k) <> 0 Thenk = 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) = FalseEnd IfElseIf b(0) = &H81 ThenIf PickData(b) = True ThenFor i = 0 To Client.Count - 1If Client(i).State = 7 Then Client(i).SendData bNext iEnd IfElseFor i = 0 To UBound(b)                s = s & b(i) & " "Next i            Showlog ">>> " & sEnd IfEnd IfEnd SubPrivate Function PickData(byt() As Byte) As BooleanDim i As LongDim mask(3) As ByteDim bData() As ByteDim Lb(3) As ByteDim L As LongDim inx As Long '偏移Dim sti As LongDim s As Stringi = UBound(byt) - 3ReDim b(i)    b(0) = 62b(1) = 62L = byt(1) Xor &H80 '128If L < 126 ThenIf UBound(byt) <> L + 5 Then Exit FunctionIf L < 125 Then '            ReDim bData(L + 2)ElseReDim bData(L + 1): L = L - 1End If'        ReDim bData(L)bData(0) = &H81        bData(1) = CByte(L + 1)        CopyMemory mask(0), byt(2), 4inx = 6sti = 2ElseIf L = 126 ThenLb(0) = byt(3)        Lb(1) = byt(2)        CopyMemory L, Lb(0), 4If UBound(byt) <> L + 7 Then Exit FunctionCopyMemory mask(0), byt(4), 4ReDim bData(L + 4)        L = L + 1CopyMemory Lb(0), L, 4bData(0) = &H81        bData(1) = &H7E        bData(2) = Lb(1)        bData(3) = Lb(0)        inx = 8sti = 4ElseIf L = 127 ThenIf UBound(byt) <> L + 9 Then Exit FunctionLb(0) = byt(5)        Lb(1) = byt(4)        Lb(2) = byt(3)        Lb(3) = byt(2)        CopyMemory L, Lb(0), 4CopyMemory mask(0), byt(6), 4inx = 10sti = 6L = 0 '由于本次应用不处理长帧,所以设为0End IfIf L <= 0 Then Exit FunctionFor i = inx To UBound(byt)        bData(sti) = byt(i) Xor mask((i - inx) Mod 4)        sti = sti + 1Next 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 = TrueEnd Function

SHA1加密,算法来源于网络上做了一些修改:

Option ExplicitPrivate 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 WordB0 As ByteB1 As ByteB2 As ByteB3 As ByteEnd 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 FunctionPrivate Function AndW(w1 As Word, w2 As Word) As WordAndW.B0 = w1.B0 And w2.B0AndW.B1 = w1.B1 And w2.B1AndW.B2 = w1.B2 And w2.B2AndW.B3 = w1.B3 And w2.B3End FunctionPrivate Function OrW(w1 As Word, w2 As Word) As WordOrW.B0 = w1.B0 Or w2.B0OrW.B1 = w1.B1 Or w2.B1OrW.B2 = w1.B2 Or w2.B2OrW.B3 = w1.B3 Or w2.B3End FunctionPrivate Function XorW(w1 As Word, w2 As Word) As WordXorW.B0 = w1.B0 Xor w2.B0XorW.B1 = w1.B1 Xor w2.B1XorW.B2 = w1.B2 Xor w2.B2XorW.B3 = w1.B3 Xor w2.B3End FunctionPrivate Function NotW(w As Word) As WordNotW.B0 = Not w.B0NotW.B1 = Not w.B1NotW.B2 = Not w.B2NotW.B3 = Not w.B3End FunctionPrivate Function AddW(w1 As Word, w2 As Word) As WordDim i As Long, w As Wordi = CLng(w1.B3) + w2.B3w.B3 = i Mod 256i = CLng(w1.B2) + w2.B2 + (i \ 256)w.B2 = i Mod 256i = CLng(w1.B1) + w2.B1 + (i \ 256)w.B1 = i Mod 256i = CLng(w1.B0) + w2.B0 + (i \ 256)w.B0 = i Mod 256AddW = wEnd FunctionPrivate Function CircShiftLeftW(w As Word, n As Long) As WordDim d1 As Double, d2 As Doubled1 = WordToDouble(w)d2 = d1d1 = d1 * (2 ^ n)d2 = d2 / (2 ^ (32 - n))CircShiftLeftW = OrW(DoubleToWord(d1), DoubleToWord(d2))End FunctionPrivate Function WordToHex(w As Word) As StringWordToHex = 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 FunctionPrivate Function HexToWord(H As String) As WordHexToWord = DoubleToWord(Val("&H" & H & "#"))End FunctionPrivate Function DoubleToWord(n As Double) As WordDoubleToWord.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 FunctionPrivate Function WordToDouble(w As Word) As DoubleWordToDouble = (w.B0 * (2 ^ 24)) + (w.B1 * (2 ^ 16)) + (w.B2 * (2 ^ 8)) _+ w.B3End FunctionPrivate Function DMod(value As Double, divisor As Double) As DoubleDMod = value - (Int(value / divisor) * divisor)If DMod < 0 Then DMod = DMod + divisorEnd FunctionPrivate Function F(t As Long, b As Word, C As Word, D As Word) As WordSelect Case tCase Is <= 19F = OrW(AndW(b, C), AndW(NotW(b), D))Case Is <= 39F = XorW(XorW(b, C), D)Case Is <= 59F = OrW(OrW(AndW(b, C), AndW(b, D)), AndW(C, D))Case ElseF = XorW(XorW(b, C), D)End SelectEnd FunctionPublic Function StringSHA1(inMessage As String) As String' 计算字符串的SHA1摘要Dim inLen As LongDim inLenW As WordDim padMessage As StringDim numBlocks As LongDim w(0 To 79) As WordDim blockText As StringDim wordText As StringDim i As Long, t As LongDim temp As WordDim k(0 To 3) As WordDim H0 As WordDim H1 As WordDim H2 As WordDim H3 As WordDim H4 As WordDim A As WordDim b As WordDim C As WordDim D As WordDim E As WordinMessage = 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 constantsk(0) = HexToWord("5A827999")k(1) = HexToWord("6ED9EBA1")k(2) = HexToWord("8F1BBCDC")k(3) = HexToWord("CA62C1D6")' initialize 160-bit (5 words) bufferH0 = 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 expandedFor i = 0 To numBlocks - 1blockText = MidB$(padMessage, (i * 64) + 1, 64)' initialize a message blockFor t = 0 To 15wordText = 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 blockFor 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 bufferA = H0b = H1C = H2D = H3E = H4' process the blockFor t = 0 To 79temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, 5), _F(t, b, C, D)), E), w(t)), k(t \ 20))E = DD = CC = CircShiftLeftW(b, 30)b = AA = tempNextH0 = AddW(H0, A)H1 = AddW(H1, b)H2 = AddW(H2, C)H3 = AddW(H3, D)H4 = AddW(H4, E)NextStringSHA1 = WordToHex(H0) & WordToHex(H1) & WordToHex(H2) _& WordToHex(H3) & WordToHex(H4)End FunctionPublic Function SHA1(inMessage() As Byte) As Byte()' 计算字节数组的SHA1摘要Dim inLen As LongDim inLenW As WordDim numBlocks As LongDim w(0 To 79) As WordDim blockText As StringDim wordText As StringDim t As LongDim temp As WordDim k(0 To 3) As WordDim H0 As WordDim H1 As WordDim H2 As WordDim H3 As WordDim H4 As WordDim A As WordDim b As WordDim C As WordDim D As WordDim E As WordDim i As LongDim lngPos As LongDim lngPadMessageLen As LongDim padMessage() As ByteinLen = UBound(inMessage) + 1inLenW = DoubleToWord(CDbl(inLen) * 8)lngPadMessageLen = inLen + 1 + (128 - (inLen Mod 64) - 9) Mod 64 + 8ReDim padMessage(lngPadMessageLen - 1) As ByteFor i = 0 To inLen - 1padMessage(i) = inMessage(i)Next ipadMessage(inLen) = 128padMessage(lngPadMessageLen - 4) = inLenW.B0padMessage(lngPadMessageLen - 3) = inLenW.B1padMessage(lngPadMessageLen - 2) = inLenW.B2padMessage(lngPadMessageLen - 1) = inLenW.B3numBlocks = lngPadMessageLen / 64' initialize constantsk(0) = HexToWord("5A827999")k(1) = HexToWord("6ED9EBA1")k(2) = HexToWord("8F1BBCDC")k(3) = HexToWord("CA62C1D6")' initialize 160-bit (5 words) bufferH0 = 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 wordsFor i = 0 To numBlocks - 1' initialize a message blockFor t = 0 To 15w(t).B0 = padMessage(lngPos)w(t).B1 = padMessage(lngPos + 1)w(t).B2 = padMessage(lngPos + 2)w(t).B3 = padMessage(lngPos + 3)lngPos = lngPos + 4Next' create extra words from the message blockFor 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 bufferA = H0b = H1C = H2D = H3E = H4' process the blockFor t = 0 To 79temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, 5), _F(t, b, C, D)), E), w(t)), k(t \ 20))E = DD = CC = CircShiftLeftW(b, 30)b = AA = tempNextH0 = AddW(H0, A)H1 = AddW(H1, b)H2 = AddW(H2, C)H3 = AddW(H3, D)H4 = AddW(H4, E)NextDim byt(19) As ByteCopyMemory byt(0), H0, 4CopyMemory byt(4), H1, 4CopyMemory byt(8), H2, 4CopyMemory byt(12), H3, 4CopyMemory byt(16), H4, 4SHA1 = bytEnd Function

BASE64编码:

Function Base64EncodeEX(Str() As Byte) As StringOn Error GoTo overDim buf() As Byte, length As Long, mods As LongConst B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="mods = (UBound(Str) + 1) Mod 3length = UBound(Str) + 1 - modsReDim buf(length / 3 * 4 + IIf(mods <> 0, 4, 0) - 1)Dim i As LongFor i = 0 To length - 1 Step 3buf(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 &H3FNextIf mods = 1 Thenbuf(length / 3 * 4) = (Str(length) And &HFC) / &H4        buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10        buf(length / 3 * 4 + 2) = 64buf(length / 3 * 4 + 3) = 64ElseIf mods = 2 Thenbuf(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) = 64End IfFor i = 0 To UBound(buf)        Base64EncodeEX = Base64EncodeEX + Mid(B64_CHAR_DICT, buf(i) + 1, 1)Nextover:End Function

很多人卡在计算key上,需要调用上面的sha1加密和base64编码函数:

Private Function AcceptKey(k As String) As StringDim b() As Byteb = SHA1(StrConv(k & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode))    AcceptKey = Base64EncodeEX(b)End Function

剩下应该就没多少问题了...