(use-modules (oop goops) (ice-9 receive) (ice-9 match)
             (srfi srfi-19))

(define-class <serveur> ()
  (sockets #:init-value '())
  (hôte #:init-keyword #:hôte #:init-thunk gethostname)
  (service #:init-keyword #:service #:init-value "12345"))
(define-method (relier (serveur <serveur>))
  (define (index adresse)
    ;; retourne une valeur d’index pour adresse, comparable avec
    ;; equal?
    (list
     (sockaddr:fam adresse)
     (sockaddr:path adresse)
     (sockaddr:addr adresse)
     (sockaddr:port adresse)))
  (define tcp
    (protoent:proto (getprotobyname "tcp")))
  (let ((sockets-existantes
         (make-hash-table))
        (nouveau-serveur (shallow-clone serveur)))
    (for-each
     (lambda (socket)
       (let ((adresse (getsockname socket)))
         (hash-set! sockets-existantes
                    ;; On ne peut pas utiliser les adresses telles
                    ;; quelles, sinon equal? ne fonctionnera pas.
                    (index adresse)
                    socket)))
     (slot-ref serveur 'sockets))
    (slot-set!
     nouveau-serveur 'sockets
     (map
      (lambda (info-adresse)
        (let ((adresse (addrinfo:addr info-adresse)))
          (let ((existante
                 (hash-ref sockets-existantes
                           (index adresse))))
            (if existante
                (begin
                  (hash-remove! sockets-existantes (index adresse))
                  existante)
                ;; Nouvelle adresse
                (let ((s (socket (addrinfo:fam info-adresse)
                                 (addrinfo:socktype info-adresse)
                                 (addrinfo:protocol info-adresse))))
                  (bind s adresse)
                  (listen s 10)
                  s)))))
      (getaddrinfo (slot-ref serveur 'hôte)
                   (slot-ref serveur 'service)
                   (logior AI_PASSIVE)
                   0 ;; Famille
                   SOCK_STREAM ;; Avec connexion
                   tcp)))
    (values nouveau-serveur
            (map cdr (hash-map->list cons sockets-existantes)))))

(define-method (initialize (object <serveur>) initargs)
  (next-method)
  (receive (serveur _)
      (relier object)
    (slot-set! object 'sockets
               (slot-ref serveur 'sockets))))
(define-method (ports (serveur <serveur>))
  (values
   ;; Liste des ports dont on doit surveiller la lecture
   (slot-ref serveur 'sockets)
   ;; Liste des ports dont on attend l’écriture
   '()
   ;; Liste des ports dont on attend une erreur
   '()))
(define-method (prête (serveur <serveur>) socket direction)
  (when (port? socket)
    (set! socket (port->fdes socket)))
  (for-each
   (lambda (socket-serveur)
     (when (and (eq? direction 'lire)
                (eqv? (port->fdes socket-serveur) socket))
       (let ((client (accept socket-serveur)))
         (let ((port (car client))
               (adresse (cdr client)))
           (format port "Bonjour ~a :)\n"
                   (inet-ntop (sockaddr:fam adresse)
                              (sockaddr:addr adresse)))
           (close-port port)))))
   (slot-ref serveur 'sockets))
  serveur)

(define (main serveur)
  (format #t "~a : le serveur lie les adresses suivantes : ~a\n"
          (date->string (current-date))
          (map
           (lambda (socket)
             (let ((adresse (getsockname socket)))
               (let ((adresse
                      (inet-ntop (sockaddr:fam adresse) (sockaddr:addr adresse)))
                     (port
                      (sockaddr:port adresse)))
                 (format #f "[~a]:~a" adresse port))))
           (slot-ref serveur 'sockets)))
  (receive (read write except) (ports serveur)
    (match (select read write except 60)
      ((read write except)
       (let traiter ((serveur serveur)
                     (tâches
                      (append
                          (map (lambda (socket)
                                 `(,socket lire))
                               read)
                          (map (lambda (socket)
                                 `(,socket écrire))
                               write)
                          (map (lambda (socket)
                                 `(,socket exception))
                               except))))
         (match tâches
           (()
            (receive (serveur à-fermer) (relier serveur)
              (for-each close-port à-fermer)
              (main serveur)))
           (((socket direction) tâches-restantes ...)
            (traiter (prête serveur socket direction)
                     tâches-restantes))))))))

(main (make <serveur>))