Un serveur WEB en OpenScheme
Par :
Guilhem de Wailly (gdw@erian-concept.com)

Résumé
Dans cet article, nous continuons la programmation d'un serveur WEB élémentaire en Scheme. Nous utilisons l'environnement Open-Scheme disponible librement sur le site www.open-scheme.com. Certaines fonctionnalités utilisées sont des extensions à la norme du langage qui peuvent être assez facilement portées vers d'entres systèmes Scheme.
Le mois dernier, nous avons utilisé les sockets pour réaliser les connexions à la place de l'utilisation des fichiers d'entrées / sorties standard. Cela permet maintenant d'accéder à notre serveur par le réseau. 
Ce mois-ci, nous allons étendre le serveur pour qu'il puisse afficher des répertoires et leur contenu. La page WEB sera dans ce cas dynamiquement générée par le serveur en fonction du contenu du répertoire. Le type MIME, lorsqu'il est reconnu, sera affiché, ainsi que la taille du fichier et la date de dernière modification.
L'environnement Open-Scheme est amélioré en fonction de ce projet. Aussi, il est nécessaire de se procurer la version la plus récente. Nous faisons notre maximum pour fournir l'environnement en temps et en heure, et librement, sur le serveur WEB d'OpenScheme (www.open-scheme.com) ou sur le CDROM de Linux Magagine. La version light suffit.
Description
Il arrive souvent de tomber sur des serveurs WEB dont le contenu s'affiche comme une liste de fichiers. Les pages HTML correspondantes ne sont pas écrites à l'avance (sauf cas particulier) mais plutôt générées par le serveur en fonction du contenu du répertoire auquel on accède. En fait la règle est assez simple : s'il n'existe pas de fichier d'index (index.html, index.htm ou index.cgi) et que l'on a le droit de lire les entrées du répertoire, alors le serveur génère la liste des fichiers. L'intérêt est que chaque entrée est assortie d'un lien hyper-texte permettant d'accéder à la ressource ; par exemple si l'entrée est un répertoire, le lien hyper-texte permet de rentrer dans ce répertoire.
Nous allons modifier le serveur WEB décrit précédemment dans ces lignes pour qu'il puisse accéder aux répertoires.
Voici ci-dessous un exemple de pages générées par le serveur sur un répertoire. On constate que les entrées du répertoire sont des liens hyper-texte. Certaines entrées sont assorties d'un type déduit de l'extension du nom de la ressource : 

