build: syscalls: Add pseudo-terminal bindings.

* guix/build/syscalls.scm (openpt, grantpt, unlockpt, ptsname, open-pty-pair,
  call-with-pty): New procedures.

Makefile.am

@@ -128,6 +128,8 @@ MODULES =					\
   guix/scripts/edit.scm				\
   guix/scripts/size.scm				\
   guix/scripts/graph.scm			\
+  guix/scripts/container.scm			\
+  guix/scripts/container/exec.scm		\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
 

doc/guix.texi

@@ -144,6 +144,7 @@ Utilities
 * Invoking guix environment::   Setting up development environments.
 * Invoking guix publish::       Sharing substitutes.
 * Invoking guix challenge::     Challenging substitute servers.
+* Invoking guix container::     Process isolation.
 
 GNU Distribution
 
@@ -3582,6 +3583,7 @@ programming interface of Guix in a convenient way.
 * Invoking guix environment::   Setting up development environments.
 * Invoking guix publish::       Sharing substitutes.
 * Invoking guix challenge::     Challenging substitute servers.
+* Invoking guix container::     Process isolation.
 @end menu
 
 @node Invoking guix build
@@ -4985,6 +4987,55 @@ URLs to compare to.
 @end table
 
 
+@node Invoking guix container
+@section Invoking @command{guix container}
+@cindex container
+
+The purpose of @command{guix container} is to manipulate processes
+running within an isolated environment, commonly known as a
+``container,'' typically created by the @command{guix environment}
+(@pxref{Invoking guix environment}) and @command{guix system container}
+(@pxref{Invoking guix system}) commands.
+
+The general syntax is:
+
+@example
+guix container @var{action} @var{options}@dots{}
+@end example
+
+@var{action} specifies the operation to perform with a container, and
+@var{options} specifies the context-specific arguments for the action.
+
+The following actions are available:
+
+@table @code
+@item exec
+Execute a command within the context of a running container.
+
+The syntax is:
+
+@example
+guix container exec @var{pid} @var{program} @var{arguments}@dots{}
+@end example
+
+@var{pid} specifies the process ID of the running container.
+@var{program} specifies an executable file name within the container's
+root file system.  @var{arguments} are the additional options that will
+be passed to @var{program}.
+
+The following command launches an interactive login shell inside a
+GuixSD container, started by @command{guix system container}, and whose
+process ID is 9001:
+
+@example
+guix container exec 9001 /run/current-system/profile/bin/bash --login
+@end example
+
+Note that the @var{pid} cannot be the parent process of a container.  It
+must be the container's PID 1 or one of its child processes.
+
+@end table
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
@@ -7168,6 +7219,27 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
+@item container
+Return a script to run the operating system declared in @var{file}
+within a container.  Currently, the script must be run as root in order
+to support more than a single user and group.
+
+The container shares its store with the host system.
+
+Additional file systems can be shared between the host and the container
+using the @code{--share} and @code{--expose} command-line options: the
+former specifies a directory to be shared with write access, while the
+latter provides read-only access to the shared directory.
+
+The example below creates a container in which the user's home directory
+is accessible read-only, and where the @file{/exchange} directory is a
+read-write mapping of the host's @file{$HOME/tmp}:
+
+@example
+guix system container my-config.scm \
+   --expose=$HOME --share=$HOME/tmp=/exchange
+@end example
+
 @end table
 
 @var{options} can contain any of the common build options provided by

gnu/system/linux-container.scm

