Recently Written · git

3rdparties/software/cl+ssl-20200427-git/test.lisp (12866 bytes)

 ;;; Copyright (C) 2008  David Lichteblau
 ;;; See LICENSE for details.
 
 #|
 (load "test.lisp")
 |#
 
 (defpackage :ssl-test
   (:use :cl))
 (in-package :ssl-test)
 
 (defvar *port* 8080)
 (defvar *cert* "/home/david/newcert.pem")
 (defvar *key* "/home/david/newkey.pem")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (asdf:operate 'asdf:load-op :trivial-sockets)
   (asdf:operate 'asdf:load-op :bordeaux-threads))
 
 (defparameter *tests* '())
 
 (defvar *sockets* '())
 (defvar *sockets-lock* (bordeaux-threads:make-lock))
 
 (defun record-socket (socket)
   (unless (integerp socket)
     (bordeaux-threads:with-lock-held (*sockets-lock*)
       (push socket *sockets*)))
   socket)
 
 (defun close-socket (socket &key abort)
   (if (streamp socket)
       (close socket :abort abort)
       (trivial-sockets:close-server socket)))
 
 (defun check-sockets ()
   (let ((failures nil))
     (bordeaux-threads:with-lock-held (*sockets-lock*)
       (dolist (socket *sockets*)
   (when (close-socket socket :abort t)
     (push socket failures)))
       (setf *sockets* nil))
     #-sbcl        ;fixme
     (when failures
       (error "failed to close sockets properly:~{  ~A~%~}" failures))))
 
 (defmacro deftest (name &body body)
   `(progn
      (defun ,name ()
        (format t "~%----- ~A ----------------------------~%" ',name)
        (handler-case
      (progn
        ,@body
        (check-sockets)
        (format t "===== [OK] ~A ====================~%" ',name)
        t)
    (error (c)
      (when (typep c 'trivial-sockets:socket-error)
        (setf c (trivial-sockets:socket-nested-error c)))
      (format t "~%===== [FAIL] ~A: ~A~%" ',name c)
      (handler-case
          (check-sockets)
        (error (c)
          (format t "muffling follow-up error ~A~%" c)))
      nil)))
      (push ',name *tests*)))
 
 (defun run-all-tests ()
   (unless (probe-file *cert*) (error "~A not found" *cert*))
   (unless (probe-file *key*) (error "~A not found" *key*))
   (let ((n 0)
   (nok 0))
     (dolist (test (reverse *tests*))
       (when (funcall test)
   (incf nok))
       (incf n))
     (format t "~&passed ~D/~D tests~%" nok n)))
 
 (define-condition quit (condition)
   ())
 
 (defparameter *please-quit* t)
 
 (defun make-test-thread (name init main &rest args)
   "Start a thread named NAME, wait until it has funcalled INIT with ARGS
    as arguments, then continue while the thread concurrently funcalls MAIN
    with INIT's return values as arguments."
   (let ((cv (bordeaux-threads:make-condition-variable))
   (lock (bordeaux-threads:make-lock name))
   ;; redirect io manually, because swan's global redirection isn't as
   ;; global as one might hope
   (out *terminal-io*)
   (init-ok nil))
     (bordeaux-threads:with-lock-held (lock)
       (setf *please-quit* nil)
       (prog1
     (bordeaux-threads:make-thread
      (lambda ()
        (flet ((notify ()
           (bordeaux-threads:with-lock-held (lock)
       (bordeaux-threads:condition-notify cv))))
          (let ((*terminal-io* out)
          (*standard-output* out)
          (*trace-output* out)
          (*error-output* out))
      (handler-case
          (let ((values (multiple-value-list (apply init args))))
            (setf init-ok t)
            (notify)
            (apply main values))
        (quit ()
          (notify)
          t)
        (error (c)
          (when (typep c 'trivial-sockets:socket-error)
            (setf c (trivial-sockets:socket-nested-error c)))
          (format t "aborting test thread ~A: ~A" name c)
          (notify)
          nil)))))
      :name name)
   (bordeaux-threads:condition-wait cv lock)
   (unless init-ok
     (error "failed to start background thread"))))))
 
 (defmacro with-thread ((name init main &rest args) &body body)
   `(invoke-with-thread (lambda () ,@body)
            ,name
            ,init
            ,main
            ,@args))
 
 (defun invoke-with-thread (body name init main &rest args)
   (let ((thread (apply #'make-test-thread name init main args)))
     (unwind-protect
    (funcall body)
       (setf *please-quit* t)
       (loop
    for delay = 0.0001 then (* delay 2)
    while (and (< delay 0.5) (bordeaux-threads:thread-alive-p thread))
    do
      (sleep delay))
       (when (bordeaux-threads:thread-alive-p thread)
   (format t "~&thread doesn't want to quit, killing it~%")
   (force-output)
   (bordeaux-threads:interrupt-thread thread (lambda () (error 'quit)))
   (loop
      for delay = 0.0001 then (* delay 2)
      while (bordeaux-threads:thread-alive-p thread)
      do
      (sleep delay))))))
 
 (defun init-server (&key (unwrap-stream-p t))
   (format t "~&SSL server listening on port ~d~%" *port*)
   (values (record-socket (trivial-sockets:open-server :port *port*))
     unwrap-stream-p))
 
 (defun test-server (listening-socket unwrap-stream-p)
   (format t "~&SSL server accepting...~%")
   (unwind-protect
        (let* ((socket (record-socket
            (trivial-sockets:accept-connection
       listening-socket
       :element-type '(unsigned-byte 8))))
         (callback nil))
    (when (eq unwrap-stream-p :caller)
      (setf callback (let ((s socket)) (lambda () (close-socket s))))
      (setf socket (cl+ssl:stream-fd socket))
      (setf unwrap-stream-p nil))
    (let ((client (record-socket
       (cl+ssl:make-ssl-server-stream
        socket
        :unwrap-stream-p unwrap-stream-p
        :close-callback callback
        :external-format :iso-8859-1
        :certificate *cert*
        :key *key*))))
      (unwind-protect
     (loop
        for line = (prog2
           (when *please-quit* (return))
           (read-line client nil)
         (when *please-quit* (return)))
        while line
        do
          (cond
            ((equal line "freeze")
       (format t "~&Freezing on client request~%")
       (loop
          (sleep 1)
          (when *please-quit* (return))))
            (t
       (format t "~&Responding to query ~A...~%" line)
       (format client "(echo ~A)~%" line)
       (force-output client))))
        (close-socket client))))
     (close-socket listening-socket)))
 
 (defun init-client (&key (unwrap-stream-p t))
   (let ((socket (record-socket
      (trivial-sockets:open-stream
       "127.0.0.1"
       *port*
       :element-type '(unsigned-byte 8))))
   (callback nil))
     (when (eq unwrap-stream-p :caller)
       (setf callback (let ((s socket)) (lambda () (close-socket s))))
       (setf socket (cl+ssl:stream-fd socket))
       (setf unwrap-stream-p nil))
     (cl+ssl:make-ssl-client-stream
      socket
      :unwrap-stream-p unwrap-stream-p
      :close-callback callback
      :external-format :iso-8859-1)))
 
 ;; CCL requires specifying the
 ;; deadline at the socket cration (
 ;; in constrast to SBCL which has
 ;; the WITH-TIMEOUT macro).
 ;;
 ;; Therefore a separate INIT-CLIENT
 ;; function is needed for CCL when
 ;; we need read/write deadlines on
 ;; the SSL client stream.
 #+clozure-common-lisp
 (defun ccl-init-client-with-deadline (&key (unwrap-stream-p t)
               seconds)
   (let* ((deadline
     (+ (get-internal-real-time)
        (* seconds internal-time-units-per-second)))
    (low
     (record-socket
      (ccl:make-socket
       :address-family :internet
       :connect :active
       :type :stream
       :remote-host "127.0.0.1"
       :remote-port *port*
       :deadline deadline))))
     (cl+ssl:make-ssl-client-stream
      low
      :unwrap-stream-p unwrap-stream-p
      :external-format :iso-8859-1)))
 
 ;;; Simple echo-server test.  Write a line and check that the result
 ;;; watches, three times in a row.
 (deftest echo
   (with-thread ("simple server" #'init-server #'test-server)
     (with-open-stream (socket (init-client))
       (write-line "test" socket)
       (force-output socket)
       (assert (equal (read-line socket) "(echo test)"))
       (write-line "test2" socket)
       (force-output socket)
       (assert (equal (read-line socket) "(echo test2)"))
       (write-line "test3" socket)
       (force-output socket)
       (assert (equal (read-line socket) "(echo test3)")))))
 
 ;;; Run tests with different BIO setup strategies:
 ;;;   - :UNWRAP-STREAMS T
 ;;;     In this case, CL+SSL will convert the socket to a file descriptor.
 ;;;   - :UNWRAP-STREAMS :CLIENT
 ;;;     Convert the socket to a file descriptor manually, and give that
 ;;;     to CL+SSL.
 ;;;   - :UNWRAP-STREAMS NIL
 ;;;     Let CL+SSL write to the stream directly, using the Lisp BIO.
 (macrolet ((deftests (name (var &rest values) &body body)
        `(progn
     ,@(loop
          for value in values
          collect
          `(deftest ,(intern (format nil "~A-~A" name value))
       (let ((,var ',value))
         ,@body))))))
 
   (deftests unwrap-strategy (usp nil t :caller)
     (with-thread ("echo server for strategy test"
       (lambda () (init-server :unwrap-stream-p usp))
       #'test-server)
       (with-open-stream (socket (init-client :unwrap-stream-p usp))
   (write-line "test" socket)
   (force-output socket)
   (assert (equal (read-line socket) "(echo test)")))))
 
   #+clozure-common-lisp
   (deftests read-deadline (usp nil t :caller)
     (with-thread ("echo server for deadline test"
       (lambda () (init-server :unwrap-stream-p usp))
       #'test-server)
       (with-open-stream
     (socket
      (ccl-init-client-with-deadline
       :unwrap-stream-p usp
       :seconds 3))
   (write-line "test" socket)
   (force-output socket)
   (assert (equal (read-line socket) "(echo test)"))
   (handler-case
       (progn
         (read-char socket)
         (error "unexpected data"))
     (ccl::communication-deadline-expired ())))))
 
   #+sbcl
   (deftests read-deadline (usp nil t :caller)
     (with-thread ("echo server for deadline test"
       (lambda () (init-server :unwrap-stream-p usp))
       #'test-server)
       (sb-sys:with-deadline (:seconds 3)
   (with-open-stream (socket (init-client :unwrap-stream-p usp))
     (write-line "test" socket)
     (force-output socket)
     (assert (equal (read-line socket) "(echo test)"))
     (handler-case
         (progn
     (read-char socket)
     (error "unexpected data"))
       (sb-sys:deadline-timeout ()))))))
 
   #+clozure-common-lisp
   (deftests write-deadline (usp nil t)
     (with-thread ("echo server for deadline test"
       (lambda () (init-server :unwrap-stream-p usp))
       #'test-server)
       (with-open-stream
     (socket
      (ccl-init-client-with-deadline
       :unwrap-stream-p usp
       :seconds 3))
       (unwind-protect
      (progn
        (write-line "test" socket)
        (force-output socket)
        (assert (equal (read-line socket) "(echo test)"))
        (write-line "freeze" socket)
        (force-output socket)
        (let ((n 0))
          (handler-case
        (loop
           (write-line "deadbeef" socket)
           (incf n))
      (ccl::communication-deadline-expired ()))
          ;; should have written a couple of lines before the deadline:
          (assert (> n 100))))
   (handler-case
       (close-socket socket :abort t)
     (ccl::communication-deadline-expired ()))))))
 
   #+sbcl
   (deftests write-deadline (usp nil t)
     (with-thread ("echo server for deadline test"
       (lambda () (init-server :unwrap-stream-p usp))
       #'test-server)
       (with-open-stream (socket (init-client :unwrap-stream-p usp))
   (unwind-protect
        (sb-sys:with-deadline (:seconds 3)
          (write-line "test" socket)
          (force-output socket)
          (assert (equal (read-line socket) "(echo test)"))
          (write-line "freeze" socket)
          (force-output socket)
          (let ((n 0))
      (handler-case
          (loop
       (write-line "deadbeef" socket)
       (incf n))
        (sb-sys:deadline-timeout ()))
      ;; should have written a couple of lines before the deadline:
      (assert (> n 100))))
     (handler-case
         (close-socket socket :abort t)
       (sb-sys:deadline-timeout ()))))))
 
   #+clozure-common-lisp
   (deftests read-char-no-hang/test (usp nil t :caller)
     (with-thread ("echo server for read-char-no-hang test"
       (lambda () (init-server :unwrap-stream-p usp))
       #'test-server)
       (with-open-stream
     (socket (ccl-init-client-with-deadline
        :unwrap-stream-p usp
        :seconds 3))
   (write-line "test" socket)
   (force-output socket)
   (assert (equal (read-line socket) "(echo test)"))
   (handler-case
       (when (read-char-no-hang socket)
         (error "unexpected data"))
     (ccl::communication-deadline-expired ()
       (error "read-char-no-hang hangs"))))))
 
   #+sbcl
   (deftests read-char-no-hang/test (usp nil t :caller)
     (with-thread ("echo server for read-char-no-hang test"
       (lambda () (init-server :unwrap-stream-p usp))
       #'test-server)
       (sb-sys:with-deadline (:seconds 3)
   (with-open-stream (socket (init-client :unwrap-stream-p usp))
     (write-line "test" socket)
     (force-output socket)
     (assert (equal (read-line socket) "(echo test)"))
     (handler-case
         (when (read-char-no-hang socket)
     (error "unexpected data"))
       (sb-sys:deadline-timeout ()
         (error "read-char-no-hang hangs"))))))))
 
 #+(or)
 (run-all-tests)