me
/
guix
Archived
1
0
Fork 0
Code

linux-container: Add 'container-excursion*'. 

* gnu/build/linux-container.scm (container-excursion*): New procedure.
* tests/containers.scm ("container-excursion*")
("container-excursion*, same namespaces"): New tests.
master
Ludovic Courtès 2017-02-06 23:45:00 +01:00
parent b9a5efa596
commit c90db25f4c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 48 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gnu/build/linux-container.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -32,7 +33,8 @@
%namespaces
run-container
call-with-container
container-excursion))
container-excursion
container-excursion*))
(define (user-namespace-supported?)
"Return #t if user namespaces are supported on this system."
@ -326,3 +328,21 @@ return the exit status."
(match (waitpid pid)
((_ . status)
(status:exit-val status))))))
(define (container-excursion* pid thunk)
"Like 'container-excursion', but return the return value of THUNK."
(match (pipe)
((in . out)
(match (container-excursion pid
(lambda ()
(close-port in)
(write (thunk) out)))
(0
(close-port out)
(let ((result (read in)))
(close-port in)
result))
(_ ;maybe PID died already
(close-port out)
(close-port in)
#f)))))

27
tests/containers.scm
View File

@ -180,4 +180,31 @@
(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))))
(result (container-excursion* pid
(lambda ()
(namespaces 1)))))
(kill pid SIGKILL)
(equal? result (namespaces pid))))))
(skip-if-unsupported)
(test-equal "container-excursion*, same namespaces"
42
(container-excursion* (getpid)
(lambda ()
(* 6 7))))
(test-end)