FreeBasic

Пример простого веб сервера. Для использования компилируем, создаем папку wwwroot в папке, где создан EXE сервера. Далее в папку wwwroot кладем проект сайта или на худой конец один файл index.html. Забиваем в браузере ваш локальный адрес (http://127.0.0.1/) Должна высветиться корневая страница сайта. Желательно до компиляции создать файл ресурсов с иконкой, в нем прописать:

1 ICON "1.ico" 

В этом случае в трее будет видна ваша иконка, щелкнув по которой , вывалится контекстное меню из трех пунктов: (Run, Pause, Exit).

Платформа: Windows
Автор: Anselme Dewavrin

'Simple Web Server, (c) Anselme Dewavrin 2006 - dewavrin@yahoo.com
'Feel free to use it, provided you mention my name.

'based on the example provided with freebasic.


#INCLUDE Once "win/winsock2.bi"
#INCLUDE Once "windows.bi"
#INCLUDE Once "win/shellapi.bi"

Const WM_SHELLNOTIFY  = WM_USER + 5
Const ID_RUN          = 1001
Const ID_PAUSE        = 1002
Const ID_EXIT         = 1003
Const SERVER_ADDR     = "localhost"
Const HOMEDIR              = "wwwroot"
Const DEFAULT_PORT    = 80
Const SERVER_BUFFSIZE = 16

Dim Shared note As NOTIFYICONDATA
Dim Shared TB_CREATED As Integer
Dim Shared szAppName As String
Dim Shared As Integer ServerPort = DEFAULT_PORT

'---

Type CLIENT
socket                        As socket
ip                        As Integer
port                        As Integer
recvthread                As Integer
prev                        As CLIENT Ptr
Next                        As CLIENT Ptr
End Type

Type SERVERCTX
    socket                        As socket
    acceptthread                As Integer
    isrunning                As Integer
    globmutex                As Integer
    filemutex                As Integer
    clientlisthead  As CLIENT Ptr
End Type


Dim Shared ctx As SERVERCTX


'multithreaded socket handling

'':::::
Sub serverDel( Byval client As CLIENT Ptr )
    Dim s As socket

    '' not already removed?
    If( client->socket <> NULL ) Then
        s = NULL
        Swap s, client->socket        ' this should be atomic..

        '' close connection
        shutdown( s, 2 )
        closesocket( s )

        '' recv thread stills running?
        If( client->recvthread <> NULL ) Then
            Threadwait( client->recvthread )
        End If

        '' remove from list
        If( client->Next ) Then
            client->Next->prev = client->prev
        End If
        If( client->prev ) Then
            client->prev->Next = client->Next
        Else
            ctx.clientlisthead = client->Next
        End If
    End If

End Sub

'':::::
Function serverEnd( ) As Integer
    Dim client As CLIENT Ptr

    ctx.isrunning = FALSE

    '' close the listening socket
    If( ctx.socket <> 0 ) Then
        shutdown(ctx.socket, 2 )
        closesocket( ctx.socket )
        ctx.socket = 0
    End If

    '' remove all clients yet running
    Dim i As Integer

    Do
        client = ctx.clientlisthead
        If( client = NULL ) Then
            Exit Do
        End If
        serverDel( client )
    Loop

    '' shutdown winsock
    Function = WSACleanup( )

End Function

'thread waiting for data to arrive, parsing HTTP GET requests and sending responses
Sub serverReceive( Byval client As CLIENT Ptr )

Dim PacketBuffer(SERVER_BUFFSIZE) As Byte
Dim As Integer  ReceivedLen = 0
Dim As Byte Ptr ReceivedBuffer = 0
Dim As String   stNL   = Chr(13) & Chr(10)
Dim As String   stNLNL = stNL & stNL

Dim FileBuffer() As Byte 'fix for fb0.16beta, thx v1ctor
Dim SendBuffer() As Byte 'fix for fb0.16beta, thx v1ctor

Dim FileHandle As Ubyte

'receive loop
Do While( ctx.isrunning And (client->socket <> NULL) )

' block until some data
Dim bytes As Integer
bytes = recv( client->socket, @PacketBuffer(0), SERVER_BUFFSIZE, 0 )

' connection closed?
If( bytes <= 0 ) Then
    Exit Do
End If

' accumulate received data
ReceivedBuffer = Reallocate(ReceivedBuffer, bytes + ReceivedLen)
Dim i As Integer
For i=0 To bytes-1
    ReceivedBuffer[ReceivedLen+i] = PacketBuffer(i)
Next i
ReceivedLen += bytes

'CRLF found twice ?
If (ReceivedLen >= 4)                   And _
    (ReceivedBuffer[ReceivedLen-4] = 13) And _
    (ReceivedBuffer[ReceivedLen-3] = 10) And _
    (ReceivedBuffer[ReceivedLen-2] = 13) And _
    (ReceivedBuffer[ReceivedLen-1] = 10) Then

    'extract get path + url decoding (special chars are coded %XY)
    Dim As String stPath = HOMEDIR
    Dim As Integer iAcc = 0, iHex = 0
    For i = 4 To ReceivedLen-1
        Dim c As Byte
        c = ReceivedBuffer[i]
        If c = Asc(" ") Then Exit For
        If iHex <> 0 Then
            iHex += 1   'decode hex code
            iAcc *= 16
            iAcc += (c-48)
            If iHex = 3 Then
                c = iAcc
                iAcc = 0
                iHex = 0
            Endif
        Endif
        If c=Asc("%") Then 'hex code coming ?
            iHex = 1
            iAcc = 0
        Endif
        If iHex = 0 Then stPath += Chr(c)
    Next i

    If (stPath = HOMEDIR + "/") Or _  'default page and
    (Instr(stPath,"..") <> 0) Then 'restrict to wwwroot
    stPath = HOMEDIR + "/index.html"
End If
'get rid of received data
ReceivedLen = 0
Deallocate(ReceivedBuffer)

'prepare response
Dim As String  stReponseHeader
Dim As Integer FileLength = 0
'read requested file from disk (no mutex, thanx to Zerospeed)
If Dir(stPath) = "" Then
    stReponseHeader = "HTTP/1.1 404 Not Found" & stNL & stNL
Else
    FileHandle = Freefile
    If Open( stPath For Binary Access Read Shared As #FileHandle ) <> 0 Then
        stReponseHeader = "HTTP/1.1 403 Forbbiden" & stNL & stNL
    Else
        FileLength = Lof(FileHandle)    'file len
        If FileLength <> 0 Then
            Redim FileBuffer(FileLength+1) As Byte
            Get #FileHandle, , FileBuffer(0), FileLength
        End If
        Close #FileHandle
        stReponseHeader = "HTTP/1.1 200 OK" & stNL
        stReponseHeader += "Cache-Control: private" & stNL
        stReponseHeader += "content-length : " & Str(FileLength) & stNL & stNL
    End If
End If
'copy response header to sendbuffer
Dim HeaderLength As Integer
HeaderLength = Len(stReponseHeader)

Dim As Integer SendBufferLen = HeaderLength + FileLength
Redim SendBuffer(SendBufferLen) As Byte

'copy loop (thx v1ctor for this simplified version)
For i = 0 To HeaderLength-1
    SendBuffer(i) = stReponseHeader[i]
Next i
'copy response data to sendbuffer
If FileLength <> 0 Then
    For i = 0 To FileLength-1
        SendBuffer(i+HeaderLength) = FileBuffer(i)
    Next i
End If

'send response
Dim As Byte Ptr sendptr
sendptr = @sendBuffer(0)

Do While (ctx.isrunning And (client->socket <> NULL) And (SendBufferLen > 0))

    ' loop until the whole buffer is sent
    bytes = send( client->socket, sendptr, SendBufferLen, 0 )

    '' connection closed?
    If( bytes <= 0 ) Then
        Exit Do
    End If

    sendptr       += bytes
    SendBufferLen -= bytes
Loop 'send loop

' remove client
client->recvthread = NULL
serverDel( client )

End If 'bFound

Loop 'receive loop

' remove client
client->recvthread = NULL
serverDel( client )

End Sub


Sub serverAccept( Byval unused As Integer )
    Dim sa As sockaddr_in
    Dim s As socket

    Do While( ctx.isrunning )

        Dim salen As Integer
        salen = Len( sockaddr_in )
        s = accept( ctx.socket, Cptr( PSOCKADDR, @sa ), @salen )
        If( s = INVALID_SOCKET ) Then
            Exit Do
        End If

        Dim client As CLIENT Ptr

        '' access global data, lock it
        Mutexlock( ctx.globmutex )

        '' allocate node
        client = Allocate( Len( CLIENT ) )

        '' add to head of list
        client->Next = ctx.clientlisthead
        ctx.clientlisthead = client
        If client->Next Then client->Next->prev = client
        client->prev = NULL

        Mutexunlock( ctx.globmutex )

        '' setup the client
        client->socket                                 = s
        client->ip                                        = (@sa)->sin_addr.S_addr
        client->port                                = (@sa)->sin_port

        '' start new recv and send threads
        client->recvthread                         = Threadcreate( @serverReceive, Cint( client ) )

    Loop

    ctx.isrunning = FALSE
End Sub


Function serverRun( ) As Integer
    ' start winsock
    Dim wsaData As WSAData
    If( WSAStartup( MAKEWORD( 2, 0 ), @wsaData ) <> 0 ) Then
        'print "error calling WSAStartup: "; WSAGetLastError( )
        Return FALSE
    End If

    If( wsaData.wVersion <> MAKEWORD( 2, 0 ) ) Then
        WSACleanup( )
        Return FALSE
    End If

    ' create a socket for listening
    ctx.socket = OpenSocket( AF_INET, SOCK_STREAM, IPPROTO_TCP )

    If( ctx.socket = NULL ) Then
        'print "error calling opensocket: "; WSAGetLastError( )
        Return FALSE
    End If

    ' bind it to the server port
    Dim sa As sockaddr_in
    sa.sin_port                        = htons( ServerPort )
    sa.sin_family                = AF_INET
    sa.sin_addr.S_addr        = INADDR_ANY
    If(bind( ctx.socket, Cptr( PSOCKADDR, @sa ), Len( sa ) ) = SOCKET_ERROR ) Then
        'print "error calling bind: "; WSAGetLastError( )
        Return FALSE
    End If

    If( listen( ctx.socket, SOMAXCONN ) = SOCKET_ERROR ) Then
        Return FALSE
    End If

    ctx.clientlisthead = NULL
    ctx.isrunning = TRUE

    ctx.globmutex = Mutexcreate( )
    ctx.filemutex = Mutexcreate( )

    ctx.acceptthread = Threadcreate( @serverAccept ) 'launch accept thread

    Function = TRUE
End Function

'----------- TRAY ICON HANDLING --------------

Function WndProc ( Byval hWnd As HWND, Byval message As UINT, Byval wParam As WPARAM, Byval lParam As LPARAM ) As LRESULT

    Static pt As Point
    Function = 0

    Select Case (message)
        Case WM_CREATE
            TB_CREATED = RegisterWindowMessage ("TaskbarCreated")
            Exit Function

        Case WM_DESTROY
            UnregisterClass (szAppName, GetModuleHandle( null ))
            Shell_NotifyIcon (NIM_DELETE, @note)
            PostQuitMessage( 0 )
            Exit Function

        Case WM_COMMAND
            If Loword (wParam)= ID_RUN Then
                If ctx.isrunning = FALSE Then serverRun( ) 'Listenning on 80
            End If
            If Loword (wParam)= ID_PAUSE Then
                If         ctx.isrunning = TRUE Then serverEnd( ) 'pause
            End If
            If Loword (wParam) = ID_EXIT Then
                DestroyWindow (hWnd)
            End If

        Case WM_SHELLNOTIFY
            If (lParam = WM_RBUTTONDOWN) Or (lParam = WM_LBUTTONDOWN) Then
                GetCursorPos (@pt)
                SetForegroundWindow (hWnd)
                Dim MainMenu As HANDLE
                Dim FileMenu As HANDLE
                MainMenu = CreateMenu ()
                FileMenu = CreateMenu ()
                If ctx.isrunning = TRUE Then
                    AppendMenu (FileMenu, MF_STRING Or MF_CHECKED Or MF_GRAYED, ID_RUN, "&Run")
                    AppendMenu (FileMenu, MF_STRING, ID_PAUSE, "&Pause")
                Else
                    AppendMenu (FileMenu, MF_STRING, ID_RUN, "&Run")
                    AppendMenu (FileMenu, MF_STRING Or MF_CHECKED Or MF_GRAYED, ID_PAUSE, "&Pause")
                End If
                AppendMenu (FileMenu, MF_STRING, ID_EXIT, "E&xit")
                InsertMenu (MainMenu, 0, MF_POPUP, Cuint(FileMenu), "invisible menu")

                TrackPopupMenuEx (FileMenu, TPM_LEFTALIGN Or TPM_RIGHTBUTTON, pt.x, pt.y, hWnd, NULL)

                PostMessage (hWnd, WM_NULL, 0, 0)
            End If

        Case TB_CREATED
            Shell_NotifyIcon (NIM_ADD, @note)

    End Select

    Function = DefWindowProc( hWnd, message, wParam, lParam )
End Function

'---------------- SIMILI-WINMAIN ----------------

Dim hInstance As HINSTANCE
hInstance = GetModuleHandle( null )

If Command$ <> "" Then
    ServerPort = Val(Command$)
Endif

If( FALSE = serverRun( ) ) Then End

Dim wMsg As MSG
Dim wcls As WNDCLASS
Dim hWnd As HWND

szAppName = "SWS"

'already running ?
hWnd=FindWindow(szAppName,NULL)
If hWnd <> 0 Then
    End
End If

With wcls
    .style = CS_HREDRAW Or CS_VREDRAW
    .lpfnWndProc = @WndProc
    .cbClsExtra = 0
    .cbWndExtra = 0
    .hInstance  = hInstance
    .hIcon = LoadIcon (hInstance, MAKEINTRESOURCE (1))
    .hCursor = LoadCursor( NULL, IDC_ARROW )
    .hbrBackground = GetStockObject( WHITE_BRUSH )
    .lpszMenuName = NULL
    .lpszClassName = Strptr( szAppName )
End With

If( RegisterClass( @wcls ) = FALSE ) Then
    End
End If

'' Create the window and _BUT DONT_ show it
hWnd = CreateWindowEx( 0, szAppName, "", 0, 0, 0, 0, 0, NULL, NULL, hInstance, NULL )

note.cbSize = Sizeof (NOTIFYICONDATA)
note.hWnd = hWnd
note.hIcon = LoadIcon (hInstance, MAKEINTRESOURCE (1))
note.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
note.uCallbackMessage = WM_SHELLNOTIFY
note.szTip= szAppName
Shell_NotifyIcon (NIM_ADD, @note)

'wait for quit message
While GetMessage( @wMsg, NULL, 0, 0 ) <> FALSE
    TranslateMessage( @wMsg )
    DispatchMessage( @wMsg )
Wend

'eventually stop server
If ctx.isrunning = TRUE Then
    serverEnd( )
End If