请各位Vfp版主合力写个HttpServer,带领大伙向BS进军

_SCREEN.Visible = .F.
SET TALK OFF
CLEAR
ON ERROR _OnError(ERROR(), MESSAGE(), MESSAGE(1), PROGRAM(), LINENO())

#DEFINE WM_SOCKET    0x400 + 100

DECLARE LONG WSAGetLastError IN "Ws2_32"
DECLARE LONG WSAStartup IN "Ws2_32" LONG, STRING@
DECLARE LONG WSACleanup IN "Ws2_32"
DECLARE LONG socket IN "Ws2_32" LONG, LONG, LONG
DECLARE LONG closesocket IN "Ws2_32" LONG
DECLARE LONG WSAAsyncSelect IN "Ws2_32" LONG, LONG, LONG, LONG
DECLARE LONG bind IN "Ws2_32" AS _bind LONG, STRING@, LONG
DECLARE LONG listen IN "Ws2_32" LONG, LONG
DECLARE LONG accept IN "Ws2_32" LONG, STRING@, LONG@
DECLARE LONG recv IN "Ws2_32" LONG, STRING@, LONG, LONG
DECLARE LONG send IN "Ws2_32" LONG, STRING@, LONG, LONG
DECLARE LONG inet_addr IN "Ws2_32" STRING@
DECLARE LONG htons IN "Ws2_32" LONG

CREATE CURSOR TEMP (编号 C(10), 用户名 C(10), 密码 C(10))
INSERT INTO TEMP VALUES ("1001", "张三", "123")
INSERT INTO TEMP VALUES ("2002", "李四", "456")
INSERT INTO TEMP VALUES ("3003", "王五", "789")


PUBLIC oForm
oForm = NEWOBJECT("WebServerForm")
oForm.Show
READ EVENTS
CLOSE DATABASES ALL
CLEAR DLLS
ON ERROR
_SCREEN.Visible = .T.
RETURN


DEFINE CLASS WebServerForm As Form
    Width = 400
    Height = 310
    Desktop = .T.
    ShowWindow = 2
    WindowType = 1
    AutoCenter = .T.
    AlwaysOnTop = .T.
    BorderStyle = 0
   
    Add Object Label1 As Label WITH Top = 10, Left = 10, AutoSize = .T.,;
        Caption = "本端: IP                  端口"
    Add Object Text1 As TextBox WITH Top = 6, Left = 60, Width = 100, Height = 20
    Add Object Text2 As TextBox WITH Top = 6, Left = 190, Width = 40, Height = 20, value = 80
    Add Object Command1 As CommandButton WITH Top = 6, Left = 235, Width = 70, Height = 20,;
        Caption = "启动服务"

    Add Object Command2 As CommandButton WITH Top = 6, Left = 320, Width = 70, Height = 20,;
        Caption = "清屏"

    Add Object Edit1 As EditBox WITH Top = 32, Left = 10, Width = 380, Height = 270

    Add Object SocketWeb1  As SocketWeb
    Add Object SocketHttp1 As SocketHttp
    Add Object HttpHead1   As HttpHead

    PROCEDURE Init
        LOCAL oIPs
        BINDEVENT(this.hWnd, WM_SOCKET, this.SocketWeb1, "_SocketMsg")

        oIPs = GETOBJECT('winmgmts:')
        oIPs = oIPs.InstancesOf('Win32_NetworkAdapterConfiguration')
        FOR EACH oIP IN oIPs
            IF oIP.IPEnabled
                this.Text1.Value = oIP.IPAddress[0]
                EXIT
            ENDIF
        ENDFOR
        
        this.AlwaysOnTop = .F.
    ENDPROC
   
    PROCEDURE Unload
        CLEAR EVENTS
    ENDPROC
   
    PROCEDURE Command1.Click
        szRet = thisform.SocketWeb1._SetListen(thisform.hWnd,;
                                               ALLTRIM(thisform.Text1.Value),;
                                               thisform.Text2.Value)
        thisform._WriteMsg(szRet)
    ENDPROC

    PROCEDURE Command2.Click
        thisform.Edit1.Value = ""
    ENDPROC

    PROCEDURE _WriteMsg
        LPARAMETERS szMsg
        this.Edit1.Value = this.Edit1.Value + szMsg + 0h0D0A
        this.Edit1.SelStart = LEN(this.Edit1.Text)
        this.Edit1.SelLength = 0
    ENDPROC
   
    PROCEDURE SocketWeb1._OnRead
        LPARAMETERS _hSocket, szReadBuf
        thisform.HttpHead1.GetFields(szReadBuf)
        *thisform._WriteMsg(szReadBuf)                         &&调试信息
        *thisform._WriteMsg(_WriteFields(thisform.HttpHead1))  &&调试信息

        DO CASE
        CASE thisform.HttpHead1.Url == "/"
            thisform.SocketHttp1._SendLogin(_hSocket)
        CASE "Submit" $ thisform.HttpHead1.Url
            IF ALINES(aUrl, thisform.HttpHead1.Url, "&") == 3
                IF STRCONV(STRTRAN(RIGHT(aUrl[3], 12), "%", ""), 16) == "登录"
                    aUrl[1] = STUFF(aUrl[1], 1, AT("=", aUrl[1]), "")
                    aUrl[2] = STUFF(aUrl[2], 1, AT("=", aUrl[2]), "")
                    IF LEFT(aUrl[1], 1) == "%"
                        aUrl[1] = STRCONV(STRTRAN(aUrl[1], "%", ""), 16)
                    ENDIF
                    IF LEFT(aUrl[2], 1) == "%"
                        aUrl[2] = STRCONV(STRTRAN(aUrl[2], "%", ""), 16)
                    ENDIF
                    SELECT TEMP
                    LOCATE FOR (ALLTRIM(用户名) == aUrl[1]) AND (ALLTRIM(密码) == aUrl[2])
                    IF FOUND()
                        thisform.SocketHttp1._SendBrowse(_hSocket)
                    ELSE
                        thisform.SocketHttp1._SendError(_hSocket)
                    ENDIF
                ENDIF
            ENDIF
        ENDCASE
    ENDPROC
