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.
#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 any ptr
prev As CLIENT Ptr
Next As CLIENT Ptr
End Type
Type SERVERCTX
socket As SOCKET
acceptthread As any ptr
isrunning As Integer
globmutex As any ptr
filemutex As any ptr
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) 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
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 any ptr )
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( cast( sub( byval as any ptr ), @serverReceive ), 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
