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 [1]

Uploader:MitgliedThePuppetMaster
Datum/Zeit:23.11.2007 18:03:38

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



Declare Function MkLen(ByRef V_Text as String, ByVal V_Len as Long, ByVal V_AlignRight as uByte) as String
Declare Sub TTYDraw()
Declare Sub XPrint(V_Text as String)
Declare Sub F_Log(ByVal V_Text as String, ByVal V_WhisNow as uByte = 0)
Declare Sub F_Header_Create_Thread(V_CID As Any Ptr)


#include "vbcompat.bi"
#include "dir.bi"
#include "tsn.bi"


Type MIME_type
    V_MIME_Code as String
    V_ExecType as String
    V_Param as String
    V_Exec as Long
End Type
Type HTTPCode_Side_type
    V_HTTPCode as Long
    V_SidePath as String
End Type
Type FIO_type
    V_State as Long
    V_Path as String
    V_FileID as integer
    V_AKPos as Long
    V_MaxLen as long
    V_HeadOnly as Long
    V_Rate as Long
    V_RateC as Long
    V_RateT as Double
    V_SData as String
End Type
Type HTTP_Param_type
    V_Name as String
    V_Value as String
End Type
Type HTTP_Type
    V_Head as String
    V_Data as String
    V_DataLen as Long
    V_Type as String
    V_Request as String
    V_RequestSucc as uByte
    V_RequestFilename as String
    V_RequestParam as String
    V_RequestFileType as String
    V_RequestMIMEID as Long
    V_HTTPVer as String
    V_ParamD(25) as HTTP_Param_type
    V_ParamC as Long
    V_PushPathIn as String
    V_PushPathOut as String
    V_PushFN as Integer
End Type
Type Client_Type
    V_Thread as Any Ptr
    V_Socket as Socket
    V_IPA as string
    T_Data as String
    V_TimeOut as Double
    T_HTTP as HTTP_Type
    V_FIO as FIO_type
End Type

Dim X_Server as Socket
Dim Shared X_ClientD() as Client_Type
Dim Shared T_ClientD as Client_Type
Dim Shared X_ClientC as Long
Dim Shared G_LogFN as Integer
Dim T_Client as Socket
Dim BV as Long
Dim X as Long
Dim Y as Long
Dim TIP as string
Dim TSock as Socket
Dim TThread as any ptr
Dim XDrawChangeT as Double
Dim TCID as Long
Dim TData as String
Dim D as String
Dim T as String
Dim Shared XCC as Long
Dim shared XLogDate as String
Dim Shared XMIMEPushID as Long
Dim Shared XAttrFiles as integer = fbnormal or fbhidden or fbreadonly or fbsystem or fbarchive


Dim Shared G_Server_Port as Integer
Dim Shared G_Server_MaxClients as Integer
Dim Shared G_Server_BlockSize as Long
Dim Shared G_Server_TimeOut as Double
Dim Shared G_Server_WWWBasePath as String
Dim Shared G_Server_LogPath as String
Dim Shared G_Server_LogName as String
Dim Shared G_MIME_InterpreterD() as MIME_type
Dim Shared G_MIME_InterpreterC as Long
Dim Shared G_HTTPCode_SidePath as String
Dim Shared G_Server_DirList as uByte
Dim Shared G_Server_DirListMIME as String
Dim Shared G_RootFileRankD() as String
Dim Shared G_RootFileRankC as Long


#include "HTML_Func.fbmod"
#include "HTTP_Func.fbmod"


Print "Lade Konfiguration..."
G_Server_Port = 1234 '81
G_Server_MaxClients = 10
G_Server_BlockSize = 1024
G_Server_TimeOut = 60
G_Server_WWWBasePath = ""
G_HTTPCode_SidePath = ""
G_Server_LogPath = ""
G_Server_LogName = ""
G_MIME_InterpreterC = 0
G_RootFileRankC = 0

