VB6之HTTP服务器的实现

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

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

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

  1 'tools.bas
  2 Private Declare Function GetTickCount Lib "kernel32" () As Long
  3 Public Const WEB_ROOT As String = "c:\web"
  4 Public req_types As Object
  5 
  6 Public Function GetHeader(ByVal data As String, ByVal idex As Integer) As Object
  7 'head [dictionary objet]:
  8 '   Request,            [dictionary objet] <Method|File|Protocol>
  9 '   Host,               [string]
 10 '   Accept-Language,    [string]
 11 '   *etc
 12     Set head = CreateObject("scripting.dictionary")
 13     Set rqst = CreateObject("scripting.dictionary")
 14     Call head.Add("RemoteHost", Form1.SckHandler(idex).RemoteHostIP)
 15     Call head.Add("RemotePort", Form1.SckHandler(idex).RemotePort)
 16     temp = Split(data, vbCrLf)
 17     'request's method, file and protocol
 18     rmfp = Split(temp(0), " ")
 19     Call rqst.Add("Method", rmfp(0))
 20     Call rqst.Add("File", rmfp(1))
 21     Call rqst.Add("Protocol", rmfp(2))
 22     Call head.Add("Request", rqst)
 23     For idex = 1 To UBound(temp)
 24         If temp(idex) <> "" Then
 25             prop = Split(temp(idex), ": ")
 26             Call head.Add(prop(0), prop(1))
 27         End If
 28     Next
 29     Set GetHeader = head
 30 End Function
 31 
 32 Public Sub Sleep(ByVal dwDelay As Long)
 33     limt = GetTickCount() + dwDelay
 34     Do While GetTickCount < limt
 35         DoEvents
 36     Loop
 37 End Sub
 38 
 39 Function URLDecode(ByVal url As String) As String
 40 'using the function [decodeURI] from js
 41     Set js = CreateObject("scriptcontrol")
 42     js.language = "javascript"
 43     URLDecode = js.eval("decodeURI('" & url & "')")
 44     Set js = Nothing
 45 End Function
 46 
 47 Public Function GetGMTDate() As String
 48     Dim WEEKDAYS
 49     Dim MONTHS
 50     Dim DEFAULT_PAGE
 51     
 52     WEEKDAYS = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
 53     MONTHS = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sept", "Oct", "Nov", "Dec")
 54     DEFAULT_PAGE = Array("index.html", "index.htm", "main.html", "main.htm")
 55     date_ = DateAdd("h", -8, Now())
 56     weekday_ = WEEKDAYS(Weekday(date_) - 1)
 57     month_ = MONTHS(Month(date_) - 1)
 58     day_ = Day(date_): year_ = Year(date_)
 59     time_ = Right(date_, 8)
 60     If Hour(time_) < 10 Then time_ = "0" & time_
 61     GetGMTDate = weekday_ & ", " & day_ & _
 62          " " & month_ & " " & year_ & _
 63          " " & time_ & " GMT"
 64 End Function
 65 
 66 Public Function url2file(ByVal url As String) As String
 67     file = URLDecode(url)
 68 '默认文件为 index.html
 69     If file = "/" Then file = "/index.html"
 70     file = Replace(file, "/", "\")
 71     file = WEB_ROOT & file
 72     url2file = file
 73 End Function
 74 
 75 Public Function GetBytes(ByVal file As String, ByRef byts() As Byte) As Long
 76 'not supported big file which size>2G
 77         fnum = FreeFile()
 78         Open file For Binary Access Read As #fnum
 79             size = LOF(fnum)
 80             If size = 0 Then
 81                 byts = vbCrLf
 82             Else
 83                 ReDim byts(size - 1) As Byte
 84                 Get #fnum, , byts
 85             End If
 86         Close #fnum
 87         GetBytes = size
 88 End Function
 89 
 90 Public Function SetResponseHeader(ByVal file As String, ByVal size As Long) As String
 91 'get the content-type from extension,
 92 '   if file has not ext, then set it to .*
 93     If InStr(file, ".") = 0 Then file = file & ".*"
 94     ext = "." & Split(file, ".")(1)
 95     ftype = req_types(ext)
 96     header = "HTTP/1.1 200 OK" & vbCrLf & _
 97             "Server: http-vb/0.1 vb/6.0" & vbCrLf & _
 98             "Date: " & GetGMTDate() & vbCrLf & _
 99             "Content-Type: " & ftype & vbCrLf & _
100             "Content-Length: " & size & vbCrLf & vbCrLf
101     SetResponseHeader = header
102 End Function

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

  1 'code by lichmama
  2 'winsock 状态常数
  3 Private Enum WINSOCK_STATE_ENUM
  4     sckClosed = 0               '关闭状态
  5     sckOpen = 1                 '打开状态
  6     sckListening = 2            '侦听状态
  7     sckConnectionPending = 3    '连接挂起
  8     sckResolvingHost = 4        '解析域名
  9     sckHostResolved = 5         '已识别主机
 10     sckConnecting = 6           '正在连接
 11     sckConnected = 7            '已连接
 12     sckClosing = 8              '同级人员正在关闭连接
 13     sckError = 9                '错误
 14 End Enum
 15 
 16 Private Sub Command1_Click()
 17     '启动监听
 18     Call Winsock1.Listen
 19     Me.Caption = "HTTP-SERVER/VB: HTTP服务启动,监听端口80"
 20 End Sub
 21 
 22 Private Sub Command2_Click()
 23     '关闭监听
 24     Call Winsock1.Close
 25     For i = 0 To 9
 26         Call SckHandler(i).Close
 27     Next
 28     Me.Caption = "HTTP-SERVER/VB: HTTP服务已停止"
 29 End Sub
 30 
 31 Private Sub Form_Load()
 32 '当前支持的文件类型
 33     Set req_types = CreateObject("scripting.dictionary")
 34     Call req_types.Add(".html", "text/html")
 35     Call req_types.Add(".htm", "text/html")
 36     Call req_types.Add(".xml", "text/xml")
 37     Call req_types.Add(".js", "application/x-javascript")
 38     Call req_types.Add(".css", "text/css")
 39     Call req_types.Add(".txt", "text/plain")
 40     Call req_types.Add(".jpg", "image/jpeg")
 41     Call req_types.Add(".png", "image/image/png")
 42     Call req_types.Add(".gif", "image/image/gif")
 43     Call req_types.Add(".ico", "image/image/x-icon")
 44     Call req_types.Add(".bmp", "application/x-bmp")
 45     Call req_types.Add(".*", "application/octet-stream")
 46     
 47     For i = 1 To 9
 48         Call Load(SckHandler(i))
 49         With SckHandler(i)
 50             .Protocol = sckTCPProtocol
 51             .LocalPort = 80
 52             .Close
 53         End With
 54     Next
 55     
 56     With Winsock1
 57         .Protocol = sckTCPProtocol
 58         .Bind 80, "0.0.0.0"
 59         .Close
 60     End With
 61 End Sub
 62 
 63 Private Sub Form_Unload(Cancel As Integer)
 64     Winsock1.Close
 65     For i = 0 To 9
 66         SckHandler(i).Close
 67     Next
 68 End Sub
 69 
 70 Private Sub SckHandler_DataArrival(Index As Integer, ByVal bytesTotal As Long)
 71     Dim buff As String
 72     Call SckHandler(Index).GetData(buff, vbString, bytesTotal)
 73     Call Handle_Request(buff, Index)
 74 End Sub
 75 
 76 Private Sub SckHandler_SendComplete(Index As Integer)
 77     Call SckHandler(Index).Close
 78 End Sub
 79 
 80 Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
 81 HANDLER_ENTRANCE_:
 82     For i = 0 To 9
 83         If SckHandler(i).State <> sckConnected And _
 84             SckHandler(i).State <> sckConnecting And _
 85             SckHandler(i).State <> sckClosing Then
 86             Call SckHandler(i).Accept(requestID)
 87             Exit Sub
 88         End If
 89     Next
 90     '如果未找到空闲的handler,等待100ms后,继续寻找
 91     Call Sleep(100): GoTo HANDLER_ENTRANCE_
 92 End Sub
 93 
 94 Private Sub Handle_Request(ByVal req As String, ByVal HandlerId As Integer)
 95     Dim byts() As Byte
 96     Set head = GetHeader(req, HandlerId)
 97     
 98     file = url2file(head("Request")("File"))
 99     fnme = Dir(file)
100     If fnme <> "" Then
101         size = GetBytes(file, byts)
102         SckHandler(HandlerId).SendData SetResponseHeader(file, size)
103         SckHandler(HandlerId).SendData byts
104         Erase byts
105         Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _
106             head("Request")("File") & " " & _
107             head("Request")("Protocol"); " " & _
108             head("RemoteHost") & ":" & head("RemotePort") & " " & _
109             "-- 200 OK"
110     Else
111         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>"
112         SckHandler(HandlerId).SendData "HTTP/1.1 404 NOT FOUND" & vbCrLf & _
113             "Server: http-vb/0.1 vb/6.0" & vbCrLf & _
114             "Date: " & GetGMTDate() & vbCrLf & _
115             "Content-Length: " & Len(page404) & vbCrLf & vbCrLf
116         SckHandler(HandlerId).SendData page404
117         Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _
118             head("Request")("File") & " " & _
119             head("Request")("Protocol"); " " & _
120             head("RemoteHost") & ":" & head("RemotePort") & " " & _
121             "-- 404 NOT FOUND"
122     End If
123     
124     Set head("Request") = Nothing
125     Set head = Nothing
126 End Sub

 

 

最后上两张图,后台:

 

404:

 

正常访问:

 

posted @ 2014-07-06 21:19  lichmama  阅读(...)  评论(...编辑  收藏