HTTP Server Protocoll Get-Responder

Category:

Network/Internet

Type:

Snippets

Difficulty:

Intermediate

Author:

Anonymous

Version Compatibility: Visual Basic 6

More information:

This CodeSnipped is Part of A HTTP 1/1 Responding module. It answers on GET commands of Client Requests. You Need A winsock control (eg. wSox) And paste this as DataArrival Private Sub wSox_DataArrival(ByVal bytesTotal As Long) Dim strRequest As String 'Get Clients Http Header wSox.GetData strRequest 'Process HTTPRespond strRequest = WriteHTTPRespond(strRequest) 'Send Respond wSoxSendData strRequest End Sub Then make a new module as containing the following code:

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Const Rootpath = "\WWW"

Function WriteHTTPRespond(ByVal RequestString As String) As String
Dim RequestType
    'Find out what sort of request
    RequestType = Left(RequestString, InStr(1, RequestString, Space(1)) - 1)
Dim RequestFile
    'Find out what file requested
    RequestFile = Mid(RequestString, InStr(1, RequestString, Space(1)) + 1, InStr(InStr(1, RequestString, Space(1)), RequestString, Space(1)) + InStr(1, RequestString, " HTTP") - 9)
    If RequestFile = "/" Or RequestFile = "" Then RequestFile = "/index.htm"

Dim RequestByte
    'Find out about the requested byte-range
    If InStr(1, RequestString, vbCrLf & "Range: bytes=") <> 0 Then RequestByte = Mid(RequestString, InStr(1, RequestString, vbCrLf & "Range: bytes="), InStr(InStr(1, RequestString, vbCrLf & "Range: ") + 1, RequestString, vbCrLf) - InStr(1, RequestString, vbCrLf & "Range: "))
Select Case RequestType

Case Is = "GET"
       'Check If the file exists on the Server
     
       Select Case FileExists(App.Path & Rootpath & RequestFile)
      
              Case Is = False
                  WriteHTTPRespond = "HTTP/1.1 404 Not Found" & vbCrLf & vbCrLf
                  Exit Function
              Case Is = True
                  Dim FileContent
                      FileContent = ReadFile(App.Path & Rootpath & RequestFile)
                      'Check If only byte range wanted
                      Select Case InStr(1, RequestString, vbCrLf & "Range: ")
                             Case Is <> 0
                             'If only byte-range wanted
                                 'Get the right byte-range
                                 RequestByte = Split(RequestByte, "-")
                                 Dim ByteRange
                                     ByteRange = Mid(FileContent, RequestByte(0) + 1, RequestByte(1) + 1)
                                 
                                 WriteHTTPRespond = "HTTP/1.1 206 Partial Content" & vbCrLf & _
                                                   "Accept-Ranges: bytes" & vbCrLf & _
                                                   "Content-Length: " & Len(ByteRange) & vbCrLf & _
                                                   "Content-Range: bytes " & RequestByte(0) & "-" & RequestByte(1) & "/" & Len(FileContent) & vbCrLf & _
                                                   ByteRange
                                                   
                             Case Else
                             
                            'Decide if file needs to Be Send Chunked
                            'Actually in Minimum rules for HTTP 1/1
                            'But: Work neither with IE nor OPERA
                             
                            'Select Case Len(FileContent)
                            '       Case Is <= 1024 * 5
                                    WriteHTTPRespond = "HTTP/1.1 200 OK" & vbCrLf & _
                                                      "Content-Length: " & Len(FileContent) & vbCrLf & _
                                                      FileContent
                            '        Case Is > 1024 * 5
                            '        WriteHTTPRespond = "HTTP/1.1 200 OK" & vbCrLf & _
                            '                          "Accept-Ranges: bytes " & vbCrLf & _
                            'End Select
                      End Select
      
       End Select
End Select

End Function

Public Function FileExists(Path As String) As Boolean
  Const NotFile = vbDirectory Or vbVolume

On Error Resume Next
    FileExists = (GetAttr(Path) And NotFile) = 0
  On Error GoTo 0
End Function

Function ReadFile(ByRef Path As String) As String
  Dim FileNr As Long

If FileLen(Path) = 0 Then Exit Function
  On Error GoTo 0
  
  F = FreeFile
  
  Open Path For Binary As #F
    ReadFile = Space(LOF(F))
    Get #F, , ReadFile
  Close #F
End Function