Realtime HTTP client-server spotter

Share your advanced PureBasic knowledge/code with the community.
User avatar
djes
Addict
Addict
Posts: 1806
Joined: Sat Feb 19, 2005 2:46 pm
Location: Pas-de-Calais, France

Realtime HTTP client-server spotter

Post by djes »

~ Realtime HTTP client-server spotter ~

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&eacute;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
Last edited by djes on Tue Jan 01, 2019 1:11 pm, edited 1 time in total.
User avatar
minimy
Enthusiast
Enthusiast
Posts: 344
Joined: Mon Jul 08, 2013 8:43 pm

Re: Realtime HTTP client-server spotter

Post by minimy »

Great job @djes!
Very interesting!
Thanks for share!
If translation=Error: reply="Sorry, Im Spanish": Endif
User avatar
djes
Addict
Addict
Posts: 1806
Joined: Sat Feb 19, 2005 2:46 pm
Location: Pas-de-Calais, France

Re: Realtime HTTP client-server spotter

Post by djes »

Little update, thanks to olliv
Post Reply