ENDDEFINE


DEFINE CLASS SocketWeb AS Session
    hWnd    = 0
    hSocket = 0

    PROCEDURE Destroy
         this._CloseSocket()
    ENDPROC
   
    PROCEDURE _CloseSocket
        closesocket(this.hSocket)
        WSACleanup()
    ENDPROC

    PROCEDURE _SetListen
        LPARAMETERS hWnd, szIP, nPort
        LOCAL stWsaData, stSockAddr
        this._CloseSocket()
        
        this.hWnd  = hWnd
        stWsaData  = REPLICATE(0h00, 398)
        WSAStartup(0x202, @stWsaData)
        this.hSocket = socket(2, 1, 0)
        WSAAsyncSelect(this.hSocket, this.hWnd, WM_SOCKET, 8)    && FD_ACCEPT
        
        stSockAddr = BINTOC(2, "2RS");                   && sin_family
                   + BINTOC(htons(nPort), "2RS");        && sin_port
                   + BINTOC(inet_addr(@szIP), "4RS");    && sin_addr
                   + REPLICATE(0h00, 8)

        IF _bind(this.hSocket, @stSockAddr, LEN(stSockAddr)) == -1
            RETURN "不能绑定到IP:" + szIP + " 端口:" + TRANSFORM(nPort)
        ELSE
            listen(this.hSocket, 5)                      && 监听，队列限制5
            RETURN "启动服务成功"
        ENDIF
    ENDPROC

    * 添加一个客户端socket
    PROCEDURE _AddClient
        LPARAMETERS _hSocket
        LOCAL stSockAddr, nSize
        stSockAddr = REPLICATE(0h00, 16)
        nSize      = LEN(stSockAddr)
        _hSocket = accept(_hSocket, @stSockAddr, @nSize)
        IF _hSocket != -1
            WSAAsyncSelect(_hSocket, this.hWnd, WM_SOCKET, 33)  && FD_READ or FD_CLOSE
        ENDIF
    ENDPROC

    PROCEDURE _OnRead
        LPARAMETERS _hSocket, szReadBuf
    ENDPROC

    * 接收到数据包
    PROCEDURE _RecvData
        LPARAMETERS _hSocket
        LOCAL szReadBuf, nDataLen
        szReadBuf = SPACE(32768)    && 32 * 1024
        nDataLen = recv(_hSocket, @szReadBuf, LEN(szReadBuf), 0)
        IF nDataLen > 0
            szReadBuf = LEFT(szReadBuf, nDataLen)
            this._OnRead(_hSocket, szReadBuf)
        ENDIF
        closesocket(_hSocket)
    ENDPROC

    * 网络消息处理
    PROCEDURE _SocketMsg
        LPARAMETERS hWnd, Msg, wParam, lParam
        DO CASE
        CASE lParam == 0x0008                && FD_ACCEPT      接收将要连接的通知
            this._AddClient(wParam)
        CASE lParam == 0x0001                && FD_READ        接收读准备好的通知   
            this._RecvData(wParam)
        CASE lParam == 0x0020                && FD_CLOSE       接收套接口关闭的通知
            closesocket(wParam)
        OTHERWISE
        ENDCASE
    ENDPROC
