30k simple web server
Hi,axipher wrote:Hey, this sounds awesome, I get it to compile and run fine, but after typing "localhost" in the browser, just a blank page comes up, I have "sws.exe" in "c:\web" and "index.html" in "c:\web\wwwroot". What am I doing wrong? I tried it in both Firefox2 and IE7
Maybe your page index.html displays blank ? Just kidding.
To fix it out, please open your file directly, not by http, by either
-double-clicking the filename in your file explorer, or by
-opening the web browser and browsing to file://c:/web/wwwroot/index.html
Yours,
Not yet, but this is not hard to implement. On reception of a http request, a function reads a file on the disk and sends back the file content as a http response to the client browser.zoomkat wrote:Does this web server support a cgi function for running programs and sending the result back to the client brouser?
Instead of reading from a file, it should call a cgi or whatever other program and send its output as a http response
upload a file
Hi everyone.
In my HTML code there is a botton that select a file and other botton that send the post command to a free basic server (simple 30K). But it does not work! Only the path and name of file are recived on server. How can the server get the file and sabe it on its own folder?
Thanks.
In my HTML code there is a botton that select a file and other botton that send the post command to a free basic server (simple 30K). But it does not work! Only the path and name of file are recived on server. How can the server get the file and sabe it on its own folder?
Thanks.
Re: upload a file
This is because a file upload is in fact an http post request. The file contents is sent in the same way as any other form field (except that it is encoded, since a file may contain binary data).Alboz wrote:Hi everyone.
In my HTML code there is a botton that select a file and other botton that send the post command to a free basic server (simple 30K). But it does not work! Only the path and name of file are recived on server. How can the server get the file and sabe it on its own folder?
Thanks.
The code of the 30k web server only copes with http get requests, because it does not analyse what is after the first line of the http request it receives (it searches for the first "CRLF found twice").
If you want to upload files, you must also parse what follows the first line. Read on the web about http post requests structures. Alternatively you can use fiddler to see in real time the http requests and responses.
Anselme
-
- Posts: 1009
- Joined: Oct 11, 2008 7:42
- Location: ABQ, NM
- Contact:
How do you know which port to use on the return of the CGI server response?Not yet, but this is not hard to implement. On reception of a http request, a function reads a file on the disk and sends back the file content as a http response to the client browser.
Instead of reading from a file, it should call a cgi or whatever other program and send its output as a http response
:M
A browser sends a request to the port 80 of the webserver. The server accepts the connection and leaves it open. Then the server reads the received request, calls any program (can be freebasic) by any means (can be a dll, a shell, an exe, another webserver...) but pays attention on catching the text output of the called program (the cgi). Then the server replies to the browser by copying the caught output inside the response which is then sent to the browser, using the connection that is still open.kiyotewolf wrote: How do you know which port to use on the return of the CGI server response?
:M
The connection is always initiated by the browser, and remains open during the whole execution on the server and cgi side, this is why no port has to be configured at the CGI program.
Anselme
Last edited by parakeet on May 30, 2011 7:32, edited 1 time in total.
-
- Posts: 1009
- Joined: Oct 11, 2008 7:42
- Location: ABQ, NM
- Contact:
-
- Posts: 64
- Joined: Jul 15, 2009 12:41
Re: 30k simple web server
This is a impressive sample I'have been playing with. I'have pending tranfering files to the server (upload documents and images) , and tranfer data records eficiently to the server ( not by parameters in a POST query). If any has some idea of how do this....
It could be considered a hybrid server. Good Job
It could be considered a hybrid server. Good Job
parakeet
Re: 30k simple web server
Great little webserver mucho kudos to 'parkeet' and
other contributions made!
Here are some workarounds for some issues I came
across while using the code.
a) handles are not released on win 7 and win 10
@line 230 and 238
b) urls can not contain http://site.doman?parameter=something
@line 158
c) added custom 404 and 403 see full code
403
404
Complete code (based on suggestions made by 'cha0s)
viewtopic.php?p=104766#p104766
Create folders wwwroot (content website) and errors (403 and 404)
Const HOMEDIR = "wwwroot"
Const SERVERERROR = "errors"
demo app.rc
Some final notes...
Tried adding logging regrettably couldn't figure out how
to get the useragent and ip from the browser.
Anno 2024 compiled with fb FreeBASIC-1.10.1-gcc-9.3 (32 bit)
the compiled .exe clocks in at around 98kb ehhhr a bit more
then the initial 30kb in 2006 ....
other contributions made!
Here are some workarounds for some issues I came
across while using the code.
a) handles are not released on win 7 and win 10
Code: Select all
' possible fix for issue with increasing handles
ThreadDetach( client->recvthread )
b) urls can not contain http://site.doman?parameter=something
Code: Select all
' tricky hack to accept parameters append to url aka page.html?title=etc
stPath = mid(stPath, 1, instrrev(stPath, "?") - 1)
c) added custom 404 and 403 see full code
403
Code: Select all
<!DOCTYPE html>
<html lang="en">
<head>
<meta name="viewport" content="width=device-width, initial-scale=1" charset="utf-8" />
<meta name="keywords" content="403 server error">
<title>index</title>
<link rel="icon" type="image/x-icon" href="../images/favicon.jpg">
<link rel="stylesheet" href="../font.css" />
<link rel="stylesheet" href="../main.css" />
</head>
<body>
403 - You are not authorised to access this resource.
</body>
</html>
Code: Select all
<!DOCTYPE html>
<html lang="en">
<head>
<meta name="viewport" content="width=device-width, initial-scale=1" charset="utf-8" />
<meta name="keywords" content="404 server error">
<title>index</title>
<link rel="icon" type="image/x-icon" href="../images/favicon.jpg">
<link rel="stylesheet" href="../font.css" />
<link rel="stylesheet" href="../main.css" />
</head>
<body>
404 - The URL you asked for does not exist on this website.
</body>
</html>
viewtopic.php?p=104766#p104766
Create folders wwwroot (content website) and errors (403 and 404)
Const HOMEDIR = "wwwroot"
Const SERVERERROR = "errors"
Code: Select all
' courtesy https://www.freebasic.net/forum/viewtopic.php?t=4199&hilit=Simple+Web+Server
' 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 tweaked by thrive4 march 2024.
#include once "win/winsock2.bi"
#include once "windows.bi"
#include once "win/shellapi.bi"
#include once "fbthread.bi"
Const WM_SHELLNOTIFY = WM_USER + 5
Const ID_RUN = 1001
Const ID_PAUSE = 1002
Const ID_EXIT = 1003
Const SERVER_ADDR = "127.0.0.1"
Const HOMEDIR = "wwwroot"
Const SERVERERROR = "errors"
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
' tricky hack to accept parameters append to url aka page.html?title=etc
stPath = mid(stPath, 1, instrrev(stPath, "?") - 1)
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
stPath = exepath + "/" + SERVERERROR + "/" + "404.html"
end if
FileHandle = Freefile
If Open( stPath For Binary Access Read Shared As #FileHandle ) <> 0 Then
stReponseHeader = "HTTP/1.1 403 Forbbiden" & stNL & stNL
stPath = exepath + "/" + SERVERERROR + "/" + "403.html"
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
'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
' possible fix for issue with increasing handles
ThreadDetach( client->recvthread )
client->recvthread = NULL
serverDel( client )
End If 'bFound
Loop 'receive loop
' remove client
ThreadDetach( client->recvthread )
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
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( ) end if'Listenning on 80
End If
If LOWORD (wParam)= ID_PAUSE Then
If ctx.isrunning = TRUE Then serverEnd( ) end if'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 = "app"
' 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
Code: Select all
//=============================================================================
// Generic project resource file
//=============================================================================
// add helpfile in exe windows only
//helpfile rcdata "help.txt"
// add an icon windows only?
FB_PROGRAM_ICON ICON "app.ico"
1 ICON "app.ico"
// add version and file info in exe windows only
VS_VERSION_INFO VERSIONINFO
FILEVERSION 1, 0, 0, 000
PRODUCTVERSION 1, 0, 0, 0
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x9L
#else
FILEFLAGS 0x8L
#endif
FILEOS 0x4L
FILETYPE 0x1L
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "Comments", "via "
VALUE "CompanyName", "parakeet"
VALUE "FileDescription", "simple windows webserver"
VALUE "FileVersion", "1, 0, 0, 000"
VALUE "InternalName", ""
VALUE "LegalCopyright", "parakeet"
VALUE "OriginalFilename", "webserver"
VALUE "PrivateBuild", ""
VALUE "ProductName", "webserver"
VALUE "ProductVersion", "1, 0, 0, 0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END
Tried adding logging regrettably couldn't figure out how
to get the useragent and ip from the browser.
Anno 2024 compiled with fb FreeBASIC-1.10.1-gcc-9.3 (32 bit)
the compiled .exe clocks in at around 98kb ehhhr a bit more
then the initial 30kb in 2006 ....
Re: 30k simple web server
Well as the old joke goes
'a mime is a terrible thing to waste' ....
Added basic mime handling some browsers,
specifically firefox can get a bit touchy when
the mime type is not supplied by the web server.
Place all the following files in one folder
and compile the code.
webserver.bas
webserver.rc
Create an 'errors' folder and place
403.html
and
404.html
in the 'errors' folder
Place a webserver.ico' in the same folder
as webserver.bas
Free ico's can be found here:
https://www.iconfinder.com/search?q=web ... price=free
webserver.wfbe
If using winfbe as editor this project file
can be used (place in same folder as webserver.bas)
Save as 'webserver.wfbe'
Create a 'wwwroot' folder to place
content served by webserver.
'a mime is a terrible thing to waste' ....
Added basic mime handling some browsers,
specifically firefox can get a bit touchy when
the mime type is not supplied by the web server.
Place all the following files in one folder
and compile the code.
webserver.bas
Code: Select all
' courtesy https://www.freebasic.net/forum/viewtopic.php?t=4199&hilit=Simple+Web+Server
' 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 tweaked by thrive4 march 2024.
#include once "win/winsock2.bi"
#include once "windows.bi"
#include once "win/shellapi.bi"
#include once "fbthread.bi"
Const WM_SHELLNOTIFY = WM_USER + 5
Const ID_RUN = 1001
Const ID_PAUSE = 1002
Const ID_EXIT = 1003
Const SERVER_ADDR = "127.0.0.1"
Const HOMEDIR = "wwwroot"
Const SERVERERROR = "errors"
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 mime as string = ""
dim fileext as string = ""
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
' tricky hack to accept parameters append to url aka page.html?title=etc
stPath = mid(stPath, 1, instrrev(stPath, "?") - 1)
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
stPath = exepath + "/" + SERVERERROR + "/" + "404.html"
end if
FileHandle = Freefile
If Open( stPath For Binary Access Read Shared As #FileHandle ) <> 0 Then
stReponseHeader = "HTTP/1.1 403 Forbbiden" & stNL & stNL
stPath = exepath + "/" + SERVERERROR + "/" + "403.html"
Else
FileLength = Lof(FileHandle) 'file len
If FileLength <> 0 Then
reDim FileBuffer(FileLength) As Byte
Get #FileHandle, , FileBuffer()
End If
Close #FileHandle
fileext = lcase(mid(stPath, instrrev(stPath, ".")))
' added mime type handling for browser
' courtesy https://www.vbforums.com/showthread.php?858597-RESOLVED-Using-Winsock-To-Send-A-Message-To-A-Web-Browser
' post by optionbase1
' for more definitions see https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Common_types
select case true
case instr(1, ".jpg, .jpeg", fileext) > 0
mime = "Content-type: image/jpeg"
case instr(1, ".gif", fileext) > 0
mime = "Content-type: image/gif"
case instr(1, ".htm, .html", fileext) > 0
mime = "Content-type: text/html"
case instr(1, ".js", fileext) > 0
mime = "Content-type: text/javascript"
case instr(1, ".css", fileext) > 0
mime = "Content-type: text/css"
case instr(1, ".csv", fileext) > 0
mime = "Content-type: text/csv"
case instr(1, ".json", fileext) > 0
mime = "Content-type: application/json"
case instr(1, ".mp3", fileext) > 0
mime = "Content-type: audio/mpeg"
case instr(1, ".mp4", fileext) > 0
mime = "Content-type: video/mp4"
case instr(1, ".pdf", fileext) > 0
mime = "Content-type: application/pdf"
case else
mime = "Content-type: application/octet-stream"
end select
stReponseHeader = "HTTP/1.1 200 OK" & stNL & mime & stNL
stReponseHeader += "Cache-Control: private" & stNL
stReponseHeader += "content-length : " & Str(FileLength) & stNL & stNL
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
' possible fix for issue with increasing handles
ThreadDetach( client->recvthread )
client->recvthread = NULL
serverDel( client )
End If 'bFound
Loop 'receive loop
' remove client
ThreadDetach( client->recvthread )
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
'https://www.freebasic.net/forum/viewtopic.php?p=288786&hilit=inet_ntoa#p288786
'print " to: " + *inet_ntoa(sa.sin_addr) + ":" + str(ntohs(sa.sin_port))
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
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( ) end if'Listenning on 80
End If
If LOWORD (wParam)= ID_PAUSE Then
If ctx.isrunning = TRUE Then serverEnd( ) end if'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 = "webserver"
' 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
Code: Select all
//=============================================================================
// Generic project resource file
//=============================================================================
// add helpfile in exe windows only
//helpfile rcdata "help.txt"
// add an icon windows only?
FB_PROGRAM_ICON ICON "webserver.ico"
1 ICON "webserver.ico"
// add version and file info in exe windows only
VS_VERSION_INFO VERSIONINFO
FILEVERSION 1, 0, 0, 000
PRODUCTVERSION 1, 0, 0, 0
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x9L
#else
FILEFLAGS 0x8L
#endif
FILEOS 0x4L
FILETYPE 0x1L
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "Comments", "via "
VALUE "CompanyName", "parakeet"
VALUE "FileDescription", "simple windows webserver"
VALUE "FileVersion", "1, 0, 0, 000"
VALUE "InternalName", ""
VALUE "LegalCopyright", "parakeet"
VALUE "OriginalFilename", "webserver"
VALUE "PrivateBuild", ""
VALUE "ProductName", "webserver"
VALUE "ProductVersion", "1, 0, 0, 0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END
403.html
Code: Select all
<!DOCTYPE html>
<html lang="en">
<head>
<meta name="viewport" content="width=device-width, initial-scale=1" charset="utf-8" />
<meta name="keywords" content="403 server error">
<title>index</title>
<link rel="icon" type="image/x-icon" href="../images/favicon.jpg">
<link rel="stylesheet" href="../font.css" />
<link rel="stylesheet" href="../main.css" />
</head>
<body>
403 - You are not authorised to access this resource.
</body>
404.html
Code: Select all
<!DOCTYPE html>
<html lang="en">
<head>
<meta name="viewport" content="width=device-width, initial-scale=1" charset="utf-8" />
<meta name="keywords" content="404 server error">
<title>index</title>
<link rel="icon" type="image/x-icon" href="../images/favicon.jpg">
<link rel="stylesheet" href="../font.css" />
<link rel="stylesheet" href="../main.css" />
</head>
<body>
404 - The URL you asked for does not exist on this website.
</body>
</html>
Place a webserver.ico' in the same folder
as webserver.bas
Free ico's can be found here:
https://www.iconfinder.com/search?q=web ... price=free
webserver.wfbe
If using winfbe as editor this project file
can be used (place in same folder as webserver.bas)
Code: Select all
' WINFBE PROJECT FILE
ProjectBuild={1510C412-1D57-4F98-8947-1BB51C4D5532}
ProjectOther32=
ProjectOther64=
ProjectCommandLine=
ActiveTab=0
File=.\webserver.bas
FileType=1
TabIndex=-1
Bookmarks=114,193
IsDesigner=false
IsDesignerView=false
FirstLine=371
Position=8343
FirstLine1=0
Position1=0
SplitPosition=0
FocusEdit=0
FileEnd=[-]
File=.\webserver.rc
FileType=4
TabIndex=-1
Bookmarks=
IsDesigner=false
IsDesignerView=false
FirstLine=0
Position=501
FirstLine1=0
Position1=0
SplitPosition=0
FocusEdit=0
FileEnd=[-]
[Notes]
NOTES-START
NOTES-END
Save as 'webserver.wfbe'
Create a 'wwwroot' folder to place
content served by webserver.