30k simple web server

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
parakeet
Posts: 48
Joined: Mar 30, 2006 15:46
Location: Lille, France

30k simple web server

Post by parakeet »

Hi folks,

This is the easy to use "Simple Web Server".

It is :
-very small (30 kb)
-very fast
-multi-threaded (it can handle requests from many clients)
-robust (tested with ApacheBench concurrent load, thanx to Zerospeed)
-has an icon in the task bar to control it (run/pause)

Typical usage :
Home-hosted web-site. I have been using this web-server a lot for more than a month without a problem, before I posted this. I placed it at home on a small low-consumption, low-noise, screenless PC that is always up, and I registered at dyndns.org. I also setup my ADSL router-modem so that it forwards port 80 requests to my small server's IP address, and finally allowed my firewalls to let port 80 in. This way I can connect home from anywhere, and share photos with my family and friends.

Platforms :
Windows, but it should be adaptable for Linux, as only socket function names have to be changed, plus the tray icon handling, that accepts three commands : run, pause, exit. Volunteers wanted, to make it multiplatform !

Instructions to compile:
-copy the code below into a sws.bas file
-create a sws.rc file containing one line : 1 ICON "icon.ico"
-find a .ico file on your hard disk or draw it yourself, and save it as "icon.ico" near the .bas file.
-Compile the code with "fbc sws.rc sws.bas -s gui"

Instructions to run:
-place the resulting sws.exe near a wwwroot directory in which you have put your web-site (html pages and images, default page is "index.html")
-run the sws.exe, your icon appears in the tray.

Instruction to test:
-run your web browser
-type localhost as the URL. You should see your web-site.

Sources / Credits / Thanxx:
-v1ctor for the fixes to have it compiled with fb0.16
-Mindless for the fixes for fb0.16b
-Zerospeed for the file-reading without a mutex, and loading SimpleWebServer with concurrent test from ApacheBench
-The FB team, for their compiler and for the example code provided in the fb windows examples, on which Simple Web Server is partly based, though I added the acceptance of free-sized HTTP requests.

Yours,
Anselme

Code: Select all

'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.

Option Explicit

#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 
                        Dim FileBuffer(FileLength) As Byte 
                        Get #FileHandle, , FileBuffer() 
                    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
            Dim 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
Last edited by parakeet on Aug 23, 2006 12:25, edited 15 times in total.
anonymous1337
Posts: 5494
Joined: Sep 12, 2005 20:06
Location: California

Post by anonymous1337 »

Can I get a precompiled version of this by any chance? ^_~;;

I ran it, and no icon appears in my tray, and no process in the process list so it must have closed.

Windows XP, Home Edition, Service pack 2 - Cable Internet.
Zippy
Posts: 1295
Joined: Feb 10, 2006 18:05

Post by Zippy »

@parakeet

Very good, works as advertised (single instance from localhost). Nice code. Tinyweb in fb, makes me wanna cry.
zerospeed
Posts: 227
Joined: Nov 04, 2005 15:29

Post by zerospeed »

@parakeet,

Simply amazing....

Maybe you could check the code from D.J.Peters (called netsupport).

http://www.freebasic.net/forum/viewtopi ... netsupport

and for linux:

http://www.freebasic.net/forum/viewtopi ... netsupport

Using them to replace Winsock especific code could create a cross/platform tiny webserver ;-)

Btw, you're using the file locking to get the ERR report correctly for the file you're opening? Why? and force to use file handle #1... from a multithread env... sounds could brake.

Maybe you could use the dir() function to check if the file exist, and report 404 error... or open with a FileHandle = FreeFile to avoid lockings...

What do you think?

Later,

Zero
parakeet
Posts: 48
Joined: Mar 30, 2006 15:46
Location: Lille, France

Post by parakeet »

Zerospeed, good ideas, thank you !
Using them to replace Winsock especific code could create a cross/platform tiny webserver ;-)
Sorry I don't have a linux platform to developp/debug/test it... I have nothing against Linux and portability (on the contrary), but I do not have enough time these days and for the next months (two babies, 1 and 19 months at home). This is why I asked for volunteers.
Btw, you're using the file locking to get the ERR report correctly for the file you're opening? Why? and force to use file handle #1... from a multithread env... sounds could brake.
Sorry, I am a beginner in freebasic file handling. Am I really locking files? I thought using a mutex would protect me from any problems. Am I incorrect?
Maybe you could use the dir() function to check if the file exist, and report 404 error... or open with a FileHandle = FreeFile to avoid lockings...
Thank you very much for the dir idea. I will make this change asap. But what about the ERR variable which seems to be global? Isn't my approach good? Because I have to test the file opening anyway, even with a DIR ensuring that the file exists...

