m_http.bas

完整的主机服务器, (含代码).程序会监视联结到主机程序上的所有机器.可是设置开启端口,最多用户..非常完整.!

Attribute VB_Name = "m_http"
Public DIR_BACKCOLOR$, DIR_HEADCOLOR$, DIR_LISTCOLOR$, DIR_BARCOLOR$, DIR_LISTFACE$, DIR_HEADFACE$


Public Sub LoadDirViewColorScheme()
   On Error GoTo DIRVIEWLOADDEFAULTS
   dx = FreeFile
   Open "..\conf\dircols.cfg" For Input As #dx
      Do Until EOF(dx)
         Input #dx, x$, y$
         x$ = LCase$(x$)
         Select Case x$
            Case "dir_backcolor"
               DIR_BACKCOLOR$ = y$
            Case "dir_headcolor"
               DIR_HEADCOLOR$ = y$
            Case "dir_listcolor"
               DIR_LISTCOLOR$ = y$
            Case "dir_barcolor"
               DIR_BARCOLOR$ = y$
            Case "dir_listface"
               DIR_LISTFACE$ = y$
            Case "dir_headface"
               DIR_HEADFACE$ = y$
         End Select
      Loop
   Close dx
   Exit Sub
DIRVIEWLOADDEFAULTS:
   DIR_BACKCOLOR$ = "white"
   DIR_HEADCOLOR$ = "navy"
   DIR_LISTCOLOR$ = "blue"
   DIR_BARCOLOR$ = "red"
   DIR_LISTFACE$ = "fixedsys"
   DIR_HEADFACE$ = "verdana"
   Close dx
   Exit Sub
End Sub



Public Sub WriteHTTP(sck As Integer, rettype As Integer, lparam As String)
   zz$ = vbCrLf & "Server: LongBow" & vbCrLf & "Server-Version: 1.1b" & vbCrLf & "Server-Programmer: Dale Reidy([e-mail])"
   
   WLog "HTTP_ERROR," & Trim$(Str$(rettype)) & "," & frmmain.ws(sck).RemoteHostIP, 1
   
   Select Case rettype
      Case 302
         d$ = "HTTP/1.0 302 File Moved" & zz$ & vbCrLf & "Location: http://" & lparam$ & vbCrLf & vbCrLf & vbCrLf
      Case 400
         d$ = "HTTP/1.0 400 Bad Request" & zz$ & vbCrLf & vbCrLf & vbCrLf
      Case 200
         d$ = "HTTP/1.0 200 OK" & zz$ & vbCrLf & vbCrLf & vbCrLf
      Case 204
         d$ = "HTTP/1.0 200 OK But Empty File" & zz$ & vbCrLf & vbCrLf & vbCrLf
      Case 401
         d$ = "HTTP/1.0 401 Unauthorized" & zz$ & vbCrLf & "WWW-Authenticate: Basic realm=" & Chr$(34) & lparam$ & Chr$(34) & vbCrLf & vbCrLf & vbCrLf
      Case 403
         d$ = "HTTP/1.0 403 Unauthorized" & zz$ & vbCrLf & vbCrLf & vbCrLf
      Case 404
         d$ = "HTTP/1.0 404 File Not Found" & zz$ & vbCrLf & vbCrLf & vbCrLf
      Case 500
         d$ = "HTTP/1.0 500 Internal Server Error" & zz$ & vbCrLf & vbCrLf & vbCrLf
   End Select
   'Debug.Print d$
   sx(sck).Buffer = d$ & sx(sck).Buffer
End Sub

Public Function GetWWWRoot(host_name As String) As String

   For t = 0 To 60
      If vhost(t).acti = "YES" And host_name$ = vhost(t).svr Then GetWWWRoot$ = vhost(t).root: Exit Function
   Next t
   GetWWWRoot = Longbow.DefaultRoot
      
End Function

Public Function ValidateUser(username As String, password As String, userlist As String) As Integer
   On Error GoTo BADBADERROR

    If InStr(userlist$, "any") Then
        ValidateUser = 1
        Exit Function
    End If
   
   For t = 0 To 2000
      If (username$ = users(t).username) And (password$ = users(t).password) And InStr(userlist$, users(t).username) > 0 And (users(t).Active = "yes") Then

         ValidateUser = 1
         Exit Function
      End If
      If t = 1000 Then DoEvents ': Debug.Print "HALFWAY"
   Next t
   ValidateUser = 0
   Exit Function:
BADBADERROR:
  ValidateUser = 0
  WLog "VALIDATE USER ERROR " & username$ & "," & userlist$, 1
End Function

Public Function GetFile(req As String) As String
   ' Get The File From A Path
   'c:\windows\desktop\hello.bmp
   On Error GoTo GETFILEERROR
   a = Len(req$)
   For b = a To 1 Step -1
    If Mid$(req$, b, 1) = "\" Then
      GetFile = Right$(req$, Len(req$) - b)
      Exit Function
    End If
   Next b
   GetFile = req$
   Exit Function
GETFILEERROR:
End Function

