examples/echo-server.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Multiplexer example, adapted from Juho Snellman's version for SBCL
   4 ;;;     which is available at http://jsnell.iki.fi/tmp/echo-server.lisp.
   5 ;;;
   6
   7 (eval-when (:compile-toplevel :load-toplevel :execute)
   8   (asdf:oos 'asdf:load-op :iolib.sockets))
   9
  10 (defpackage echo-server
  11   (:nicknames #:es)
  12   (:use :cl :alexandria)
  13   (:export #:run-server #:*port*))
  14
  15 (in-package :echo-server)
  16
  17 (defparameter *port* 9999)
  18 (defvar *event-base* nil)
  19 (defvar *sockets* ())
  20 (defvar *counter* 0)
  21
  22 (defun add-socket (socket)
  23   (push socket *sockets*))
  24
  25 (defun remove-socket (socket)
  26   (removef *sockets* socket))
  27
  28 (defun close-socket (socket)
  29   (let ((fd (iolib.sockets:socket-os-fd socket)))
  30     (ignore-some-conditions (isys:syscall-error)
  31       (iomux:remove-fd-handlers *event-base* fd))
  32     (remove-socket socket)
  33     (close socket)))
  34
  35 (defun make-echoer (stream id disconnector)
  36   (lambda (fd event exception)
  37     (declare (ignore fd event exception))
  38     (handler-case
  39         (let ((line (read-line stream)))
  40           (cond ((string= line "quit")
  41                  (funcall disconnector))
  42                 (t
  43                  (format t "~A: ~A~%" id line)
  44                  (format stream "~A: ~A~%" id line)
  45                  (ignore-some-conditions (iolib.streams:hangup)
  46                    (finish-output stream)))))
  47       (end-of-file ()
  48         (funcall disconnector)))))
  49
  50 (defun make-disconnector (socket id)
  51   (lambda ()
  52     (format t "~A: closing~%" id)
  53     (close-socket socket)))
  54
  55 (defun serve (socket id)
  56   (iomux:set-io-handler *event-base*
  57                         (iolib.sockets:socket-os-fd socket)
  58                         :read
  59                         (make-echoer socket id
  60                                      (make-disconnector socket id))))
  61
  62 (defun make-listener-handler (socket)
  63   (lambda (fd event exception)
  64     (declare (ignore fd event))
  65     (block nil
  66       (when (eql :timeout exception)
  67         (warn "Got a server timeout!")
  68         (return))
  69       (let ((client (iolib.sockets:accept-connection socket)))
  70         (when client
  71           (setf (iolib.streams:fd-non-blocking client) t)
  72           (add-socket client)
  73           (incf *counter*)
  74           (format t "Accepted client ~A~%" *counter*)
  75           (serve client *counter*))))))
  76
  77 (defun start-echo-server (host port)
  78   (let ((socket
  79          (iolib.sockets:make-socket :connect :passive :address-family :internet :type :stream
  80                                     :local-host host :local-port port
  81                                     :backlog 5 :reuse-address t
  82                                     :external-format '(:utf-8 :eol-style :crlf) :ipv6 nil)))
  83     (setf *counter* 0
  84           *sockets* nil)
  85     (unwind-protect-case ()
  86         (progn
  87           (setf (iolib.streams:fd-non-blocking socket) t)
  88           (iomux:set-io-handler *event-base*
  89                                 (iolib.sockets:socket-os-fd socket)
  90                                 :read
  91                                 (make-listener-handler socket)
  92                                 :timeout 15))
  93       (:abort (close socket)))
  94     socket))
  95
  96 (defun close-all-sockets ()
  97   (map 'nil #'close-socket *sockets*))
  98
  99 (defun run-server (&key (host iolib.sockets:+ipv4-unspecified+)
 100                    (port *port*) (new-process t) (timeout 10))
 101   (flet ((%run-server ()
 102            (unwind-protect
 103                 (progn
 104                   (setf *event-base* (make-instance 'iomux:event-base))
 105                   (with-open-stream (sock (start-echo-server host port))
 106                     (declare (ignorable sock))
 107                     (iomux:event-dispatch *event-base* :timeout timeout)))
 108              (close-all-sockets)
 109              (close *event-base*))))
 110     (let ((iolib.sockets:*ipv6* nil))
 111       (if new-process
 112           (bt:make-thread #'%run-server)
 113           (%run-server)))))