Open "Conf.LC1" For Binary as #1
Do
    If EOF(1) = -1 then Exit do
    Line Input #1, TData
    XCC += 1
    If TData <> "" then
        If Left(TData, 1) <> "'" then
            Y = instr(1, TData,"=")
            If Y > 0 then
                TIP = Trim(Mid(TData, 1, Y - 1))
                TData = Trim(Mid(TData, Y + 1))
                if TData = "" then TIP = ""
                Select Case lcase(TIP)
                    case ""
                    case "server_port", "server_maxclients", "server_tx_blocksize", "server_trx_timeout"
                        If Val(TData) <> 0 then
                            If (CLng(TData) > 0) and (CLng(TData) <= 65535) Then
                                Select Case lcase(TIP)
                                    case "server_port": G_Server_Port = CLng(TData)
                                    case "server_maxclients": G_Server_MaxClients = CLng(TData)
                                    case "server_tx_blocksize": G_Server_BlockSize = CLng(TData)
                                    case "server_trx_timeout": G_Server_TimeOut = CLng(TData)
                                End Select
                            Else: Print "[LCI] "; lcase(TIP); " Wert muss gröser 0 und kleiner 65536 sein! [Nutze Standardeinstellung]"
                            End If
                        else: Print "[LCI] "; lcase(TIP); " Wert muss eine Zahl sein! [Nutze Standardeinstellung]"
                        Endif
                    case "server_path_www", "server_path_httperror"
                        If Dir(TData, fbdirectory) <> "" then
                            Select Case lcase(TIP)
                                case "server_path_www": G_Server_WWWBasePath = TData
                                case "server_path_httperror": G_HTTPCode_SidePath = TData
                            End Select
                        else: Print "[LCI] "; lcase(TIP); " Path wurde nicht gefunden / existiert nicht! [Nutze Standardeinstellung]"
                        Endif
                    case "server_path_log": G_Server_LogPath = exepath & "/" & TData
                    case "server_path_log_filename"
                        If Len(TData) < 30 then
                            for y = 1 to len(TData)
                                Select case asc(mid(TData,y,1))
                                    case asc("a") to asc("z")
                                    case asc("A") to asc("Z")
                                    case asc("0") to asc("9")
                                    case asc("_")
                                    case asc("-")
                                    case else: y = -1: exit for
                                end select
                            next
                            if y < 0 then
                                Print "[LCI] "; lcase(TIP); " Dateiname enthält ungültige Zeichen [Nutze Standardeinstellung]"
                            else: G_Server_LogName = TData
                            endif
                        else: Print "[LCI] "; lcase(TIP); " Dateiname zu lang! (max. 30 Zeichen) [Nutze Standardeinstellung]"
                        endif
                    case "server_dir_list": if val(TData) = 1 then G_Server_DirList = 1
                    case "server_dir_list_mime": G_Server_DirListMIME = TData
                    case "server_root_file"
                        G_RootFileRankC += 1
                        Redim Preserve G_RootFileRankD(G_RootFileRankC) as String
                        G_RootFileRankD(G_RootFileRankC) = TData
                    case "mime"
                        Y = InStr(1, TData, ",")
                        If Y > 0 Then
                            D = Trim(Mid(TData, 1, Y - 1))
                            TData = Trim(Mid(TData, Y + 1))
                            Y = InStr(1, TData, ":")
                            If Y > 0 Then
                                T = LCase(Trim(Mid(TData, 1, Y - 1)))
                                TData = Trim(Mid(TData, Y + 1))
                                G_MIME_InterpreterC += 1
                                Redim Preserve G_MIME_InterpreterD(G_MIME_InterpreterC) as MIME_type
                                With G_MIME_InterpreterD(G_MIME_InterpreterC)
                                    .V_MIME_Code = lcase(D)
                                    .V_ExecType = T
                                    .V_Param = TData
                                    Select Case T
                                        case "mime": .V_Exec = 0
                                        case "path": .V_Exec = 1
                                    End Select
                                End With
                            Else: Print "[LCI] "; lcase(TIP); " Syntaxfehler in MIME Konfiguration!"
                            End If
                        Else: Print "[LCI] "; lcase(TIP); " Syntaxfehler in MIME Konfiguration!"
                        End If
                    case else: Print "[LCI] "; lcase(TIP); " Ubekannter Parameter! [Nutze Standardeinstellung]"
                End Select
            Else: Print "[LC1] Konfigurationsfehler in Zeile: "; XCC
            End if
        End if
    End If
