PureBasic

Forums PureBasic
Nous sommes le Mer 19/Juin/2019 0:09

Heures au format UTC + 1 heure




Poster un nouveau sujet Répondre au sujet  [ 7 messages ] 
Auteur Message
 Sujet du message: Observateur de dialogue client-serveur HTTP
MessagePosté: Mar 14/Fév/2017 12:07 
Hors ligne
Avatar de l’utilisateur

Inscription: Ven 11/Fév/2005 17:34
Messages: 4210
Localisation: Arras, France
~ Observateur de dialogue client-serveur HTTP ~

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:
; ****************************************************************************
;
; 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


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Observateur de dialogue client-serveur HTTP
MessagePosté: Mer 15/Fév/2017 0:30 
Hors ligne
Avatar de l’utilisateur

Inscription: Sam 12/Sep/2015 14:31
Messages: 310
Localisation: Alger
mmm ça donne des idées, merci maître :D

_________________
.....i Love Pb :)


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Observateur de dialogue client-serveur HTTP
MessagePosté: Mer 15/Fév/2017 10:30 
Hors ligne
Avatar de l’utilisateur

Inscription: Ven 11/Fév/2005 17:34
Messages: 4210
Localisation: Arras, France
celtic88 a écrit:
mmm ça donne des idées, merci maître :D

Merci, mais je ne suis qu'un humble bidouilleur :oops: :)


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Observateur de dialogue client-serveur HTTP
MessagePosté: Mer 15/Fév/2017 11:21 
Hors ligne
Avatar de l’utilisateur

Inscription: Sam 23/Sep/2006 18:32
Messages: 6626
Localisation: Isere
Aaaaaah !!! ça s'appelle bidouiller ce que tu sais faire !!! 8O
Alors moi aussi, j'aimerais bien aussi savoir bidouiller :mrgreen:

Ca pourrait nous aider à comprendre ces requettes HTTP qui sont pas si simple que ça au final
Marche bien ici, merci pour le partage 8)

_________________
ImageLe bonheur est une route...
Pas une destination

PureBasic Forum Officiel - Site PureBasic


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Observateur de dialogue client-serveur HTTP
MessagePosté: Dim 30/Déc/2018 23:48 
Hors ligne

Inscription: Ven 29/Juin/2007 17:50
Messages: 3413
@Djes

Je ne l'avais pas vu ce code.
Code:
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
Je me demande si cette partie, peu essentielle à la fonction principale du code, n'est pas viable.
Code:
Procedure.i HexToDec (h$)
h$ = ReplaceString(h$, "%", "")
ProcedureReturn Val("$" + h$)
EndProcedure
C'est ce que j'ai réussi à lire pour l'instant. Ça semble un super code, en tout cas.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Observateur de dialogue client-serveur HTTP
MessagePosté: Lun 31/Déc/2018 12:55 
Hors ligne
Avatar de l’utilisateur

Inscription: Ven 11/Fév/2005 17:34
Messages: 4210
Localisation: Arras, France
Ah oui, faut dire que le code original du serveur date un peu. Ça fait quelques années que je voulais en faire cadeau à la communauté, et j'ai fait la mise à jour sans trop rentrer dans les détails.


Haut
 Profil  
Répondre en citant le message  
 Sujet du message: Re: Observateur de dialogue client-serveur HTTP
MessagePosté: Mar 01/Jan/2019 13:11 
Hors ligne
Avatar de l’utilisateur

Inscription: Ven 11/Fév/2005 17:34
Messages: 4210
Localisation: Arras, France
Petite mise à jour, merci à Ollivier


Haut
 Profil  
Répondre en citant le message  
Afficher les messages postés depuis:  Trier par  
Poster un nouveau sujet Répondre au sujet  [ 7 messages ] 

Heures au format UTC + 1 heure


Qui est en ligne

Utilisateurs parcourant ce forum: Google [Bot] et 4 invités


Vous ne pouvez pas poster de nouveaux sujets
Vous ne pouvez pas répondre aux sujets
Vous ne pouvez pas éditer vos messages
Vous ne pouvez pas supprimer vos messages

Rechercher:
Aller à:  

 


Powered by phpBB © 2008 phpBB Group | Traduction par: phpBB-fr.com
subSilver+ theme by Canver Software, sponsor Sanal Modifiye