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) <>  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() = &H81 Then
            If PickData(b) = True Then
                For i =  To Client.Count -
                    If Client(i).State =  Then Client(i).SendData b
                Next i
            End If
        Else
            For i =  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() As Byte
    Dim bData() As Byte
    Dim Lb() As Byte
    Dim L As Long
    Dim inx As Long '偏移
    Dim sti As Long
    Dim s As String
    i = UBound(byt) -
    ReDim b(i)
    b() =
    b() =
    L = byt() Xor &H80 '
    If L <  Then
        If UBound(byt) <> L +  Then Exit Function
        If L <  Then '
            ReDim bData(L + )
        Else
            ReDim bData(L + ): L = L -
        End If
'        ReDim bData(L)
        bData() = &H81
        bData() = CByte(L + )
        CopyMemory mask(), byt(),
        inx =
        sti =
    ElseIf L =  Then
        Lb() = byt()
        Lb() = byt()
        CopyMemory L, Lb(),
        If UBound(byt) <> L +  Then Exit Function
        CopyMemory mask(), byt(),
        ReDim bData(L + )
        L = L +
        CopyMemory Lb(), L,
        bData() = &H81
        bData() = &H7E
        bData() = Lb()
        bData() = Lb()
        inx =
        sti =
    ElseIf L =  Then
        If UBound(byt) <> L +  Then Exit Function
        Lb() = byt()
        Lb() = byt()
        Lb() = byt()
        Lb() = byt()
        CopyMemory L, Lb(),
        CopyMemory mask(), byt(),
        inx =
        sti =
        L =  '由于本次应用不处理长帧,所以设为0
    End If
    If L <=  Then Exit Function
    For i = inx To UBound(byt)
        bData(sti) = byt(i) Xor mask((i - inx) Mod )
        sti = sti +
    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
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) / 

' initialize constants
k() = HexToWord("5A827999")
k() = HexToWord("6ED9EBA1")
k() = HexToWord("8F1BBCDC")
k() = HexToWord("CA62C1D6")

' initialize 160-bit (5 words) buffer
H0 = HexToWord("")
H1 = HexToWord("EFCDAB89")
H2 = HexToWord("98BADCFE")
H3 = HexToWord("")
H4 = HexToWord("C3D2E1F0")

' each 512 byte message block consists of 16 words (W) but W is expanded
For i =  To numBlocks -
blockText = MidB$(padMessage, (i * ) + , )
' initialize a message block
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

' create extra words from the message block
For t =  To
' 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 - ), w(t - )), _
w(t - )), w(t - )), )
Next

' make initial assignments to the buffer
A = H0
b = H1
C = H2
D = H3
E = H4

' process the block
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

Public Function SHA1(inMessage() As Byte) As Byte()
' 计算字节数组的SHA1摘要
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 / 

' initialize constants
k() = HexToWord("5A827999")
k() = HexToWord("6ED9EBA1")
k() = HexToWord("8F1BBCDC")
k() = HexToWord("CA62C1D6")

' initialize 160-bit (5 words) buffer
H0 = HexToWord("")
H1 = HexToWord("EFCDAB89")
H2 = HexToWord("98BADCFE")
H3 = HexToWord("")
H4 = HexToWord("C3D2E1F0")

' each 512 byte message block consists of 16 words (W) but W is expanded
' to 80 words
For i =  To numBlocks -
' initialize a message block
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

' create extra words from the message block
For t =  To
' 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 - ), w(t - )), _
w(t - )), w(t - )), )
Next

' make initial assignments to the buffer
A = H0
b = H1
C = H2
D = H3
E = H4

' process the block
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

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) + ) 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)
        Base64EncodeEX = Base64EncodeEX + Mid(B64_CHAR_DICT, buf(i) + , )
    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