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