Public Sub Write_HTML(sck As Integer, freq As String, method As String, host As String)
   On Error GoTo WRITEHTMLERROR
   If Exists(freq) = 0 Then GoTo WRITEHTMLERROR
   dx = FreeFile
   Open freq For Binary As #dx
   d = LOF(dx)
   If d = 0 Then Close dx: WXB sck, "File Is Empty": sx(sck).Reqok = True: Exit Sub
   f$ = Space$(d)
   Get #dx, , f$
   Close dx
   f$ = ReplaceStr(f$, "<%METHOD%>", method$)
   f$ = ReplaceStr(f$, "<%HOST%>", host$)
   f$ = ReplaceStr(f$, "<%TIME%>", Time$)
   f$ = ReplaceStr(f$, "<%DATE%>", Date$)
   f$ = ReplaceStr(f$, "<%TIMER%>", Timer)
   f$ = ReplaceStr(f$, "<%SERVER%>", LONGBOW_SERVER_DETAILS)
   sx(sck).Buffer = f$
   Exit Sub
WRITEHTMLERROR:
   Close dx
   WriteHTTP sck, 500, "-"
End Sub

Public Sub Write_BINARY(sck As Integer, filename As String)
   On Error GoTo WRITEBINARYERROR

   If Exists(filename) = 0 Then GoTo WRITEBINARYERROR
   dx = FreeFile
   Open filename For Binary As #dx
   d = LOF(dx)
   If d = 0 Then Close dx: WXB sck, "File Is Empty": sx(sck).Reqok = True: Exit Sub
   f$ = Space$(d)
   Get #dx, , f$
   Close dx
   sx(sck).Buffer = f$
   Exit Sub
WRITEBINARYERROR:
   Close dx
   WriteHTTP sck, 500, "-"
End Sub

Public Sub Write_TEXT(sck As Integer, filename As String)
   On Error GoTo WRITETEXTERROR
   dx = FreeFile
   Open filename For Binary As #dx
   d = LOF(dx)
   If d = 0 Then Close dx: WXB sck, "File Is Empty": sx(sck).Reqok = True: Exit Sub
   f$ = Space$(d)
   Get #dx, , f$
   Close dx
   sx(sck).Buffer = f$
   Exit Sub
WRITETEXTERROR:
   Close dx
   WriteHTTP sck, 500, "-"
End Sub


Public Function GetMimeType(filename As String) As String
   For t = 0 To 200
      If InStr(filename, mimes(t).ext) Then GetMimeType = mimes(t).mtype: Exit Function
   Next t
End Function

Public Sub ProcessHeader(sck As Integer)
   'On Error GoTo PROCESSERROR
   Dim Errloc$
   
   ' Show message if the server is down for maintenance
   If SERVERDOWNMSG$ <> "" Then
    WXB sck, SERVERDOWNMSG$
    sx(sck).Reqok = True
    Exit Sub
   End If
   
   sx(sck).Buffer = ""
   
   NumReq = NumReq + 1
      
   ' *** GATHER ALL THE INFORMATION FROM THE HTTP HEADER ***
   Errloc$ = "HEADER"
   
   cheader$ = sx(sck).Header
   
   sx(sck).Referer = ""
   
   ' GET THE REFERRER
    If InStr(cheader$, "Referer: ") Then
        ax1 = InStr(cheader$, "Referer: ")
        ax1 = ax1 + Len("Referer :")
        ax2 = InStr(ax1 + 1, cheader$, vbCrLf)
    
        sx(sck).Referer = Mid$(cheader$, ax1, ax2 - ax1)
    End If
   
   
   ' GET THE HTTP METHOD FOR THE REQUEST
      a$ = Left$(cheader$, 3)
   
      If a$ = "POS" Then method$ = "post" Else method$ = "get"
   
      a1 = InStr(cheader$, " ")
      a2 = InStr(a1 + 1, cheader$, " ")
   
   ' GET THE REQUEST
      request$ = Mid$(cheader, a1 + 1, a2 - a1 - 1)
   
      uprequest$ = RidFormatting(request$)
   
   
   
   ' PROCESS DATA PASSED AS PARAMETERS TO THE PAGE
      If InStr(request$, "?") Then
         a1 = InStr(request$, "?")
         postdata$ = "&" & Right$(request$, Len(request$) - a1)
         request$ = Left$(request$, a1 - 1)
      End If
   
      a1 = InStr(cheader$, vbCrLf & vbCrLf)
   
      a1 = a1 + Len(vbCrLf & vbCrLf)

      a1 = a1 - 1
      
      If a1 < Len(cheader$) Then
         temp1$ = Trim$(Right$(cheader$, Len(cheader$) - a1))
         'temp1$ = Left$(temp1$, Len(temp1$) - 2)
      End If
   
      If temp1$ <> "" Then
         If postdata$ = "" Then
            postdata$ = postdata$ & temp1$
         Else
            postdata$ = postdata$ & "&" & temp1$
         End If
      End If
   
   
   ' GET THE HOST
      a1 = InStr(cheader$, "Host:") + Len("Host: ")