Figure 1: Affichage d'un répertoire ; la page est générée par le serveur. Pour chaque entrée du répertoire, on affiche son type MIME s'il est connu, la taille du fichier et la date de dernière modification. Notez que le serveur fonctionne déjà avec Netscape Nagigator. Le port 8080 a été choisi lors de la création de l'objet serveur.
Pour réaliser cela, le serveur doit détecter que la ressource est un répertoire, que ce répertoire ne contient aucun index par défaut, et que l'utilisateur possède le droit de lire le contenu du répertoire.
Production de la page HTML
Voici en premier lieu la fonction responsable de l'affichage de la page WEB en fonction d'une requête correspondante à un répertoire :
; Production de la page HTML pour un répertoire.
; Query est la requête qui contient la ressource demandée.
; La ressource est la totalité d répertoire, depuis la racine.
(define (output-tree server query)
 (let* ([start  (string-length 
                 (<server>:root-directory server))]
         ; Nom publique de la ressource (suppression
         ; de la racine du serveur).
         [public (substring (<query>:resource query)
                           start 
                           (string-length
                            (<query>:resource query)))])
    ; Entête de la page.
    (display "<html><body>")

    ; Affichage du nom du répertoire affiché.
    (display "<table width=100% cols=1 border=0>\n")
   (display "<tr bgcolor=#aaaaaa><td align=center>")
   (format #t "<b>~a</b></td></tr>\n" public)
   (display "</table>")

    ; Affichage de la table à 4 colones.
    (display "<table width=100% cols=4 border=0>\n")

    ; Titres des colones.
    (display "<tr bgcolor=#aaaaaa>")
   (display "    <th width=1>Resource     </th>\n")
   (display "    <th width=1>Type         </th>\n")
   (display "    <th width=1>Size         </th>\n")
   (display "    <th>Modification date</th></tr>\n")

    ; Si le répertoire n'est pas la racine du serveur
    ; affichage du répertoire .. permettant de remonter
    ; dans le répertoire parent.
    (if (not (eqv? public "/"))
       (begin
         (format #t
                 "<tr><td><a href=~a><b>.&nbsp;.</b></a></td>"
                 (let ([name (os:dirname public)])
                   (if (eqv? name "/.")
                       "/"
                       name)))
         (display "<td>&nbsp;</td><td>&nbsp;</td><td>&nbsp;</td>\n")))

    ; Parcourt des entrées du répertoire.
    (os:rundir (<query>:resource query)
              #f ; pas de sélection de fichier
              #f ; pas de récursion dans les sous-répertoires
              #t ; donner les répertoires
              (lambda (name)
                (let* (; Nom publique de la ressource.
                        [resource (substring name
                                            start
                                            (string-length name))]
                        ; Recherche dans la liste des types MIME
                        ; d'un type correspondant à l'extension
                        ; du fichier.
                        [mime     (assoc (os:extname resource)
                                        *mimes*)]
                        ; S'il existe un type, la description
                        ; est en troisième position.
                        [desc     (if (and mime
                                          (> (length mime) 2))
                                     (caddr mime)
                                     #f)])
                   ; Lien hyper-texte.
                   (format #t "<tr><td><a href=~s>" resource)
                   
                   ; Nom, en gras si c'est un répertoire.
                   (format #t 
                          (if (os:directory? name)
                              "<b>~a/</b>"
                              "~a")
                          (os:basename resource))
                  (display "</a></td>\n")
                  
                   ; Description MIME, si elle existe.
                   (format #t
                          "<td>~a</td>\n" 
                          (if desc desc "&nbsp;"))

                   ; Taille de la ressource.
                   (format #t "<td>~a</td>\n" (os:size name))
                  
                   ; Date de dernière modification.
                   (format #t
                          "<td>&nbsp;&nbsp;~a</td>\n"
                          (date->string (os:modified name)))
                  
                   ; Fin de la ligne du tableau.
                   (display "</tr>\n"))))
                   
    ; Fin du tableau et fin de la page HTML.
    (display "</table></body></html>\n")))
Cette fonction sera invoquée avec une ressource dont on est certain qu'elle correspond à un répertoire et que ce répertoire possède les droits de visite par le serveur.
Elle affiche le nom de la ressource demandée dans une table. Puis les entrées du répertoire sont affichées une à une dans un tableau à quatre colonnes, avec le nom de l'entrée, son type MIME s'il est connu, la taille de la ressource et la date de dernière modification. L'affichage est rendu agréable en utilisant quelques enjoliveurs HTML.
Types MIME
Le format des types MIME a été légèrement modifié depuis sa première présentation, pour prendre en compte la description du type. Chaque entrée de la liste des types est une liste à deux ou trois champs, le premier étant le nom de l'extension du fichier, le second, le type MIME correspondant, ou faux, et le troisième, la description, ou faux ou rien. On a principalement :
(define *mimes*
 '(("htm"  "text/html"  "Page&nbsp;WEB")
   ("html" "text/html"  "Page&nbsp;WEB")
   ("txt"  "text/plain" "Texte")
   ("css"  "text/css"   "Style&nbsp;HTML")
   ("gif"  "image/gif"  "Image&nbsp;GIF")
   ("jpg"  "image/jpeg" "Image&nbsp;JPEG")
   ("jpeg" "image/jpeg" "Image&nbsp;JPEG")
   ("tif"  "image/tiff" "Image&nbsp;TIF")
   ("tiff" "image/tiff" "Image&nbsp;TIFF")
   ("png"  "image/png"  "Image&nbsp;PNG")
   ("tgz"  #f           "Archive")
   ("osm"  "text/html"  "OpenScheme&nbsp;source")
   ("scm"  "text/html"  "Scheme&nbsp;source")
   ("c"    "text/html"  "C&nbsp;source")
   ("h"    "text/html"  "C&nbsp;header")
   ("tgz"  #f           "Archive")
   ("gz"   #f           "Archive")
   ))
Les descriptions des types ne doivent pas contenir d'espaces pour être affichées sur une seule ligne dans le tableau. On remplacera donc les espaces par l'espace insécable HTML noté &nbsp; (attention au point-virgule). Nous avons volontairement réduit la liste des types possibles. Dans le cas d'une liste très longue, on pourra placer les types dans une table de hachage (OpenScheme possède de manière native une bibliothèque pour la gestion des tables de hachage).
Au fait, Christiane, MIME, ça veut dire Multi Purpose Internet Mail Extension :) (Dictionnaire: http://www.iiris.fr/pages/Vocab.htm).
Attention, le format des types MIME du serveur a changé, aussi, nous devons prendre en compte cette modification dans le code existant. La fonction à modifier est output-resource, au début. Cette fonction doit aussi être modifié pour prendre en compte l'affichage des répertoires.
Prise en compte des répertoires
La prise en compte des répertoire se fait au moment de l'analyse de la ressource demandée, dans la fonction output-resource.  Cette fonction avait été présentée initialement, mais simplifiée. Voici donc la nouvelle version :
; Traitement des requêtes
(define (output-resource server query)
 (let* ([resource (<query>:resource query)]
        [protocol (<query>:protocol query)]
        [path?    (path? resource)]
        [ext      (if path? #f (os:extname resource))]
        [mime     (if path? #f (assoc ext *mimes*))]
        [mime     (if mime (cadr mime) #f)]
        [mime     (if mime mime "text/plain")])
   (format *current-error-port* "mime = ~s\n" mime)
    ; si le protocole est supérieur à 0.9, produire
    ; les entêtes
    (if (and (or (string=? protocol "HTTP/1.0")
                (string=? protocol "HTTP/1.1")
                (string=? protocol "HTTP/1.2"))
           (string=? mime "text/plain")
           (string=? mime "text/html"))
       (begin
         (print-header query "200 OK")
         (format #t "Content-Length: ~a\r\n" (os:size resource))
         (format #t "Last-Modified: ~a\r\n\r" 
                 (format-date (os:modified resource)))
         (format #t "Content-Type: ~a\r\n\r\n" mime)))
   (cond [(string-ci=? (<query>:command query) "head")
          (format *current-error-port* "header requested\n")
          'nothing]
          [path?
          (format *current-error-port* "tree requested\n")
          (output-tree server query)]
          [else
          (format *current-error-port* "file requested\n")
          (output-file server query)])))
La prise en compte des répertoires est simplement effectuée lorsque la ressource demandée est un répertoire. Pour l'instant, le serveur ne gère pas les droits d'accès aux ressources. Nous ajouterons cela ultérieurement.
Traitement des requêtes
La dernière fonction à modifier est celle qui traite les requêtes en amont. Elle doit maintenant s'assurer, lorsque la ressource demandée est un répertoire, qu'il n'existe pas d'index par défaut :
(define (process-query server query)
 ; vérification que le répertoire racine existe
 (if (not (os:directory? (<server>:root-directory 
                          server)))
     (print-error server
                  query
                  404 
                  "Not found" 
                  "No such file or directory: "
                  (<server>:root-directory server)))

  ; Vérification qu'un répertoire est terminé par /.
  (let ([url (<query>:url query)])
   (if (os:directory? (path! (<server>:root-directory 
                                server)
                             url))
       (if (not (path? url))
           (<query>:url! query
                         (string-append 
                           (<query>:url query)
                          "/")))))

  ; Si l'URL est un répertoire, vérifier si un index
 ; par défaut n'existe pas.
  (let ([url (<query>:url query)])
   (if (path? url)
       (let loop ([indexes (<server>:default-indexes 
                             server)])
         (if (not (null? indexes))
             (let* ([nurl (string-append 
                            url
                            (car indexes))]
                    [path (path! (<server>:root-directory
                                   server)
                                 nurl)])
               (if (os:exists? path)
                   (<query>:url! query nurl)
                   (loop (cdr indexes))))))))

  ; Fabrication du nom de la ressource
  (<query>:resource! query
                    (path! (<server>:root-directory server)
                           (<query>:url query)))

  ; Vérification des droits d'accès
  (check-access server query)

  ; Obtention de la ressource
  (let ([err (trap (output-resource server query))])
   (if err
       (format *current-error-port* 
                "*** Error ~a\n"
                err))))
Les ajouts en rouges permettent de s'assurer que le nom d'un répertoire est bien terminé par le caractère / et le cas échéant, de l'ajouter. Puis la fonction vérifie aussi que, dans le répertoire demandé, il n'existe pas d'index par défaut. S'il en existe un, il est rajouté à la ressource. Le reste à déjà été expliqué précédemment.
Avec ces ajouts et modifications, notre serveur est maintenant capable de naviguer dans le système de fichier du serveur WEB.
L'auteur

Guilhem de Wailly, directeur de la société Erian Concept : support, formations, configurations, administration, développements Linux. Environnement Open-Scheme.
http://www.erian-concept.com
Références
WEB
¨	TCP/IP, Architecture, protocoles, applications
Douglas Comer
InterEdition
·	W3C
http://www.w3c.org
·	CGI
http://www.jmarshall.com/easy/cgi/
·	CGI
http://hoohoo.ncsa.uiuc.edu/cgi/
·	CGI
http://www.tsden.org/ryutaroh/fileupload-e.shtml
·	CGI en Français
http://www.scripts-fr.com/
·	CGI+Scheme
http://www.lh.com/~oleg/ftp/Scheme/web.html
·	FastCGI
http://www.fastcgi.com/
·	HTTP en Français
http://webbo.enst-bretagne.fr/ActiveWebFr/eg-uk-tut.book_29.fr.html
·	HTTP 1.0
http://www.ietf.org/rfc/rfc1945.txt
·	HTTP 1.1
http://www.ietf.org/rfc/rfc2616.txt
Scheme
¨	Structure et Interprétation des programmes informatiques
H. Abelson, GJ. Sussman
InterEdition
¨	The Scheme Programming Languages - Ansi Scheme 
R. Kent Dybvig
Prentice Hall
¨	Les langages Lisps - Christian Queinnec
InterEdition
¨	Programmer avec Scheme - J. Chazarin
Thomson Publishing
¨	Revised4 Report on the Algorithmic Language Scheme
W. Clinger, J. Rees
ftp://ftp.nj.nec.com/pub/kelsey
Environnements Scheme Free
¨	Bigloo - Manuel Serrano
http://kaolin.unice.fr
Environnement de programmation Scheme.
¨	DrScheme - Rice University
http://www.cs.rice.edu/CS/PLT/
Environnement Scheme libre très avancé.
¨	PCScheme - Texas Instrument
ftp://cui.unige.ch/public/pcs/pcscheme.exe
Un très bon environnement de programmation Scheme pour DOS, avec éditeur intégré.
¨	Scm - A. Jaffer
http://www-swiss.ai.mit.edu/~jaffer
La référence des interprètes Scheme. Très petit, rapide, pour beaucoup de plates-formes, extensible.
¨	Stk - Erik Gallesio
http://kaolin.unice.fr
Interprète Scheme avec la bibliothèque TK.
D'autres liens sont visibles sur le site www.schemers.org.
Environnements Scheme commerciaux
¨	ChezScheme - Cadence, Inc
http://www.scheme.com/
Environnement Scheme très performant.
¨	EdScheme, 3Dscheme - Scheme, Inc
http://www.schemers.com/
Environnement de programmation Scheme pour Windows.
¨	Inlab Scheme - Inlab Software GmbH
http://www.munich.net/inlab/scheme/
Environnement commercial
¨	Open-Scheme - Erian Concept
http://www.open-scheme.com
Environnement professionnel de programmation Scheme comprenant un interprète, un compilateur et un débogueur symbolique. 
Existe en version libre et commerciale, pour Linux, FreeBSD, Solaris, Windows et BeOS, sur systèmes Intel et Sun.