m_http.bas

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

   
      a2 = InStr(a1 + 1, cheader$, vbCrLf)
   
      host$ = Mid$(cheader$, a1, a2 - a1)
   
  ' Debug.Print "REKKY:" & request$
   
   ' GET AUTHORIZATION DATA
      If InStr(cheader$, "Authorization: Basic ") Then
         a1 = InStr(cheader$, "Authorization: Basic ") + Len("Authorization: Basic ")
         a2 = InStr(a1, cheader$, vbCrLf)
         auth_data$ = B64.Decode(Mid$(cheader, a1, a2 - a1))
         a1 = InStr(auth_data$, ":")
         auth_name$ = Left$(auth_data$, a1 - 1)
         auth_pword$ = Right$(auth_data$, Len(auth_data$) - a1)
      End If
   
   ' *** Replace virtual directory entries with actual server directory entries
   
   Errloc$ = "PROCESS": VDIR = 0: REQTYPE = 0: request$ = Trim$(request$)

      request$ = RidFormatting(request$)
         
      
         
         
         For t = 0 To 60
            old_request$ = request$
            If vdirz(t).acti = "YES" Then request$ = Trim$(ReplaceStr(" " & request$, " " & vdirz(t).virt, vdirz(t).real))
            If old_request$ <> request$ Then VDIR = 1: Exit For
         Next t
   
      request$ = Trim$(ReplBack(request$))
   
      If VDIR = 0 Then request$ = GetWWWRoot(host$) & request$

         If request$ = "\" Then request$ = GetWWWRoot(host$)
   
    '  Debug.Print "request=" & request$
               
               If IsDir(request$) = 1 Then REQTYPE = 1
               If Exists(request$) = 1 Then REQTYPE = 2
   
         If REQTYPE = 1 And Right$(request$, 1) <> "\" Then
            'WXB sck, "<META HTTP-EQUIV=" & Chr$(34) & "Refresh" & Chr$(34) & " CONTENT=" & Chr$(34) & "0; URL=" & "http://" & host$ & ":" & Trim$(Str$(Longbow.ListenPort)) & uprequest$ & "/" & Chr$(34) & ">"
            WriteHTTP sck, 302, host$ & uprequest$ & "/"
            sx(sck).Reqok = True
               Exit Sub
         End If
      
      If REQTYPE = 0 Then
         WriteHTTP sck, 404, "_"
         sx(sck).Reqok = True
         Exit Sub
      End If
   
      If REQTYPE = 1 Then req_dir$ = request$
      
      If REQTYPE = 2 Then req_dir$ = GetDirectory(request$): req_file$ = GetFilename(request$)

      If Exists(req_dir$ & Longbow.SecurityFile) = 0 Then
         WriteHTTP sck, 403, "_"
         sx(sck).Reqok = True
         Exit Sub
      End If
      
      ' Get The Security Settings
         
            DIR_READ = 1
            DIR_WRITE = 1
            DIR_EXECUTE = 1
            DIR_SECURITY = 1
            DIR_VIEW = 1
            DIR_USERS$ = ""
         
         
         dx = FreeFile
         Open req_dir$ & Longbow.SecurityFile For Input As #dx
         Do Until EOF(dx)
            Line Input #dx, f$
            f$ = LCase$(f$)
            Select Case f$
               Case "read=no"
                  DIR_READ = 0
               Case "write=no"
                  DIR_WRITE = 0
               Case "dirview=no"
                  DIR_VIEW = 0
               Case "execute=no"
                  DIR_EXECUTE = 0
               Case "secure=no"
                  DIR_SECURITY = 0
            End Select
            If Left$(f$, 6) = "domain" Then DIR_DOMAIN$ = Right$(f$, Len(f$) - 7)
            If Left$(f$, 5) = "users" Then DIR_USERS$ = Right$(f$, Len(f$) - 6)
         Loop
         Close dx
         
         If DIR_SECURITY = 1 Then
         
            If auth_name$ = "" Or auth_pword$ = "" Then
               WriteHTTP sck, 401, DIR_DOMAIN$
               sx(sck).Reqok = True
               Exit Sub
            End If
            
            CAN_ACCESS = ValidateUser(auth_name$, auth_pword$, DIR_USERS$)
         
            If CAN_ACCESS = 0 Then
               WriteHTTP sck, 403, "-"
               sx(sck).Reqok = True
               Exit Sub
            End If
            
         End If
         
         If LCase$(req_file$) = LCase$(Longbow.SecurityFile) Then
            WLog "Security File Attempted Access " & frmmain.ws(sck).RemoteHostIP, 1
            AppendIPBan sck
            WriteHTTP sck, 403, "-"
            sx(sck).Reqok = True
            Exit Sub
         End If
            

         
         If REQTYPE = 1 And Exists(req_dir$ & Longbow.IndexFile) = 1 Then
            req_file$ = Longbow.IndexFile
            REQTYPE = 2
         End If
         
         If REQTYPE = 1 And DIR_READ = 0 Then
            If Exists(req_dir$ & Longbow.IndexFile) = 1 And DIR_READ = 1 Then
               req_file$ = Longbow.IndexFile
               REQTYPE = 2
            Else
               WriteHTTP sck, 403, "-"
               sx(sck).Reqok = True
               Exit Sub
            End If
         End If
         
         If REQTYPE = 2 And DIR_READ = 0 Then
            WriteHTTP sck, 403, "-"
            sx(sck).Reqok = True
            Exit Sub
         End If

         ADDIT$ = username$
         If ADDIT$ = "" Then ADDIT$ = "NoAuth"

         WLog frmmain.ws(sck).RemoteHostIP & "," & req_dir$ & req_file$, 2

         Select Case REQTYPE
            Case 1
