Buchempfehlung
Windows System Programming
Windows System Programming
Das Kompendium liefert viele interessante Informationen zur Windows-Programmierung auf Englisch. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

HTTP_Server [3]

Uploader:MitgliedThePuppetMaster
Datum/Zeit:23.11.2007 18:07:34

'======================================================================
'(c) 2007 By.: /_\ DeltaLab's - Deutschland
'Autor: Martin Wiemann
'======================================================================


Declare Function HTTP_Get_Code_Desc(V_Code As Long) As String
Declare Function HTTP_Header_Create(V_HTTPCode as Long, V_Data As String, V_DataLen as Long = -1, V_MIME as String = "text/text") as String
Declare Sub HTTP_Header_Read(ByRef V_CID as Long)
Declare Sub HTTP_SendErrorClose(ByRef V_CID as Integer, ByVal V_Code as Long)
Declare Function MIME_Get_Type_Desc(V_FileType As String) As String
Declare Function Replace(ByVal V_Data As String, ByVal V_Expression As String, ByVal V_ReplaceBy As String) As String


Function HTTP_Header_Create(V_HTTPCode as Long, V_Data As String, V_DataLen as Long = -1, V_MIME as String = "text/text") as String
Dim T as String
Dim FBCRLF as String
FBCRLF = Chr(13) & Chr(10)
T = T & "HTTP/1.1 "  & Str(V_HTTPCode) & " " & HTTP_Get_Code_Desc(V_HTTPCode) & FBCRLF
T = T & "Server: CIC4U_FileServer [HTTP]" & FBCRLF
T = T & "Accept-Ranges: bytes" & FBCRLF
T = T & "Content-Type: " & V_MIME & FBCRLF
If V_DataLen > -1 then
    T = T & "Content-Length: " & str(V_DataLen) & FBCRLF
Else:T = T & "Content-Length: " & str(Len(V_Data)) & FBCRLF
End if
T = T & "Connection: close" & FBCRLF
T = T & FBCRLF
T = T & V_Data
Return T
End Function