Loop
Close #1
X = 0
Y = 0
XCC = 0
if G_RootFileRankC = 0 then
    G_RootFileRankC += 1
    Redim Preserve G_RootFileRankD(G_RootFileRankC) as String
    G_RootFileRankD(G_RootFileRankC) = "index.html"
End If

F_Log String(50, "=")
F_Log "Öffne Log...", 1

XPrint ""
If G_Server_WWWBasePath = "" then XPrint "[FATALER FEHLER!] Es wurde kein User-Verzeichniss angegeben! Ohne Verzeichniss kann der Server keine Informationen zur verfügung stellen!"
XPrint ""

XPrint "Versuche Server zu inizialisieren..."
Do
    sleep 1000
    If InKey = Chr(27) then end
    BV = TSN_Create_Listen(X_Server, G_Server_Port)
    If BV >= 0 then
        XPrint "[OK] HTTP_Server arbeitet, und wartet auf Verbindungsanfragen!"
        exit do
    End If
Loop
sleep 1000

Dim THID as Any Ptr

Do
    If X_Server = 0 Then
        BV = TSN_Create_Listen(X_Server, G_Server_Port)
        If BV >= 0 then
            XPrint "[OK] HTTP_Server arbeitet, und wartet auf Verbindungsanfragen!"
            exit do
        End If
    End If
    BV = TSN_Event_Get(X_Server)
    Select Case BV
        Case 0
        Case 1
            TCID = 0
            For X = 1 To X_ClientC
                If X_ClientD(X).V_Socket <= 0 Then
                    TCID = X
                    Exit For
                End If
            Next
            If TCID = 0 Then
                If X_ClientC < G_Server_MaxClients then
                    X_ClientC += 1
                    TCID = X_ClientC
                    Redim Preserve X_ClientD(X_ClientC) as Client_Type
                End If
            End If
            BV = TSN_Create_Accept(X_Server, T_Client)
            If BV = 0 then
                If TCID > 0 then
                    X_ClientD(TCID) = T_ClientD
                    X_ClientD(TCID).V_Socket = T_Client
                    BV = TSN_IPAddress_Get(T_Client, TIP)
                    If BV = 0 then X_ClientD(TCID).V_IPA = TIP
                    X_ClientD(TCID).V_TimeOut = Timer + G_Server_TimeOut
                    THID = ThreadCreate(@F_Header_Create_Thread, @TCID)
                    Sleep 1
                    If THID = 0 Then TSN_Close T_Client
                    X_ClientD(X).V_Thread = THID
                    Sleep 1
                Else
                    XPrint "[REQ] No Free -> Create New -> SERVER FULL! KILL NEW!"
                    TSN_Data_Send T_Client, HTTP_Header_Create(307, HTML_HTTPCode_CreatePage(307, HTTP_Get_Code_Desc(307)))
                    TSN_Close T_Client
                End If
            Else
                XPrint "[Fehler] " & TSN_GuruCode("DE", BV)
                Exit Do
            End If
        Case Else
            XPrint "[Fehler] " & TSN_GuruCode("DE", BV)
            Exit Do
    End Select
    If XDrawChangeT < Timer then
        TTYDraw
        XDrawChangeT = Timer + 0.20
    end if
Loop Until InKey = Chr(27)


TSN_Close X_Server
For X = 1 to X_ClientC
    TSock = X_ClientD(X).V_Socket
    TSN_Close TSock
    ThreadWait(X_ClientD(X).V_Thread)
Next
sleep 1
if BV <> 0 then Print "[Fehler] "; TSN_GuruCode("DE", BV)
F_Log "Schliesse Log...", 1
F_Log String(50, "=")
if G_LogFN <> 0 then close #G_LogFN
End BV