ENDDEFINE

DEFINE CLASS SocketHttp AS Session
    PROCEDURE _SendLogin
        LPARAMETERS _hSocket
        LOCAL szHead, szHtml
        szHtml = [<html><body><form name="Login" action="" method="get">] + 0h0D0A +;
                 [用户名<input class="input" type="text" name="Username" value="张三" size="20" />] + 0h0D0A +;
                 [密码<input class="input" type="password" name="Password" value="123" size="20" />] + 0h0D0A +;
                 [<input class="btn" type="submit" name="Submit" value="登录" style="width:80px" />] + 0h0D0A +;
                 [</form></body></html>]

        szHead = [HTTP/1.1 200 OK] + 0h0D0A +;
                 [Content-Type: text/html] + 0h0D0A +;
                 [Content-Length: ] + TRANSFORM(LEN(szHtml)) + 0h0D0A0D0A
                 
        this._SendData(_hSocket, szHead)
        this._SendData(_hSocket, szHtml)
    ENDPROC

    PROCEDURE _SendBrowse
        LPARAMETERS _hSocket
        LOCAL szHead, szHtml
        szHtml = [<html><body>] + 0h0D0A +;
                 [<table border="1">] + 0h0D0A +;
                 [<tr><td>编号</td><td>用户名</td><td>密码</td></tr>] + 0h0D0A
        select TEMP
        SCAN
            szHtml = szHtml +;  
                     [<tr><td>] + RTRIM(编号) + [</td><td>] + RTRIM(用户名) + [</td><td>] + RTRIM(密码) + [</td></tr>] + 0h0D0A
        ENDSCAN
        szHtml = szHtml + [</table></body></html>]
        
        szHead = [HTTP/1.1 200 OK] + 0h0D0A +;
                 [Content-Type: text/html] + 0h0D0A +;
                 [Content-Length: ] + TRANSFORM(LEN(szHtml)) + 0h0D0A0D0A
                 
        this._SendData(_hSocket, szHead)
        this._SendData(_hSocket, szHtml)
    ENDPROC
   
    PROCEDURE _SendError
        LPARAMETERS _hSocket
        this._SendData(_hSocket,;
                       [HTTP/1.1 200 OK] +  + 0h0D0A +;
                       [Content-Type: text/html] + 0h0D0A0D0A +;
                       [<h1>404 登录失败</h1>] + 0h0D0A +;
                       [输入的用户名或密码有误])
    ENDPROC

    * 发送数据包
    PROCEDURE _SendData
        LPARAMETERS _hSocket, szDate
        IF send(_hSocket, @szDate, LEN(szDate), 0) == -1
            IF WSAGetLastError() == 10035    && WSAEWOULDBLOCK
                RETURN "网络繁忙，请稍候发送。"
            ELSE
                RETURN "发送失败"
            ENDIF
        ENDIF
        RETURN ""
    ENDPROC
ENDDEFINE