Sub HTTP_Header_Read(ByRef V_CID as Long)
Dim XPos as Long
Dim T as string
Dim X as Long
If X_ClientD(V_CID).T_HTTP.V_Head = "" then
    XPos = instr(1, X_ClientD(V_CID).T_Data, Chr(13) & Chr(10) & Chr(13) & Chr(10))
    If XPos > 0 then
        X_ClientD(V_CID).T_HTTP.V_Head = Mid(X_ClientD(V_CID).T_Data,1, xpos + 1)
        X_ClientD(V_CID).T_HTTP.V_Data = Mid(X_ClientD(V_CID).T_Data, xpos + 4)
        X_ClientD(V_CID).T_Data = ""
        For X = 1 to Len(X_ClientD(V_CID).T_HTTP.V_Head)
            XPos = Instr(1, X_ClientD(V_CID).T_HTTP.V_Head, Chr(13) & chr(10))
            If XPos > 0 then
                T = Mid(X_ClientD(V_CID).T_HTTP.V_Head,1,xPos-1)
                X_ClientD(V_CID).T_HTTP.V_Head = Mid(X_ClientD(V_CID).T_HTTP.V_Head,xpos + 2)
                if X > 1 then
                    XPos = InStr(1, T, ": ")
                    If XPos > 0 then
                        X_ClientD(V_CID).T_HTTP.V_ParamC = X_ClientD(V_CID).T_HTTP.V_ParamC + 1
                        X_ClientD(V_CID).T_HTTP.V_ParamD(X_ClientD(V_CID).T_HTTP.V_ParamC).V_Name = lcase(Mid(T, 1, xPos - 1))
                        X_ClientD(V_CID).T_HTTP.V_ParamD(X_ClientD(V_CID).T_HTTP.V_ParamC).V_Value = Mid(T, xPos + 2)
                    End If
                Else: X_ClientD(V_CID).T_HTTP.V_Request = T
                End If
            Else: Exit For
            End If
        Next
        If X_ClientD(V_CID).T_HTTP.V_Request <> "" then
            T = X_ClientD(V_CID).T_HTTP.V_Request
            XPos = InStr(1, T, " ")
            If XPos > 0 then
                X_ClientD(V_CID).T_HTTP.V_Type = lcase(Mid(T, 1, xPos - 1))
                T = Mid(T, xPos + 1)
                If Len(T) > 9 then
                    X_ClientD(V_CID).T_HTTP.V_HTTPVer = UCase(Mid(T, Len(T) - 7))
                    X_ClientD(V_CID).T_HTTP.V_Request = Mid(T, 1, Len(T) - 9)
                else: HTTP_SendErrorClose V_CID, 400: Exit Sub
                endif
            else: HTTP_SendErrorClose V_CID, 400: Exit Sub
            endif
        else: HTTP_SendErrorClose V_CID, 400: Exit Sub
        end If
        If Left(X_ClientD(V_CID).T_HTTP.V_HTTPVer, 5) <> "HTTP/" Then HTTP_SendErrorClose V_CID, 505: Exit Sub
        If Val(Mid(X_ClientD(V_CID).T_HTTP.V_HTTPVer, 6)) < 1 Then HTTP_SendErrorClose V_CID, 505: Exit Sub
        For X = 1 to X_ClientD(V_CID).T_HTTP.V_ParamC
            T = X_ClientD(V_CID).T_HTTP.V_ParamD(X).V_Value
            Select Case X_ClientD(V_CID).T_HTTP.V_ParamD(X).V_Name
                case "content-length"
                    XPos = instr(1, T, " ")
                    If XPos > 0 then
                        X_ClientD(V_CID).T_HTTP.V_DataLen = Val(Mid(T, 1, XPos - 1))
                    Else: X_ClientD(V_CID).T_HTTP.V_DataLen = Val(T)
                    End if
            end Select
        Next
        T = X_ClientD(V_CID).T_HTTP.V_Request
        XPos = InStr(1, T, "?")
        If XPos > 0 then
            X_ClientD(V_CID).T_HTTP.V_RequestParam = mid(T, XPos)
            T = mid(t, 1, xpos - 1)
        End If
        For X = 1 to Len(T)
            If Mid(T, X, 1) = "\"  then Mid (T, X, 1) = "/"
            If Mid(T, X, 1) = "~"  then Mid (T, X, 1) = "_"
            If Mid(T, X, 1) = "*"  then Mid (T, X, 1) = "_"
            If Mid(T, X, 1) = "|"  then Mid (T, X, 1) = "_"
        Next
        For X = 1 to Len(T) - 1
            If (Mid(T, X, 1) = ".") and (Mid(T, X + 1, 1) = ".")  then T = Left(T, X) & Mid(T, X + 1)
        Next
        For X = 1 to Len(T) - 2
            If (Mid(T, X, 1) = "/") and (Mid(T, X + 1, 1) = ".") and (Mid(T, X + 2, 1) = "/")  then T = Left(T, X) & Mid(T, X + 1)
        Next
        For X = 1 to Len(T) - 1
            If (Mid(T, X, 1) = "/") and (Mid(T, X + 2, 1) = "/")  then T = Left(T, X) & Mid(T, X + 1)
        Next
        X_ClientD(V_CID).T_HTTP.V_Request = T
        T = ExePath & "/MIME_PUSH/"
        If Dir(T, fbdirectory) = "" then MKDir T
        XMIMEPushID += 1
        X_ClientD(V_CID).T_HTTP.V_PushPathIn = T  & str(XMIMEPushID) & ".MIMEIN"
        X_ClientD(V_CID).T_HTTP.V_PushPathOut = T  & str(XMIMEPushID) & ".MIMEOUT"
        If (X_ClientD(V_CID).T_HTTP.V_DataLen > 0) or (len(X_ClientD(V_CID).T_HTTP.V_RequestParam) > 0) then
            X_ClientD(V_CID).T_HTTP.V_PushFN = FreeFile
            Open X_ClientD(V_CID).T_HTTP.V_PushPathIn for Binary as X_ClientD(V_CID).T_HTTP.V_PushFN
            If X_ClientD(V_CID).T_HTTP.V_DataLen > 0 Then
                X_ClientD(V_CID).V_FIO.V_State = 0
                PUT #X_ClientD(V_CID).T_HTTP.V_PushFN, LOF(X_ClientD(V_CID).T_HTTP.V_PushFN), X_ClientD(V_CID).T_HTTP.V_Data
            Else
                X_ClientD(V_CID).T_HTTP.V_RequestSucc = 1
                PUT #X_ClientD(V_CID).T_HTTP.V_PushFN, LOF(X_ClientD(V_CID).T_HTTP.V_PushFN), X_ClientD(V_CID).T_HTTP.V_RequestParam
            End If
            X_ClientD(V_CID).T_HTTP.V_Data = ""
        Else: X_ClientD(V_CID).T_HTTP.V_RequestSucc = 1
        End If
    End If
End If
If X_ClientD(V_CID).T_HTTP.V_Head <> "" then
    PUT #X_ClientD(V_CID).T_HTTP.V_PushFN, LOF(X_ClientD(V_CID).T_HTTP.V_PushFN), X_ClientD(V_CID).T_Data
    If X_ClientD(V_CID).T_HTTP.V_DataLen >= LOF(X_ClientD(V_CID).T_HTTP.V_PushFN) Then
        Close #X_ClientD(V_CID).T_HTTP.V_PushFN
        X_ClientD(V_CID).T_HTTP.V_PushFN = 0
        X_ClientD(V_CID).T_HTTP.V_RequestSucc = 1
        X_ClientD(V_CID).V_FIO.V_State = 1
    End If