Sub TTYDraw()
Dim XX as Long
Dim XW as Long
Dim XH as Long
Dim XS as Long
Dim XV as Long
DIM TS as String
Dim DD() as String
DIM TW as String
XW = LOWORD(Width)
XH = HIWORD(Width)
Redim DD(X_ClientC) as String
Dim TClient as Client_Type
For XX = 1 to X_ClientC
    TClient = X_ClientD(XX)
    With TClient
        TW = Format(.V_TimeOut - Timer, "000") & "-" & TClient.V_Socket
        If .V_Socket > 0 then
            Select Case TClient.V_FIO.V_State
                case 0: TS = "[" & MKLen(str(XX), 5, 1) & "][" & MKLen(.V_IPA, 15, 1) & "][    ][             ][" & TW & "][" & String(25, 32) & "] Warte auf eingehende Daten..."
                case 1: TS = "[" & MKLen(str(XX), 5, 1) & "][" & MKLen(.V_IPA, 15, 1) & "][    ][             ][" & TW & "][" & String(25, 32) & "] Lese Anfrage / Erzeuge Antwort..."
                case 2: TS = "[" & MKLen(str(XX), 5, 1) & "][" & MKLen(.V_IPA, 15, 1) & "][    ][             ][" & TW & "][" & String(25, 32) & "] Sende HTTP-Header..."
                case 3
                    XV = Fix(100 / .V_FIO.V_MaxLen * .V_FIO.V_AKPos)
                    TS = "[" & MKLen(str(XX), 5, 1) & "][" & MKLen(.V_IPA, 15, 1) & "][" & MKLen(str(XV) & "%", 4, 1) & "][" & MKLen(Format(.V_FIO.V_Rate, "###,###,###"), 8, 1) & " KB/s][" & TW & "][" & MKLen(String(Fix(XV / 4), 35), 25, 0) & "] " & .T_HTTP.V_RequestFilename
                case 9: TS = "[" & MKLen(str(XX), 5, 1) & "][" & MKLen(.V_IPA, 15, 1) & "][    ][             ][" & TW & "][" & String(25, 32) & "] Schliesse Verbindung..."
                case else: TS = "[" & MKLen(str(XX), 5, 1) & "][" & MKLen(.V_IPA, 15, 1) & "][    ][             ][" & TW & "][" & String(25, 32) & "] =[UNBEKANNTER STATUS]="
            End Select
'           If (X_ClientD(XX).V_TimeOut - Timer) < 0 Then
'               TSN_Close TClient.V_Socket
'               X_ClientD(XX) = TClient
'           End If
        else: TS = "[" & MKLen(str(XX), 5, 1) & "][" & String(15, 32) & "][    ][             ][   ][" & String(25, 32) & "] -"
        End if
        If Len(TS) > XW then TS = Left(TS, XW)
        DD(XX) = TS & String(XW - len(TS), 32)
    End With
Next
XS = XH - X_ClientC - 2
For XX = XCC to X_ClientC
    Print ""
Next
XCC = X_ClientC + 2
Locate XS, 1, 0
For XX = 1 to X_ClientC
    Print DD(XX)
Next
Print Format(Now, "yyyy.mm.dd - hh:mm:ss")
end sub


Sub XPrint(V_Text as String)
Dim XW as Long
Dim XH as Long
Dim XS as Long
XW = LOWORD(Width)
XH = HIWORD(Width)
XS = XH - X_ClientC - 3
Locate XH, 1, 0
Print ""
Locate XS, 1, 0
Print V_Text & String(XW - Len(V_text), 32)
F_Log V_Text
End Sub


Function MkLen(ByRef V_Text as String, ByVal V_Len as Long, ByVal V_AlignRight as uByte) as String
If Len(V_Text) < V_len then
    If V_AlignRight = 1 then
        Return String(V_Len - Len(V_Text), 32) & V_Text
    else: Return V_Text & String(V_Len - Len(V_Text), 32)
    Endif
else: Return V_Text
endif
end Function


