;;; 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.
;;;
#: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))
(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?
(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
%namespaces 1
(lambda ()
(sleep 100))))
+ (expected (namespaces pid))
(result (container-excursion* pid
(lambda ()
(namespaces 1)))))
(kill pid SIGKILL)
- (equal? result (namespaces pid))))))
+ (equal? result expected)))))
(skip-if-unsupported)
(test-equal "container-excursion*, same namespaces"
(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)