French topic link
Following a discussion with falsam about its utf8 update of the included web server example (the 'Atomic web server'), I've modified an old web server code to propose to see in real time the dialog between a web server and a navigator.
So you can see on the left panel the included server incoming ou outcoming requests (essentially headers typically hidden), and on the right the client, the navigator.
By default, the server is sending the PureBasic atomic web server sample page (in examples directory). It can be changed with the top gadgets on right side or in the source code. Note that it's possible to use another navigator (like Google's Chrome) on http://localhost:8080 (default port). So you can see how are the headers of misc navigators.
Beware, this code DO contains bugs (as old unused code parts...)
Please note that the server is a fully working multi threaded server able to send files and other stuff, but it only handles a little set of commands. To go further, please see in the code, and search on the forums about web servers done in PB (as the simple webserver ++ de falsam), and on DarkPlayer's HTTP library among others.
Version 1 (02/14/2017) : server and client OK
Version 1.1 (01/01/2019) : cleaning and cleaned HexToDec function by olliv
Code: Select all
; ****************************************************************************
;
; Realtime HTTP client-server spotter ; HTTP server demo
; (c)djes 2017
;
; ~ENGLISH
; Displays a realtime HTTP client/server dialog
; Left side shows incoming and outcoming strings from integrated server
; Right side is the client, a navigator who interprets pages.
;
; You have to give the path to your HTML files (index.html by default)
;
; ~FRENCH
; Affiche un dialogue HTTP client/serveur en temps réel
; Le côté gauche affiche les chaînes entrantes et sortantes du serveur intégré
; Le côté droit est le client (un navigateur) qui interprête les pages.
;
; Vous devez spécifier le chemin de vos fichiers HTML (index.html par défaut)
;
;TODO : realtime requests editing and uploading
;
; ****************************************************************************
EnableExplicit
Enumeration
#WEBGADGET
#BUTTON_BACKWARD
#BUTTON_FORWARD
#BUTTON_HOME
#BUTTON_PRINT
#BUTTON_SEARCH
#BUTTON_QUIT
#STRING_URL
#STRING_SERVERBASEDIR
#BUTTON_SERVERBASEPATHREQUEST
#SCINTILLA_SERVERINPUTLOG
#SCINTILLA_SERVEROUTPUTLOG
EndEnumeration
#ENTERKEY_EVENT = 15
#BS_FLAT = $8000
#TH32CS_SNAPHEAPLIST = $1
#TH32CS_SNAPPROCESS = $2
#TH32CS_SNAPTHREAD = $4
#TH32CS_SNAPMODULE = $8
#TH32CS_SNAPALL = #TH32CS_SNAPHEAPLIST | #TH32CS_SNAPPROCESS | #TH32CS_SNAPTHREAD | #TH32CS_SNAPMODULE
#TH32CS_INHERIT = $80000000
#INVALID_HANDLE_VALUE = - 1
#PROCESS32LIB = 9999
#PACKET_SIZE = 524288
Structure SentFile
ClientID.l
Header$
FileNumber.l
FileLength.l
*FileBuffer
*HeaderOffset
EndStructure
; NOTE : I've chosen to add processes to this list so that it can be played with as necessary...
Global NewList Process32.PROCESSENTRY32 ()
Global EOL$, hWnd
Global BaseDirectory$, StartPage$
EOL$ = Chr(13) + Chr(10)
; ****************************************************************************
; ; From code by 'PB'...
; ; (h$ can be 0 - FFFFFFF)
;
; Procedure.i HexToDec (h$)
; Define r.i, d.i, a$
; If Left (h$, 1) = "%" : h$ = Right (h$, Len (h$) - 1) : EndIf
; h$ = UCase (h$)
; For r = 1 To Len (h$)
; d = d << 4 : a$ = Mid (h$, r, 1)
; If Asc (a$) > 60
; d = d + Asc (a$) - 55
; Else
; d = d + Asc (a$) - 48
; EndIf
; Next
; ProcedureReturn d
; EndProcedure
Procedure.i HexToDec (h$)
h$ = ReplaceString(h$, "%", "")
ProcedureReturn Val("$" + h$)
EndProcedure
; ****************************************************************************
Procedure.s UnHexURL(url$)
Define pos.i, hexx$, url$
Repeat
pos = FindString (url$, "%", 0)
If pos
hexx$ = Mid (url$, pos, 3)
url$ = ReplaceString (url$, hexx$, Chr (HexToDec (hexx$)))
EndIf
Until pos = 0
ProcedureReturn url$
EndProcedure
; ****************************************************************************
Procedure.s AlphaOnly(chaine$)
Define d$ = "", i.i, c.i
For i = 1 To Len(chaine$)
c = Asc(Mid(chaine$, i, 1))
;convertit quelques accents
If (c >= 192 And c <= 197) Or (c >= 224 And c <= 229) : c = Asc("a") : EndIf
If c = Asc("Ç") Or c = Asc("ç") : c = Asc("c") : EndIf
If (c >= $C8 And c <= $CB) Or (c >= $E8 And c <= $EB) : c = Asc("e") : EndIf
If (c >= 204 And c <= 207) Or (c >= 236 And c <= 239) : c = Asc("i") : EndIf
If (c >= 210 And c <= 214) Or (c >= 242 And c <= 246) : c = Asc("o") : EndIf
If (c >= 217 And c <= 220) Or (c >= 249 And c <= 252) : c = Asc("u") : EndIf
If (c >= 65 And c <= 90) Or (c >= 97 And c <= 122) : d$ = d$ + Chr(c) : EndIf ;ne garde que les caractères alpha
Next
ProcedureReturn d$
EndProcedure
; ****************************************************************************
Procedure.s TransformSeparators(chaine$)
Define d$ = "", i.i, c.i, d$
For i = 1 To Len(chaine$)
c = Asc(Mid(chaine$, i, 1))
;convertit les caractères spéciaux en séparateurs ( + )
If (c >= 0 And c <= 36) Or (c >= 38 And c <= 42) Or (c >= 44 And c <= 47) Or (c >= 58 And c <= 64) Or (c >= 91 And c <= 96) Or (c >= 123 And c <= 191) : c = Asc(" + ") : EndIf
d$ = d$ + Chr(c)
Next
ProcedureReturn d$
EndProcedure
; ****************************************************************************
Procedure.i BuildRequestHeader( *Buffer, DataLength.l, ContentType$ )
Define Length.i
Length = PokeS( *Buffer, "HTTP/1.1 200 OK" + EOL$, -1, #PB_UTF8) : *Buffer + Length
;Length = PokeS( *Buffer, "Date : Wed, 07 Aug 1996 11 : 15 : 43 GMT" + EOL$, -1, #PB_UTF8) : *Buffer + Length
Length = PokeS( *Buffer, "Server: DjesMiniServ" + EOL$, -1, #PB_UTF8) : *Buffer + Length
Length = PokeS( *Buffer, "Content-Length: " + Str(DataLength) + EOL$, -1, #PB_UTF8) : *Buffer + Length
Length = PokeS( *Buffer, "Content-Type: " + ContentType$ + EOL$, -1, #PB_UTF8) : *Buffer + Length
Length = PokeS( *Buffer, EOL$, -1, #PB_UTF8) : *Buffer + Length
; Length = PokeS( *Buffer, "Last - modified : Thu, 27 Jun 1996 16 : 40 : 50 GMT" + Chr(13) + Chr(10) , *Buffer) : *Buffer + Length
; Length = PokeS( *Buffer, "Accept - Ranges : bytes" + EOL$ , *Buffer) : *Buffer + Length
; Length = PokeS( *Buffer, "Connection : close" + EOL$) : *Buffer + Length
ProcedureReturn *Buffer
EndProcedure
; ****************************************************************************
Procedure.i BuildNotFoundHeader( *Buffer, DataLength.l )
Define Length.i
Length = PokeS( *Buffer, "HTTP/1.1 404 Not Found" + EOL$, -1, #PB_UTF8) : *Buffer + Length
Length = PokeS( *Buffer, "Content-Type: text/html" + EOL$, -1, #PB_UTF8) : *Buffer + Length
Length = PokeS( *Buffer, "Content-Length: " + Str(DataLength) + EOL$, -1, #PB_UTF8) : *Buffer + Length
Length = PokeS( *Buffer, EOL$, -1, #PB_UTF8) : *Buffer + Length
ProcedureReturn *Buffer
EndProcedure
; ****************************************************************************
Procedure FileSendingThread( *ThreadVariables.SentFile)
Define nb.i, i.i
Define ClientID.i = *ThreadVariables\ClientID
Define FileNumber.i = *ThreadVariables\FileNumber
Define FileLength.i = *ThreadVariables\FileLength
Define *FileBuffer = *ThreadVariables\FileBuffer
Define *HeaderOffset = *ThreadVariables\HeaderOffset
; Envoie d'abord l'entête HTTP (mieux pour les gros fichiers, ça évite de faire patienter le client)
SendNetworkData(ClientID, *FileBuffer, *HeaderOffset - *FileBuffer)
; Envoie le fichier en parts de #PACKET_SIZE octets
nb = FileLength / #PACKET_SIZE
If nb > 0
For i = 1 To nb
ReadData(FileNumber, *HeaderOffset, #PACKET_SIZE)
While SendNetworkData(ClientID, *HeaderOffset, #PACKET_SIZE) < #PACKET_SIZE
Delay(100)
Wend
Next i
EndIf
;reste
i = FileLength%#PACKET_SIZE
If i > 0
ReadData(FileNumber, *HeaderOffset, i)
While SendNetworkData(ClientID, *HeaderOffset, i) < i
Delay(100)
Wend
EndIf
CloseFile(FileNumber)
FreeMemory(*ThreadVariables)
EndProcedure
; ****************************************************************************
Procedure NavigationCallback(Gadget, URL.s)
SetGadgetText(#STRING_URL, URL)
ProcedureReturn #True
EndProcedure
; ****************************************************************************
Procedure Navigator(x, y, w, h, URL.s)
Define i.i, s.l
;If WebGadget(#WEBGADGET, 0, 0, ScreenWidth, ScreenHeight, "file://" + Index)
If WebGadget(#WEBGADGET, x, y, w, h, URL)
SetGadgetAttribute(#WEBGADGET, #PB_Web_NavigationCallback, @NavigationCallback())
ButtonGadget(#BUTTON_BACKWARD, x + 1, 1, 40, 30, "Back")
GadgetToolTip(#BUTTON_BACKWARD, "Page précédente")
ButtonGadget(#BUTTON_FORWARD, x + 43, 1, 40, 30, "Forw")
GadgetToolTip(#BUTTON_FORWARD, "Page suivante")
ButtonGadget(#BUTTON_HOME, x + 85, 1, 40, 30, "Home")
GadgetToolTip(#BUTTON_HOME, "Page d'accueil")
ButtonGadget(#BUTTON_PRINT, x + 127, 1, 40, 30, "Print")
GadgetToolTip(#BUTTON_PRINT, "Imprimer")
ButtonGadget(#BUTTON_SEARCH, x + 170, 1, 64, 30, "Search")
GadgetToolTip(#BUTTON_SEARCH, "Rechercher")
ButtonGadget(#BUTTON_QUIT, x + w - 32, 1, 30, 30, "Quit")
GadgetToolTip(#BUTTON_QUIT, "Quitter")
StringGadget(#STRING_URL, x + 234, 8, 320, 16, URL)
;"Aplatit" les boutons
For i = #BUTTON_BACKWARD To #BUTTON_QUIT
s = GetWindowLong_(GadgetID(i), #GWL_STYLE)
SetWindowLong_(GadgetID(i), #GWL_STYLE, #BS_FLAT|s )
HideGadget(i, 0) ; Need to redraw the gadget after changing it's style : (
Next
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
; ****************************************************************************
Procedure ServerGadgets(x, y, w, h)
InitScintilla()
ScintillaGadget(#SCINTILLA_SERVERINPUTLOG, x, y, w, h/2, 0)
ScintillaGadget(#SCINTILLA_SERVEROUTPUTLOG, x, y + h / 2, w, h/2, 0)
TextGadget( #PB_Any, x + 1, 1, 320, 16, "Server base directory")
StringGadget(#STRING_SERVERBASEDIR, x + 1, 16, 320, 16, BaseDirectory$)
ButtonGadget(#BUTTON_SERVERBASEPATHREQUEST, x + 321, 15, 18, 18, "...")
EndProcedure
; ****************************************************************************
Procedure ServerInputLog(Text.s)
ScintillaSendMessage(#SCINTILLA_SERVERINPUTLOG, #SCI_APPENDTEXT, Len(Text), UTF8(Text))
EndProcedure
; ****************************************************************************
Procedure ServerOutputLog(Text.s)
ScintillaSendMessage(#SCINTILLA_SERVEROUTPUTLOG, #SCI_APPENDTEXT, Len(Text), UTF8(Text))
EndProcedure
; ****************************************************************************
Procedure ServerSendString(ClientID, head$, body$)
ServerOutputLog("- Header start" + EOL$)
SendNetworkString(ClientID, head$)
ServerOutputLog("- Header end" + EOL$)
ServerOutputLog("- Content start" + EOL$)
SendNetworkString(ClientID, body$)
ServerOutputLog(body$ + EOL$)
ServerOutputLog("- Content end" + EOL$)
EndProcedure
; ****************************************************************************
;
Procedure ServerSendFile(ClientID.i, File$)
Define *ThreadVariables.SentFile
Define RequestedFile$ = UnHexURL(Right(File$, Len(File$) - 1)) ; Enlève un car à la chaîne et convertit les car spéciaux %
Define DefaultPage$ = "index.html"
Define ContentType$
Define.i FileNumber, FileLength
Define *FileBuffer, *HeaderOffset
Define Error$
If RequestedFile$ = ""
RequestedFile$ = DefaultPage$
Else
RequestedFile$ = ReplaceString(RequestedFile$, "/", "\")
EndIf
;Exemple de remplacement de fichier
; If Right(RequestedFile$, 11) = "function.js"
; BaseDirectory$ = ""
; RequestedFile$ = "fakefunction.js"
; EndIf
;Exemple de commande serveur directe
; If Right(RequestedFile$, 4) = "Quit"
; End
; EndIf
;type MIME du fichier demandé
Select LCase(GetExtensionPart(RequestedFile$))
Case "gif"
ContentType$ = "image/gif"
Case "zip"
ContentType$ = "multipart/x-zip"
Case "bmp"
ContentType$ = "image/bmp"
Case "png"
ContentType$ = "image/png"
Case "jpg"
ContentType$ = "image/jpeg"
Case "jpeg"
ContentType$ = "image/jpeg"
Case "tif"
ContentType$ = "image/tif"
Case "tiff"
ContentType$ = "image/tif"
Case "wav"
ContentType$ = "audio/wav"
Case "txt"
ContentType$ = "text/plain"
Case "doc"
ContentType$ = "application/msword"
Case "xls"
ContentType$ = "application/vnd.ms-excel"
Case "js"
ContentType$ = "text/javascript"
Case "zip"
ContentType$ = "application/zip"
Case "exe"
ContentType$ = "application/octet-stream"
Case "pdf"
ContentType$ = "application/pdf"
Case "mov"
ContentType$ = "video/quicktime"
Case "qt"
ContentType$ = "video/quicktime"
Case "avi"
ContentType$ = "video/avi"
Case "mpg"
ContentType$ = "video/mpg"
Case "mpeg"
ContentType$ = "video/mpeg"
Case "swf"
ContentType$ = "application/x-shockwave-flash"
Case "htm"
ContentType$ = "text/html"
Case "html"
ContentType$ = "text/html"
Default
ContentType$ = "application/octet-stream"
EndSelect
;Si le type est du genre à être accepté directement par le navigateur
If ContentType$ <> "misc"
;Test if the file exists, and if not display the error message
FileNumber + 1
If ReadFile(FileNumber, BaseDirectory$ + RequestedFile$)
ServerOutputLog("--- Sending " + BaseDirectory$ + RequestedFile$ + " file" + EOL$)
FileLength = Lof(FileNumber)
If FileLength > 0
; Réserve la mémoire puis crée un thread qui va s'occuper d'envoyer le fichier. Nous pouvons passer aux requêtes suivantes
*FileBuffer = AllocateMemory(#PACKET_SIZE + 512) ; taille de l'header + taille d'un paquet
If *FileBuffer <> 0
*HeaderOffset = BuildRequestHeader( *FileBuffer, FileLength, ContentType$)
ServerOutputLog("- Header start" + EOL$)
ServerOutputLog(PeekS(*FileBuffer, *HeaderOffset - *FileBuffer, #PB_UTF8))
ServerOutputLog("- Header end" + EOL$)
*ThreadVariables = AllocateMemory(SizeOf(SentFile))
*ThreadVariables\ClientID = ClientID
*ThreadVariables\FileNumber = FileNumber
*ThreadVariables\FileLength = FileLength
*ThreadVariables\FileBuffer = *FileBuffer
*ThreadVariables\HeaderOffset = *HeaderOffset
ServerOutputLog("- Content to send : " + Str(FileLength) + " bytes" + EOL$)
CreateThread(@FileSendingThread(), *ThreadVariables)
ServerOutputLog("- Content sent (not shown here)" + EOL$)
EndIf
EndIf
Else
ServerOutputLog("--- ERROR 404 - File requested " + BaseDirectory$ + RequestedFile$ + " not found" + EOL$)
; Essaye de trouver le fichier 404.htm sinon envoie un message standard
If ReadFile(0, BaseDirectory$ + "404.htm")
FileLength = Lof(0)
*FileBuffer = AllocateMemory(FileLength + 512)
If *FileBuffer <> 0
ServerOutputLog("--- Sending found 404.htm file" + EOL$)
*HeaderOffset = BuildNotFoundHeader( *FileBuffer, FileLength)
ServerOutputLog("- Header start" + EOL$)
ServerOutputLog(PeekS(*FileBuffer, *HeaderOffset - *FileBuffer, #PB_UTF8))
ServerOutputLog("- Header end" + EOL$)
ReadData(0, *HeaderOffset, FileLength)
CloseFile(0)
ServerOutputLog("- Content to send : " + Str(FileLength) + " bytes" + EOL$)
SendNetworkData(ClientID, *FileBuffer, *HeaderOffset - *FileBuffer + FileLength)
ServerOutputLog("- Content sent (not shown here)" + EOL$)
FreeMemory(*FileBuffer)
EndIf
Else
ServerOutputLog("--- 404.htm error file not found" + EOL$)
Error$ = "<HTML><BODY>File not found</BODY></HTML>" + EOL$
*FileBuffer = AllocateMemory(Len(Error$) + 512)
If *FileBuffer <> 0
ServerOutputLog("--- Sending a minimal 404 error page" + EOL$)
*HeaderOffset = BuildNotFoundHeader( *FileBuffer, Len(Error$))
ServerOutputLog("- Header start" + EOL$)
ServerOutputLog(PeekS(*FileBuffer, *HeaderOffset - *FileBuffer, #PB_UTF8))
ServerOutputLog("- Header end" + EOL$)
PokeS( *HeaderOffset, Error$, -1, #PB_UTF8|#PB_String_NoZero)
ServerOutputLog("- Content start" + EOL$)
SendNetworkData(ClientID, *FileBuffer, *HeaderOffset - *FileBuffer + Len(Error$))
ServerOutputLog(Error$ + EOL$ + "- Content end" + EOL$)
FreeMemory(*FileBuffer)
EndIf
EndIf
EndIf
EndIf
EndProcedure
; ****************************************************************************
Procedure HandleIncomingRequest(ClientID.i, *IncomingRequestBuffer)
Define File$ = ""
Define http$ = ""
Define program$ = ""
Define command$
Define parameter$
Define.i eop = 0, eoc = 0, deb = 0, fin, count, loc
Define c$
Define head$
Define body$
Define Incoming$ = PeekS( *IncomingRequestBuffer, -1, #PB_UTF8)
ServerInputLog(Incoming$)
If Incoming$ <> ""
eoc = FindString(Incoming$, " ", 0) ; End of command part of Incoming$
If eoc > 0
command$ = LCase(Left (Incoming$, eoc)) ; Command part of Incoming$
parameter$ = Mid(Incoming$, eoc + 1, Len(Incoming$) - eoc - 1) ; Parameter part of Incoming$
EndIf
EndIf
Select command$
Case "get "
eop = FindString(parameter$, " ", 0) ; End of first parameter ("GET")
If eop > 0
File$ = Mid(parameter$, 1, eop - 1) ; First parameter ("/thisfile.txt")
http$ = Mid(parameter$, eop + 1, Len(parameter$) - eop - 1) ; Second parameter
Else
File$ = Mid(parameter$, eop + 1, Len(parameter$) - eop - 1) ; Second parameter
EndIf
Case "post "
eop = FindString(parameter$, " ", 0) ; End of first parameter ("POST")
If eop > 0
File$ = Mid(parameter$, 1, eop - 1) ; First parameter ("/thisfile.txt")
http$ = Mid(parameter$, eop + 1, Len(parameter$) - eop - 1) ; Second parameter
Else
File$ = Mid(parameter$, eop + 1, Len(parameter$) - eop - 1) ; Second parameter
EndIf
Case "user-agent: "
program$ = Mid(Incoming$, eoc + 1, Len(Incoming$) - eoc - 1)
EndSelect
; Default page
If File$ = "/" : File$ = "/" + StartPage$ : EndIf
;S'il n'y pas de fichier spécifié, il s'agit sans doute d'un autre type de requête
If File$ <> "" Or http$ <> ""
Dim words$(16)
;- extraction des mots envoyés par la page, ici, recherche du champ "text"
deb = FindString(File$, "text=", 0)
If deb <> 0
fin = FindString(File$, "&", 0)
If fin = 0 : fin = Len(File$) : EndIf ;si il n'y a pas de '&', c'est qu'il n'y a pas d'autres paramètres (on n'a pas appuyé sur le submit)"
File$ = Mid(File$, deb + 5, fin - deb - 4)
;Debug File$
;nettoie la chaine pour la recherche
File$ = TransformSeparators(LCase(UnHexURL(File$)))
count = 0
loc = FindString (File$, " + ", 0)
While loc <> 0 And count<16
c$ = AlphaOnly(Mid(File$, 1, loc - 1))
If Len(c$)>1
words$(count) = c$
EndIf
File$ = Right(File$, Len(File$) - loc)
loc = FindString(File$, " + ", 0)
count = count + 1
Wend
;dernier mot
If count < 16
c$ = AlphaOnly(LCase(UnHexURL(File$)))
words$(count) = c$
EndIf
ServerOutputLog("--- Search command" + EOL$)
;écrit l'en tête de la page de résultats
head$ = "HTTP/1.1 200 OK" + EOL$
head$ = head$ + "Server: DjesMiniserv" + EOL$
;contient la taille de la page à envoyer; sera modifié à la fin avec la taille réelle comprenant l'entête
head$ = head$ + "Accept-Ranges: bytes" + EOL$
; SendNetworkString(ClientID, "Connection : close" + EOL$) ;pour les connexions non persistantes
; head$ = head$ + "Connection: close" + EOL$
head$ = head$ + "Content-Type: text/html" + EOL$
head$ = head$ + "Content-Length: *% *% *%" + EOL$
head$ = head$ + EOL$
body$ = "<html>" + EOL$
body$ = body$ + EOL$
body$ = body$ + "<head>" + EOL$
body$ = body$ + "</head>" + EOL$
body$ = body$ + "<body bgcolor=#003366 link=#AAAAFF vlink=#AAAAFF>" + EOL$
body$ = body$ + "<FONT COLOR='#FFFFFF'><H3>Résultat de la recherche</H3></FONT>"
body$ = body$ + "</body>" + EOL$
body$ = body$ + "</html>" + EOL$
;Debug Str(Len(body$))
head$ = ReplaceString(head$, " *% *% *%", Str(Len(body$)))
;attention aux chaines de plus de 65535 cars!
ServerSendString(ClientID, head$, body$)
Else
;si il y a un fichier spécifié, va le chercher et l'envoie au client
ServerSendFile(ClientID, File$)
EndIf
Else
ServerOutputLog("--- Unknown command" + EOL$)
head$ = "HTTP/1.1 200 OK" + EOL$
head$ = head$ + "Server : DjesMiniserv" + EOL$
head$ = head$ + "Accept - Ranges : bytes" + EOL$
head$ = head$ + "Content - Length : *% *% *%" + EOL$
head$ = head$ + "Content - Type : text/html" + EOL$
head$ = head$ + EOL$
body$ = "<html>" + EOL$
body$ = body$ + EOL$
body$ = body$ + "<head>" + EOL$
body$ = body$ + "</head>" + EOL$
body$ = body$ + "<body bgcolor = '#003366'>" + EOL$
body$ = body$ + "<font color = '#FFFFFF'>Unknown command</font>" + EOL$
body$ = body$ + "</body>" + EOL$
body$ = body$ + "</html>" + EOL$
head$ = ReplaceString(head$, " *% *% *%", Str(Len(body$)))
ServerSendString(ClientID, head$, body$)
EndIf
EndProcedure
; ****************************************************************************
;-*** START
If InitNetwork() = 0
MessageRequester("Error", "Network functions can't be initialised.", 0)
End
EndIf
;Chemin de notre programme
;Define ApplicationDirectory.s = GetPathPart(ProgramFilename()) : If Right(ApplicationDirectory, 1) <> "\" : ApplicationDirectory + "\" : EndIf
BaseDirectory$ = #PB_Compiler_Home + "Examples\Sources - Advanced\Atomic Web Server\WWW\"
StartPage$ = "index.html"
Define MyServerPort.w = 8080
Define BaseURL.s = "http://127.0.0.1:" + StrU(MyServerPort, #PB_Word) + "/"
Define Quit = 0
Define ScreenWidth.i = GetSystemMetrics_(#SM_CXSCREEN), ScreenHeight.i = GetSystemMetrics_(#SM_CYSCREEN)
Define MyWindowWidth.i = ScreenWidth * 0.75
Define MyWindowHeight.i = ScreenHeight * 0.75
Define hBrush.i
Define DefaultNavigatorName.s
Define Socket.i
Define.i WEvent, SEvent, ClientID
Define *IncomingRequestBuffer
Define Done.i
Define i.i
Define RequestLength.i
Define Error.l
Define Path$
*IncomingRequestBuffer = AllocateMemory(8192)
If *IncomingRequestBuffer = 0
MessageRequester("Error", "Can't allocate 8192 bytes of memory.", 0)
End
EndIf
Socket = CreateNetworkServer(0, MyServerPort, #PB_Network_TCP, "127.0.0.1")
If Socket
hWnd.i = OpenWindow(0, 0, 0, MyWindowWidth, MyWindowHeight, "Realtime HTTP Spotter", #PB_Window_SystemMenu | #PB_Window_ScreenCentered )
If hWnd
; ;Couleur de fond
; hBrush = CreateSolidBrush_(RGB(00, $33, $66))
; SetClassLong_(hWnd, #GCL_HBRBACKGROUND, hBrush)
; InvalidateRect_(hWnd, #Null, #True)
AddKeyboardShortcut(0, #PB_Shortcut_Return, #ENTERKEY_EVENT)
ServerGadgets(0, 40, MyWindowWidth/2, MyWindowHeight)
ServerInputLog("*** Server input log" + EOL$)
ServerOutputLog("*** Server output log" + EOL$)
ServerOutputLog("--- Server started" + EOL$)
;Différentes manips de la fenêtre
; SetWindowLong_(WindowID(), #GWL_EXSTYLE, #WS_EX_TOOLWINDOW) ; enlève l'icone de la barre des tâches (avec l'option invisible de la fenêtre)
; ShowWindow_(WindowID(), #SW_SHOW)
; BackWindow(WindowID()) ; met la fenêtre à l'arrière plan
;Essaye de créer une fenêtre web
If Navigator(MyWindowWidth/2, 40, MyWindowWidth/2, MyWindowHeight, BaseURL + StartPage$)
DefaultNavigatorName = "WebGadget"
; Fred the genius stored the Interface pointer to IWebBrowser2 in the DATA
; member of the windowstructure of the WEBGADGET containerwindow, so we can get
; that easily :
;récupère le pointeur du gadget
; WebObject.IWebBrowser2 = GetWindowLong_(GadgetID(#WEBGADGET), #GWL_USERDATA)
Else
MessageRequester("Error", "Can't integrate a navigator window", 0)
End
EndIf
;Fait que les événements réseaux réveillent la fenêtre
; #FD_ALL = #FD_READ|#FD_WRITE|#FD_OOB|#FD_ACCEPT|#FD_CONNECT|#FD_CLOSE
#FD_ALL = #FD_OOB|#FD_ACCEPT|#FD_CONNECT|#FD_CLOSE
WSAAsyncSelect_(Socket, WindowID(0), #WM_NULL, #FD_ALL)
Delay(2000)
Repeat
;- Window events
WEvent = WindowEvent()
If WEvent = 0 : Delay(10) : EndIf
If WEvent = #PB_Event_Gadget
Select EventGadget()
Case #BUTTON_BACKWARD
SetGadgetState(#WEBGADGET, #PB_Web_Back)
;SetGadgetState(#WEBGADGET, #PB_Web_Refresh)
Case #BUTTON_FORWARD
SetGadgetState(#WEBGADGET, #PB_Web_Forward)
;SetGadgetState(#WEBGADGET, #PB_Web_Refresh)
Case #BUTTON_HOME
SetGadgetText(#WEBGADGET, "\")
;SetGadgetState(#WEBGADGET, #PB_Web_Refresh)
Case #BUTTON_SEARCH
SetGadgetText(#WEBGADGET, BaseURL + "search.htm")
;SetGadgetState(#WEBGADGET, #PB_Web_Refresh)
Case #BUTTON_SERVERBASEPATHREQUEST
Path$ = PathRequester("Please select the new server base directory", BaseDirectory$)
If Path$
BaseDirectory$ = Path$
SetGadgetText(#STRING_SERVERBASEDIR, BaseDirectory$)
EndIf
Case #STRING_URL
If EventType() = #PB_EventType_LostFocus
SetGadgetText(#WEBGADGET, GetGadgetText(#STRING_URL))
EndIf
Case #BUTTON_QUIT
Quit = 1
EndSelect
EndIf
;Shortcuts and menu events (like enter key in a string gadget...)
If WEvent = #PB_Event_Menu
Select EventMenu()
Case #ENTERKEY_EVENT
If GetActiveGadget() = #STRING_URL
SetGadgetText(#WEBGADGET, GetGadgetText(#STRING_URL))
EndIf
If GetActiveGadget() = #STRING_SERVERBASEDIR
BaseDirectory$ = GetGadgetText(#STRING_SERVERBASEDIR)
EndIf
EndSelect
EndIf
;- Server events
SEvent = NetworkServerEvent()
If SEvent
ClientID = EventClient()
Select SEvent
;New client
Case #PB_NetworkEvent_Connect
;A client is leaving
Case #PB_NetworkEvent_Disconnect
;CloseNetworkConnection(ClientID)
;Raw data has been received
Case #PB_NetworkEvent_Data
Done = #False
; If done then close Socket, either gracefull or due to an error
Repeat
FillMemory(*IncomingRequestBuffer, 4096, 0, #PB_Integer)
RequestLength = ReceiveNetworkData(ClientID, *IncomingRequestBuffer, 4096)
If RequestLength > 0
HandleIncomingRequest(ClientID, *IncomingRequestBuffer)
ElseIf RequestLength = 0
Done = #True
Else
Error = WSAGetLastError_()
If Error = #WSAEWOULDBLOCK
; We are non-blocking so : no more data to read
Delay(100)
Done = #True
; So close the socket
ElseIf Error <> 0
Done = #True
EndIf
EndIf
Until Done = #True
EndSelect
EndIf
Until WEvent = #PB_Event_CloseWindow Or Quit = 1
Else
MessageRequester("Error", "Can't open main window", 0)
EndIf
CloseNetworkServer(0)
ServerOutputLog("--- Server stopped" + EOL$)
Else
MessageRequester("Error", "Selected port is occupied. Try to close all servers and start again.", 0)
EndIf
End