[jackhill/guix/guix.git] / tests / containers.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-containers)
  #:use-module (guix utils)
  #:use-module (guix build syscalls)
  #:use-module (gnu build linux-container)
  #:use-module ((gnu system linux-container)
                #:select (eval/container))
  #:use-module (gnu system file-systems)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module (guix tests)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define (assert-exit x)
  (primitive-exit (if x 0 1)))

(test-begin "containers")

;; Skip these tests unless user namespaces are available and the setgroups
;; file (introduced in Linux 3.19 to address a security issue) exists.
(define (skip-if-unsupported)
  (unless (and (user-namespace-supported?)
               (unprivileged-user-namespace-supported?)
               (setgroups-supported?))
    (test-skip 1)))

(skip-if-unsupported)
(test-assert "call-with-container, exit with 0 when there is no error"
  (zero?
   (call-with-container '() (const #t) #:namespaces '(user))))

(skip-if-unsupported)
(test-assert "call-with-container, user namespace"
  (zero?
   (call-with-container '()
     (lambda ()
       ;; The user is root within the new user namespace.
       (assert-exit (and (zero? (getuid)) (zero? (getgid)))))
     #:namespaces '(user))))

(skip-if-unsupported)
(test-assert "call-with-container, user namespace, guest UID/GID"
  (zero?
   (call-with-container '()
     (lambda ()
       (assert-exit (and (= 42 (getuid)) (= 77 (getgid)))))
     #:guest-uid 42
     #:guest-gid 77
     #:namespaces '(user))))

(skip-if-unsupported)
(test-assert "call-with-container, uts namespace"
  (zero?
   (call-with-container '()
     (lambda ()
       ;; The user is root within the container and should be able to change
       ;; the hostname of that container.
       (sethostname "test-container")
       (primitive-exit 0))
     #:namespaces '(user uts))))

(skip-if-unsupported)
(test-assert "call-with-container, pid namespace"
  (zero?
   (call-with-container '()
     (lambda ()
       (match (primitive-fork)
         (0
          ;; The first forked process in the new pid namespace is pid 2.
          (assert-exit (= 2 (getpid))))
         (pid
          (primitive-exit
           (match (waitpid pid)
             ((_ . status)
              (status:exit-val status)))))))
     #:namespaces '(user pid))))

(skip-if-unsupported)
(test-assert "call-with-container, mnt namespace"
  (zero?
   (call-with-container (list (file-system
                                (device "none")
                                (mount-point "/testing")
                                (type "tmpfs")
                                (check? #f)))
     (lambda ()
       (assert-exit (file-exists? "/testing")))
     #:namespaces '(user mnt))))

(skip-if-unsupported)
(test-equal "call-with-container, mnt namespace, wrong bind mount"
  `(system-error ,ENOENT)
  ;; An exception should be raised; see <http://bugs.gnu.org/23306>.
  (catch 'system-error
    (lambda ()
      (call-with-container (list (file-system
                                   (device "/does-not-exist")
                                   (mount-point "/foo")
                                   (type "none")
                                   (flags '(bind-mount))
                                   (check? #f)))
        (const #t)
        #:namespaces '(user mnt)))
    (lambda args
      (list 'system-error (system-error-errno args)))))

(skip-if-unsupported)
(test-assert "call-with-container, all namespaces"
  (zero?
   (call-with-container '()
     (lambda ()
       (primitive-exit 0)))))

(skip-if-unsupported)
(test-assert "call-with-container, mnt namespace, root permissions"
  (zero?
   (call-with-container '()
     (lambda ()
       (assert-exit (= #o755 (stat:perms (lstat "/")))))
     #:namespaces '(user mnt))))

(skip-if-unsupported)
(test-assert "container-excursion"
  (call-with-temporary-directory
   (lambda (root)
     ;; Two pipes: One for the container to signal that the test can begin,
     ;; and one for the parent to signal to the container that the test is
     ;; over.
     (match (list (pipe) (pipe))
       (((start-in . start-out) (end-in . end-out))
        (define (container)
          (close end-out)
          (close start-in)
          ;; Signal for the test to start.
          (write 'ready start-out)
          (close start-out)
          ;; Wait for test completion.
          (read end-in)
          (close end-in))

        (define (namespaces pid)
          (let ((pid (number->string pid)))
            (map (lambda (ns)
                   (readlink (string-append "/proc/" pid "/ns/" ns)))
                 '("user" "ipc" "uts" "net" "pid" "mnt"))))

        (let* ((pid (run-container root '() %namespaces 1 container))
               (container-namespaces (namespaces pid))
               (result
                (begin
                  (close start-out)
                  ;; Wait for container to be ready.
                  (read start-in)
                  (close start-in)
                  (container-excursion pid
                    (lambda ()
                      ;; Fork again so that the pid is within the context of
                      ;; the joined pid namespace instead of the original pid
                      ;; namespace.
                      (match (primitive-fork)
                        (0
                         ;; Check that all of the namespace identifiers are
                         ;; the same as the container process.
                         (assert-exit
                          (equal? container-namespaces
                                  (namespaces (getpid)))))
                        (fork-pid
                         (match (waitpid fork-pid)
                           ((_ . status)
                            (primitive-exit
                             (status:exit-val status)))))))))))
          (close end-in)
          ;; Stop the container.
          (write 'done end-out)
          (close end-out)
          (waitpid pid)
          (zero? result)))))))

(skip-if-unsupported)
(test-equal "container-excursion, same namespaces"
  42
  ;; The parent and child are in the same namespaces.  'container-excursion'
  ;; should notice that and avoid calling 'setns' since that would fail.
  (container-excursion (getpid)
    (lambda ()
      (primitive-exit 42))))

(skip-if-unsupported)
(test-assert "container-excursion*"
  (call-with-temporary-directory
   (lambda (root)
     (define (namespaces pid)
       (let ((pid (number->string pid)))
         (map (lambda (ns)
                (readlink (string-append "/proc/" pid "/ns/" ns)))
              '("user" "ipc" "uts" "net" "pid" "mnt"))))

     (let* ((pid    (run-container root '()
                                   %namespaces 1
                                   (lambda ()
                                     (sleep 100))))
            (expected (namespaces pid))
            (result (container-excursion* pid
                      (lambda ()
                        (namespaces 1)))))
       (kill pid SIGKILL)
       (equal? result expected)))))

(skip-if-unsupported)
(test-equal "container-excursion*, same namespaces"
  42
  (container-excursion* (getpid)
    (lambda ()
      (* 6 7))))

(skip-if-unsupported)
(test-equal "eval/container, exit status"
  42
  (let* ((store  (open-connection-for-tests))
         (status (run-with-store store
                   (eval/container #~(exit 42)))))
    (close-connection store)
    (status:exit-val status)))

(skip-if-unsupported)
(test-assert "eval/container, writable user mapping"
  (call-with-temporary-directory
   (lambda (directory)
     (define store
       (open-connection-for-tests))
     (define result
       (string-append directory "/r"))
     (define requisites*
       (store-lift requisites))

     (call-with-output-file result (const #t))
     (run-with-store store
       (mlet %store-monad ((status (eval/container
                                    #~(begin
                                        (use-modules (ice-9 ftw))
                                        (call-with-output-file "/result"
                                          (lambda (port)
                                            (write (scandir #$(%store-prefix))
                                                   port))))
                                    #:mappings
                                    (list (file-system-mapping
                                           (source result)
                                           (target "/result")
                                           (writable? #t)))))
                           (reqs   (requisites*
                                    (list (derivation->output-path
                                           (%guile-for-build))))))
         (close-connection store)
         (return (and (zero? (pk 'status status))
                      (lset= string=? (cons* "." ".." (map basename reqs))
                             (pk (call-with-input-file result read))))))))))

(skip-if-unsupported)
(test-assert "eval/container, non-empty load path"
  (call-with-temporary-directory
   (lambda (directory)
     (define store
       (open-connection-for-tests))
     (define result
       (string-append directory "/r"))
     (define requisites*
       (store-lift requisites))

     (mkdir result)
     (run-with-store store
       (mlet %store-monad ((status (eval/container
                                    (with-imported-modules '((guix build utils))
                                      #~(begin
                                          (use-modules (guix build utils))
                                          (mkdir-p "/result/a/b/c")))
                                    #:mappings
                                    (list (file-system-mapping
                                           (source result)
                                           (target "/result")
                                           (writable? #t))))))
         (close-connection store)
         (return (and (zero? status)
                      (file-is-directory?
                       (string-append result "/a/b/c")))))))))

(test-end)
Commit	Line	Data
c1f6a0c2 DT	1	;;; GNU Guix --- Functional package management for GNU
c1f6a0c2 DT	2	;;; Copyright © 2015 David Thompson <davet@gnu.org>
af76c020	3	;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
c1f6a0c2 DT	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (test-containers)
	21	#:use-module (guix utils)
	22	#:use-module (guix build syscalls)
	23	#:use-module (gnu build linux-container)
bacfec86 LC	24	#:use-module ((gnu system linux-container)
bacfec86 LC	25	#:select (eval/container))
5970e8e2	26	#:use-module (gnu system file-systems)
bacfec86 LC	27	#:use-module (guix store)
	28	#:use-module (guix monads)
	29	#:use-module (guix gexp)
	30	#:use-module (guix derivations)
	31	#:use-module (guix tests)
	32	#:use-module (srfi srfi-1)
c1f6a0c2 DT	33	#:use-module (srfi srfi-64)
	34	#:use-module (ice-9 match))
	35
	36	(define (assert-exit x)
	37	(primitive-exit (if x 0 1)))
	38
a9edb211 ML	39	(test-begin "containers")
a9edb211 ML	40
bc459b61 DT	41	;; Skip these tests unless user namespaces are available and the setgroups
bc459b61 DT	42	;; file (introduced in Linux 3.19 to address a security issue) exists.
25a3bfbe LC	43	(define (skip-if-unsupported)
	44	(unless (and (user-namespace-supported?)
	45	(unprivileged-user-namespace-supported?)
	46	(setgroups-supported?))
	47	(test-skip 1)))
c1f6a0c2	48
25a3bfbe	49	(skip-if-unsupported)
a72ccbc2 DT	50	(test-assert "call-with-container, exit with 0 when there is no error"
	51	(zero?
	52	(call-with-container '() (const #t) #:namespaces '(user))))
	53
25a3bfbe	54	(skip-if-unsupported)
c1f6a0c2 DT	55	(test-assert "call-with-container, user namespace"
	56	(zero?
	57	(call-with-container '()
	58	(lambda ()
	59	;; The user is root within the new user namespace.
	60	(assert-exit (and (zero? (getuid)) (zero? (getgid)))))
	61	#:namespaces '(user))))
	62
af76c020 LC	63	(skip-if-unsupported)
	64	(test-assert "call-with-container, user namespace, guest UID/GID"
	65	(zero?
	66	(call-with-container '()
	67	(lambda ()
	68	(assert-exit (and (= 42 (getuid)) (= 77 (getgid)))))
	69	#:guest-uid 42
	70	#:guest-gid 77
	71	#:namespaces '(user))))
	72
25a3bfbe	73	(skip-if-unsupported)
c1f6a0c2 DT	74	(test-assert "call-with-container, uts namespace"
	75	(zero?
	76	(call-with-container '()
	77	(lambda ()
	78	;; The user is root within the container and should be able to change
	79	;; the hostname of that container.
	80	(sethostname "test-container")
	81	(primitive-exit 0))
	82	#:namespaces '(user uts))))
	83
25a3bfbe	84	(skip-if-unsupported)
c1f6a0c2 DT	85	(test-assert "call-with-container, pid namespace"
	86	(zero?
	87	(call-with-container '()
	88	(lambda ()
	89	(match (primitive-fork)
	90	(0
	91	;; The first forked process in the new pid namespace is pid 2.
	92	(assert-exit (= 2 (getpid))))
	93	(pid
	94	(primitive-exit
	95	(match (waitpid pid)
	96	((_ . status)
	97	(status:exit-val status)))))))
	98	#:namespaces '(user pid))))
	99
25a3bfbe	100	(skip-if-unsupported)
c1f6a0c2 DT	101	(test-assert "call-with-container, mnt namespace"
c1f6a0c2 DT	102	(zero?
5970e8e2 LC	103	(call-with-container (list (file-system
	104	(device "none")
	105	(mount-point "/testing")
a24b56fa AP	106	(type "tmpfs")
a24b56fa AP	107	(check? #f)))
c1f6a0c2 DT	108	(lambda ()
	109	(assert-exit (file-exists? "/testing")))
	110	#:namespaces '(user mnt))))
	111
25a3bfbe	112	(skip-if-unsupported)
c06f6db7 LC	113	(test-equal "call-with-container, mnt namespace, wrong bind mount"
	114	`(system-error ,ENOENT)
	115	;; An exception should be raised; see <http://bugs.gnu.org/23306>.
	116	(catch 'system-error
	117	(lambda ()
5970e8e2 LC	118	(call-with-container (list (file-system
	119	(device "/does-not-exist")
	120	(mount-point "/foo")
	121	(type "none")
a24b56fa AP	122	(flags '(bind-mount))
a24b56fa AP	123	(check? #f)))
c06f6db7 LC	124	(const #t)
	125	#:namespaces '(user mnt)))
	126	(lambda args
	127	(list 'system-error (system-error-errno args)))))
	128
25a3bfbe	129	(skip-if-unsupported)
c1f6a0c2 DT	130	(test-assert "call-with-container, all namespaces"
	131	(zero?
	132	(call-with-container '()
	133	(lambda ()
	134	(primitive-exit 0)))))
	135
e7481835 JL	136	(skip-if-unsupported)
	137	(test-assert "call-with-container, mnt namespace, root permissions"
	138	(zero?
	139	(call-with-container '()
	140	(lambda ()
	141	(assert-exit (= #o755 (stat:perms (lstat "/")))))
	142	#:namespaces '(user mnt))))
	143
25a3bfbe	144	(skip-if-unsupported)
c1f6a0c2 DT	145	(test-assert "container-excursion"
	146	(call-with-temporary-directory
	147	(lambda (root)
	148	;; Two pipes: One for the container to signal that the test can begin,
	149	;; and one for the parent to signal to the container that the test is
	150	;; over.
	151	(match (list (pipe) (pipe))
	152	(((start-in . start-out) (end-in . end-out))
	153	(define (container)
	154	(close end-out)
	155	(close start-in)
	156	;; Signal for the test to start.
	157	(write 'ready start-out)
	158	(close start-out)
	159	;; Wait for test completion.
	160	(read end-in)
	161	(close end-in))
	162
	163	(define (namespaces pid)
	164	(let ((pid (number->string pid)))
	165	(map (lambda (ns)
	166	(readlink (string-append "/proc/" pid "/ns/" ns)))
	167	'("user" "ipc" "uts" "net" "pid" "mnt"))))
	168
831bc146	169	(let* ((pid (run-container root '() %namespaces 1 container))
c1f6a0c2 DT	170	(container-namespaces (namespaces pid))
	171	(result
	172	(begin
	173	(close start-out)
	174	;; Wait for container to be ready.
	175	(read start-in)
	176	(close start-in)
	177	(container-excursion pid
	178	(lambda ()
	179	;; Fork again so that the pid is within the context of
	180	;; the joined pid namespace instead of the original pid
	181	;; namespace.
	182	(match (primitive-fork)
	183	(0
	184	;; Check that all of the namespace identifiers are
	185	;; the same as the container process.
	186	(assert-exit
	187	(equal? container-namespaces
	188	(namespaces (getpid)))))
	189	(fork-pid
	190	(match (waitpid fork-pid)
	191	((_ . status)
	192	(primitive-exit
	193	(status:exit-val status)))))))))))
	194	(close end-in)
	195	;; Stop the container.
	196	(write 'done end-out)
	197	(close end-out)
	198	(waitpid pid)
	199	(zero? result)))))))
	200
7fee5b53 LC	201	(skip-if-unsupported)
	202	(test-equal "container-excursion, same namespaces"
	203	42
	204	;; The parent and child are in the same namespaces. 'container-excursion'
	205	;; should notice that and avoid calling 'setns' since that would fail.
	206	(container-excursion (getpid)
	207	(lambda ()
	208	(primitive-exit 42))))
	209
c90db25f LC	210	(skip-if-unsupported)
	211	(test-assert "container-excursion*"
	212	(call-with-temporary-directory
	213	(lambda (root)
	214	(define (namespaces pid)
	215	(let ((pid (number->string pid)))
	216	(map (lambda (ns)
	217	(readlink (string-append "/proc/" pid "/ns/" ns)))
	218	'("user" "ipc" "uts" "net" "pid" "mnt"))))
	219
	220	(let* ((pid (run-container root '()
	221	%namespaces 1
	222	(lambda ()
	223	(sleep 100))))
3e894917	224	(expected (namespaces pid))
c90db25f LC	225	(result (container-excursion* pid
	226	(lambda ()
	227	(namespaces 1)))))
	228	(kill pid SIGKILL)
3e894917	229	(equal? result expected)))))
c90db25f LC	230
	231	(skip-if-unsupported)
	232	(test-equal "container-excursion*, same namespaces"
	233	42
	234	(container-excursion* (getpid)
	235	(lambda ()
	236	(* 6 7))))
	237
bacfec86 LC	238	(skip-if-unsupported)
	239	(test-equal "eval/container, exit status"
	240	42
	241	(let* ((store (open-connection-for-tests))
	242	(status (run-with-store store
	243	(eval/container #~(exit 42)))))
	244	(close-connection store)
	245	(status:exit-val status)))
	246
	247	(skip-if-unsupported)
	248	(test-assert "eval/container, writable user mapping"
	249	(call-with-temporary-directory
	250	(lambda (directory)
	251	(define store
	252	(open-connection-for-tests))
	253	(define result
	254	(string-append directory "/r"))
	255	(define requisites*
	256	(store-lift requisites))
	257
	258	(call-with-output-file result (const #t))
	259	(run-with-store store
	260	(mlet %store-monad ((status (eval/container
	261	#~(begin
	262	(use-modules (ice-9 ftw))
	263	(call-with-output-file "/result"
	264	(lambda (port)
	265	(write (scandir #$(%store-prefix))
	266	port))))
	267	#:mappings
	268	(list (file-system-mapping
	269	(source result)
	270	(target "/result")
	271	(writable? #t)))))
	272	(reqs (requisites*
	273	(list (derivation->output-path
	274	(%guile-for-build))))))
	275	(close-connection store)
	276	(return (and (zero? (pk 'status status))
	277	(lset= string=? (cons* "." ".." (map basename reqs))
	278	(pk (call-with-input-file result read))))))))))
	279
e464ac66	280	(skip-if-unsupported)
96b35998 LC	281	(test-assert "eval/container, non-empty load path"
	282	(call-with-temporary-directory
	283	(lambda (directory)
	284	(define store
	285	(open-connection-for-tests))
	286	(define result
	287	(string-append directory "/r"))
	288	(define requisites*
	289	(store-lift requisites))
	290
	291	(mkdir result)
	292	(run-with-store store
	293	(mlet %store-monad ((status (eval/container
	294	(with-imported-modules '((guix build utils))
	295	#~(begin
	296	(use-modules (guix build utils))
	297	(mkdir-p "/result/a/b/c")))
	298	#:mappings
	299	(list (file-system-mapping
	300	(source result)
	301	(target "/result")
	302	(writable? #t))))))
	303	(close-connection store)
	304	(return (and (zero? status)
	305	(file-is-directory?
	306	(string-append result "/a/b/c")))))))))
	307
c1f6a0c2	308	(test-end)