VB6+Winsock编写的websocket服务端

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