[Small-cl-src] serve-event-tricky.lisp

[Luke Gorrie]

;;; There was a recent threads on comp.lang.lisp about SERVE-EVENT. I
;;; was having trouble articulating some issues, so I wrote this small
;;; demonstration program to clear my thinking.
;;;
;;; More examples are possible. Post 'em if you find 'em!

;;; serve-event-tricky.lisp -- Tricky examples of SERVE-EVENT
;;; First version, written by Luke Gorrie in May 2004.
;;;
;;; A nice pretty PDF version of this program can be downloaded from:
;;;   http://www.bluetail.com/~luke/misc/lisp/serve-event-tricky.pdf
;;;
;;;# Introduction
;;;
;;; This is a small example to show some tricky aspects of using the
;;; `SERVE-EVENT' framework in CMUCL. First we define a simple server
;;; program, then we write some small clients to provoke it into
;;; behaving badly.

(in-package :cl-user)

(defvar port 10000
  "The TCP port for the server.")

;;; We will often want to print short messages, so here is a helpful
;;; little utility:

(defun say (format &rest args)
  "Print a formatted message to standard-output on a fresh line."
  (format t "~&~?~%" format args)
  (force-output))

;;;# The server
;;;
;;; The server binds a listening socket and loops accepting
;;; connections. For each connection it calls READ, prints the result,
;;; and closes the socket. All I/O scheduling is driven by
;;; `SERVE-EVENT'.
;;;
;;; The server reports abnormal exits and unhandled conditions from
;;; handlers.

(defun run-server ()
  "Run the server in a loop until aborted."
  (let ((listen-socket (start-server)))
    (unwind-protect (server-loop)
      (stop-server listen-socket))))

(defun start-server ()
  "Start the server."
  (let ((socket (ext:create-inet-listener port :stream :reuse-address t))
        (nr-connections 0))
    (sys:add-fd-handler socket :input
                        (lambda (s)
                          (server-accept (incf nr-connections) s)))
    socket))

(defun server-loop ()
  "Loop serving requests until aborted.
If an error is raised then it is printed and the loop continues."
  (with-simple-restart (stop-server "Stop the example server.")
    (handler-case (loop (sys:serve-all-events))
      (error (err)
        (say "Continuing after error: ~A" (type-of err))))))

(defun stop-server (socket)
  (sys:invalidate-descriptor socket)
  (close-socket socket))

(defun server-accept (nr listen-socket)
  "Accept new connection number NR from LISTEN-SOCKET.
This is a callback for when SERVE-EVENT detects a new connection."
  (sys:add-fd-handler (accept-tcp-connection listen-socket)
                      :input
                      (lambda (socket)
                        (server-handle-connection nr socket))))

(defun server-handle-connection (number socket)
  "Handle connection NUMBER on SOCKET.
Try to READ one sexp from the socket and print it.
Also print a message if we lose control (the stack unwinds) unexpectedly.

This is a callback for when SERVE-EVENT detects available data."
  (let ((stream (sys:make-fd-stream socket :input t))
        (successful nil))
    (unwind-protect
         (with-standard-io-syntax
           (say "Connection #~D read ~A" number (read stream))
           (setq successful t))
      (close-connection stream)
      (unless successful (say "Connection #~D aborted!" number)))))

(defun close-connection (stream)
  (sys:invalidate-descriptor (sys:fd-stream-fd stream))
  (when (open-stream-p stream)
    (close stream)))

;;;# The client
;;;
;;; The client part is just a few utilities for opening sockets and
;;; sending strings.

(defun make-client ()
  "Connect to the server and return the (unbuffered) output stream."
  (let ((fd (connect-to-inet-socket "localhost" port)))
    (sys:make-fd-stream fd :output t :buffering :none)))

(defmacro with-clients ((&rest variables) &body body)
  "Bind VARIABLES to new connections to the server and execute BODY.
Ensure the connections are closed before returning."
  `(let ,(mapcar (lambda (var) (list var '(make-client))) variables)
     (unwind-protect
          (progn , at body)
       (dolist (client (list , at variables))
         (close-connection client)))))

(defun send (client string)
  "Send STRING to CLIENT and pause a moment to let the server process it."
  (princ string client)
  (sleep 0.1))

;;;# Test cases
;;;
;;; Our task now is to write clients that provoke undesirable
;;; behaviour from the server. To test the programs you should start
;;; two Lisp systems and load this file in both. Then in one you do
;;; `(run-server)' and in the other you can call the exploit functions
;;; defined below.
;;;
;;; An important tool is being able to make the server enter calls to
;;; `READ' and choosing when to allow them to exit. We can do this by
;;; sending a SEXP in two parts -- the first causes the server to
;;; start reading, and it can't finish until we send the rest.

(defparameter first-half "(foo"
  "The first half of a SEXP.")

(defparameter second-half "bar)"
  "The other half of the SEXP.")

;;;## Delay exploit
;;;
;;; Clients can case delays for each other. Here is a case with two
;;; clients, A and B, where A must wait for B to finish a request
;;; before being able to proceed, even though all of A's data is
;;; available to the server.

(defun delay ()
  (with-clients (a b)
    (send a first-half)
    (send b first-half)
    (send a second-half)
    (sleep 5)
    (send b second-half)))

;;; The expected output is for the server to say nothing for a few
;;; seconds, and then print:
;; Connection #2 read (FOOBAR)
;; Connection #1 read (FOOBAR)
;;; Here's why:
;;;
;;; Both clients connect and send half of a request, with A sending
;;; first. The server enters "blocking" `READ's, first for A and then
;;; for B, and awaits more input. The relevant parts of the server's
;;; Lisp stack look like this:
;;;
;;    (SERVE-EVENT)
;;    (READ B)
;;    (SERVE-EVENT)
;;    (READ A)
;;    (SERVE-EVENT)
;;    (SERVER-LOOP)
;;;
;;; Next A sends the rest of his request. But what can we do with it?
;;; Nothing yet: we cannot return from `(READ A)' without first
;;; returning from `(READ B)', and B is still blocking. A must wait
;;; for B's request to complete. In the test case this takes a few
;;; seconds.
;;;
;;; This case can occur if the network fails between client and
;;; server, and it's easy to trigger deliberately (maliciously). A
;;; timeout of some kind is required to break out of the problem.

;;;## Error propagation exploit
;;;
;;; Another issue presents itself from looking at the previous stack
;;; diagram. What if an unhandled condition is signalled in the `READ'
;;; of B? With our server it will propagate right up the stack and be
;;; handled by `SERVER-LOOP'. That means that an error triggered by
;;; client B will cause client A's handler to be unwound from the
;;; stack, aborting his connection in the process.

(defun error-propagation ()
  (with-clients (a b)
    (send a first-half)
    (send b "#@ <- illegal read syntax: will trigger an error.")
    (ignore-errors (send a second-half))))

;;; The expected output on the server is:
;; Connection #2 aborted!
;; Connection #1 aborted!
;; Continuing after error: READER-ERROR

;;;# Conclusion
;;;
;;; `SERVE-EVENT' presents a simple interface and makes it easy to
;;; write common server programs. However, you have to be thoughtful
;;; about how you use it, and be aware of what's on the
;;; stack. Otherwise you could be eaten alive on the big bad internet.