标题:请各位Vfp版主合力写个HttpServer,带领大伙向BS进军
只看楼主
tigerpub
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2023-4-20
结帖率:0
已结贴  问题点数:20 回复次数:13 
请各位Vfp版主合力写个HttpServer,带领大伙向BS进军
目前已知Vfp可用的HttpServer端有: HttpFll[孤独王] FWS[木瓜] VfpWeb[abiao] FoxWeb [老外]
通过这么久的观察,相信版主完全有能力写一个更好更完善的服务端,顶起来!


[此贴子已经被作者于2023-5-12 14:46编辑过]

搜索更多相关主题的帖子: 版主 VfpWeb 能力 Vfp 服务端 
2023-05-12 14:45
sam_jiang
Rank: 8Rank: 8
等 级:贵宾
威 望:10
帖 子:542
专家分:781
注 册:2021-10-13
得分:3 

好建议!
2023-05-12 14:50
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:432
帖 子:10064
专家分:41463
注 册:2014-5-20
得分:3 
HTTP协议是基于TCP/IP协议,VFP调用windows SOCKET的几个API函数就可以写出Web Server的网络通信部分。
但不建议用VFP写网络服务,因只用VFP做网络服务的能力很有限,只适宜较小规模的应用。
另,Web Server 涉及到web编程,要做得好还要掌握HTML、CSS、JS等。
2023-05-12 15:28
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:432
帖 子:10064
专家分:41463
注 册:2014-5-20
得分:0 
在抽屉里找到个不记得那年写的东东,记得当时在MZ发过。
非常简单的Demo,有兴趣的就看看。



程序代码:
_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

2023-05-12 15:33
tigerpub
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2023-4-20
得分:0 
OLDBB
2023-05-12 15:38
csyx
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:29
帖 子:484
专家分:1827
注 册:2018-3-13
得分:3 
想想为啥这些 vfp-web 技术都已经推出很多年了还是没得到普及应用,你就知道其学习和改造成本有多大!不是生成一个 Hello World 页面就完事了,至少,你的所有 UI 都必须重来,最基本的你必须熟练掌握 html,js 以及 Vue,jQuery,Node,React,。。。等等其中任意一种前端框架。而还在使用 vfp 的,基本都是非专业的,不是没精力没能力花大量时间去学习这些知识,就是 web 化的需求不足
2023-05-12 15:51
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:432
帖 子:10064
专家分:41463
注 册:2014-5-20
得分:0 
个人觉得,有时间用VFP搞这些东东,还不如学些新鲜的东西。
除非熟悉网络协议和WEB的编程,又对VFP情有独钟,那就恭喜。
2023-05-12 15:59
shizi0
Rank: 3Rank: 3
等 级:论坛游侠
威 望:3
帖 子:32
专家分:116
注 册:2012-10-2
得分:3 
vfp的特点、优势非常鲜明,退市这么多年也没有哪个能替代或弥补它的位置,这可能是它还存在的原因。
但毕竟是上世纪小家闺秀,硬要它跨越时代指点江山,怕是用才不当。
2023-05-12 16:18
独木星空
Rank: 16Rank: 16Rank: 16Rank: 16
来 自:河北省曲阳县
等 级:版主
威 望:57
帖 子:713
专家分:556
注 册:2016-6-29
得分:3 
回复 3楼 吹水佬
吹水佬版主涉猎广泛,好像在编程方面没有障碍可言。
我只对我用的着,去努力学一学,其他的只是走马观花而已。

素数问题的解决是我学习编程永恒的动力。
2023-05-12 16:22
kangss
Rank: 4
等 级:贵宾
威 望:10
帖 子:138
专家分:237
注 册:2014-6-12
得分:3 
回复 楼主 tigerpub
孤独王的 HttpServer.fll 是专门为 VFP 免费打造的较为专业好用的 HttpServer。并且有不少人在用。

这个帖子里面,我上传过 FLL 的详细使用说明和效果,压缩包里面也有源码:
https://bbs.bccn.net/viewthread.php?tid=509467&page=4
2023-05-12 18:57



参与讨论请移步原网站贴子:https://bbs.bccn.net/thread-512179-1-1.html




关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.065565 second(s), 8 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved