Realtime HTTP client-server spotter
Suite au sujet de falsam sur la mise à jour unicode de l'atomic web server (voir http://www.purebasic.fr/french/viewtopi ... =6&t=16482), j'ai commencé à retravailler un vieux code de serveur web pour voir en direct le dialogue entre un serveur et un navigateur.
Vous avez donc à gauche la partie serveur, à droite la partie navigateur, et vous pouvez observer en direct le dialogue entre les deux, dont les fameux "headers" (entêtes) qui sont habituellement cachés aux internautes.
Par défaut, le serveur affiche la page index.html incluse dans les exemples de PureBasic pour l'Atomic Web Server. Cela peut se changer avec les gadgets en haut et bien sûr dans le source.
A noter qu'une fois le programme lancé, il est possible d'utiliser un autre navigateur local (tel que chrome) sur l'adresse http://localhost:8080 (port par défaut), ce qui vous permet de voir les autres types d'entête des autres navigateurs.
Attention, ce code n'est pas exempt de bugs.
A noter également que le serveur inclus est un véritable serveur http multithread, avec gestion des fichiers, même s'il ne prend en charge qu'un petit ensemble de commandes. Pour aller plus loin, faire une recherche sur le forum sur les serveurs faits en PB (dont simple webserver ++ de falsam), et sur la bibliothèque HTTP de DarkPlayer, entre autres
Version 1 (14/02/2017) : serveur et client fonctionnels
Version 1.1 (01/01/2019) : petit nettoyage de code et nouvelle fonction HexToDec par ollivier
Code : Tout sélectionner
; ****************************************************************************
;
; 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