[Small-cl-src] prefork-client.lisp

[Thomas F. Burdick]

;;;; prefork-client.lisp
;;;;
;;;; A very simple SBCL network client for use in testing the servers in
;;;; prefork-example-simple.lisp and prefork-example-realistic.lisp.

;;;; Copyright (C) 2004, Thomas F. Burdick
;;;; 
;;;; Permission is hereby granted, free of charge, to any person obtaining a
;;;; copy of this software and associated documentation files (the "Software"),
;;;; to deal in the Software without restriction, including without limitation
;;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;;; and/or sell copies of the Software, and to permit persons to whom the
;;;; Software is furnished to do so, subject to the following conditions:
;;;; 
;;;; The above copyright notice and this permission notice shall be included in 
;;;; all copies or substantial portions of the Software.
;;;; 
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 
;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 
;;;; IN THE SOFTWARE.

(in-package :cl-user)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (require :sb-posix)
  (require :sb-bsd-sockets)
  (use-package :sb-bsd-sockets))

;;; The client is broken across many functions in order to make it easier to
;;; poke at the server.
;;;
;;; We send a line identifying ourselves, then an s-expression.  The server
;;; identifies itself, then sends our s-expression back to us.

(defvar *socket* nil)
(defvar *stream* nil)

(defun client (&optional object)
  "Return the echo from the server as multiple values."
  (client-connect)
  (client-herald)
  (client-write (with-output-to-string (s) (print object s)))
  (multiple-value-prog1 (client-results)
    (socket-close *socket*)))

;;;
;;; Easily hang server processes
;;; 

(defvar *hung* (queue))

(defun hang (&optional (n 1))
  "Send N partial requests to the server, causing the processes to hang."
  (dotimes (i n)
    (let (*socket* *stream*)
      (client-connect)
      (client-herald)
      (client-write "(:hang ")
      (queue-add (cons *socket* *stream*) *hung*))))

(defun release (&optional (n 1))
  "Send the rest of a proper request to N hung servers."
  (loop repeat n
        for pair = (queue-pop *hung*)
        when pair collect (destructuring-bind (*socket* . *stream*) pair
			    (client-write ":release) ")
			    (client-results))))

;;;
;;; The guts
;;; 

(defun client-connect ()
  (setf *socket* (make-instance 'inet-socket :type :stream :protocol :tcp))
  (socket-connect *socket* (make-inet-address "127.0.0.1") 1978)
  (setf *stream* (socket-make-stream *socket* :input t :output t)))
  
(defun client-herald ()
  (format *stream* "PID ~D~%" (sb-posix:getpid))
  (finish-output *stream*))
      
(defun client-write (string)
  "Send STRING to the server.  If this is an incomplete sexp, it can be used to
hang the server."
  (write-string string *stream*)
  (finish-output *stream*))

(defun client-results ()
  (values (read-line *stream*)
	  (read *stream*)))

;;;
;;; Misc utils
;;; 

(defstruct (queue (:constructor %make-queue (list tail)))
  (list nil :type list)
  (tail nil :type list))

(defun queue (&rest elements)
  (make-queue elements))

(defun make-queue (&optional list)
  (%make-queue list (last list)))

(defun queue-add (item queue)
  (if (null (queue-tail queue))
      (setf (queue-list queue) (list item)
	    (queue-tail queue) (queue-list queue))
      (setf (cdr (queue-tail queue)) (list item)
	    (queue-tail queue) (cdr (queue-tail queue))))
  queue)

(defun queue-pop (queue)
  (prog1
      (pop (queue-list queue))
    (when (null (queue-list queue))
      (setf (queue-tail queue) nil))))