Sub F_Log(ByVal V_Text as String, ByVal V_WhisNow as uByte = 0)
If XLogDate <> format(now, "yyyy_mm_dd") then
    XLogDate = format(now, "yyyy_mm_dd")
    if G_LogFN <> 0 then Close #G_LogFN: G_LogFN = 0
    if G_Server_LogPath <> "" then
        If dir(G_Server_LogPath, fbdirectory) = "" then
            XPrint "LOG-Path existiert nicht! Erstelle Path! -> " & G_Server_LogPath
            MKDir G_Server_LogPath
            If dir(G_Server_LogPath, fbdirectory) = "" then XPrint "[=FEHLER=] Konnte Log-Verzeichniss nicht erstellen!"
        end if
        G_LogFN = FreeFile
        Open G_Server_LogPath & "/" & G_Server_LogName & XLogDate & ".log" for binary as #G_LogFN
    Endif
End If
if G_LogFN <> 0 then
    Dim T as String
    T = V_Text & chr(13) & chr(10)
    If V_WhisNow = 1 then T = "[" & format(now, "yyyymmdd-hhmmss-") & str(timer) & "] " & T
    Put #G_LogFN, Lof(G_LogFN) + 1, T
End if
end sub


Sub F_Header_Create_Thread(V_CID As Any Ptr)
Dim X As Integer = *cptr(Integer Ptr, V_CID)
Dim TSock as Socket
Dim TBV as Long
Dim TCID as Long
Dim TData as String
X_ClientD(X).V_TimeOut = Timer + G_Server_TimeOut * 10
do
        TSock = X_ClientD(x).V_Socket
        If TSock > 0 Then
            If (X_ClientD(x).V_TimeOut - Timer) >= 0 then
                Select case X_ClientD(x).V_FIO.V_State
                    case 0
                        TBV = TSN_Data_Get(Tsock, TData)
                        Select Case TBV
                            Case 0
                            case 2
                                X_ClientD(X).V_TimeOut = Timer + G_Server_TimeOut
                                X_ClientD(x).T_Data += TData
                                HTTP_Header_Read x
                            Case 3: X_ClientD(x).V_FIO.V_State = 9
                            case else
                                XPrint "[Fehler] " & TSN_GuruCode("DE", TBV)
                                X_ClientD(x).V_FIO.V_State = 9
                        End Select
                End Select
                Select case X_ClientD(x).V_FIO.V_State
                    case 1
                        Dim T as String
                        Dim XFT as String
                        XFT = X_ClientD(X).T_HTTP.V_RequestFileType
                        X_ClientD(X).V_FIO.V_State = 2
                        If Right(X_ClientD(X).V_FIO.V_Path,1) = "/" then
                            XPrint "[" & format(now, "yyyymmdd-hh:mmss") & "][" & MKLen(X_ClientD(X).V_IPA, 15, 1) & "][" & MKLen(X_ClientD(X).T_HTTP.V_Type,4,1) & "][" & str(200) &"] " & X_ClientD(X).T_HTTP.V_Request
                            XMIMEPushID += 1
                            T = ExePath & "/MIME_PUSH/"
                            If Dir(T, fbdirectory) = "" then MKDir T
                            X_ClientD(X).T_HTTP.V_PushPathOut = T & str(XMIMEPushID) & ".MIMEOUT"
                            X_ClientD(X).V_FIO.V_FileID = Freefile
                            Open X_ClientD(X).T_HTTP.V_PushPathOut for Binary as #X_ClientD(X).V_FIO.V_FileID
                            Put #X_ClientD(X).V_FIO.V_FileID, 1, HTTP_Header_Create(200, HTML_HTTP_CreateDirList(G_Server_WWWBasePath, X_ClientD(X).V_FIO.V_Path, X_ClientD(X).T_HTTP.V_Request), , "text/html")
                            Close #X_ClientD(X).V_FIO.V_FileID
                            X_ClientD(X).V_FIO.V_Path = X_ClientD(X).T_HTTP.V_PushPathOut
                            X_ClientD(X).V_FIO.V_FileID = Freefile
                            Open X_ClientD(X).V_FIO.V_Path for Binary as #X_ClientD(X).V_FIO.V_FileID
                            X_ClientD(X).V_FIO.V_MaxLen = LOF(X_ClientD(X).V_FIO.V_FileID)
                            If X_ClientD(X).V_FIO.V_HeadOnly = 1 then X_ClientD(X).V_FIO.V_State = 9
                        else
                            X_ClientD(X).V_FIO.V_FileID = Freefile
                            Open X_ClientD(X).V_FIO.V_Path for Binary as #X_ClientD(X).V_FIO.V_FileID
                            X_ClientD(X).V_FIO.V_MaxLen = LOF(X_ClientD(X).V_FIO.V_FileID)
                            If X_ClientD(X).V_FIO.V_HeadOnly = 1 then X_ClientD(X).V_FIO.V_State = 9
                            TSock = X_ClientD(X).V_Socket
                            TSN_Data_Send TSock, HTTP_Header_Create(200, "", X_ClientD(X).V_FIO.V_MaxLen, MIME_Get_Type_Desc(XFT))
                        end if
                        XPrint "[" & format(now, "yyyymmdd-hh:mmss") & "][" & MKLen(X_ClientD(X).V_IPA, 15, 1) & "][" & MKLen(X_ClientD(X).T_HTTP.V_Type,4,1) & "][" & str(200) &"] " & X_ClientD(X).T_HTTP.V_Request
                        X_ClientD(X).V_FIO.V_AKPos = 1
                        X_ClientD(X).V_FIO.V_State = 3
                    case 2
                    case 3
                        X_ClientD(X).V_TimeOut = Timer + G_Server_TimeOut
                        if X_ClientD(x).V_Socket <> 0 then
                            TData = Space(G_Server_BlockSize)
                            If X_ClientD(x).V_FIO.V_MaxLen - X_ClientD(x).V_FIO.V_AKPos < G_Server_BlockSize then TData = Space(X_ClientD(x).V_FIO.V_MaxLen - X_ClientD(x).V_FIO.V_AKPos + 1)
                            Get #X_ClientD(x).V_FIO.V_FileID, X_ClientD(x).V_FIO.V_AKPos, TData
                            TSN_Data_Send TSock, TData
                            X_ClientD(x).V_FIO.V_AKPos = X_ClientD(x).V_FIO.V_AKPos + Len(TData)
                            X_ClientD(x).V_FIO.V_RateC = X_ClientD(x).V_FIO.V_RateC + Len(TData)
                            If X_ClientD(x).V_FIO.V_RateT < Timer then
                                X_ClientD(x).V_FIO.V_Rate = (X_ClientD(x).V_FIO.V_RateC * 2) \ 2000
                                X_ClientD(x).V_FIO.V_RateC = 0
                                X_ClientD(x).V_FIO.V_RateT = Timer + 0.5
                            End If
                            If X_ClientD(x).V_FIO.V_MaxLen <= X_ClientD(x).V_FIO.V_AKPos then X_ClientD(x).V_FIO.V_State = 9
                            X_ClientD(TCID).V_TimeOut = Timer + G_Server_TimeOut
                        else: X_ClientD(x).V_FIO.V_State = 9
                        End if
                    case 9
                        if X_ClientD(x).V_FIO.V_FileID <> 0 then Close #X_ClientD(x).V_FIO.V_FileID
                        if X_ClientD(X).T_HTTP.V_PushPathIn <> "" then
                            Kill X_ClientD(X).T_HTTP.V_PushPathIn
                            X_ClientD(X).T_HTTP.V_PushPathIn = ""
                        End if
                        if X_ClientD(X).T_HTTP.V_PushPathOut <> "" then
                            Kill X_ClientD(X).T_HTTP.V_PushPathOut
                            X_ClientD(X).T_HTTP.V_PushPathOut = ""
                        End if
                        X_ClientD(x).V_FIO.V_FileID = 0
                        TSN_Close TSock
                        X_ClientD(x).V_Socket = TSock
                end select
            Else
                XPrint "TimeOut!"
'               If X_ClientD(x).V_FIO.V_State <> 1 then
                    TSN_Close TSock
                    X_ClientD(x).V_Socket = TSock
'               Else: HTTP_SendErrorClose X, 408
'               End if
            End if
        Else: Exit Do
        End If
loop
TSN_Close TSock
TSock = 0
X_ClientD(X).V_Socket = TSock
end Sub