DEFINE CLASS HttpHead AS Session
    Method            = ""
    Url               = ""
    HttpVer           = ""
   
    Authorization     = ""
    Content_Encoding  = ""
    Content_Length    = ""
    Content_Type      = ""
    From              = ""
    If_Modified_Since = ""
    Referer           = ""
    User_Agent        = ""
    Host              = ""
    Auth_Password     = ""
    Auth_Username     = ""
    Auth_Type         = ""
   
    PostData          = ""

    PROCEDURE GetFields(szFields)
        LOCAL szField
        CREATE CURSOR OtherFields (Name C(30), Value C(254))
        ALINES(a_Fields, szFields)
        szField     = a_Fields[1]
        this.Method = LEFT(szField, AT(" ", szField)-1)
        szField     = STUFF(szField, 1, AT(" ", szField), "")
        this.Url    = LEFT(szField, AT(" HTTP/", szField)-1)
        IF EMPTY(this.Url)
            this.Url = "/"
        ELSE
            IF LEFT(this.Url, 1) != "/"
                this.Url = "/" + this.Url
            ENDIF
        ENDIF
        this.HttpVer = STUFF(szField, 1, AT(" HTTP/", szField)+5, "")
        FOR i = 2 TO ALEN(a_Fields)
            szField = a_Fields[i]
            IF EMPTY(szField)    && end of header is 0h0D0A0D0A
                EXIT
            ENDIF
            INSERT INTO OtherFields VALUES (LEFT(szField, AT(":", szField)-1),;
                                            LTRIM(STUFF(szField, 1, AT(":", szField), "")))
        ENDFOR
        this.Authorization     = this.GetOtherFields("Authorization")
        this.Content_Encoding  = this.GetOtherFields("Content-Encoding")
        this.Content_Length    = this.GetOtherFields("Content-Length")
        this.Content_Type      = this.GetOtherFields("Content-Type")
        this.From              = this.GetOtherFields("From")
        this.If_Modified_Since = this.GetOtherFields("If-Modified-Since")
        this.Referer           = this.GetOtherFields("Referer")
        this.User_Agent        = this.GetOtherFields("User-Agent")
        this.Host              = this.GetOtherFields("Host")
        this.Auth_Password     = this.Authorization
        this.Auth_Type         = LEFT(this.Auth_Password, AT(" ", this.Auth_Password)-1)
        this.Auth_Password     = STUFF(this.Auth_Password, 1, AT(" ", this.Auth_Password), "")
        this.Auth_Password     = STRCONV(this.Auth_Password, 14)    && base64 编码数据转换
        this.Auth_Username     = LEFT(this.Auth_Password, AT(":", this.Auth_Password)-1)
        this.Auth_Password     = STUFF(this.Auth_Password, 1, AT(":", this.Auth_Password), "")
        USE IN "OtherFields"
    ENDPROC

    FUNCTION GetOtherFields(szName)
        SELECT OtherFields
        LOCATE FOR ALLTRIM(Name) == szName
        RETURN ALLTRIM(Value)
    ENDFUNC
ENDDEFINE


*调试信息
FUNCTION _WriteFields(oHttpHead)
    RETURN "************" + 0h0D0A +;
           "Method.............." + oHttpHead.Method + 0h0D0A +;
           "Url................." + oHttpHead.Url + 0h0D0A +;
           "HttpVer............." + oHttpHead.HttpVer + 0h0D0A +;
           "Authorization......." + oHttpHead.Authorization + 0h0D0A +;
           "Content_Encoding...." + oHttpHead.Content_Encoding + 0h0D0A +;
           "Content_Length......" + oHttpHead.Content_Length + 0h0D0A +;
           "Content_Type........" + oHttpHead.Content_Type + 0h0D0A +;
           "From................" + oHttpHead.From + 0h0D0A +;
           "If_Modified_Since..." + oHttpHead.If_Modified_Since + 0h0D0A +;
           "Referer............." + oHttpHead.Referer + 0h0D0A +;
           "User_Agent.........." + oHttpHead.User_Agent + 0h0D0A +;
           "Host................" + oHttpHead.Host + 0h0D0A +;
           "Auth_Password......." + oHttpHead.Auth_Password + 0h0D0A +;
           "Auth_Username......." + oHttpHead.Auth_Username + 0h0D0A +;
           "Auth_Type..........." + oHttpHead.Auth_Type
ENDFUNC


FUNCTION _OnError(nErrNum, szErrMsg, szErrCode, szErrProgram, nErrLineNo)
    LOCAL szMsg, nRet
   
    szMsg = '错误信息: ' + szErrMsg           + 0h0D0D;
          + '错误编号: ' + TRANSFORM(nErrNum) + 0h0D0D;
          + '错误代码: ' + szErrCode          + 0h0D0D;
          + '出错程序: ' + szErrProgram       + 0h0D0D;
          + '出错行号: ' + TRANSFORM(nErrLineNo)

    nRet = MESSAGEBOX(szMsg, 2+48+512, "Error")

    DO CASE
    CASE nRet == 3            && 终止
        CANCEL
    CASE nRet == 4            && 重试
        RETRY
    ENDCASE
ENDFUNC