VB6之HTTP服务器的实现

之前用VBS写过一个，效率和支持比较low，这次闲着没事用VB重写了一次。

当前的实现版本仅支持静态文件的访问（*.html之类），支持访问方式为GET，HTTP状态支持200和404。

两个文件，一个是定义了常用到的函数的模块tools.bas

 'tools.bas
 Private Declare Function GetTickCount Lib "kernel32" () As Long
 Public Const WEB_ROOT As String = "c:\web"
 Public req_types As Object

 Public Function GetHeader(ByVal data As String, ByVal idex As Integer) As Object
 'head [dictionary objet]:
 '   Request,            [dictionary objet] <Method|File|Protocol>
 '   Host,               [string]
 '   Accept-Language,    [string]
 '   *etc
     Set head = CreateObject("scripting.dictionary")
     Set rqst = CreateObject("scripting.dictionary")
     Call head.Add("RemoteHost", Form1.SckHandler(idex).RemoteHostIP)
     Call head.Add("RemotePort", Form1.SckHandler(idex).RemotePort)
     temp = Split(data, vbCrLf)
     'request's method, file and protocol
     rmfp = Split(temp(), " ")
     Call rqst.Add("Method", rmfp())
     Call rqst.Add("File", rmfp())
     Call rqst.Add("Protocol", rmfp())
     Call head.Add("Request", rqst)
     For idex =  To UBound(temp)
         If temp(idex) <> "" Then
             prop = Split(temp(idex), ": ")
             Call head.Add(prop(), prop())
         End If
     Next
     Set GetHeader = head
 End Function

 Public Sub Sleep(ByVal dwDelay As Long)
     limt = GetTickCount() + dwDelay
     Do While GetTickCount < limt
         DoEvents
     Loop
 End Sub

 Function URLDecode(ByVal url As String) As String
 'using the function [decodeURI] from js
     Set js = CreateObject("scriptcontrol")
     js.language = "javascript"
     URLDecode = js.eval("decodeURI('" & url & "')")
     Set js = Nothing
 End Function

 Public Function GetGMTDate() As String
     Dim WEEKDAYS
     Dim MONTHS
     Dim DEFAULT_PAGE

     WEEKDAYS = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
     MONTHS = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sept", "Oct", "Nov", "Dec")
     DEFAULT_PAGE = Array("index.html", "index.htm", "main.html", "main.htm")
     date_ = DateAdd("h", -, Now())
     weekday_ = WEEKDAYS(Weekday(date_) - )
     month_ = MONTHS(Month(date_) - )
     day_ = Day(date_): year_ = Year(date_)
     time_ = Right(date_, )
     If Hour(time_) <  Then time_ = "" & time_
     GetGMTDate = weekday_ & ", " & day_ & _
          " " & month_ & " " & year_ & _
          " " & time_ & " GMT"
 End Function

 Public Function url2file(ByVal url As String) As String
     file = URLDecode(url)
 '默认文件为 index.html
     If file = "/" Then file = "/index.html"
     file = Replace(file, "/", "\")
     file = WEB_ROOT & file
     url2file = file
 End Function

 Public Function GetBytes(ByVal file As String, ByRef byts() As Byte) As Long
 'not supported big file which size>2G
         fnum = FreeFile()
         Open file For Binary Access Read As #fnum
             size = LOF(fnum)
             If size =  Then
                 byts = vbCrLf
             Else
                 ReDim byts(size - ) As Byte
                 Get #fnum, , byts
             End If
         Close #fnum
         GetBytes = size
 End Function

 Public Function SetResponseHeader(ByVal file As String, ByVal size As Long) As String
 'get the content-type from extension,
 '   if file has not ext, then set it to .*
     If InStr(file, ".") =  Then file = file & ".*"
     ext = "." & Split(file, ".")()
     ftype = req_types(ext)
     header = "HTTP/1.1 200 OK" & vbCrLf & _
             "Server: http-vb/0.1 vb/6.0" & vbCrLf & _
             "Date: " & GetGMTDate() & vbCrLf & _
             "Content-Type: " & ftype & vbCrLf & _
             "Content-Length: " & size & vbCrLf & vbCrLf
     SetResponseHeader = header
 End Function

然后是窗体部分，目前日志全部都用的Debug打印的，因此就没专门来写日志输出：

 'code by lichmama
 'winsock 状态常数
 Private Enum WINSOCK_STATE_ENUM
     sckClosed =                '关闭状态
     sckOpen =                  '打开状态
     sckListening =             '侦听状态
     sckConnectionPending =     '连接挂起
     sckResolvingHost =         '解析域名
     sckHostResolved =          '已识别主机
     sckConnecting =            '正在连接
     sckConnected =             '已连接
     sckClosing =               '同级人员正在关闭连接
     sckError =                 '错误
 End Enum

 Private Sub Command1_Click()
     '启动监听
     Call Winsock1.Listen
     Me.Caption = "HTTP-SERVER/VB： HTTP服务启动，监听端口80"
 End Sub

 Private Sub Command2_Click()
     '关闭监听
     Call Winsock1.Close
     For i =  To
         Call SckHandler(i).Close
     Next
     Me.Caption = "HTTP-SERVER/VB： HTTP服务已停止"
 End Sub

 Private Sub Form_Load()
 '当前支持的文件类型
     Set req_types = CreateObject("scripting.dictionary")
     Call req_types.Add(".html", "text/html")
     Call req_types.Add(".htm", "text/html")
     Call req_types.Add(".xml", "text/xml")
     Call req_types.Add(".js", "application/x-javascript")
     Call req_types.Add(".css", "text/css")
     Call req_types.Add(".txt", "text/plain")
     Call req_types.Add(".jpg", "image/jpeg")
     Call req_types.Add(".png", "image/image/png")
     Call req_types.Add(".gif", "image/image/gif")
     Call req_types.Add(".ico", "image/image/x-icon")
     Call req_types.Add(".bmp", "application/x-bmp")
     Call req_types.Add(".*", "application/octet-stream")

     For i =  To
         Call Load(SckHandler(i))
         With SckHandler(i)
             .Protocol = sckTCPProtocol
             .LocalPort =
             .Close
         End With
     Next

     With Winsock1
         .Protocol = sckTCPProtocol
         .Bind , "0.0.0.0"
         .Close
     End With
 End Sub

 Private Sub Form_Unload(Cancel As Integer)
     Winsock1.Close
     For i =  To
         SckHandler(i).Close
     Next
 End Sub

 Private Sub SckHandler_DataArrival(Index As Integer, ByVal bytesTotal As Long)
     Dim buff As String
     Call SckHandler(Index).GetData(buff, vbString, bytesTotal)
     Call Handle_Request(buff, Index)
 End Sub

 Private Sub SckHandler_SendComplete(Index As Integer)
     Call SckHandler(Index).Close
 End Sub

 Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
 HANDLER_ENTRANCE_:
     For i =  To
         If SckHandler(i).State <> sckConnected And _
             SckHandler(i).State <> sckConnecting And _
             SckHandler(i).State <> sckClosing Then
             Call SckHandler(i).Accept(requestID)
             Exit Sub
         End If
     Next
     '如果未找到空闲的handler，等待100ms后，继续寻找
     Call Sleep(): GoTo HANDLER_ENTRANCE_
 End Sub

 Private Sub Handle_Request(ByVal req As String, ByVal HandlerId As Integer)
     Dim byts() As Byte
     Set head = GetHeader(req, HandlerId)

     file = url2file(head("Request")("File"))
     fnme = Dir(file)
     If fnme <> "" Then
         size = GetBytes(file, byts)
         SckHandler(HandlerId).SendData SetResponseHeader(file, size)
         SckHandler(HandlerId).SendData byts
         Erase byts
         Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _
             head("Request")("File") & " " & _
             head("Request")("Protocol"); " " & _
             head("RemoteHost") & ":" & head("RemotePort") & " " & _
             "-- 200 OK"
     Else
         page404 = "<!DOCTYPE html><html><head><title>404错误 - HTTP_VB(@lichmama)</title><body><br><p style='text-align:center;font-family:consolas'>""don't busy on trying, maybe you just took a wrong way of opening.""<br>        -- kindly tip from <i style='color:red;font-size:32px'>404</i></p></body></head></html>"
         SckHandler(HandlerId).SendData "HTTP/1.1 404 NOT FOUND" & vbCrLf & _
             "Server: http-vb/0.1 vb/6.0" & vbCrLf & _
             "Date: " & GetGMTDate() & vbCrLf & _
             "Content-Length: " & Len(page404) & vbCrLf & vbCrLf
         SckHandler(HandlerId).SendData page404
         Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _
             head("Request")("File") & " " & _
             head("Request")("Protocol"); " " & _
             head("RemoteHost") & ":" & head("RemotePort") & " " & _
             "-- 404 NOT FOUND"
     End If

     Set head("Request") = Nothing
     Set head = Nothing
 End Sub

最后上两张图，后台：

404：

正常访问：