Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
HTTP_Server [3]
| Uploader: |  ThePuppetMaster |
| 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