Anyway the code seems to be already quite robust. I edited my initial post, see the section "typical usage" in the intro.

Yours,
Anselme
parakeet
Posts: 48
Joined: Mar 30, 2006 15:46
Location: Lille, France

If Simple Web Server stops immediately...

Post by parakeet »

anonymous1337,

This could be because of the windows SP2 firewall. Did you open the firewall port 80 in ? Did you ask to be prompted when a program tries to listen on a port (which is the case for a web-server) ?

Anyway, to see the error messages, un-comment the error-printing lines in the serverRun function, and remove your -s gui compiling option to let the console appear.

Please read the intro section of my post, I just added a 'typical usage' paragraph. Please give me your email address for a precompiled file.
jupiter3888
Posts: 103
Joined: Jun 30, 2005 3:54
Location: adelaide, australia
Contact:

Post by jupiter3888 »

nothing to see here, i messed up my posting.

move along, move along...
Last edited by jupiter3888 on May 19, 2006 11:58, edited 1 time in total.
jupiter3888
Posts: 103
Joined: Jun 30, 2005 3:54
Location: adelaide, australia
Contact:

Post by jupiter3888 »

hey parakeet,
sounds likea cool little program you have there.

but i seem to be having some trouble compiling it. when i do try it gives me

Code: Select all

sws.bas(9) : error 24: file not found, "win/winsock2.bas"

#include once "windows.bi"
               ^
i have looked in the /inc/win/ folder and there is no file called "winsock2.bi" or in my entire fb installation directory.

i have also looked at google but nothing shows up.
a search of the forum gives references to it but nothing about where i can get it, as far as i can see.

so why dont i have it?

oh, i have fb.16 and windows XP (no Service Packs's atm)
Last edited by jupiter3888 on May 20, 2006 9:06, edited 1 time in total.
steven522
Posts: 265
Joined: May 27, 2005 13:02
Location: Alabama, USA
Contact:

Post by steven522 »

How are any of getting this to compile????

FreeBASIC Compiler - Version 0.16 for win32 (target:win32)
Copyright (C) 2004-2006 Andre Victor T. Vicentini

compiling: fbWebServer.bas -o fbWebServer.asm
fbWebServer.bas(130) : error 96: Branch crossing local array or object definition, array or object: FILEBUFFER
fbWebServer.bas(267) : error 4: Duplicated definition, client

dim client as CLIENT ptr
^
fbWebServer.bas(264) : error 95: Branching to other SUB's/FUNCTION's or to module-level, array or object: FILEBUFFER
> Execution finished.
parakeet
Posts: 48
Joined: Mar 30, 2006 15:46
Location: Lille, France

Post by parakeet »

Jupiter3888, steven522,

The inc/win32/winsock2.bi should be there. I could post it, but it's 48k. I think maybe you did not install a full version of FB. I also remarked that both of you use fb 0.16 which is a beta.
v1ctor
Site Admin
Posts: 3804
Joined: May 27, 2005 8:08
Location: SP / Bra[s]il
Contact:

Post by v1ctor »

Add:

Code: Select all

	dim FileBuffer() as byte 
	dim SendBuffer() as byte
Before the

Code: Select all

   'receive loop 
   do while( ctx.isrunning and (client->socket <> NULL) ) 
Line and it will compile in the current 0.16 release, that error will disappear when compound statements begin to create new scope blocks.
parakeet
Posts: 48
Joined: Mar 30, 2006 15:46
Location: Lille, France

Post by parakeet »

fixed. Thanx v1ctor.
steven522
Posts: 265
Joined: May 27, 2005 13:02
Location: Alabama, USA
Contact:

Post by steven522 »

anonymous1337 wrote:I ran it, and no icon appears in my tray, and no process in the process list so it must have closed.
Change the "if not serverrun" line to this:

Code: Select all

if serverRun( ) = 0 then end
The use of NOT has changed and will not run properly on the lateset "test" version.
steven522
Posts: 265
Joined: May 27, 2005 13:02
Location: Alabama, USA
Contact:

Post by steven522 »

Hmmm...
I have been trying to get a working version of this going. Maybe it has something to do with the beta (0.16) version, but as soon as the web browser attempts to connect, the program bails out. I have tried to add as many print statements at every END that terminates the program, but can not track down the problem.
Anyone else have any luck with an 0.16 compile?
v1ctor
Site Admin
Posts: 3804
Joined: May 27, 2005 8:08
Location: SP / Bra[s]il
Contact:

Post by v1ctor »

It seems to work fine here, btw, the copy loop can be changed to:

Code: Select all

            for i = 0 to HeaderLength-1 
                SendBuffer(i) = stReponseHeader[i]
            next i 
A bit faster.
Post Reply