@@ -106,7 +106,12 @@ that will be shared with the host system."
                 (setenv "TMPDIR" "/tmp")
                 (setenv "GUIX_NEW_SYSTEM" #$os-drv)
                 (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
-                (primitive-load (string-append #$os-drv "/boot"))))))
+                (primitive-load (string-append #$os-drv "/boot")))
+              ;; A range of 65536 uid/gids is used to cover 16 bits worth of
+              ;; users and groups, which is sufficient for most cases.
+              ;;
+              ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
+              #:host-uids 65536)))
 
       (gexp->script "run-container" script
                     #:modules '((ice-9 match)

guix/build/syscalls.scm

@@ -23,6 +23,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -82,7 +83,13 @@
             interface-address
             interface-netmask
             interface-broadcast-address
-            network-interfaces))
+            network-interfaces
+
+            openpt
+            grantpt
+            unlockpt
+            ptsname
+            call-with-pty))
 
 ;;; Commentary:
 ;;;
@@ -849,4 +856,105 @@ network interface.  This is implemented using the 'getifaddrs' libc function."
   (let ((ptr (dynamic-func "freeifaddrs" (dynamic-link))))
     (pointer->procedure void ptr '(*))))
 
+
+;;;
+;;; Psuedo-Terminals.
+;;;
+
+;; See misc/sys/select.h in GNU libc.
+
+(define cc-t uint8)
+(define speed-t unsigned-int)
+(define tcflag-t unsigned-int)
+(define NCCS 32)
+
+;; (define-c-struct termios
+;;   values->termios
+;;   read-termios
+;;   write-termios!
+;;   (c-iflag tcflag-t)
+;;   (c-oflag tcflag-t)
+;;   (c-cflag tcflag-t)
+;;   (c-lflag tcflag-t)
+;;   (c-line cc-t)
+;;   (c))
+
+(define TIOCSCTTY #x540E)
+
+(define getpt
+  (let* ((ptr  (dynamic-func "getpt" (dynamic-link)))
+         (proc (pointer->procedure int ptr '())))
+    (lambda ()
+      "Open a new master pseudo-terminal and return its file descriptor."
+      (let* ((ret (proc))
+             (err (errno)))
+        (if (= ret -1)
+            (throw 'system-error "getpt" "~A"
+                   (list (strerror err))
+                   (list err))
+            ret)))))
+
+(define grantpt
+  (let* ((ptr  (dynamic-func "grantpt" (dynamic-link)))
+         (proc (pointer->procedure int ptr (list int))))
+    (lambda (fdes)
+      "Changes the ownership and access permission of the slave
+pseudo-terminal device corresponding to the master pseudo-terminal device
+associated with the file descriptor FDES."
+      (let* ((ret (proc fdes))
+             (err (errno)))
+        (unless (zero? ret)
+          (throw 'system-error "grantpt" "~d: ~A"
+                 (list fdes (strerror err))
+                 (list err)))))))
+
+(define unlockpt
+  (let* ((ptr  (dynamic-func "unlockpt" (dynamic-link)))
+         (proc (pointer->procedure int ptr (list int))))
+    (lambda (fdes)
+      "Unlocks the slave pseudo-terminal device corresponding to the master
+pseudo-terminal device associated with the file descriptor FDES."
+      (let* ((ret (proc fdes))
+             (err (errno)))
+        (unless (zero? ret)
+          (throw 'system-error "unlockpt" "~d: ~A"
+                 (list fdes (strerror err))
+                 (list err)))))))
+
+(define ptsname
+  (let* ((ptr  (dynamic-func "ptsname" (dynamic-link)))
+         (proc (pointer->procedure '* ptr (list int))))
+    (lambda (fdes)
+      "If the file descriptor FDES is associated with a master pseudo-terminal
+device, return the file name of the associated slave pseudo-terminal file.
+Otherwise, return #f."
+      (let ((ret (proc fdes)))
+        (and (not (null-pointer? ret))
+             (pointer->string ret))))))
+
+(define (open-pty-pair)
+  "Open a new pseudo-terminal pair and return the corresponding ports."
+  (let ((master (getpt)))
+    (catch #t
+      (lambda ()
+        (grantpt master)
+        (unlockpt master)
+        (let ((name (ptsname master)))
+          (values (fdopen master "r+")
+                  (open-file name "r+"))))
+      (lambda args
+        (close master)
+        (apply throw args)))))
+
+(define (call-with-pty proc)
+  "Apply PROC with the master and slave side of a new pseudo-terminal pair."
+  (let-values (((master slave) (open-pty-pair)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc master slave))
+      (lambda ()
+        (close slave)
+        (close master)))))
+
 ;;; syscalls.scm ends here

guix/scripts/container.scm

@@ -0,0 +1,63 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@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 (guix scripts container)
+  #:use-module (ice-9 match)
+  #:use-module (guix ui)
+  #:export (guix-container))
+
+(define (show-help)
+  (display (_ "Usage: guix container ACTION ARGS...
+Build and manipulate Linux containers.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   exec            execute a command inside of an existing container\n"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %actions '("exec"))
+
+(define (resolve-action name)
+  (let ((module (resolve-interface
+                 `(guix scripts container ,(string->symbol name))))
+        (proc (string->symbol (string-append "guix-container-" name))))
+    (module-ref module proc)))
+
+(define (guix-container . args)
+  (with-error-handling
+    (match args
+      (()
+       (format (current-error-port)
+               (_ "guix container: missing action~%")))
+      ((or ("-h") ("--help"))
+       (show-help)
+       (exit 0))
+      (("--version")
+       (show-version-and-exit "guix container"))
+      ((action args ...)
+       (if (member action %actions)
+           (apply (resolve-action action) args)
+           (format (current-error-port)
+                   (_ "guix container: invalid action~%")))))))

guix/scripts/container/exec.scm

@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@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 (guix scripts container exec)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (gnu build linux-container)
+  #:export (guix-container-exec))
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix container exec")))))
+
+(define (show-help)
+  (display (_ "Usage: guix container exec PID COMMAND [ARGS...]
+Execute COMMMAND within the container process PID.\n"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define (partition-args args)
+  "Split ARGS into two lists; one containing the arguments for this program,
+and the other containing arguments for the command to be executed."
+  (break (lambda (arg)
+           ;; Split after the pid argument.
+           (not (false-if-exception (string->number arg))))
+         args))
+
+(define (guix-container-exec . args)
+  (define (handle-argument arg result)
+    (if (assoc-ref result 'pid)
+        (leave (_ "~a: extraneous argument~%") arg)
+        (alist-cons 'pid (string->number* arg) result)))
+
+  (let-values (((args command) (partition-args args)))
+    (let* ((opts (parse-command-line args %options '(())
+                                     #:argument-handler
+                                     handle-argument))
+           (pid  (assoc-ref opts 'pid)))
+
+      (unless pid
+        (leave (_ "no pid specified~%")))
+
+      (when (null? command)
+        (leave (_ "no command specified~%")))
+
+      (unless (file-exists? (string-append "/proc/" (number->string pid)))
+        (leave (_ "no such process ~d~%") pid))
+
+      (let ((result (container-excursion pid
+                      (lambda ()
+                        (match command
+                          ((program . program-args)
+                           (apply execlp program program program-args)))))))
+        (unless (zero? result)
+          (leave (_ "exec failed with status ~d~%") result))))))

guix/scripts/system.scm

@@ -33,6 +33,7 @@
   #:use-module (gnu build install)
   #:use-module (gnu system)
   #:use-module (gnu system file-systems)
+  #:use-module (gnu system linux-container)
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)
   #:use-module (gnu services)
@@ -336,6 +337,8 @@ list of services."
   (case action
     ((build init reconfigure)
      (operating-system-derivation os))
+    ((container)
+     (container-script os #:mappings mappings))
     ((vm-image)
      (system-qemu-image os #:disk-image-size image-size))
     ((vm)
@@ -368,10 +371,12 @@ building anything."
                                                 #:full-boot? full-boot?
                                                 #:mappings mappings))
        (grub      (package->derivation grub))
-       (grub.cfg  (operating-system-grub.cfg os
-                                             (if (eq? 'init action)
-                                                 '()
-                                                 (previous-grub-entries))))
+       (grub.cfg  (if (eq? 'container action)
+                      (return #f)
+                      (operating-system-grub.cfg os
+                                                 (if (eq? 'init action)
+                                                     '()
+                                                     (previous-grub-entries)))))
        (drvs   -> (if (and grub? (memq action '(init reconfigure)))
                       (list sys grub grub.cfg)
                       (list sys)))
@@ -451,6 +456,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
    reconfigure      switch to a new operating system configuration\n"))
   (display (_ "\
    build            build the operating system without installing anything\n"))
+  (display (_ "\
+  container         build a Linux container that shares the host's store\n"))
   (display (_ "\
    vm               build a virtual machine image that shares the host's store\n"))
   (display (_ "\
@@ -557,7 +564,7 @@ Build the operating system declared in FILE according to ACTION.\n"))
         (alist-cons 'argument arg result)
         (let ((action (string->symbol arg)))
           (case action
-            ((build vm vm-image disk-image reconfigure init
+            ((build container vm vm-image disk-image reconfigure init
               extension-graph dmd-graph)
              (alist-cons 'action action result))
             (else (leave (_ "~a: unknown action~%") action))))))
@@ -586,7 +593,7 @@ Build the operating system declared in FILE according to ACTION.\n"))
         (exit 1))
 
       (case action
-        ((build vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image reconfigure)
          (unless (= count 1)
            (fail)))
         ((init)

po/guix/POTFILES.in

@@ -23,6 +23,8 @@ guix/scripts/edit.scm
 guix/scripts/size.scm
 guix/scripts/graph.scm
 guix/scripts/challenge.scm
+guix/scripts/container.scm
+guix/scripts/container/exec.scm
 guix/upstream.scm
 guix/ui.scm
 guix/http-client.scm