End If
If X_ClientD(V_CID).T_HTTP.V_RequestSucc = 1 then
    If X_ClientD(V_CID).T_HTTP.V_PushFN <> 0 then
        Close X_ClientD(V_CID).T_HTTP.V_PushFN
        X_ClientD(V_CID).T_HTTP.V_PushFN = 0
    End If
    Dim XOK as uByte
    XOK = 0
    T = G_Server_WWWBasePath & X_ClientD(V_CID).T_HTTP.V_Request
    If Right(X_ClientD(V_CID).T_HTTP.V_Request, 1) = "/" then
        For X = 1 to G_RootFileRankC
            If dir(T & X_ClientD(V_CID).T_HTTP.V_Request & G_RootFileRankD(x), XAttrFiles) <> "" then
                X_ClientD(V_CID).T_HTTP.V_Request += G_RootFileRankD(x)
                XOK = X: exit for
            end if
        Next
        If XOK = 0 then If G_Server_DirList = 0 then X_ClientD(V_CID).T_HTTP.V_Request += "index.html"
    End if
    T = G_Server_WWWBasePath & X_ClientD(V_CID).T_HTTP.V_Request
    If Right(X_ClientD(V_CID).T_HTTP.V_Request, 1) = "/" then
        If G_Server_DirList <> 0 then
            If Dir(Left(T, Len(t) -1), fbdirectory) = "" then HTTP_SendErrorClose V_CID, 404: Exit sub
        else: HTTP_SendErrorClose V_CID, 403: Exit sub
        End If
    else: If Dir(T, XAttrFiles) = "" then HTTP_SendErrorClose V_CID, 404: Exit sub
    end if
    XOK = 0
    T = X_ClientD(V_CID).T_HTTP.V_Request
    For X = len(T) to 1 step -1
        if mid(T,X,1) = "/" then
            T = mid(T,X)
            X_ClientD(V_CID).T_HTTP.V_RequestFilename = T
            exit for
        end if
    Next
    For X = len(T) to 1 step -1
        if mid(T,X,1) = "." then
            X_ClientD(V_CID).T_HTTP.V_RequestFileType = lcase(mid(T, X + 1))
            exit for
        end if
    Next
    T = X_ClientD(V_CID).T_HTTP.V_RequestFileType
    X_ClientD(V_CID).V_FIO.V_Path = G_Server_WWWBasePath & X_ClientD(V_CID).T_HTTP.V_Request
    If T <> "" then
        For X = 1 to G_MIME_InterpreterC
            With G_MIME_InterpreterD(X)
                If .V_MIME_Code = T then
                    If .V_Exec = 1 Then
                        T = .V_Param
                        T = Replace(T, "$type", X_ClientD(V_CID).T_HTTP.V_Type)
                        T = Replace(T, "$request", X_ClientD(V_CID).T_HTTP.V_Request)
                        T = Replace(T, "$ipa", X_ClientD(V_CID).V_IPA)
                        T = Replace(T, "$port", Str(G_Server_Port))
                        T = Replace(T, "$rootpath", G_Server_WWWBasePath)
                        T = Replace(T, "$inpath", G_Server_WWWBasePath & X_ClientD(V_CID).T_HTTP.V_Request)
                        T = Replace(T, "$outpath", X_ClientD(V_CID).T_HTTP.V_PushPathOut)
                        T = Replace(T, "$headerpath", X_ClientD(V_CID).T_HTTP.V_PushPathOut & "_h")
                        T = Replace(T, "$serverinfo", "")
                        sleep 1
                        run .V_Param
                        sleep 1
                        X_ClientD(V_CID).V_FIO.V_Path = X_ClientD(V_CID).T_HTTP.V_PushPathOut
                    End If
                    Exit For
                End If
            End With
        Next
    End If
    Select Case X_ClientD(V_CID).T_HTTP.V_Type
        case "get", "put", "post"
            XOK = 1
            X_ClientD(V_CID).V_FIO.V_HeadOnly = 0
        case "head"
            XOK = 1
            X_ClientD(V_CID).V_FIO.V_HeadOnly = 1
        case "delete"
        case "trace"
        case "connect"
        case "options"
        case "patch"
        case "link"
        case "unlink"
    End Select
    If XOK = 0 then
        XPrint "[-!-] [" & X_ClientD(V_CID).T_HTTP.V_Type & "] " & X_ClientD(V_CID).T_HTTP.V_Request
        HTTP_SendErrorClose V_CID, 405: Exit Sub
    Else: X_ClientD(V_CID).V_FIO.V_State = 1
    End if
