diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-10-12 09:37:18 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-10-12 09:37:18 +0200 |
commit | 66689cc004024b0373de1e51bc602e0ebf13bb70 (patch) | |
tree | b54767a9662c6cd5de7966203a6d4c64b10df797 | |
parent | 08c021916dbd3a235a9f9cc33df4c418c0724e03 (diff) | |
download | guile-66689cc004024b0373de1e51bc602e0ebf13bb70.tar.gz |
tests: Add REPL server test for CVE-2016-8606.
This is a followup to 08c021916dbd3a235a9f9cc33df4c418c0724e03.
* test-suite/tests/00-repl-server.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add it.
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/00-repl-server.test | 139 |
2 files changed, 140 insertions, 0 deletions
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index fabbbb530..fac3345e1 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -23,6 +23,7 @@ SUBDIRS = standalone vm SCM_TESTS = tests/00-initial-env.test \ + tests/00-repl-server.test \ tests/00-socket.test \ tests/alist.test \ tests/and-let-star.test \ diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test new file mode 100644 index 000000000..ca389bafb --- /dev/null +++ b/test-suite/tests/00-repl-server.test @@ -0,0 +1,139 @@ +;;;; 00-repl-server.test --- REPL server. -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2016 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (repl-server) + #:use-module (system repl server) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (web uri) + #:use-module (web request) + #:use-module (test-suite lib)) + +(define (call-with-repl-server proc) + "Set up a REPL server in a separate process and call PROC with a +socket connected to that server." + (let ((sockaddr (make-socket-address AF_UNIX "/tmp/repl-server")) + (client-socket (socket AF_UNIX SOCK_STREAM 0))) + (false-if-exception + (delete-file (sockaddr:path sockaddr))) + + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))) + (bind server-socket sockaddr) + (set! %load-verbosely #f) + + (close-fdes 2) + + ;; Arrange so that the alarming "possible break-in attempt" + ;; message doesn't show up when running the test suite. + (dup2 (open-fdes "/dev/null" O_WRONLY) 2) + + (run-server server-socket))) + (lambda () + (primitive-exit 0)))) + (pid + (dynamic-wind + (const #t) + (lambda () + ;; XXX: We can't synchronize with the server's 'accept' call + ;; because it's buried inside 'run-server', hence this hack. + (let loop ((tries 0)) + (catch 'system-error + (lambda () + (connect client-socket sockaddr)) + (lambda args + (when (and (memv (system-error-errno args) + (list ENOENT ECONNREFUSED)) + (< tries 3)) + (sleep 1) + (loop (+ tries 1)))))) + + (proc client-socket)) + (lambda () + (false-if-exception (close-port client-socket)) + (false-if-exception (kill pid SIGTERM)))))))) + +(define-syntax-rule (with-repl-server client-socket body ...) + "Evaluate BODY... in a context where CLIENT-SOCKET is bound to a +socket connected to a fresh REPL server." + (call-with-repl-server + (lambda (client-socket) + body ...))) + +(define (read-until-prompt port str) + "Read from PORT until STR has been read or the end-of-file was +reached." + (let loop () + (match (read-line port) + ((? eof-object?) + #t) + (line + (or (string=? line str) (loop)))))) + +(define %last-line-before-prompt + "Enter `,help' for help.") + + +;;; REPL server tests. +;;; +;;; Since we call 'primitive-fork', these tests must run before any +;;; tests that create threads. + +(with-test-prefix "repl-server" + + (pass-if-equal "simple expression" + "scheme@(repl-server)> $1 = 42\n" + (with-repl-server socket + (read-until-prompt socket %last-line-before-prompt) + (display "(+ 40 2)\n(quit)\n" socket) + (read-string socket))) + + (pass-if "HTTP inter-protocol attack" ;CVE-2016-8606 + (with-repl-server socket + ;; Avoid SIGPIPE when the server closes the connection. + (sigaction SIGPIPE SIG_IGN) + + (read-until-prompt socket %last-line-before-prompt) + + ;; Simulate an HTTP inter-protocol attack. + (write-request (build-request (string->uri "http://localhost")) + socket) + + ;; Make sure the server reacts by closing the connection. If it + ;; fails to do that, this test hangs. + (catch 'system-error + (lambda () + (let loop ((n 0)) + (display "(+ 40 2)\n(quit)\n" socket) ;trigger EPIPE + (read-string socket) + (if (> n 5) + #f ;failure + (begin + (sleep 1) + (loop (+ 1 n)))))) + (lambda args + (->bool (memv (system-error-errno args) + (list ECONNRESET EPIPE)))))))) + +;;; Local Variables: +;;; eval: (put 'with-repl-server 'scheme-indent-function 1) +;;; End: |