' DIR_BACKCOLOR$, DIR_HEADCOLOR$, DIR_LISTCOLOR$, DIR_BARCOLOR$, DIR_LISTFACE$, DIR_HEADFACE$
            If DIR_VIEW = 0 Then
                WriteHTTP sck, 403, "-"
                sx(sck).Reqok = True
                Exit Sub
            End If
            
            WXB sck, "<!-- AUTO GENERATED DIRECTORY LISTING -->" & vbCrLf
            WXB sck, "<!-- BROWSED BY " & ADDIT$ & " -->" & vbCrLf
            WXB sck, "<html><body bgcolor=" & DIR_BACKCOLOR$ & ">" & vbCrLf
            WXB sck, "<font face=" & Chr$(34) & DIR_HEADFACE$ & Chr$(34) & " color=" & DIR_HEADCOLOR$ & ">" & vbCrLf
            WXB sck, "<h1 align=center>Directory Listing For " & uprequest$ & "</h1></font>" & vbCrLf
            WXB sck, "<hr noshade color=" & DIR_BARCOLOR$ & ">" & vbCrLf
            WXB sck, "<font face=" & DIR_LISTFACE$ & " color=" & DIR_LISTCOLOR$ & ">" & vbCrLf
            
            fsu.di(sck).Path = req_dir$
            fsu.fi(sck).Path = req_dir$
            
            HREF$ = "http://" & host$ '& ":"  & Trim$(Str$(Longbow.ListenPort))
            
               
               If uprequest$ = "/" Then
                  For t = 0 To 60
                     If vdirz(t).virt <> "" Then
                        If Longbow.DirListing = 2 Then WXB sck, "<IMG SRC=" & Chr$(34) & HREF$ & "/docs/FILE_DIRECTORY.GIF" & Chr$(34) & ">"
                        WXB sck, "<A HREF=" & Chr$(34) & HREF$ & vdirz(t).virt & "/" & Chr$(34) & ">" & vdirz(t).virt & "</a><br>" & vbCrLf
                     End If
                  Next t
               Else
                  If Longbow.DirListing = 2 Then WXB sck, "<IMG SRC=" & Chr$(34) & HREF$ & "/docs/FILE_DIRECTORY.GIF" & Chr$(34) & ">"
                  WXB sck, "<A HREF=" & Chr$(34) & ".." & Chr$(34) & ">..</a><br>"
               End If
               
               For t = 0 To fsu.di(sck).ListCount - 1
                  d$ = LCase$(GetFilename(fsu.di(sck).List(t)))
                  If Longbow.DirListing = 2 Then WXB sck, "<IMG SRC=" & Chr$(34) & HREF$ & "/docs/FILE_DIRECTORY.GIF" & Chr$(34) & ">"
                  WXB sck, "<A HREF=" & Chr$(34) & HREF$ & uprequest$ & d$ & "/" & Chr$(34) & ">/" & d$ & "</a><br>" & vbCrLf
               Next t
               
               For t = 0 To fsu.fi(sck).ListCount - 1
                  
                  d$ = fsu.fi(sck).List(t)
                  If LCase$(d$) = LCase$(Longbow.SecurityFile) Then GoTo NOTHIS
                  x$ = GetMimeType(d$)
                  If x$ = "" Then x$ = "UNKNOWN"
                  If Longbow.DirListing = 2 Then WXB sck, "<IMG SRC=" & Chr$(34) & HREF$ & "/docs/FILE_" & x$ & ".GIF" & Chr$(34) & ">"
                  WXB sck, "<A HREF=" & Chr$(34) & HREF$ & uprequest$ & d$ & Chr$(34) & ">" & d$ & "</a><br>" & vbCrLf
NOTHIS:
                  
               Next t
               
               WXB sck, "</font></body></html>"
               sx(sck).Reqok = True
               Exit Sub
            Case 2
               e$ = GetMimeType(req_file$)
                  Select Case e$
                     Case "DENIED"
                            WriteHTTP sck, 403, "-"
                            sx(sck).Reqok = True
                            Exit Sub
                     Case "SCRIPT"
                        If DIR_EXECUTE = 0 Then
                            WriteHTTP sck, 403, "--"
                            sx(sck).Reqok = True
                            Exit Sub
                        End If
                        cx(sck).Execute sck, req_dir$ & req_file$, postdata$
                        sx(sck).Reqok = True
                        Exit Sub
                     Case "HTML"
                        Write_HTML sck, req_dir$ & req_file$, method$, host$
                        sx(sck).Reqok = True
                        Exit Sub
                     Case Else
                        'Debug.Print req_dir$ & req_file$
                        Write_BINARY sck, req_dir$ & req_file$
                        sx(sck).Reqok = True
                        Exit Sub
                  End Select
               WriteHTTP sck, 500, "-"
               sx(sck).Reqok = True
               Exit Sub
         End Select
    
    WXB sck, "Sorry. But i couldn't process this request, cu l8r!"
    sx(sck).Reqok = True
   
   Exit Sub
PROCESSERROR:
   WLog "Error Processing Request", 1
   Select Case Errloc
      Case "HEADER"
         WriteHTTP sck, 400, "-"
      Case Else
         WriteHTTP sck, 500, "_"
   End Select
   sx(sck).Reqok = True
End Sub