End if
End Sub


Sub HTTP_SendErrorClose(ByRef V_CID as Integer, ByVal V_Code as Long)
XPrint "[" & format(now, "yyyymmdd-hh:mmss") & "][" & MKLen(X_ClientD(V_CID).V_IPA, 15, 1) & "][" & MKLen(X_ClientD(V_CID).T_HTTP.V_Type,4,1) & "][" & str(V_Code) &"] " & X_ClientD(V_CID).T_HTTP.V_Request
Dim TSock as Socket
TSock = X_ClientD(V_CID).V_Socket
TSN_Data_Send TSock, HTTP_Header_Create(V_Code, HTML_HTTPCode_CreatePage(V_Code, HTTP_Get_Code_Desc(V_Code)), , "text/html")
TSN_Close TSock
X_ClientD(V_CID).V_Socket = TSock
End Sub


Function MIME_Get_Type_Desc(V_FileType As String) As String
Select Case lcase(V_FileType)

    case "html", "htm" ', "pws", "php", "php2", "php3"
        return "text/html"

    case "txt"
        return "text/text"

    case "css"
        return "text/css"



    case "tar", "zip"
        return "application/" & lcase(v_fileType)

    case "gtar"
        return "application/x-" & lcase(v_fileType)

    case "gz"
        return "application/gzip"

    case "doc"
        return "application/msword"

    case "bin", "exe", "com", "dll"
        return "application/octet-stream"

    case "swf"
        return "application/x-shockwave-flash"



    case "mid", "midi"
        return "audio/x-midi"

    case "mp2"
        return "audio/x-mpeg"

    case "mp3", "wav", "ogg"
        return "audio/x-" & lcase(v_fileType)



    case "jpg", "jpeg", "jpe"
        return "image/jpeg"

    case "bmp", "gif", "png"
        return "image/" & lcase(v_fileType)



    case "avi"
        return "video/x-msvideo"

    case "qt", "mov"
        return "image/quicktime"



    case else: Return "*/" & lcase(V_FileType)

end Select
End Function


Function HTTP_Get_Code_Desc(V_Code As Long) As String
Select Case V_Code
    Case 100: Return "Continue"
    Case 101: Return "Switching Protocols"

    Case 200: Return "OK"
    Case 201: Return "Created"
    Case 202: Return "Accepted"
    Case 203: Return "Non Authoritative Information"
    Case 204: Return "No Contend"
    Case 205: Return "Reset Contend"
    Case 206: Return "Partial Content"

    Case 300: Return "Multiple Choise"
    Case 301: Return "Moved Permanently"
    Case 302: Return "Found"
    Case 303: Return "See Other"
    Case 304: Return "Not Modified"
    Case 305: Return "Use Proxy"
    Case 307: Return "Temporary Redirect"

    Case 400: Return "Bad Request"
    Case 401: Return "Unauthorized"
    Case 402: Return "Payment Required"
    Case 403: Return "Forbidden"
    Case 404: Return "Not Found"
    Case 405: Return "Method Not Allowed"
    Case 406: Return "Not Acceptable"
    Case 407: Return "Proxy Authentcation Required"
    Case 408: Return "Request Time-out"
    Case 409: Return "Conflict"
    Case 410: Return "Gone"
    Case 411: Return "Length Required"
    Case 412: Return "Precondition Faild"
    Case 413: Return "Request Entry Too Large"
    Case 414: Return "Request URI Too Large"
    Case 415: Return "Unsupportet Media Type"
    Case 416: Return "Requested range not satisfiable"
    Case 417: Return "Exeption Faild"
    Case 490: Return "IP Banned"
    Case 491: Return "Hacking Attack Blocked"

    Case 500: Return "Internal Server Error"
    Case 501: Return "Not Implemented"
    Case 502: Return "Bad Gateway"
    Case 503: Return "Service Unavailable"
    Case 504: Return "Gateway Time-out"
    Case 505: Return "HTTP Version not supported"
    Case Else: Return "Internal Server Error"
End Select
End Function



'-----------------------------------------------------------------------------------------------------
Function Replace(ByVal V_Data As String, ByVal V_Expression As String, ByVal V_ReplaceBy As String) As String
Dim X As Long
Dim SL As Long
Dim D as String
D = V_Data
SL = Len(V_Expression)
X = 0
Do
    X = X + 1
    If X > Len(D) - SL + 1 Then Exit Do
    If Mid(D, X, SL) = V_Expression Then
        D = Mid(D, 1, X - 1) & V_ReplaceBy & Mid(D, X + SL)
        X = X - (SL  - 1)
        If X < 0 then X = 0
    End If
Loop
Return D
End Function