请各位Vfp版主合力写个HttpServer,带领大伙向BS进军
目前已知Vfp可用的HttpServer端有: HttpFll[孤独王] FWS[木瓜] VfpWeb[abiao] FoxWeb [老外]通过这么久的观察,相信版主完全有能力写一个更好更完善的服务端,顶起来!
[此贴子已经被作者于2023-5-12 14:46编辑过]
_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